(*  Title:      HOL/Library/Function_Algebras.thy
    Author:     Jeremy Avigad and Kevin Donnelly; Florian Haftmann, TUM
*)

section \<open>Pointwise instantiation of functions to algebra type classes\<close>

theory Function_Algebras
imports Main
begin

text \<open>Pointwise operations\<close>

instantiation "fun" :: (type, plus) plus
begin

definition "f + g = (\<lambda>x. f x + g x)"
instance ..

end

lemma plus_fun_apply [simp]:
  "(f + g) x = f x + g x"
  by (simp add: plus_fun_def)

instantiation "fun" :: (type, zero) zero
begin

definition "0 = (\<lambda>x. 0)"
instance ..

end

lemma zero_fun_apply [simp]:
  "0 x = 0"
  by (simp add: zero_fun_def)

instantiation "fun" :: (type, times) times
begin

definition "f * g = (\<lambda>x. f x * g x)"
instance ..

end

lemma times_fun_apply [simp]:
  "(f * g) x = f x * g x"
  by (simp add: times_fun_def)

instantiation "fun" :: (type, one) one
begin

definition "1 = (\<lambda>x. 1)"
instance ..

end

lemma one_fun_apply [simp]:
  "1 x = 1"
  by (simp add: one_fun_def)

text \<open>Additive structures\<close>

instance "fun" :: (type, semigroup_add) semigroup_add
  by standard (simp add: fun_eq_iff add.assoc)

instance "fun" :: (type, cancel_semigroup_add) cancel_semigroup_add
  by standard (simp_all add: fun_eq_iff)

instance "fun" :: (type, ab_semigroup_add) ab_semigroup_add
  by standard (simp add: fun_eq_iff add.commute)

instance "fun" :: (type, cancel_ab_semigroup_add) cancel_ab_semigroup_add
  by standard (simp_all add: fun_eq_iff diff_diff_eq)

instance "fun" :: (type, monoid_add) monoid_add
  by standard (simp_all add: fun_eq_iff)

instance "fun" :: (type, comm_monoid_add) comm_monoid_add
  by standard simp

instance "fun" :: (type, cancel_comm_monoid_add) cancel_comm_monoid_add ..

instance "fun" :: (type, group_add) group_add
  by standard (simp_all add: fun_eq_iff)

instance "fun" :: (type, ab_group_add) ab_group_add
  by standard simp_all

text \<open>Multiplicative structures\<close>

instance "fun" :: (type, semigroup_mult) semigroup_mult
  by standard (simp add: fun_eq_iff mult.assoc)

instance "fun" :: (type, ab_semigroup_mult) ab_semigroup_mult
  by standard (simp add: fun_eq_iff mult.commute)

instance "fun" :: (type, monoid_mult) monoid_mult
  by standard (simp_all add: fun_eq_iff)

instance "fun" :: (type, comm_monoid_mult) comm_monoid_mult
  by standard simp

text \<open>Misc\<close>

instance "fun" :: (type, "Rings.dvd") "Rings.dvd" ..

instance "fun" :: (type, mult_zero) mult_zero
  by standard (simp_all add: fun_eq_iff)

instance "fun" :: (type, zero_neq_one) zero_neq_one
  by standard (simp add: fun_eq_iff)

text \<open>Ring structures\<close>

instance "fun" :: (type, semiring) semiring
  by standard (simp_all add: fun_eq_iff algebra_simps)

instance "fun" :: (type, comm_semiring) comm_semiring
  by standard (simp add: fun_eq_iff  algebra_simps)

instance "fun" :: (type, semiring_0) semiring_0 ..

instance "fun" :: (type, comm_semiring_0) comm_semiring_0 ..

instance "fun" :: (type, semiring_0_cancel) semiring_0_cancel ..

instance "fun" :: (type, comm_semiring_0_cancel) comm_semiring_0_cancel ..

instance "fun" :: (type, semiring_1) semiring_1 ..

lemma numeral_fun: \<^marker>\<open>contributor \<open>Akihisa Yamada\<close>\<close>
  \<open>numeral n = (\<lambda>x::'a. numeral n)\<close>
  by (induction n) (simp_all only: numeral.simps plus_fun_def, simp_all)

lemma numeral_fun_apply [simp]: \<^marker>\<open>contributor \<open>Akihisa Yamada\<close>\<close>
  \<open>numeral n x = numeral n\<close>
  by (simp add: numeral_fun)

lemma of_nat_fun: "of_nat n = (\<lambda>x::'a. of_nat n)"
proof -
  have comp: "comp = (\<lambda>f g x. f (g x))"
    by (rule ext)+ simp
  have plus_fun: "plus = (\<lambda>f g x. f x + g x)"
    by (rule ext, rule ext) (fact plus_fun_def)
  have "of_nat n = (comp (plus (1::'b)) ^^ n) (\<lambda>x::'a. 0)"
    by (simp add: of_nat_def plus_fun zero_fun_def one_fun_def comp)
  also have "... = comp ((plus 1) ^^ n) (\<lambda>x::'a. 0)"
    by (simp only: comp_funpow)
  finally show ?thesis by (simp add: of_nat_def comp)
qed

lemma of_nat_fun_apply [simp]:
  "of_nat n x = of_nat n"
  by (simp add: of_nat_fun)

instance "fun" :: (type, comm_semiring_1) comm_semiring_1 ..

instance "fun" :: (type, semiring_1_cancel) semiring_1_cancel ..

instance "fun" :: (type, comm_semiring_1_cancel) comm_semiring_1_cancel
  by standard (auto simp add: times_fun_def algebra_simps)

instance "fun" :: (type, semiring_char_0) semiring_char_0
proof
  from inj_of_nat have "inj (\<lambda>n (x::'a). of_nat n :: 'b)"
    by (rule inj_fun)
  then have "inj (\<lambda>n. of_nat n :: 'a \<Rightarrow> 'b)"
    by (simp add: of_nat_fun)
  then show "inj (of_nat :: nat \<Rightarrow> 'a \<Rightarrow> 'b)" .
qed

instance "fun" :: (type, ring) ring ..

instance "fun" :: (type, comm_ring) comm_ring ..

instance "fun" :: (type, ring_1) ring_1 ..

instance "fun" :: (type, comm_ring_1) comm_ring_1 ..

instance "fun" :: (type, ring_char_0) ring_char_0 ..

text \<open>Ordered structures\<close>

instance "fun" :: (type, ordered_ab_semigroup_add) ordered_ab_semigroup_add
  by standard (auto simp add: le_fun_def intro: add_left_mono)

instance "fun" :: (type, ordered_cancel_ab_semigroup_add) ordered_cancel_ab_semigroup_add ..

instance "fun" :: (type, ordered_ab_semigroup_add_imp_le) ordered_ab_semigroup_add_imp_le
  by standard (simp add: le_fun_def)

instance "fun" :: (type, ordered_comm_monoid_add) ordered_comm_monoid_add ..

instance "fun" :: (type, ordered_cancel_comm_monoid_add) ordered_cancel_comm_monoid_add ..

instance "fun" :: (type, ordered_ab_group_add) ordered_ab_group_add ..

instance "fun" :: (type, ordered_semiring) ordered_semiring
  by standard (auto simp add: le_fun_def intro: mult_left_mono mult_right_mono)

instance "fun" :: (type, dioid) dioid
proof standard
  fix a b :: "'a \<Rightarrow> 'b"
  show "a \<le> b \<longleftrightarrow> (\<exists>c. b = a + c)"
    unfolding le_fun_def plus_fun_def fun_eq_iff choice_iff[symmetric, of "\<lambda>x c. b x = a x + c"]
    by (intro arg_cong[where f=All] ext canonically_ordered_monoid_add_class.le_iff_add)
qed

instance "fun" :: (type, ordered_comm_semiring) ordered_comm_semiring
  by standard (fact mult_left_mono)

instance "fun" :: (type, ordered_cancel_semiring) ordered_cancel_semiring ..

instance "fun" :: (type, ordered_cancel_comm_semiring) ordered_cancel_comm_semiring ..

instance "fun" :: (type, ordered_ring) ordered_ring ..

instance "fun" :: (type, ordered_comm_ring) ordered_comm_ring ..

lemmas func_plus = plus_fun_def
lemmas func_zero = zero_fun_def
lemmas func_times = times_fun_def
lemmas func_one = one_fun_def

end


(*  Gauss-Jordan elimination for matrices represented as functions
    Author: Tobias Nipkow
*)
header {* Gauss-Jordan elimination algorithm *}
theory Gauss_Jordan_Elim_Fun
imports Main
begin

text{* Matrices are functions: *}

type_synonym 'a matrix = "nat \<Rightarrow> nat \<Rightarrow> 'a"

text{* In order to restrict to finite matrices, a matrix is usually combined
with one or two natural numbers indicating the maximal row and column of the
matrix.

Gauss-Jordan elimination is parameterized with a natural number @{text
n}. It indicates that the matrix @{text A} has @{text n} rows and columns.
In fact, @{text A} is the augmented matrix with @{text "n+1"} columns. Column
@{text n} is the ``right-hand side'', i.e.\ the constant vector @{text
b}. The result is the unit matrix augmented with the solution in column
@{text n}; see the correctness theorem below. *}

fun gauss_jordan :: "('a::field)matrix \<Rightarrow> nat \<Rightarrow> ('a)matrix option" where
"gauss_jordan A 0 = Some(A)" |
"gauss_jordan A (Suc m) =
 (case dropWhile (\<lambda>i. A i m = 0) [0..<Suc m] of
   [] \<Rightarrow> None |
   p # _ \<Rightarrow>
    (let Ap' = (\<lambda>j. A p j / A p m);
         A' = (\<lambda>i. if i=p then Ap' else (\<lambda>j. A i j - A i m * Ap' j))
     in gauss_jordan (Fun.swap p m A') m))"

text{* Some auxiliary functions: *}

definition solution :: "('a::field)matrix \<Rightarrow> nat \<Rightarrow> (nat \<Rightarrow> 'a) \<Rightarrow> bool" where
"solution A n x = (\<forall>i<n. (\<Sum> j=0..<n. A i j * x j) = A i n)"

definition unit :: "('a::field)matrix \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> bool" where
"unit A m n =
 (\<forall>i j::nat. m\<le>j \<longrightarrow> j<n \<longrightarrow> A i j = (if i=j then 1 else 0))"

lemma solution_swap:
assumes "p1 < n" "p2 < n"
shows "solution (Fun.swap p1 p2 A) n x = solution A n x" (is "?L = ?R")
proof(cases "p1=p2")
  case True thus ?thesis by simp
next
  case False
  show ?thesis
  proof
    assume ?R thus ?L using assms False by(simp add: solution_def Fun.swap_def)
  next
   assume ?L
   show ?R
   proof(auto simp: solution_def)
     fix i assume "i<n"
     show "(\<Sum>j = 0..<n. A i j * x j) = A i n"
     proof cases
       assume "i=p1"
       with `?L` assms False show ?thesis
         by(fastforce simp add: solution_def Fun.swap_def)
     next
       assume "i\<noteq>p1"
       show ?thesis
       proof cases
         assume "i=p2"
         with `?L` assms False show ?thesis
           by(fastforce simp add: solution_def Fun.swap_def)
       next
         assume "i\<noteq>p2"
         with `i\<noteq>p1` `?L` `i<n` assms False show ?thesis
           by(fastforce simp add: solution_def Fun.swap_def)
       qed
     qed
   qed
 qed
qed

(* Converting these apply scripts makes them blow up - see above *)

lemma solution_upd1:
  "c \<noteq> 0 \<Longrightarrow> solution (A(p:=(\<lambda>j. A p j / c))) n x = solution A n x"
apply(cases "p<n")
 prefer 2
 apply(simp add: solution_def)
apply(clarsimp simp add: solution_def)
apply rule
 apply clarsimp
 apply(case_tac "i=p")
  apply (simp add: setsum_divide_distrib[symmetric] eq_divide_eq field_simps)
 apply simp
apply (simp add: setsum_divide_distrib[symmetric] eq_divide_eq field_simps)
done

lemma solution_upd_but1: "\<lbrakk> ap = A p; \<forall>i j. i\<noteq>p \<longrightarrow> a i j = A i j; p<n \<rbrakk> \<Longrightarrow>
 solution (\<lambda>i. if i=p then ap else (\<lambda>j. a i j - c i * ap j)) n x =
 solution A n x"
apply(clarsimp simp add: solution_def)
apply rule
 prefer 2
 apply (simp add: field_simps setsum_subtractf setsum_right_distrib[symmetric])
apply(clarsimp)
apply(case_tac "i=p")
 apply simp
apply (auto simp add: field_simps setsum_subtractf setsum_right_distrib[symmetric] all_conj_distrib)
done

subsection{* Correctness *}

text{* The correctness proof: *}

lemma gauss_jordan_lemma: "m\<le>n \<Longrightarrow> unit A m n \<Longrightarrow> gauss_jordan A m = Some B \<Longrightarrow>
  unit B 0 n \<and> solution A n (\<lambda>j. B j n)"
proof(induct m arbitrary: A B)
  case 0
  { fix a and b c d :: "'a"
    have "(if a then b else c) * d = (if a then b*d else c*d)" by simp
  } with 0 show ?case by(simp add: unit_def solution_def setsum.If_cases)
next
  case (Suc m)
  let "?Ap' p" = "(\<lambda>j. A p j / A p m)"
  let "?A' p" = "(\<lambda>i. if i=p then ?Ap' p else (\<lambda>j. A i j - A i m * ?Ap' p j))"
  from `gauss_jordan A (Suc m) = Some B`
  obtain p ks where "dropWhile (\<lambda>i. A i m = 0) [0..<Suc m] = p#ks" and
    rec: "gauss_jordan (Fun.swap p m (?A' p)) m = Some B"
    by (auto split: list.splits)
  from this have p: "p\<le>m" "A p m \<noteq> 0"
    apply(simp_all add: dropWhile_eq_Cons_conv del:upt_Suc)
    by (metis set_upt atLeast0AtMost atLeastLessThanSuc_atLeastAtMost atMost_iff in_set_conv_decomp)
  have "m\<le>n" "m<n" using `Suc m \<le> n` by arith+
  have "unit (Fun.swap p m (?A' p)) m n" using Suc.prems(2) p
    unfolding unit_def Fun.swap_def Suc_le_eq by (auto simp: le_less)
  from Suc.hyps[OF `m\<le>n` this rec] `m<n` p
  show ?case
    by(simp add: solution_swap solution_upd1 solution_upd_but1[where A = "A(p := ?Ap' p)"])
qed

theorem gauss_jordan_correct:
  "gauss_jordan A n = Some B \<Longrightarrow> solution A n (\<lambda>j. B j n)"
by(simp add:gauss_jordan_lemma[of n n] unit_def  field_simps)

definition solution2 :: "('a::field)matrix \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> (nat \<Rightarrow> 'a) \<Rightarrow> bool"
where "solution2 A m n x = (\<forall>i<m. (\<Sum> j=0..<m. A i j * x j) = A i n)"

definition "usolution A m n x \<longleftrightarrow>
  solution2 A m n x \<and> (\<forall>y. solution2 A m n y \<longrightarrow> (\<forall>j<m. y j = x j))"

lemma non_null_if_pivot:
  assumes "usolution A m n x" and "q < m" shows "\<exists>p<m. A p q \<noteq> 0"
proof(rule ccontr)
  assume "\<not>(\<exists>p<m. A p q \<noteq> 0)"
  hence 1: "\<And>p. p<m \<Longrightarrow> A p q = 0" by simp
  { fix y assume 2: "\<forall>j. j\<noteq>q \<longrightarrow> y j = x j"
    { fix i assume "i<m"
      with assms(1) have "A i n = (\<Sum>j = 0..<m. A i j * x j)"
        by (auto simp: solution2_def usolution_def)
      with 1[OF `i<m`] 2
      have "(\<Sum>j = 0..<m. A i j * y j) = A i n"
        by (auto intro!: setsum.cong)
    }
    hence "solution2 A m n y" by(simp add: solution2_def)
  }
  hence "solution2 A m n (x(q:=0))" and "solution2 A m n (x(q:=1))" by auto
  with assms(1) zero_neq_one `q < m`
  show False
    by (simp add: usolution_def)
       (metis fun_upd_same zero_neq_one)
qed

lemma lem1:
  fixes f :: "'a \<Rightarrow> 'b::field"
  shows "(\<Sum>x\<in>A. f x * (a * g x)) = a * (\<Sum>x\<in>A. f x * g x)"
  by (simp add: setsum_right_distrib field_simps)

subsection{* Complete *}

lemma gauss_jordan_complete:
  "m \<le> n \<Longrightarrow> usolution A m n x \<Longrightarrow> \<exists>B. gauss_jordan A m = Some B"
proof(induction m arbitrary: A)
  case 0 show ?case by simp
next
  case (Suc m A)
  from `Suc m \<le> n` have "m\<le>n" and "m<Suc m" by arith+
  from non_null_if_pivot[OF Suc.prems(2) `m<Suc m`]
  obtain p' where "p'<Suc m" and "A p' m \<noteq> 0" by blast
  hence "dropWhile (\<lambda>i. A i m = 0) [0..<Suc m] \<noteq> []"
    by (simp add: dropWhile_eq_Nil_conv)
       (metis atLeast0LessThan lessThan_iff linorder_neqE_nat not_less_eq)
  then obtain p xs where 1: "dropWhile (\<lambda>i. A i m = 0) [0..<Suc m] = p#xs"
    by (metis list.exhaust)
  from this have "p\<le>m" "A p m \<noteq> 0"
    by (simp_all add: dropWhile_eq_Cons_conv del: upt_Suc)
       (metis set_upt atLeast0AtMost atLeastLessThanSuc_atLeastAtMost atMost_iff in_set_conv_decomp)
  then have p: "p < Suc m" "A p m \<noteq> 0"
    by auto
  let ?Ap' = "(\<lambda>j. A p j / A p m)"
  let ?A' = "(\<lambda>i. if i=p then ?Ap' else (\<lambda>j. A i j - A i m * ?Ap' j))"
  let ?A = "Fun.swap p m ?A'"
  have A: "solution2 A (Suc m) n x" using Suc.prems(2) by(simp add: usolution_def)
  { fix i assume le_m: "p < Suc m" "i < Suc m" "A p m \<noteq> 0"
    have "(\<Sum>j = 0..<m. (A i j - A i m * A p j / A p m) * x j) =
      ((\<Sum>j = 0..<Suc m. A i j * x j) - A i m * x m) -
      ((\<Sum>j = 0..<Suc m. A p j * x j) - A p m * x m) * A i m / A p m"
      by (simp add: field_simps setsum_subtractf setsum_divide_distrib
                    setsum_right_distrib)
    also have "\<dots> = A i n - A p n * A i m / A p m"
      using A le_m
      by (simp add: solution2_def field_simps del: setsum_op_ivl_Suc)
    finally have "(\<Sum>j = 0..<m. (A i j - A i m * A p j / A p m) * x j) =
      A i n - A p n * A i m / A p m" . }
  then have "solution2 ?A m n x" using p
    by (auto simp add: solution2_def Fun.swap_def field_simps)
  moreover
  { fix y assume a: "solution2 ?A m n y"
    let ?y = "y(m := A p n / A p m - (\<Sum>j = 0..<m. A p j * y j) / A p m)"
    have "solution2 A (Suc m) n ?y" unfolding solution2_def
    proof safe
      fix i assume "i < Suc m"
      show "(\<Sum>j=0..<Suc m. A i j * ?y j) = A i n"
      proof (cases "i = p")
        assume "i = p" with p show ?thesis by (simp add: field_simps)
      next
        assume "i \<noteq> p"
        show ?thesis
        proof (cases "i = m")
          assume "i = m"
          with p `i \<noteq> p` have "p < m" by simp
          with a[unfolded solution2_def, THEN spec, of p] p(2)
          have "A p m * (A m m * A p n + A p m * (\<Sum>j = 0..<m. y j * A m j)) = A p m * (A m n * A p m + A m m * (\<Sum>j = 0..<m. y j * A p j))"
            by (simp add: Fun.swap_def field_simps setsum_subtractf lem1 lem2 setsum_divide_distrib[symmetric]
                     split: if_splits)
          with `A p m \<noteq> 0` show ?thesis unfolding `i = m`
            by simp (simp add: field_simps)
        next
          assume "i \<noteq> m"
          then have "i < m" using `i < Suc m` by simp
          with a[unfolded solution2_def, THEN spec, of i] p(2)
          have "A p m * (A i m * A p n + A p m * (\<Sum>j = 0..<m. y j * A i j)) = A p m * (A i n * A p m + A i m * (\<Sum>j = 0..<m. y j * A p j))"
            by (simp add: Fun.swap_def field_simps setsum_subtractf lem1 lem2 setsum_divide_distrib[symmetric]
                     split: if_splits)
          with `A p m \<noteq> 0` show ?thesis
            by simp (simp add: field_simps)
        qed
      qed
    qed
    with `usolution A (Suc m) n x`
    have "\<forall>j<Suc m. ?y j = x j" by (simp add: usolution_def)
    hence "\<forall>j<m. y j = x j"
      by simp (metis less_SucI nat_neq_iff)
  } ultimately have "usolution ?A m n x" by(simp add: usolution_def)
  from Suc.IH[OF `m\<le>n` this] 1 show ?case by(simp)
qed

text{* Future work: extend the proof to matrix inversion. *}

hide_const (open) unit

end


(*
    Title:      Least_Squares_Approximation.thy
    Author:     Jose Divasón <jose.divasonm at unirioja.es>
    Author:     Jesús Aransay <jesus-maria.aransay at unirioja.es>
*)

section\<open>Least Squares Approximation\<close>

theory Least_Squares_Approximation
imports
 QR_Decomposition
begin

subsection\<open>Second part of the Fundamental Theorem of Linear Algebra\<close>

text\<open>See @{url "http://en.wikipedia.org/wiki/Fundamental_theorem_of_linear_algebra"}\<close>

lemma null_space_orthogonal_complement_row_space:
  fixes A::"real^'cols^'rows::{finite,wellorder}"
  shows "null_space A = orthogonal_complement (row_space A)"
proof (unfold null_space_def orthogonal_complement_def, auto)
  fix x xa assume Ax: "A *v x = 0" and xa: "xa \<in> row_space A"
  obtain y where y: "xa = transpose A *v y" using xa unfolding row_space_eq by blast
  have "y v* A = xa"
    using transpose_vector y by fastforce
  thus "orthogonal x xa" unfolding orthogonal_def
    using Ax dot_lmul_matrix inner_commute inner_zero_right
    by (metis Ax dot_lmul_matrix inner_commute inner_zero_right)
next
  fix x assume xa: "\<forall>xa\<in>row_space A. orthogonal x xa"
  show "A *v x = 0"
    using xa unfolding row_space_eq orthogonal_def
    by (auto, metis transpose_transpose dot_lmul_matrix inner_eq_zero_iff transpose_vector)
qed

lemma left_null_space_orthogonal_complement_col_space:
  fixes A::"real^'cols::{finite,wellorder}^'rows"
  shows "left_null_space A = orthogonal_complement (col_space A)"
  using null_space_orthogonal_complement_row_space[of "transpose A"]
  unfolding left_null_space_eq_null_space_transpose
  unfolding col_space_eq_row_space_transpose .

subsection\<open>Least Squares Approximation\<close>

text\<open>See @{url "https://people.math.osu.edu/husen.1/teaching/571/least_squares.pdf"}\<close>

text\<open>Part 3 of the Theorem 1.7 in the previous website.\<close>

lemma least_squares_approximation:
  fixes X::"'a::{euclidean_space} set"
  assumes subspace_S: "subspace S"
  and ind_X: "independent X"
  and X: "X \<subseteq> S"
  and span_X: "S \<subseteq> span X"
  and o: "pairwise orthogonal X"
  and not_eq: "proj_onto v X \<noteq> y"
  and y: "y \<in> S"
  shows "norm (v - proj_onto v X) < norm (v - y)"
proof -
  have S_eq_spanX: "S = span X"
    using X span_X span_subspace subspace_S by auto
  let ?p="proj_onto v X"
  have not_0: "(norm(?p - y))^2 \<noteq> 0"
    by (metis (lifting) eq_iff_diff_eq_0 norm_eq_zero not_eq power_eq_0_iff)
  have "norm (v-y)^2 = norm (v - ?p + ?p - y)^2" by auto
  also have "... = norm ((v - ?p) + (?p - y))^2"
    unfolding add.assoc[symmetric] by simp
  also have "... = (norm (v - ?p))^2 + (norm(?p - y))^2"
  proof (rule phytagorean_theorem_norm, rule in_orthogonal_complement_imp_orthogonal)
    show "?p - y \<in> S" unfolding proj_onto_def proj_def[abs_def]
    proof (rule subspace_diff[OF subspace_S _ y],
        rule subspace_sum[OF subspace_S])
      show "x \<in> X \<Longrightarrow> (v \<bullet> x / (x \<bullet> x)) *\<^sub>R x \<in> S" for x
        by (metis S_eq_spanX X rev_subsetD span_mul)
    qed
    show "v - ?p \<in> orthogonal_complement S"
      using v_minus_p_orthogonal_complement assms by auto
  qed
  finally have "norm (v-?p)^2 < norm (v-y)^2" using not_0 by fastforce
  thus ?thesis by (metis (full_types) norm_gt_square power2_norm_eq_inner)
qed

lemma least_squares_approximation2:
  fixes S::"'a::{euclidean_space} set"
  assumes subspace_S: "subspace S"
  and y: "y \<in> S"
  shows "\<exists>p\<in>S. norm (v - p) \<le> norm (v - y) \<and> (v-p) \<in> orthogonal_complement S"
proof -
  obtain X where  ind_X: "independent X"
    and X: "X \<subseteq> S"
    and span_X: "S \<subseteq> span X"
    and o: "pairwise orthogonal X"
    by (metis order_refl orthonormal_basis_subspace subspace_S)
  let ?p="proj_onto v X"
  show ?thesis
  proof (rule bexI[of _ ?p], rule conjI)
    show "norm (v - proj_onto v X) \<le> norm (v - y)"
    proof (cases "?p=y")
      case True thus "norm (v - ?p) \<le> norm (v - y)" by simp
    next
      case False
      have "norm (v - ?p) < norm (v - y)"
        by (rule least_squares_approximation[OF subspace_S ind_X X span_X o False y])
      thus "norm (v - ?p) \<le> norm (v - y)" by simp
    qed
    show "?p \<in> S"
      using [[unfold_abs_def = false]]
    proof (unfold proj_onto_def proj_def, rule subspace_sum)
      show "subspace S" using subspace_S .
      show "x\<in>X \<Longrightarrow> proj v x \<in> S" for x
        by (simp add: proj_def X rev_subsetD subspace_S subspace_mul)
    qed
    show "v - ?p\<in> orthogonal_complement S"
      by (rule v_minus_p_orthogonal_complement[OF subspace_S ind_X X span_X o])
  qed
qed

corollary least_squares_approximation3:
  fixes S::"'a::{euclidean_space} set"
  assumes subspace_S: "subspace S"
  shows "\<exists>p\<in>S. \<forall>y\<in>S. norm (v - p) \<le> norm (v - y) \<and> (v-p) \<in> orthogonal_complement S"
proof -
  obtain X where  ind_X: "independent X"
    and X: "X \<subseteq> S"
    and span_X: "S \<subseteq> span X"
    and o: "pairwise orthogonal X"
    by (metis order_refl orthonormal_basis_subspace subspace_S)
  let ?p="proj_onto v X"
  show ?thesis
  proof (rule bexI[of _ ?p], auto)
    fix y assume y: "y\<in>S"
    show "norm (v - ?p) \<le> norm (v - y)"
    proof (cases "?p=y")
      case True thus ?thesis by simp
    next
      case False
      have "norm (v - ?p) < norm (v - y)"
        by (rule least_squares_approximation[OF subspace_S ind_X X span_X o False y])
      thus ?thesis by simp
    qed
    show "v - ?p \<in> orthogonal_complement S"
      by (rule v_minus_p_orthogonal_complement[OF subspace_S ind_X X span_X o])
  next
    show "?p \<in> S"
    proof (unfold proj_onto_def, rule subspace_sum)
      show "subspace S" using subspace_S .
      show "x \<in> X \<Longrightarrow> proj v x \<in> S" for x
        by (metis Projections.proj_def X subset_iff subspace_S subspace_mul)
    qed
  qed
qed

lemma norm_least_squares:
  fixes A::"real^'cols::{finite,wellorder}^'rows"
  shows "\<exists>x. \<forall>x'. norm (b - A *v x) \<le> norm (b - A *v x')"
proof -
  have "\<exists>p\<in>col_space A. \<forall>y\<in>col_space A. norm (b - p) \<le> norm (b - y) \<and> (b-p) \<in> orthogonal_complement (col_space A)"
    using least_squares_approximation3[OF subspace_col_space[of A, unfolded subspace_vec_eq]] .
  from this obtain p where p: "p \<in> col_space A" and least: "\<forall>y\<in>col_space A. norm (b - p) \<le> norm (b - y)"
    and bp_orthogonal: "(b-p) \<in> orthogonal_complement (col_space A)"
    by blast
  obtain x where x: "p = A *v x" using p unfolding col_space_eq by blast
  show ?thesis
  proof (rule exI[of _ x], auto)
    fix x'
    have "A *v x' \<in> col_space A" unfolding col_space_eq by auto
    thus "norm (b - A *v x) \<le> norm (b - A *v x')" using least unfolding x by auto
  qed
qed

definition "set_least_squares_approximation A b = {x. \<forall>y. norm (b - A *v x) \<le> norm (b - A *v y)}"

corollary least_squares_approximation4:
  fixes S::"'a::{euclidean_space} set"
  assumes subspace_S: "subspace S"
  shows "\<exists>!p\<in>S. \<forall>y\<in>S-{p}. norm (v - p) < norm (v - y)"
proof (auto)
  obtain X where  ind_X: "independent X"
    and X: "X \<subseteq> S"
    and span_X: "S \<subseteq> span X"
    and o: "pairwise orthogonal X"
    by (metis order_refl orthonormal_basis_subspace subspace_S)
  let ?p="sum (proj v) X"
  show "\<exists>p. p \<in> S \<and> (\<forall>y\<in>S - {p}. norm (v - p) < norm (v - y))"
  proof (rule exI[of _ ?p], rule conjI,  rule subspace_sum)
    show "subspace S" using subspace_S .
    show "x \<in> X \<Longrightarrow> proj v x \<in> S" for x
      by (metis Projections.proj_def X subset_iff subspace_S subspace_mul)
    show "\<forall>y\<in>S - {?p}. norm (v - ?p) < norm (v - y)"
      using X ind_X least_squares_approximation  o span_X subspace_S proj_onto_def
      by (metis (mono_tags) Diff_iff singletonI)
  qed
  fix p y
  assume p: "p \<in> S"
    and "\<forall>y\<in>S - {p}. norm (v - p) < norm (v - y)"
    and "y \<in> S"
    and "\<forall>ya\<in>S - {y}. norm (v - y) < norm (v - ya)"
  thus "p = y" by (metis member_remove not_less_iff_gr_or_eq remove_def)
qed

corollary least_squares_approximation4':
  fixes S::"'a::{euclidean_space} set"
  assumes subspace_S: "subspace S"
  shows "\<exists>!p\<in>S. \<forall>y\<in>S. norm (v - p) \<le> norm (v - y)"
proof (auto)
  obtain X where ind_X: "independent X"
    and X: "X \<subseteq> S"
    and span_X: "S \<subseteq> span X"
    and o: "pairwise orthogonal X"
    by (metis order_refl orthonormal_basis_subspace subspace_S)
  let ?p="sum (proj v) X"
  show "\<exists>p. p \<in> S \<and> (\<forall>y\<in>S. norm (v - p) \<le> norm (v - y))"
  proof (rule exI[of _ ?p], rule conjI, rule subspace_sum)
    show "subspace S" using subspace_S .
    show "x \<in> X \<Longrightarrow> proj v x \<in> S" for x
      by (metis Projections.proj_def X subset_iff subspace_S subspace_mul)
    show "\<forall>y\<in>S. norm (v - ?p) \<le> norm (v - y)"
      by (metis (mono_tags) proj_onto_def X dual_order.refl ind_X
         least_squares_approximation less_imp_le o span_X subspace_S)
  qed
  fix p y
  assume p: "p \<in> S" and p': "\<forall>y\<in>S. norm (v - p) \<le> norm (v - y)"
    and y: "y \<in> S" and y': "\<forall>ya\<in>S. norm (v - y) \<le> norm (v - ya)"
  obtain a where a: "a\<in>S" and a': "\<forall>y\<in>S-{a}. norm (v - a) < norm (v - y)"
    and a_uniq: "\<forall>b. (b\<in>S \<and> (\<forall>c\<in>S-{b}. norm (v - b) < norm (v - c))) \<longrightarrow> b=a"
    using least_squares_approximation4[OF subspace_S]
    by metis
  have "p=a" using p p' a_uniq leD  by (metis a a' member_remove remove_def)
  moreover have "y=a" using y y' a_uniq
    by (metis a a' leD member_remove remove_def)
  ultimately show "p = y" by simp
qed

corollary least_squares_approximation5:
  fixes S::"'a::{euclidean_space} set"
  assumes subspace_S: "subspace S"
  shows "\<exists>!p\<in>S. \<forall>y\<in>S-{p}. norm (v - p) < norm (v - y) \<and> v-p \<in> orthogonal_complement S"
proof (auto)
  obtain X where  ind_X: "independent X"
    and X: "X \<subseteq> S"
    and span_X: "S \<subseteq> span X"
    and o: "pairwise orthogonal X"
    by (metis order_refl orthonormal_basis_subspace subspace_S)
  let ?p="sum (proj v) X"
  show "\<exists>p. p \<in> S \<and> (\<forall>y\<in>S - {p}. norm (v - p) < norm (v - y) \<and> v - p \<in> orthogonal_complement S)"
  proof (rule exI[of _ ?p], rule conjI, rule subspace_sum)
    show "subspace S" using subspace_S .
    show "x \<in> X \<Longrightarrow> proj v x \<in> S" for x
      by (simp add: Projections.proj_def X rev_subsetD subspace_S subspace_mul)
    have "\<forall>y\<in>S - {?p}. norm (v - ?p) < norm (v - y)"
      using least_squares_approximation[OF subspace_S ind_X X span_X o]
      unfolding proj_onto_def
      by (metis (no_types) member_remove remove_def)
    moreover have "v - ?p \<in> orthogonal_complement S"
      by (metis (no_types) X ind_X o span_X subspace_S v_minus_p_orthogonal_complement proj_onto_def)
    ultimately show "\<forall>y\<in>S - {?p}. norm (v - ?p) < norm (v - y) \<and> v - ?p \<in> orthogonal_complement S"
      by auto
  qed
  fix p y
  assume p: "p \<in> S" and p': "\<forall>y\<in>S - {p}. norm (v - p) < norm (v - y) \<and> v - p \<in> orthogonal_complement S"
    and y: "y \<in> S" and y': "\<forall>ya\<in>S - {y}. norm (v - y) < norm (v - ya) \<and> v - y \<in> orthogonal_complement S"
  show "p=y"
    by (metis least_squares_approximation4 p p' subspace_S y y')
qed

corollary least_squares_approximation5':
  fixes S::"'a::{euclidean_space} set"
  assumes subspace_S: "subspace S"
  shows "\<exists>!p\<in>S. \<forall>y\<in>S. norm (v - p) \<le> norm (v - y) \<and> v-p \<in> orthogonal_complement S"
  by (metis least_squares_approximation3 least_squares_approximation4' subspace_S)

corollary least_squares_approximation6:
  fixes S::"'a::{euclidean_space} set"
  assumes subspace_S: "subspace S"
  and "p\<in>S"
  and "\<forall>y\<in>S. norm (v - p) \<le> norm (v - y)"
  shows "v-p \<in> orthogonal_complement S"
proof -
  obtain a where a: "a\<in>S" and a': "\<forall>y\<in>S. norm (v - a) \<le> norm (v - y) \<and> v-a \<in> orthogonal_complement S"
    and "\<forall>b. (b\<in>S \<and> (\<forall>y\<in>S. norm (v - b) \<le> norm (v - y) \<and> v-b \<in> orthogonal_complement S)) \<longrightarrow> b=a"
    using least_squares_approximation5'[OF subspace_S] by metis
  have "p=a"
    by (metis a a' assms(2) assms(3) least_squares_approximation4' subspace_S)
  thus ?thesis using a' by (metis assms(2))
qed

corollary least_squares_approximation7:
  fixes S::"'a::{euclidean_space} set"
  assumes subspace_S: "subspace S"
  and "v - p \<in> orthogonal_complement S"
  and "p\<in>S"
  and "y \<in> S"
  shows "norm (v - p) \<le> norm (v - y)"
proof (cases "y=p")
  case True thus ?thesis by simp
next
  case False
  have "norm (v - y)^2 = norm ((v - p) + (p - y))^2"
    by (metis (hide_lams, no_types) add_diff_cancel_left add_ac(1) add_diff_add add_diff_cancel)
  also have "... = norm (v - p)^2 + norm (p - y)^2"
  proof (rule phytagorean_theorem_norm, rule in_orthogonal_complement_imp_orthogonal)
    show "p - y \<in> S" by (metis assms(3) assms(4) subspace_S subspace_diff)
    show "v - p \<in> orthogonal_complement S" by (metis assms(2))
  qed
  finally have "norm (v - p)^2 \<le> norm (v - y)^2" by auto
  thus "norm (v - p)\<le> norm (v - y)" by (metis norm_ge_zero power2_le_imp_le)
qed

lemma in_set_least_squares_approximation:
  fixes A::"real^'cols::{finite, wellorder}^'rows"
  assumes o: "A *v x - b \<in> orthogonal_complement (col_space A)"
  shows "(x \<in> set_least_squares_approximation A b)"
proof (unfold set_least_squares_approximation_def, auto)
  fix y
  show " norm (b - A *v x) \<le> norm (b - A *v y)"
  proof (rule least_squares_approximation7)
    show "subspace (col_space A)" using subspace_col_space[of A, unfolded subspace_vec_eq] .
    show "b - A *v x \<in> orthogonal_complement (col_space A)"
      using o subspace_orthogonal_complement[of "(col_space A)"]
      using minus_diff_eq subspace_neg by metis
    show "A *v x \<in> col_space A" unfolding col_space_eq[of A] by auto
    show "A *v y \<in> col_space A" unfolding col_space_eq by auto
  qed
qed

lemma in_set_least_squares_approximation_eq_full_rank:
  fixes A::"real^'cols::mod_type^'rows::mod_type"
  assumes r: "rank A = ncols A"
  shows "(x \<in> set_least_squares_approximation A b) = (x = matrix_inv (transpose A ** A)**transpose A *v b)"
proof -
  have int_tA: "invertible (transpose A ** A)" using invertible_transpose_mult[OF r] .
  show ?thesis
  proof
    fix x assume "x \<in> set_least_squares_approximation A b"
    hence "transpose A ** A *v x = transpose A *v b" using in_set_least_squares_approximation_eq by auto
    thus "x = matrix_inv (transpose A ** A) ** transpose A *v b"
      by (metis int_tA matrix_inv_left matrix_vector_mul_assoc matrix_vector_mul_lid)
  next
    fix x assume "x = matrix_inv (transpose A ** A) ** transpose A *v b"
    hence "transpose A ** A *v x = transpose A *v b"
      by (metis int_tA matrix_inv_right matrix_vector_mul_assoc matrix_vector_mul_lid)
    thus "x \<in> set_least_squares_approximation A b" unfolding in_set_least_squares_approximation_eq .
  qed
qed

lemma in_set_least_squares_approximation_eq_full_rank_QR:
  fixes A::"real^'cols::{mod_type}^'rows::{mod_type}"
  assumes r: "rank A = ncols A"
  shows "(x \<in> set_least_squares_approximation A b) = ((snd (QR_decomposition A)) *v x = transpose (fst (QR_decomposition A)) *v b)"
proof -
  let ?Q = "fst (QR_decomposition A)"
  let ?R = "snd (QR_decomposition A)"
  have inv_tR: "invertible (transpose ?R)"
    by (metis invertible_snd_QR_decomposition invertible_transpose r)
  have inv_inv_tR: "invertible (matrix_inv (transpose ?R))"
    by (metis inv_tR invertible_fst_Gauss_Jordan_PA matrix_inv_Gauss_Jordan_PA)
  have "(x \<in> set_least_squares_approximation A b) = (transpose A ** A *v x = transpose A *v b)"
    using in_set_least_squares_approximation_eq .
  also have "... = (transpose (?Q ** ?R) ** (?Q ** ?R) *v x = transpose (?Q ** ?R) *v b)"
    using QR_decomposition_mult[OF r] by simp
  also have "... = (transpose ?R ** transpose ?Q **  (?Q ** ?R) *v x  = transpose ?R ** transpose ?Q *v b)"
    by (metis (hide_lams, no_types) matrix_transpose_mul)
  also have "... = (transpose ?R *v (transpose ?Q ** (?Q ** ?R) *v x)  = transpose ?R *v (transpose ?Q *v b))"
    by (metis (hide_lams, no_types) matrix_vector_mul_assoc)
  also have "... = (matrix_inv (transpose ?R) *v (transpose ?R *v (transpose ?Q ** (?Q ** ?R) *v x))
    = matrix_inv (transpose ?R) *v (transpose ?R *v (transpose ?Q *v b)))"
    using inv_matrix_vector_mul_left[OF inv_inv_tR] by auto
  also have "... = ((matrix_inv (transpose ?R) ** transpose ?R) *v (transpose ?Q ** (?Q ** ?R) *v x)
    = (matrix_inv (transpose ?R) ** transpose ?R) *v (transpose ?Q *v b))"
    by (metis (hide_lams, no_types) matrix_vector_mul_assoc)
  also have "... = (transpose ?Q ** (?Q ** ?R) *v x = transpose ?Q *v b)"
    unfolding matrix_inv_left[OF inv_tR]
    unfolding matrix_vector_mul_lid ..
  also have "... = ((transpose ?Q ** ?Q) ** ?R *v x = transpose ?Q *v b)"
    by (metis (hide_lams, no_types) matrix_mul_assoc)
  also have "... = (?R *v x = transpose ?Q *v b)"
    unfolding orthogonal_matrix_fst_QR_decomposition[OF r]
    unfolding matrix_mul_lid ..
  finally show "(x \<in> set_least_squares_approximation A b) = (?R *v x = (transpose ?Q) *v b)" .
qed

(*TODO: Maybe demonstrate that in this case there's only one solution.*)
corollary in_set_least_squares_approximation_eq_full_rank_QR2:
  fixes A::"real^'cols::{mod_type}^'rows::{mod_type}"
  assumes r: "rank A = ncols A"
  shows "(x \<in> set_least_squares_approximation A b) = (x = matrix_inv (snd (QR_decomposition A)) ** transpose (fst (QR_decomposition A)) *v b)"
proof -
  let ?Q = "fst (QR_decomposition A)"
  let ?R = "snd (QR_decomposition A)"
  have inv_R: "invertible ?R" by (metis invertible_snd_QR_decomposition r)
  have "(x \<in> set_least_squares_approximation A b) = (?R *v x = transpose ?Q *v b)"
    using in_set_least_squares_approximation_eq_full_rank_QR[OF r] .
  also have "... = (matrix_inv ?R ** ?R *v x = matrix_inv ?R ** transpose ?Q *v b)"
    by (metis (hide_lams, no_types) Gauss_Jordan_PA_eq calculation fst_Gauss_Jordan_PA inv_R
      inv_matrix_vector_mul_left invertible_fst_Gauss_Jordan_PA matrix_inv_Gauss matrix_vector_mul_assoc)
  also have "... = (x = matrix_inv ?R ** transpose ?Q *v b)"
    by (metis inv_R matrix_inv_left matrix_vector_mul_lid)
  finally show "(x \<in> set_least_squares_approximation A b) = (x = matrix_inv ?R ** transpose ?Q *v b)" .
qed

lemma set_least_squares_approximation_unique_solution:
  fixes A::"real^'cols::{mod_type}^'rows::{mod_type}"
  assumes r: "rank A = ncols A"
  shows "(set_least_squares_approximation A b) = {matrix_inv (transpose A ** A)**transpose A *v b}"
  by (metis (hide_lams, mono_tags) empty_iff in_set_least_squares_approximation_eq_full_rank
    empty_iff insertI1 r subsetI subset_singletonD)

lemma set_least_squares_approximation_unique_solution_QR:
  fixes A::"real^'cols::{mod_type}^'rows::{mod_type}"
  assumes r: "rank A = ncols A"
  shows "(set_least_squares_approximation A b) = {matrix_inv (snd (QR_decomposition A)) ** transpose (fst (QR_decomposition A)) *v b}"
  by (metis (hide_lams, mono_tags) empty_iff in_set_least_squares_approximation_eq_full_rank_QR2 insertI1 r subsetI subset_singletonD)

end


theory ANiceLimit
  imports  "HOL-Real_Asymp.Real_Asymp"
begin

(* With help from Manuel Eberl on Zulip *)

(* Reminder of different forms:

translations
  "LIM x F1. f :> F2" == "CONST filterlim (\<lambda>x. f) F2 F1"

abbreviation (in topological_space)
  tendsto :: "('b \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'b filter \<Rightarrow> bool"  (infixr "\<longlongrightarrow>" 55)
  where "(f \<longlongrightarrow> l) F \<equiv> filterlim f (nhds l) F"

*)

lemma \<open>filterlim (\<lambda>x::real. (1 + 1 / x) powr x) (nhds (exp 1)) at_top\<close>
  by real_asymp

lemma x1:
  fixes a::real
  assumes "a > 0"
  shows "((\<lambda>x. a powr x) \<longlongrightarrow> 1) (at_right 0)"
(*  shows "filterlim (\<lambda>x::real. a powr x) (at_right 1) (at_right 0)"*)
using assms by real_asymp

lemma "a \<in> {0<..<1} \<Longrightarrow> filterlim (\<lambda>x::real. a powr x) (at_left 1) (at_right 0)"
      "a > 1 \<Longrightarrow> filterlim (\<lambda>x::real. a powr x) (at_right 1) (at_right 0)"
  by real_asymp+

sledgehammer_params[debug=true,timeout=600]

lemma  xx2:
  fixes a::real
  assumes "a > 0"
  shows "LIM (x::real) at_right 0. a powr x :> nhds 1"  using x1 assms by simp

lemma xx3:
 fixes a::real
  assumes "a > 0"
  shows "((\<lambda>x. a powr x) has_real_derivative ln a * a powr x) (at x)"
proof -
  have "((\<lambda>_. a) has_real_derivative 0) (at x)" by simp
  moreover have "((\<lambda>x. x) has_real_derivative 1) (at x)" by simp
  ultimately show ?thesis using   DERIV_powr[of "\<lambda>_.a" 0 x "\<lambda>x. x" 1] assms
    by (simp add: mult.commute)
qed

lemma  xx:
  fixes a::real
  assumes "a > 0"
  shows "LIM x at_right 0. (a powr x - 1) / x :> nhds (ln a)"
proof -
  let ?f' = "\<lambda>x. (ln a) * (a powr x)"
  let ?g' = "\<lambda>_. 1::real"
  show ?thesis
proof(rule lhopital_right_0)
  show "((\<lambda>x. a powr x - 1) \<longlongrightarrow> 0) (at_right 0)" using assms by real_asymp
  show " ((\<lambda>x. x) \<longlongrightarrow> 0) (at_right 0)" using assms by simp
  show " \<forall>\<^sub>F x in at_right 0. x \<noteq> 0"
    using eventually_at_filter not_eventuallyD by blast
  show " \<forall>\<^sub>F x::real in at_right 0. ?g' x \<noteq> (0::real)"
    unfolding eventually_at_filter apply(eventually_elim,rule,rule)
    by simp

  show "\<forall>\<^sub>F x in at_right 0. ((\<lambda>x. a powr x - 1) has_real_derivative ?f' x) (at x)"
    unfolding eventually_at_filter apply(eventually_elim,rule)
  proof
    fix x::real
    assume "x \<noteq> 0" and "x \<in> {0<..}"
    show "((\<lambda>x. a powr x - 1) has_real_derivative ln a * a powr x) (at x) "
      using xx3 assms DERIV_minus DERIV_add sorry
  qed
  show " \<forall>\<^sub>F x in at_right 0. ((\<lambda>x. x) has_real_derivative ?g' x) (at x)"
    by simp
  show " LIM x at_right 0. ?f' x / ?g' x :> nhds  (ln a)"  using assms by real_asymp
qed
qed

lemma yy:
  fixes a b :: real
  assumes "a > 0" "b > 0"
  shows   "((\<lambda>x. ((a powr (1/x) + b powr (1/x)) / 2) powr x) \<longlongrightarrow> exp ((ln a + ln b) / 2)) at_top"
  using assms by real_asymp

lemma bob:
  fixes f::"nat \<Rightarrow> real" and g::"real \<Rightarrow> real"
  assumes  "\<forall>n. f n = g n" and  "(g \<longlongrightarrow> c) at_top"
  shows "f \<longlonglongrightarrow> c"
  using assms tendsto_cong[of g f at_top c]
  by (smt eventually_elim2 filterlim_iff filterlim_real_sequentially)

lemma
  fixes a::real and b::real
  assumes "a > 0" and "b > 0"
  shows "(\<lambda>n. ( (root  n a + root n b )  / 2)^n) \<longlonglongrightarrow> (sqrt(a*b))"
proof -
  have "(\<lambda>n. ( (root  n a + root n b )  / 2)^n) = ((\<lambda>x. ((a powr (1/x) + b powr (1/x)) / 2) powr x))" sorry
  moreover have "(sqrt(a*b)) = exp ((ln a + ln b) / 2)" sorry
  ultimately show ?thesis using yy[OF assms] bob by force
qed

end


theory Isar_Demo
imports Complex_Main
begin

section "An introductory example"

lemma "\<not> surj(f :: 'a \<Rightarrow> 'a set)"
proof
  assume 0: "surj f"
  from 0 have 1: "\<forall>A. \<exists>a. A = f a" by(simp add: surj_def)
  from 1 have 2: "\<exists>a. {x. x \<notin> f x} = f a" by blast
  from 2 show "False" by blast
qed

text \<open>A bit shorter:\<close>

lemma "\<not> surj(f :: 'a \<Rightarrow> 'a set)"
proof
  assume 0: "surj f"
  from 0 have 1: "\<exists>a. {x. x \<notin> f x} = f a" by(auto simp: surj_def)
  from 1 show "False" by blast
qed

subsection \<open>"this", "then", "hence" and "thus\<close>

text \<open>Avoid labels, use "this"\<close>

lemma "\<not> surj(f :: 'a \<Rightarrow> 'a set)"
proof
  assume "surj f"
  from this have "\<exists>a. {x. x \<notin> f x} = f a" by(auto simp: surj_def)
  from this show "False" by blast
qed

text \<open>"then" = "from this"\<close>

lemma "\<not> surj(f :: 'a \<Rightarrow> 'a set)"
proof
  assume "surj f"
  then have "\<exists>a. {x. x \<notin> f x} = f a" by(auto simp: surj_def)
  then show "False" by blast
qed

text \<open>"hence" = "then have", "thus" = "then show"\<close>

lemma "\<not> surj(f :: 'a \<Rightarrow> 'a set)"
proof
  assume "surj f"
  hence "\<exists>a. {x. x \<notin> f x} = f a" by(auto simp: surj_def)
  thus "False" by blast
qed

subsection \<open>Structured statements: "fixes", "assumes", "shows"\<close>

lemma
  fixes f :: "'a \<Rightarrow> 'a set"
  assumes s: "surj f"
  shows "False"
proof -  (* no automatic proof step! *)
  have "\<exists> a. {x. x \<notin> f x} = f a" using s
    by(auto simp: surj_def)
  thus "False" by blast
qed

section "Proof patterns"

lemma "P \<longleftrightarrow> Q"
proof
  assume "P"
  show "Q" sorry
next
  assume "Q"
  show "P" sorry
qed

lemma "A = (B::'a set)"
proof
  show "A \<subseteq> B" sorry
next
  show "B \<subseteq> A" sorry
qed

lemma "A \<subseteq> B"
proof
  fix a
  assume "a \<in> A"
  show "a \<in> B" sorry
qed

text "Contradiction"\<section>

lemma P
proof (rule ccontr)
  assume "\<not>P"
  show "False" sorry
qed

text "Case distinction"

lemma "R"
proof cases
  assume "P"
  show "R" sorry
next
  assume "\<not> P"
  show "R" sorry
qed

lemma "R"
proof -
  have "P \<or> Q" sorry
  then show "R"
  proof
    assume "P"
    show "R" sorry
  next
    assume "Q"
    show "R" sorry
  qed
qed

text \<open>"obtain" example\<close>

lemma "\<not> surj(f :: 'a \<Rightarrow> 'a set)"
proof
  assume "surj f"
  hence "\<exists>a. {x. x \<notin> f x} = f a" by(auto simp: surj_def)
  then obtain a where "{x. x \<notin> f x} = f a" by blast
  hence "a \<notin> f a \<longleftrightarrow> a \<in> f a" by blast
  thus "False" by blast
qed

text \<open>Interactive exercise:\<close>

lemma assumes "\<exists>x. \<forall>y. P x y" shows "\<forall>y. \<exists>x. P x y"
sorry

subsection \<open>(In)Equation Chains\<close>

lemma "(0::real) \<le> x^2 + y^2 - 2*x*y"
proof -
  have "0 \<le> (x - y)^2" by simp
  also have "\<dots> = x^2 + y^2 - 2*x*y"
    by(simp add: numeral_eq_Suc algebra_simps)
  finally show "0 \<le> x^2 + y^2 - 2*x*y" .
qed

text \<open>Interactive exercise:\<close>

lemma
  fixes x y :: real
  assumes "x \<ge> y" "y > 0"
  shows "(x - y) ^ 2 \<le> x^2 - y^2"
proof -
  have "(x - y) ^ 2 = x^2 + y^2 - 2*x*y"
    by(simp add: numeral_eq_Suc algebra_simps)
  show "(x - y) ^ 2 \<le> x^2 - y^2" sorry
qed

section "Streamlining proofs"

subsection "Pattern matching and ?-variables"

text \<open>Show \<open>\<exists>\<close>\<close>

lemma "\<exists> xs. length xs = 0" (is "\<exists> xs. ?P xs")
proof
  show "?P([])" by simp
qed

text \<open>Multiple EX easier with forward proof:\<close>

lemma "\<exists> x y :: int. x < z & z < y" (is "\<exists> x y. ?P x y")
proof -
  have "?P (z - 1) (z + 1)" by arith
  thus ?thesis by blast
qed

subsection "Quoting facts"

lemma assumes "x < (0::int)" shows "x*x > 0"
proof -
  from `x<0` show ?thesis by(metis mult_neg_neg)
qed

subsection "Example: Top Down Proof Development"

lemma "\<exists>ys zs. xs = ys @ zs \<and>
          (length ys = length zs \<or> length ys = length zs + 1)"
sorry

section "Solutions to interactive exercises"

lemma assumes "\<exists>x. \<forall>y. P x y" shows "\<forall>y. \<exists>x. P x y"
proof
  fix b
  from assms obtain a where 0: "\<forall>y. P a y" by blast
  show "\<exists>x. P x b"
  proof
    show "P a b" using 0 by blast
  qed
qed

lemma fixes x y :: real assumes "x \<ge> y" "y > 0"
shows "(x - y) ^ 2 \<le> x^2 - y^2"
proof -
  have "(x - y) ^ 2 = x^2 + y^2 - 2*x*y"
    by(simp add: numeral_eq_Suc algebra_simps)
  also have "\<dots> \<le> x^2 + y^2 - 2*y*y"
    using assms by(simp)
  also have "\<dots> = x^2 - y^2"
    by(simp add: numeral_eq_Suc)
  finally show ?thesis .
qed

subsection "Example: Top Down Proof Development"

text \<open>The key idea: case distinction on length:\<close>

lemma "\<exists>ys zs. xs = ys @ zs \<and> (length ys = length zs \<or> length ys = length zs + 1)"
proof cases
  assume "EX n. length xs = n+n"
  show ?thesis sorry
next
  assume "\<not> (EX n. length xs = n+n)"
  show ?thesis sorry
qed

text \<open>A proof skeleton:\<close>

lemma "\<exists>ys zs. xs = ys @ zs \<and> (length ys = length zs \<or> length ys = length zs + 1)"
proof cases
  assume "\<exists>n. length xs = n+n"
  then obtain n where "length xs = n+n" by blast
  let ?ys = "take n xs"
  let ?zs = "take n (drop n xs)"
  have "xs = ?ys @ ?zs \<and> length ?ys = length ?zs" sorry
  thus ?thesis by blast
next
  assume "\<not> (\<exists>n. length xs = n+n)"
  then obtain n where "length xs = Suc(n+n)" sorry
  let ?ys = "take (Suc n) xs"
  let ?zs = "take n (drop (Suc n) xs)"
  have "xs = ?ys @ ?zs \<and> length ?ys = length ?zs + 1" sorry
  then show ?thesis by blast
qed

text "The complete proof:"

lemma "\<exists>ys zs. xs = ys @ zs \<and> (length ys = length zs \<or> length ys = length zs + 1)"
proof cases
  assume "\<exists>n. length xs = n+n"
  then obtain n where "length xs = n+n" by blast
  let ?ys = "take n xs"
  let ?zs = "take n (drop n xs)"
  have "xs = ?ys @ ?zs \<and> length ?ys = length ?zs"
    by (simp add: `length xs = n + n`)
  thus ?thesis by blast
next
  assume "\<not> (\<exists>n. length xs = n+n)"
  hence "\<exists>n. length xs = Suc(n+n)" by arith
  then obtain n where l: "length xs = Suc(n+n)" by blast
  let ?ys = "take (Suc n) xs"
  let ?zs = "take n (drop (Suc n) xs)"
  have "xs = ?ys @ ?zs \<and> length ?ys = length ?zs + 1" by (simp add: l)
  thus ?thesis by blast
qed

end


(*
  File:    Factorizations.thy
  Author:  Manuel Eberl, TU München
*)
section \<open>Factorizations of polynomials\<close>
theory Factorizations
imports
  Complex_Main
  Linear_Recurrences_Misc
  "HOL-Computational_Algebra.Computational_Algebra"
  "HOL-Computational_Algebra.Polynomial_Factorial"
begin

text \<open>
  We view a factorisation of a polynomial as a pair consisting of the leading coefficient
  and a list of roots with multiplicities. This gives us a factorization into factors of
  the form $(X - c) ^ {n+1}$.
\<close>
definition interp_factorization where
  "interp_factorization = (\<lambda>(a,cs). Polynomial.smult a (\<Prod>(c,n)\<leftarrow>cs. [:-c,1:] ^ Suc n))"

text \<open>
  An alternative way to factorise is as a pair of the leading coefficient and
  factors of the form $(1 - cX) ^ {n+1}$.
\<close>
definition interp_alt_factorization where
  "interp_alt_factorization = (\<lambda>(a,cs). Polynomial.smult a (\<Prod>(c,n)\<leftarrow>cs. [:1,-c:] ^ Suc n))"

definition is_factorization_of where
  "is_factorization_of fctrs p =
     (interp_factorization fctrs = p \<and> distinct (map fst (snd fctrs)))"

definition is_alt_factorization_of where
  "is_alt_factorization_of fctrs p =
     (interp_alt_factorization fctrs = p \<and> 0 \<notin> set (map fst (snd fctrs)) \<and>
     distinct (map fst (snd fctrs)))"

text \<open>
  Regular and alternative factorisations are related by reflecting the polynomial.
\<close>
lemma interp_factorization_reflect:
  assumes "(0::'a::idom) \<notin> fst ` set (snd fctrs)"
  shows   "reflect_poly (interp_factorization fctrs) = interp_alt_factorization fctrs"
proof -
  have "reflect_poly (interp_factorization fctrs) =
          Polynomial.smult (fst fctrs) (\<Prod>x\<leftarrow>snd fctrs. reflect_poly [:- fst x, 1:] ^ Suc (snd x))"
    by (simp add: interp_factorization_def interp_alt_factorization_def case_prod_unfold
             reflect_poly_smult reflect_poly_prod_list reflect_poly_power o_def del: power_Suc)
  also have "map (\<lambda>x. reflect_poly [:- fst x, 1:] ^ Suc (snd x)) (snd fctrs) =
               map (\<lambda>x. [:1, - fst x:] ^ Suc (snd x)) (snd fctrs)"
    using assms by (intro list.map_cong0, subst reflect_poly_pCons) auto
  also have "Polynomial.smult (fst fctrs) (prod_list \<dots>) = interp_alt_factorization fctrs"
    by (simp add: interp_alt_factorization_def case_prod_unfold)
  finally show ?thesis .
qed

lemma interp_alt_factorization_reflect:
  assumes "(0::'a::idom) \<notin> fst ` set (snd fctrs)"
  shows   "reflect_poly (interp_alt_factorization fctrs) = interp_factorization fctrs"
proof -
  have "reflect_poly (interp_alt_factorization fctrs) =
          Polynomial.smult (fst fctrs) (\<Prod>x\<leftarrow>snd fctrs. reflect_poly [:1, - fst x:] ^ Suc (snd x))"
    by (simp add: interp_factorization_def interp_alt_factorization_def case_prod_unfold
             reflect_poly_smult reflect_poly_prod_list reflect_poly_power o_def del: power_Suc)
  also have "map (\<lambda>x. reflect_poly [:1, - fst x:] ^ Suc (snd x)) (snd fctrs) =
               map (\<lambda>x. [:- fst x, 1:] ^ Suc (snd x)) (snd fctrs)"
  proof (intro list.map_cong0, clarsimp simp del: power_Suc, goal_cases)
    fix c n assume "(c, n) \<in> set (snd fctrs)"
    with assms have "c \<noteq> 0" by force
    thus "reflect_poly [:1, -c:] ^ Suc n = [:-c, 1:] ^ Suc n"
      by (simp add: reflect_poly_pCons del: power_Suc)
  qed
  also have "Polynomial.smult (fst fctrs) (prod_list \<dots>) = interp_factorization fctrs"
    by (simp add: interp_factorization_def case_prod_unfold)
  finally show ?thesis .
qed

lemma coeff_0_interp_factorization:
  "coeff (interp_factorization fctrs) 0 = (0 :: 'a :: idom) \<longleftrightarrow>
     fst fctrs = 0 \<or> 0 \<in> fst ` set (snd fctrs)"
  by (force simp: interp_factorization_def case_prod_unfold coeff_0_prod_list o_def
                  coeff_0_power prod_list_zero_iff simp del: power_Suc)

lemma reflect_factorization:
  assumes "coeff p 0 \<noteq> (0::'a::idom)"
  assumes "is_factorization_of fctrs p"
  shows   "is_alt_factorization_of fctrs (reflect_poly p)"
  using assms by (force simp: interp_factorization_reflect is_factorization_of_def
                    is_alt_factorization_of_def coeff_0_interp_factorization)

lemma reflect_factorization':
  assumes "coeff p 0 \<noteq> (0::'a::idom)"
  assumes "is_alt_factorization_of fctrs p"
  shows   "is_factorization_of fctrs (reflect_poly p)"
  using assms by (force simp: interp_alt_factorization_reflect is_factorization_of_def
                    is_alt_factorization_of_def coeff_0_interp_factorization)

lemma zero_in_factorization_iff:
  assumes "is_factorization_of fctrs p"
  shows   "coeff p 0 = 0 \<longleftrightarrow> p = 0 \<or> (0::'a::idom) \<in> fst ` set (snd fctrs)"
proof (cases "p = 0")
  assume "p \<noteq> 0"
  with assms have [simp]: "fst fctrs \<noteq> 0"
    by (auto simp: is_factorization_of_def interp_factorization_def case_prod_unfold)
  from assms have "p = interp_factorization fctrs" by (simp add: is_factorization_of_def)
  also have "coeff \<dots> 0 = 0 \<longleftrightarrow> 0 \<in> fst ` set (snd fctrs)"
    by (force simp add: interp_factorization_def case_prod_unfold coeff_0_prod_list
                        prod_list_zero_iff o_def coeff_0_power)
  finally show ?thesis using \<open>p \<noteq> 0\<close> by blast
next
  assume p: "p = 0"
  with assms have "interp_factorization fctrs = 0" by (simp add: is_factorization_of_def)
  also have "interp_factorization fctrs = 0 \<longleftrightarrow>
                 fst fctrs = 0 \<or> (\<Prod>(c,n)\<leftarrow>snd fctrs. [:-c,1:]^Suc n) = 0"
    by (simp add: interp_factorization_def case_prod_unfold)
  also have "(\<Prod>(c,n)\<leftarrow>snd fctrs. [:-c,1:]^Suc n) = 0 \<longleftrightarrow> False"
    by (auto simp: prod_list_zero_iff simp del: power_Suc)
  finally show ?thesis by (simp add: \<open>p = 0\<close>)
qed

lemma poly_prod_list [simp]: "poly (prod_list ps) x = prod_list (map (\<lambda>p. poly p x) ps)"
  by (induction ps) auto

lemma is_factorization_of_roots:
  fixes a :: "'a :: idom"
  assumes "is_factorization_of (a, fctrs) p" "p \<noteq> 0"
  shows   "set (map fst fctrs) = {x. poly p x = 0}"
  using assms
  by (force simp: is_factorization_of_def interp_factorization_def o_def
        case_prod_unfold prod_list_zero_iff simp del: power_Suc)

lemma (in monoid_mult) prod_list_prod_nth: "prod_list xs = (\<Prod>i<length xs. xs ! i)"
  by (induction xs) (auto simp: prod.lessThan_Suc_shift simp del: prod.lessThan_Suc)

lemma order_prod:
  assumes "\<And>x. x \<in> A \<Longrightarrow> f x \<noteq> 0"
  assumes "\<And>x y. x \<in> A \<Longrightarrow> y \<in> A \<Longrightarrow> x \<noteq> y \<Longrightarrow> coprime (f x) (f y)"
  shows   "order c (prod f A) = (\<Sum>x\<in>A. order c (f x))"
  using assms
proof (induction A rule: infinite_finite_induct)
  case (insert x A)
  from insert.hyps have "order c (prod f (insert x A)) = order c (f x * prod f A)"
    by simp
  also have "\<dots> = order c (f x) + order c (prod f A)"
    using insert.prems and insert.hyps by (intro order_mult) auto
  also have "order c (prod f A) = (\<Sum>x\<in>A. order c (f x))"
    using insert.prems and insert.hyps by (intro insert.IH) auto
  finally show ?case using insert.hyps by simp
qed auto

lemma is_factorization_of_order:
  fixes p :: "'a :: field_gcd poly"
  assumes "p \<noteq> 0"
  assumes "is_factorization_of (a, fctrs) p"
  assumes "(c, n) \<in> set fctrs"
  shows   "order c p = Suc n"
proof -
  from assms have distinct: "distinct (map fst (fctrs))"
    by (simp add: is_factorization_of_def)
  from assms have [simp]: "a \<noteq> 0"
    by (auto simp: is_factorization_of_def interp_factorization_def)
  from assms(2) have "p = interp_factorization (a, fctrs)"
    unfolding is_factorization_of_def by simp
  also have "order c \<dots> = order c (\<Prod>(c,n)\<leftarrow>fctrs. [:-c, 1:] ^ Suc n)"
    unfolding interp_factorization_def by (simp add: order_smult)
  also have "(\<Prod>(c,n)\<leftarrow>fctrs. [:-c, 1:] ^ Suc n) =
               (\<Prod>i\<in>{..<length fctrs}. [:-fst (fctrs ! i), 1:] ^ Suc (snd (fctrs ! i)))"
    by (simp add: prod_list_prod_nth case_prod_unfold)
  also have "order c \<dots> =
               (\<Sum>x<length fctrs. order c ([:- fst (fctrs ! x), 1:] ^ Suc (snd (fctrs ! x))))"
  proof (rule order_prod)
    fix i
    assume "i \<in> {..<length fctrs}"
    then show "[:- fst (fctrs ! i), 1:] ^ Suc (snd (fctrs ! i)) \<noteq> 0"
      by (simp only: power_eq_0_iff) simp
  next
    fix i j :: nat
    assume "i \<noteq> j" "i \<in> {..<length fctrs}" "j \<in> {..<length fctrs}"
    then have "fst (fctrs ! i) \<noteq> fst (fctrs ! j)"
      using nth_eq_iff_index_eq [OF distinct, of i j] by simp
    then show "coprime ([:- fst (fctrs ! i), 1:] ^ Suc (snd (fctrs ! i)))
      ([:- fst (fctrs ! j), 1:] ^ Suc (snd (fctrs ! j)))"
      by (simp only: coprime_power_left_iff coprime_power_right_iff)
        (auto simp add: coprime_linear_poly)
  qed
  also have "\<dots> = (\<Sum>(c',n')\<leftarrow>fctrs. order c ([:-c', 1:] ^ Suc n'))"
    by (simp add: sum_list_sum_nth case_prod_unfold atLeast0LessThan)
  also have "\<dots> = (\<Sum>(c',n')\<leftarrow>fctrs. if c = c' then Suc n' else 0)"
    by (intro arg_cong[OF map_cong]) (auto simp add: order_power_n_n order_0I simp del: power_Suc)
  also have "\<dots> = (\<Sum>x\<leftarrow>fctrs. if x = (c, n) then Suc (snd x) else 0)"
    using distinct assms by (intro arg_cong[OF map_cong]) (force simp: distinct_map inj_on_def)+
  also from distinct have "\<dots> = (\<Sum>x\<in>set fctrs. if x = (c, n) then Suc (snd x) else 0)"
    by (intro sum_list_distinct_conv_sum_set) (simp_all add: distinct_map)
  also from assms have "\<dots> = Suc n" by simp
  finally show ?thesis .
qed

text \<open>
  For complex polynomials, a factorisation in the above sense always exists.
\<close>
lemma complex_factorization_exists:
  "\<exists>fctrs. is_factorization_of fctrs (p :: complex poly)"
proof (cases "p = 0")
  case True
  thus ?thesis
    by (intro exI[of _ "(0, [])"]) (auto simp: is_factorization_of_def interp_factorization_def)
next
  case False
  hence "\<exists>xs. set xs = {x. poly p x = 0} \<and> distinct xs"
    by (intro finite_distinct_list poly_roots_finite)
  then obtain xs where [simp]: "set xs = {x. poly p x = 0}" "distinct xs" by blast
  have "interp_factorization (lead_coeff p, map (\<lambda>x. (x, order x p - 1)) xs) =
          smult (lead_coeff p) (\<Prod>x\<leftarrow>xs. [:- x, 1:] ^ Suc (order x p - 1))"
    by (simp add: interp_factorization_def o_def)
  also have "(\<Prod>x\<leftarrow>xs. [:- x, 1:] ^ Suc (order x p - 1)) =
               (\<Prod>x|poly p x = 0. [:- x, 1:] ^ Suc (order x p - 1))"
    by (subst prod.distinct_set_conv_list [symmetric]) simp_all
  also have "\<dots> = (\<Prod>x|poly p x = 0. [:- x, 1:] ^ order x p)"
  proof (intro prod.cong refl, goal_cases)
    case (1 x)
    with False have "order x p \<noteq> 0" by (subst (asm) order_root) auto
    hence *: "Suc (order x p - 1) = order x p" by simp
    show ?case by (simp only: *)
  qed
  also have "smult (lead_coeff p) \<dots> = p"
    by (rule complex_poly_decompose)
  finally have "is_factorization_of (lead_coeff p, map (\<lambda>x. (x, order x p - 1)) xs) p"
    by (auto simp: is_factorization_of_def o_def)
  thus ?thesis ..
qed

text \<open>
  By reflecting the polynomial, this means that for complex polynomials with non-zero
  constant coefficient, the alternative factorisation also exists.
\<close>
corollary complex_alt_factorization_exists:
  assumes "coeff p 0 \<noteq> 0"
  shows   "\<exists>fctrs. is_alt_factorization_of fctrs (p :: complex poly)"
proof -
  from assms have "coeff (reflect_poly p) 0 \<noteq> 0"
    by auto
  moreover from complex_factorization_exists [of "reflect_poly p"]
  obtain fctrs where "is_factorization_of fctrs (reflect_poly p)" ..
  ultimately have "is_alt_factorization_of fctrs (reflect_poly (reflect_poly p))"
    by (rule reflect_factorization)
  also from assms have "reflect_poly (reflect_poly p) = p"
    by simp
  finally show ?thesis ..
qed

end


theory RelUtils
  imports Main "HOL.Transitive_Closure"
begin

\<comment> \<open>NOTE added definition.\<close>
definition reflexive where
  "reflexive R \<equiv> \<forall>x. R x x"

\<comment> \<open>NOTE translation of 'TC' in relationScript.sml:69.\<close>
\<comment> \<open>TODO can we replace this with something from 'HOL.Transitive\_Closure'?\<close>
definition TC where
  "TC R a b \<equiv> (\<forall>P. (\<forall>x y. R x y \<longrightarrow> P x y) \<and> (\<forall>x y z. P x y \<and> P y z \<longrightarrow> P x z) \<longrightarrow> P a b)"

\<comment> \<open>NOTE adapts transitive closure definitions of Isabelle and HOL4.\<close>
lemma TC_equiv_tranclp: "TC R a b \<longleftrightarrow> (R\<^sup>+\<^sup>+ a b)"
proof -
  {
    have "TC R a b \<Longrightarrow> (R\<^sup>+\<^sup>+ a b)"
      unfolding TC_def
      using tranclp.r_into_trancl tranclp_trans
      by metis
  }
  moreover
  {
    have "(R\<^sup>+\<^sup>+ a b) \<Longrightarrow> TC R a b" proof(induction rule: tranclp.induct)
      case (r_into_trancl a b)
      then show ?case by(subst TC_def; auto)
    next
      case (trancl_into_trancl a b c)
      then show ?case unfolding TC_def by blast
    qed
  }
  ultimately show ?thesis
    by fast
qed

lemma TC_IMP_NOT_TC_CONJ_1:
  fixes R P  and  x y
  assumes "\<not>(R\<^sup>+\<^sup>+ x y)"
  shows "\<not>((\<lambda>x y. R x y \<and> P x y)\<^sup>+\<^sup>+ x y)"
proof -
  from assms(1) have 1: "\<not>TC R x y"
    using TC_equiv_tranclp
    by fast
  {
    assume P: "\<not>TC R x y"
    then obtain P where a: "(\<forall>x y. R x y \<longrightarrow> P x y) \<and> (\<forall>x y z. P x y \<and> P y z \<longrightarrow> P x z) \<longrightarrow> \<not>P x y"
      unfolding TC_def
      by blast
    {
      assume P_1: "(\<forall>x y. R x y \<longrightarrow> P x y)" "(\<forall>x y z. P x y \<and> P y z \<longrightarrow> P x z)"
      then have "(\<forall>x y. R x y \<and> P x y \<longrightarrow> P x y)" "(\<forall>x y z. P x y \<and> P y z \<longrightarrow> P x z)"
        by blast+
      moreover from a and P_1 have "\<not>P x y"
        by blast
      then have "\<exists>P. (\<forall>x y. R x y \<and> P x y \<longrightarrow> P x y) \<and> (\<forall>x y z. P x y \<and> P y z \<longrightarrow> P x z) \<longrightarrow> \<not>P x y"
        by blast
    }
    then have "\<exists>P.
      (\<forall>x y. R x y \<and> P x y \<longrightarrow> P x y) \<and> (\<forall>x y z. P x y \<and> P y z \<longrightarrow> P x z) \<longrightarrow> \<not>P x y"
      by blast
  }
  note 2 = this
  {
    from 1 2 have "\<exists>P.
      (\<forall>x y. R x y \<and> P x y \<longrightarrow> P x y) \<and> (\<forall>x y z. P x y \<and> P y z \<longrightarrow> P x z) \<longrightarrow> \<not>P x y"
      by blast
    then have "\<not>TC (\<lambda>x y. R x y \<and> P x y) x y"
      unfolding TC_def
      by (metis assms tranclp.r_into_trancl tranclp_trans)
    then have "\<not>(\<lambda>x y. R x y \<and> P x y)\<^sup>+\<^sup>+ x y"
      using TC_equiv_tranclp
      by fast
  }
  then show ?thesis
    by blast
qed

lemma TC_IMP_NOT_TC_CONJ:
  fixes R R' P x y
  assumes "\<forall>x y. P x y \<longrightarrow> R' x y \<longrightarrow> R x y" "\<not>R\<^sup>+\<^sup>+ x y"
  shows "\<not>(\<lambda>x y. R' x y \<and> P x y)\<^sup>+\<^sup>+ x y"
proof -
  from assms(2)
  have 1: "\<not>(\<lambda>x y. R x y \<and> P x  y)\<^sup>+\<^sup>+ x y"
    using TC_IMP_NOT_TC_CONJ_1[where P="\<lambda>x y. P x y"]
    by blast
  {
    {
      from 1 have  "\<not>TC (\<lambda>x y. R x y \<and> P x  y) x y"
        using TC_equiv_tranclp
        by fast
      then have "\<exists>Pa.
      (\<forall>x y. R x y \<and> P x y \<longrightarrow> Pa x y) \<and> (\<forall>x y z. Pa x y \<and> Pa y z \<longrightarrow> Pa x z)
      \<longrightarrow> \<not>Pa x y"
        unfolding TC_def
        by blast
    }
    then obtain Pa where a:
      "(\<forall>x y. R x y \<and> P x y \<longrightarrow> Pa x y) \<and> (\<forall>x y z. Pa x y \<and> Pa y z \<longrightarrow> Pa x z) \<longrightarrow> \<not>Pa x y"
      by blast
    then have "\<not>(\<forall>Pa. (\<forall>x y. R' x y \<and> P x y \<longrightarrow> Pa x y) \<and> (\<forall>x y z. Pa x y \<and> Pa y z \<longrightarrow> Pa x z) \<longrightarrow> Pa x y)"
      by (metis assms(1) assms(2) tranclp.r_into_trancl tranclp_trans)
    then have "\<not>TC (\<lambda>x y. R' x y \<and> P x y) x y"
      unfolding TC_def
      by blast
  }
  then show ?thesis
    using TC_equiv_tranclp
    by fast
qed

\<comment> \<open>NOTE added lemma (relationScript.sml:314)\<close>
lemma TC_INDUCT:
  fixes R :: "'a \<Rightarrow> 'a \<Rightarrow> bool" and P
  assumes "(\<forall>x y. R x y \<longrightarrow> P x y)" "(\<forall>x y z. P x y \<and> P y z \<longrightarrow> P x z)"
  shows "\<forall>u v. (TC R) u v \<longrightarrow> P u v"
  using assms
  unfolding TC_def
  by metis

lemma REFL_IMP_3_CONJ_1:
  fixes R P x y
  assumes "((\<lambda>x y. R x y \<and> P x y)\<^sup>+\<^sup>+ x y)"
  shows "R\<^sup>+\<^sup>+ x y"
  using assms
proof -
  show ?thesis
    using assms TC_IMP_NOT_TC_CONJ_1
    by fast
qed

lemma REFL_IMP_3_CONJ:
  fixes R'
  assumes "reflexive R'"
  shows "(\<forall>P x y.
    (R'\<^sup>+\<^sup>+ x y) \<longrightarrow> ( ((\<lambda>x y. R' x y \<and> P x \<and> P y)\<^sup>+\<^sup>+ x y) \<or> (\<exists>z. \<not>P z \<and> R'\<^sup>+\<^sup>+ x z \<and> R'\<^sup>+\<^sup>+ z y)))"
proof -
  {
    fix P
    {
      have "\<forall>x y. R' x y \<longrightarrow> (\<lambda>x y. R' x y \<and> P x \<and> P y)\<^sup>+\<^sup>+ x y \<or> (\<exists>z. \<not> P z \<and> R'\<^sup>+\<^sup>+ x z \<and> R'\<^sup>+\<^sup>+ z y)"
      proof (auto)
        fix x y
        assume P: "R' x y" "\<forall>z. R'\<^sup>+\<^sup>+ x z \<longrightarrow> P z \<or> \<not> R'\<^sup>+\<^sup>+ z y"
        then show "(\<lambda>x y. R' x y \<and> P x \<and> P y)\<^sup>+\<^sup>+ x y"
        proof -
          have a: "\<And>a. \<not> R' x a \<or> \<not> R' a y \<or> P a"
            using P(2)
            by blast
          have "reflexive R'"
            by (meson assms)
          then show ?thesis
            using a P(1)
            by (simp add: reflexive_def tranclp.r_into_trancl)
        qed
      qed
    }
    moreover {
      have "\<forall>x y z. ((\<lambda>x y. R' x y \<and> P x \<and> P y)\<^sup>+\<^sup>+ x y \<or> (\<exists>z. \<not> P z \<and> R'\<^sup>+\<^sup>+ x z \<and> R'\<^sup>+\<^sup>+ z y)) \<and>
         ((\<lambda>x y. R' x y \<and> P x \<and> P y)\<^sup>+\<^sup>+ y z \<or> (\<exists>za. \<not> P za \<and> R'\<^sup>+\<^sup>+ y za \<and> R'\<^sup>+\<^sup>+ za z)) \<longrightarrow>
         (\<lambda>x y. R' x y \<and> P x \<and> P y)\<^sup>+\<^sup>+ x z \<or> (\<exists>za. \<not> P za \<and> R'\<^sup>+\<^sup>+ x za \<and> R'\<^sup>+\<^sup>+ za z)"
      proof (auto)
        fix x y z za
        assume P: "\<forall>za. R'\<^sup>+\<^sup>+ x za \<longrightarrow> P za \<or> \<not> R'\<^sup>+\<^sup>+ za z" "(\<lambda>x y. R' x y \<and> P x \<and> P y)\<^sup>+\<^sup>+ x y"
          "\<not> P za" "R'\<^sup>+\<^sup>+ y za" "R'\<^sup>+\<^sup>+ za z"
        then show "(\<lambda>x y. R' x y \<and> P x \<and> P y)\<^sup>+\<^sup>+ x z"
          using P
          by (meson P rtranclp_tranclp_tranclp TC_IMP_NOT_TC_CONJ_1  tranclp_into_rtranclp)
      next
        fix x y z za
        assume P: "\<forall>za. R'\<^sup>+\<^sup>+ x za \<longrightarrow> P za \<or> \<not> R'\<^sup>+\<^sup>+ za z" "\<not> P za" "R'\<^sup>+\<^sup>+ x za" "R'\<^sup>+\<^sup>+ za y"
          "(\<lambda>x y. R' x y \<and> P x \<and> P y)\<^sup>+\<^sup>+ y z"
        then show "(\<lambda>x y. R' x y \<and> P x \<and> P y)\<^sup>+\<^sup>+ x z"
          by (meson P TC_IMP_NOT_TC_CONJ_1 tranclp_trans)
      qed
    }
    ultimately have "\<forall>u v.
      TC R' u v
      \<longrightarrow> (\<lambda>x y. R' x y \<and> P x \<and> P y)\<^sup>+\<^sup>+ u v \<or> (\<exists>z. \<not> P z \<and> R'\<^sup>+\<^sup>+ u z \<and> R'\<^sup>+\<^sup>+ z v)"
      using TC_INDUCT[where R="R'" and
          P="\<lambda>x y. ( ((\<lambda>x y. R' x y \<and> P x \<and> P y)\<^sup>+\<^sup>+ x y) \<or> (\<exists>z. \<not>P z \<and> R'\<^sup>+\<^sup>+ x z \<and> R'\<^sup>+\<^sup>+ z y))"]
      by fast
  }
  then show ?thesis
    by (simp add: TC_equiv_tranclp)
qed

\<comment> \<open>NOTE
  This is not a trivial translation: 'TC\_INDUCT' in relationScript.sml:314 differs significantly
from 'trancl\_induct' and 'trancl\_trans\_induct' in Transitive\_Closure:375, 391\<close>
lemma TC_CASES1_NEQ:
  fixes R x z
  assumes "R\<^sup>+\<^sup>+ x z"
  shows "R x z \<or> (\<exists>y :: 'a. \<not>(x = y) \<and> \<not>(y = z) \<and> R x y \<and> R\<^sup>+\<^sup>+ y z)"
proof -
  {
    fix u v
    have "\<forall>x y. R x y \<longrightarrow> R x y \<or> (\<exists>ya. x \<noteq> ya \<and> ya \<noteq> y \<and> R x ya \<and> R\<^sup>+\<^sup>+ ya y)"
      by meson
    moreover have "\<forall>x y z.
      (R x y \<or> (\<exists>ya. x \<noteq> ya \<and> ya \<noteq> y \<and> R x ya \<and> R\<^sup>+\<^sup>+ ya y))
      \<and> (R y z \<or> (\<exists>ya. y \<noteq> ya \<and> ya \<noteq> z \<and> R y ya \<and> R\<^sup>+\<^sup>+ ya z))
      \<longrightarrow> R x z \<or> (\<exists>y. x \<noteq> y \<and> y \<noteq> z \<and> R x y \<and> R\<^sup>+\<^sup>+ y z)"
      by (metis tranclp.r_into_trancl tranclp_trans)
    ultimately have "TC R u v \<longrightarrow> R u v \<or> (\<exists>y. u \<noteq> y \<and> y \<noteq> v \<and> R u y \<and> R\<^sup>+\<^sup>+ y v)"
      using TC_INDUCT[where P="\<lambda>x z. R x z \<or> (\<exists>y :: 'a. \<not>(x = y) \<and> \<not>(y = z) \<and> R x y \<and> R\<^sup>+\<^sup>+ y z)"]
      by blast
  }
  then show ?thesis
    using assms TC_equiv_tranclp
    by (simp add: TC_equiv_tranclp)
qed
end