section {* A C-Struct for one-shot consensu *}

theory Consensus
imports CStruct
begin

text {* This theory provides a model for the C-Struct locale, thus showing
  that the assumption of the C-Struct locale are consistent. *}

locale Consensus
begin

fun \<delta>::"'v option \<Rightarrow> 'v \<Rightarrow> 'v option" (infix "\<bullet>" 65) where
  "\<delta> None r = Some r"
| "\<delta> (Some v) r = Some v"

interpretation pre_CStruct \<delta> None .
notation exec (infix "\<star>" 65)
notation less_eq (infix "\<preceq>" 50 )
notation None ("\<bottom>")

lemma single_use:
  fixes r rs
  shows  "\<bottom> \<star> ([r]@rs) = Some r"
proof (induct rs)
  case Nil
  thus ?case by simp
next
  case (Cons r rs)
  thus ?case by auto
qed

lemma bot: "\<exists> rs . s = \<bottom> \<star> rs"
proof (cases s)
  case None thus ?thesis
    by (metis exec.simps(1))
next
  case (Some v) thus ?thesis
    by (metis Consensus.single_use)
qed

lemma prec_eq_None_or_equal:
fixes s1 s2
assumes "s1 \<preceq> s2"
shows "s1 = None \<or> s1 = s2" using assms single_use
  by (metis less_eq_def not_None_eq pre_CStruct.exec.simps(1) pre_CStruct.exec_append)

lemma compat2_bot:
assumes "compat2 s1 s2"
shows "s1 = \<bottom> \<or> s2 = \<bottom> \<or> s1 = s2"
  using assms
by (auto simp add: compat2_def less_eq_def)
(metis Consensus.prec_eq_None_or_equal assms(1) compat2_def option.distinct(1))

lemma compat_bot1:
assumes "compat {s1,s2,s3}" and "s1 \<noteq> \<bottom>"
shows "s1 \<noteq> \<bottom> \<Longrightarrow> (\<And> s . s \<in> {s2,s3} \<Longrightarrow> s = \<bottom> \<or> s = s1)"
using compat2_bot assms
   by (metis insertCI local.compat_def)

lemma compat_bot2:
assumes "compat {s1,s2,s3}" and "s1 \<noteq> \<bottom>"
shows "s1 = \<bottom> \<Longrightarrow> s2 = \<bottom> \<or> s3 = \<bottom> \<or> s2 = s3"
using compat2_bot assms by metis

lemma sup_bot_bot:"sup \<bottom> \<bottom> = \<bottom>"
apply(simp add:sup_def is_lub_def is_ub_def)
apply(rule the_equality[where a="\<bottom>"])
  subgoal by (smt pre_CStruct.exec.simps(1) pre_CStruct.less_eq_def)
  subgoal by (smt Consensus.prec_eq_None_or_equal pre_CStruct.exec.simps(1) pre_CStruct.less_eq_def)
done

lemma sup_bot1:
assumes "s1 = \<bottom>"
shows "sup s1 s2 = s2" using assms
apply(simp add:sup_def is_lub_def is_ub_def)
apply(rule the_equality[where a="s2"])
  subgoal by (metis Consensus.bot pre_CStruct.exec.simps(1) pre_CStruct.less_eq_def)
  subgoal by (metis Consensus.prec_eq_None_or_equal exec.simps(1) pre_CStruct.less_eq_def)
done

lemma sup_bot2:
assumes "s2 = \<bottom>"
shows "sup s1 s2 = s1" using assms
apply(simp add:sup_def is_lub_def is_ub_def)
apply(rule the_equality[where a="s1"])
  subgoal by (metis Consensus.bot pre_CStruct.exec.simps(1) pre_CStruct.less_eq_def)
  subgoal by (metis Consensus.prec_eq_None_or_equal exec.simps(1) pre_CStruct.less_eq_def)
done

lemma sup_not_bot:
assumes "s1 \<noteq> \<bottom>" and "s2 \<noteq> \<bottom>" and "compat2 s1 s2"
shows "sup s1 s2 = s1"
proof -
  from assms have "s1 = s2"
    by (metis Consensus.compat2_bot)
  thus ?thesis
    apply(simp add:sup_def is_lub_def is_ub_def)
    apply(rule the_equality[where a="s2"])
      subgoal by (metis Consensus.prec_eq_None_or_equal assms(1) less_bullet)
      subgoal by (metis Consensus.prec_eq_None_or_equal assms(2))
    done
qed

lemma sup_cons:
assumes "compat2 s1 s2"
shows "(s1 = s2 \<and> sup s1 s2 = s1) \<or> (s1 = \<bottom> \<and> sup s1 s2 = s2) \<or> (s2 = \<bottom> \<and> sup s1 s2 = s1)"
by (metis Consensus.compat2_bot Consensus.sup_bot1 Consensus.sup_bot2 Consensus.sup_not_bot assms)

interpretation CStruct \<delta> \<bottom>
apply (unfold_locales)
  subgoal using Consensus.prec_eq_None_or_equal by auto
  subgoal
    apply (simp add:is_glb_def is_lb_def)
    apply (metis Consensus.bot Consensus.prec_eq_None_or_equal pre_CStruct.less_eq_def)
    done
  subgoal
    by (metis Consensus.prec_eq_None_or_equal bot.extremum empty_set is_glb_def pre_CStruct.exec.simps(1) pre_CStruct.is_lb_def sup.cobounded2)
  subgoal
    by (metis Consensus.bot pre_CStruct.less_eq_def)
  subgoal
    apply (simp add:compat2_def is_lub_def is_ub_def)
    by (metis Consensus.prec_eq_None_or_equal \<open>\<And>s. \<bottom> \<preceq> s\<close>)
  subgoal
    by (metis (no_types, lifting) Consensus.sup_cons insertCI insert_absorb2 local.compat_def)
done

end

end


(*  Title:      HOL/Library/Bit.thy
    Author:     Brian Huffman
*)

section {* The Field of Integers mod 2 *}

theory Bit
imports Main
begin

subsection {* Bits as a datatype *}

typedef bit = "UNIV :: bool set"
  morphisms set Bit
  ..

instantiation bit :: "{zero, one}"
begin

definition zero_bit_def:
  "0 = Bit False"

definition one_bit_def:
  "1 = Bit True"

instance ..

end

old_rep_datatype "0::bit" "1::bit"
proof -
  fix P and x :: bit
  assume "P (0::bit)" and "P (1::bit)"
  then have "\<forall>b. P (Bit b)"
    unfolding zero_bit_def one_bit_def
    by (simp add: all_bool_eq)
  then show "P x"
    by (induct x) simp
next
  show "(0::bit) \<noteq> (1::bit)"
    unfolding zero_bit_def one_bit_def
    by (simp add: Bit_inject)
qed

lemma Bit_set_eq [simp]:
  "Bit (set b) = b"
  by (fact set_inverse)

lemma set_Bit_eq [simp]:
  "set (Bit P) = P"
  by (rule Bit_inverse) rule

lemma bit_eq_iff:
  "x = y \<longleftrightarrow> (set x \<longleftrightarrow> set y)"
  by (auto simp add: set_inject)

lemma Bit_inject [simp]:
  "Bit P = Bit Q \<longleftrightarrow> (P \<longleftrightarrow> Q)"
  by (auto simp add: Bit_inject)

lemma set [iff]:
  "\<not> set 0"
  "set 1"
  by (simp_all add: zero_bit_def one_bit_def Bit_inverse)

lemma set_iff:
  "set b \<longleftrightarrow> b = 1"
  by (cases b) simp_all

lemma bit_eq_iff_set:
  "b = 0 \<longleftrightarrow> \<not> set b"
  "b = 1 \<longleftrightarrow> set b"
  by (simp_all add: bit_eq_iff)

lemma Bit [simp, code]:
  "Bit False = 0"
  "Bit True = 1"
  by (simp_all add: zero_bit_def one_bit_def)

lemma bit_not_0_iff [iff]:
  "(x::bit) \<noteq> 0 \<longleftrightarrow> x = 1"
  by (simp add: bit_eq_iff)

lemma bit_not_1_iff [iff]:
  "(x::bit) \<noteq> 1 \<longleftrightarrow> x = 0"
  by (simp add: bit_eq_iff)

lemma [code]:
  "HOL.equal 0 b \<longleftrightarrow> \<not> set b"
  "HOL.equal 1 b \<longleftrightarrow> set b"
  by (simp_all add: equal set_iff)

subsection {* Type @{typ bit} forms a field *}

instantiation bit :: field_inverse_zero
begin

definition plus_bit_def:
  "x + y = case_bit y (case_bit 1 0 y) x"

definition times_bit_def:
  "x * y = case_bit 0 y x"

definition uminus_bit_def [simp]:
  "- x = (x :: bit)"

definition minus_bit_def [simp]:
  "x - y = (x + y :: bit)"

definition inverse_bit_def [simp]:
  "inverse x = (x :: bit)"

definition divide_bit_def [simp]:
  "x / y = (x * y :: bit)"

lemmas field_bit_defs =
  plus_bit_def times_bit_def minus_bit_def uminus_bit_def
  divide_bit_def inverse_bit_def

instance proof
qed (unfold field_bit_defs, auto split: bit.split)

end

lemma bit_add_self: "x + x = (0 :: bit)"
  unfolding plus_bit_def by (simp split: bit.split)

lemma bit_mult_eq_1_iff [simp]: "x * y = (1 :: bit) \<longleftrightarrow> x = 1 \<and> y = 1"
  unfolding times_bit_def by (simp split: bit.split)

text {* Not sure whether the next two should be simp rules. *}

lemma bit_add_eq_0_iff: "x + y = (0 :: bit) \<longleftrightarrow> x = y"
  unfolding plus_bit_def by (simp split: bit.split)

lemma bit_add_eq_1_iff: "x + y = (1 :: bit) \<longleftrightarrow> x \<noteq> y"
  unfolding plus_bit_def by (simp split: bit.split)

subsection {* Numerals at type @{typ bit} *}

text {* All numerals reduce to either 0 or 1. *}

lemma bit_minus1 [simp]: "- 1 = (1 :: bit)"
  by (simp only: uminus_bit_def)

lemma bit_neg_numeral [simp]: "(- numeral w :: bit) = numeral w"
  by (simp only: uminus_bit_def)

lemma bit_numeral_even [simp]: "numeral (Num.Bit0 w) = (0 :: bit)"
  by (simp only: numeral_Bit0 bit_add_self)

lemma bit_numeral_odd [simp]: "numeral (Num.Bit1 w) = (1 :: bit)"
  by (simp only: numeral_Bit1 bit_add_self add_0_left)

subsection {* Conversion from @{typ bit} *}

context zero_neq_one
begin

definition of_bit :: "bit \<Rightarrow> 'a"
where
  "of_bit b = case_bit 0 1 b"

lemma of_bit_eq [simp, code]:
  "of_bit 0 = 0"
  "of_bit 1 = 1"
  by (simp_all add: of_bit_def)

lemma of_bit_eq_iff:
  "of_bit x = of_bit y \<longleftrightarrow> x = y"
  by (cases x) (cases y, simp_all)+

end

context semiring_1
begin

lemma of_nat_of_bit_eq:
  "of_nat (of_bit b) = of_bit b"
  by (cases b) simp_all

end

context ring_1
begin

lemma of_int_of_bit_eq:
  "of_int (of_bit b) = of_bit b"
  by (cases b) simp_all

end

hide_const (open) set

end


(*  Title:      ZF/AC/WO1_AC.thy
    Author:     Krzysztof Grabczewski

The proofs of WO1 ==> AC1 and WO1 ==> AC10(n) for n >= 1

The latter proof is referred to as clear by the Rubins.
However it seems to be quite complicated.
The formal proof presented below is a mechanisation of the proof
by Lawrence C. Paulson which is the following:

Assume WO1.  Let s be a set of infinite sets.

Suppose x \<in> s.  Then x is equipollent to |x| (by WO1), an infinite cardinal
call it K.  Since K = K \<oplus> K = |K+K| (by InfCard_cdouble_eq) there is an
isomorphism h \<in> bij(K+K, x).  (Here + means disjoint sum.)

So there is a partition of x into 2-element sets, namely

        {{h(Inl(i)), h(Inr(i))} . i \<in> K}

So for all x \<in> s the desired partition exists.  By AC1 (which follows from WO1)
there exists a function f that chooses a partition for each x \<in> s.  Therefore we
have AC10(2).

*)

theory WO1_AC
imports AC_Equiv
begin

(* ********************************************************************** *)
(* WO1 ==> AC1                                                            *)
(* ********************************************************************** *)

theorem WO1_AC1: "WO1 ==> AC1"
by (unfold AC1_def WO1_def, fast elim!: ex_choice_fun)

(* ********************************************************************** *)
(* WO1 ==> AC10(n) (n >= 1)                                               *)
(* ********************************************************************** *)

lemma lemma1: "[| WO1; \<forall>B \<in> A. \<exists>C \<in> D(B). P(C,B) |] ==> \<exists>f. \<forall>B \<in> A. P(f`B,B)"
apply (unfold WO1_def)
apply (erule_tac x = "\<Union>({{C \<in> D (B) . P (C,B) }. B \<in> A}) " in allE)
apply (erule exE, drule ex_choice_fun, fast)
apply (erule exE)
apply (rule_tac x = "\<lambda>x \<in> A. f`{C \<in> D (x) . P (C,x) }" in exI)
apply (simp, blast dest!: apply_type [OF _ RepFunI])
done

lemma lemma2_1: "[| ~Finite(B); WO1 |] ==> |B| + |B| \<approx>  B"
apply (unfold WO1_def)
apply (rule eqpoll_trans)
prefer 2 apply (fast elim!: well_ord_cardinal_eqpoll)
apply (rule eqpoll_sym [THEN eqpoll_trans])
apply (fast elim!: well_ord_cardinal_eqpoll)
apply (drule spec [of _ B])
apply (clarify dest!: eqpoll_imp_Finite_iff [OF well_ord_cardinal_eqpoll])
apply (simp add: cadd_def [symmetric]
            eqpoll_refl InfCard_cdouble_eq Card_cardinal Inf_Card_is_InfCard)
done

lemma lemma2_2:
     "f \<in> bij(D+D, B) ==> {{f`Inl(i), f`Inr(i)}. i \<in> D} \<in> Pow(Pow(B))"
by (fast elim!: bij_is_fun [THEN apply_type])

lemma lemma2_3:
        "f \<in> bij(D+D, B) ==> pairwise_disjoint({{f`Inl(i), f`Inr(i)}. i \<in> D})"
apply (unfold pairwise_disjoint_def)
apply (blast dest: bij_is_inj [THEN inj_apply_equality])
done

lemma lemma2_4:
     "[| f \<in> bij(D+D, B); 1\<le>n |]
      ==> sets_of_size_between({{f`Inl(i), f`Inr(i)}. i \<in> D}, 2, succ(n))"
apply (simp (no_asm_simp) add: sets_of_size_between_def succ_def)
apply (blast intro!: cons_lepoll_cong
            intro: singleton_eqpoll_1 [THEN eqpoll_imp_lepoll]
                   le_imp_subset [THEN subset_imp_lepoll]  lepoll_trans
            dest: bij_is_inj [THEN inj_apply_equality] elim!: mem_irrefl)
done

lemma lemma2_5:
     "f \<in> bij(D+D, B) ==> \<Union>({{f`Inl(i), f`Inr(i)}. i \<in> D})=B"
apply (unfold bij_def surj_def)
apply (fast elim!: inj_is_fun [THEN apply_type])
done

lemma lemma2:
     "[| WO1; ~Finite(B); 1\<le>n  |]
      ==> \<exists>C \<in> Pow(Pow(B)). pairwise_disjoint(C) &
                sets_of_size_between(C, 2, succ(n)) &
                \<Union>(C)=B"
apply (drule lemma2_1 [THEN eqpoll_def [THEN def_imp_iff, THEN iffD1]],
       assumption)
apply (blast intro!: lemma2_2 lemma2_3 lemma2_4 lemma2_5)
done

theorem WO1_AC10: "[| WO1; 1\<le>n |] ==> AC10(n)"
apply (unfold AC10_def)
apply (fast intro!: lemma1 elim!: lemma2)
done

end


theory T116
imports Main
begin
lemma "(
(\<forall> x::nat. \<forall> y::nat. meet(x, y) = meet(y, x)) &
(\<forall> x::nat. \<forall> y::nat. join(x, y) = join(y, x)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, meet(y, z)) = meet(meet(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(x, join(y, z)) = join(join(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. meet(x, join(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. join(x, meet(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, join(y, z)) = join(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(join(x, y), z) = join(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, over(join(mult(x, y), z), y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(y, undr(x, join(mult(x, y), z))) = y) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(over(x, y), y), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(y, undr(y, x)), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(meet(x, y), z) = meet(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(x, meet(y, z)) = join(over(x, y), over(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(meet(x, y), z) = join(undr(x, z), undr(y, z))) &
(\<forall> x::nat. \<forall> y::nat. invo(join(x, y)) = meet(invo(x), invo(y))) &
(\<forall> x::nat. \<forall> y::nat. invo(meet(x, y)) = join(invo(x), invo(y))) &
(\<forall> x::nat. invo(invo(x)) = x)
) \<longrightarrow>
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(join(x, y), z) = join(over(x, z), over(y, z)))
"
nitpick[card nat=4,timeout=86400]
oops
end


theory T7
imports Main
begin
lemma "(
(\<forall> x::nat. \<forall> y::nat. meet(x, y) = meet(y, x)) &
(\<forall> x::nat. \<forall> y::nat. join(x, y) = join(y, x)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, meet(y, z)) = meet(meet(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(x, join(y, z)) = join(join(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. meet(x, join(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. join(x, meet(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, join(y, z)) = join(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(join(x, y), z) = join(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, over(join(mult(x, y), z), y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(y, undr(x, join(mult(x, y), z))) = y) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(over(x, y), y), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(y, undr(y, x)), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(meet(x, y), z) = meet(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(x, meet(y, z)) = join(over(x, y), over(x, z))) &
(\<forall> x::nat. \<forall> y::nat. invo(join(x, y)) = meet(invo(x), invo(y))) &
(\<forall> x::nat. \<forall> y::nat. invo(meet(x, y)) = join(invo(x), invo(y))) &
(\<forall> x::nat. invo(invo(x)) = x)
) \<longrightarrow>
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, meet(y, z)) = meet(mult(x, y), mult(x, z)))
"
nitpick[card nat=4,timeout=86400]
oops
end


(* Author: Alexander Bentkamp, Universität des Saarlandes
*)
section \<open>Alternative Lebesgue Measure Definition\<close>

theory Lebesgue_Functional
imports "HOL-Analysis.Lebesgue_Measure"
begin

text \<open>Lebesgue\_Measure.lborel is defined on the typeclass euclidean\_space, which does not allow the
space dimension to be dependent on a variable. As the Lebesgue measure of higher dimensions is the
product measure of the one dimensional Lebesgue measure, we can easily define a more flexible version
of the Lebesgue measure as follows. This version of the Lebesgue measure measures sets of functions
from nat to real whose values are undefined for arguments higher than n. These "Extensional Function Spaces"
 are defined in HOL/FuncSet. \<close>

definition lborel_f :: "nat \<Rightarrow> (nat \<Rightarrow> real) measure" where
  "lborel_f n = (\<Pi>\<^sub>M b\<in>{..<n}. lborel)"

lemma product_sigma_finite_interval: "product_sigma_finite (\<lambda>b. interval_measure (\<lambda>x. x))"
  unfolding product_sigma_finite_def using  sigma_finite_interval_measure by auto

lemma l_borel_f_1: "distr (lborel_f 1) lborel (\<lambda>x. x 0) = lborel"
  unfolding lborel_f_def
  using product_sigma_finite.distr_singleton[OF product_sigma_finite_interval, of 0]
    lborel_eq_real lessThan_Suc by auto

lemma space_lborel_f: "space (lborel_f n) = Pi\<^sub>E {..<n} (\<lambda>_. UNIV)" unfolding lborel_f_def
  unfolding space_PiM space_lborel space_borel by metis

lemma space_lborel_f_subset: "space (lborel_f n) \<subseteq> space (lborel_f (Suc n))"
unfolding space_lborel_f by (rule subsetI, rule PiE_I, blast,
  metis PiE_E  Suc_n_not_le_n le_cases lessThan_subset_iff subsetCE)

lemma space_lborel_add_dim:
assumes "f \<in> space (lborel_f n)"
shows "f(n:=x) \<in> space (lborel_f (Suc n))"
unfolding space_lborel_f
using assms lessThan_Suc space_lborel_f by auto

lemma integral_lborel_f:
assumes "f \<in> borel_measurable (lborel_f (Suc n))"
shows "integral\<^sup>N (lborel_f (Suc n)) f = \<integral>\<^sup>+ y. \<integral>\<^sup>+ x. f (x(n := y)) \<partial>lborel_f n \<partial>lborel"
  unfolding lborel_f_def
  using product_sigma_finite.product_nn_integral_insert_rev[OF product_sigma_finite_interval, of "{..<n}", OF finite_lessThan _]
  assms[unfolded lborel_f_def] lborel_eq_real by (simp add: lessThan_Suc)

lemma emeasure_lborel_f_Suc:
assumes "A \<in> sets (lborel_f (Suc n))"
assumes "\<And>y. {x\<in>space (lborel_f n). x(n := y) \<in> A} \<in> sets (lborel_f n)"
shows "emeasure (lborel_f (Suc n)) A = \<integral>\<^sup>+ y. emeasure (lborel_f n) {x\<in>space (lborel_f n). x(n := y) \<in> A} \<partial>lborel"
proof -
  {
    fix x y assume "x\<in>space (lborel_f n)"
    then have "(indicator A) (x(n := y)) = (indicator {x\<in>space (lborel_f n). x(n := y) \<in> A}) x" using indicator_def
      by (metis (no_types, lifting) mem_Collect_eq)
  }
  then show ?thesis
    unfolding nn_integral_indicator[OF assms(1), symmetric] nn_integral_indicator[OF assms(2), symmetric]
     integral_lborel_f[OF borel_measurable_indicator, OF assms(1)]
    using nn_integral_cong by (metis (no_types, lifting))
qed

lemma lborel_f_measurable_add_dim: "(\<lambda>f. f(n := x)) \<in> measurable (lborel_f n) (lborel_f (Suc n))"
proof -
  have "x \<in> space lborel" by simp
  have 0:"(\<lambda>(f, y). f(n := y)) \<circ> (\<lambda>xa. (xa, x)) = (\<lambda>f. f(n := x))" unfolding comp_def  using case_prod_conv by fast
  show ?thesis unfolding lborel_f_def
    using measurable_comp[OF measurable_Pair2'[of x lborel "Pi\<^sub>M {..<n} (\<lambda>b. lborel)", OF \<open>x \<in> space lborel\<close>]
    measurable_add_dim[of n "{..<n}" "\<lambda>b. lborel"], unfolded 0] lessThan_Suc by auto
qed

lemma sets_lborel_f_sub_dim:
assumes "A \<in> sets (lborel_f (Suc n))"
shows "{x. x(n := y) \<in> A} \<inter> space (lborel_f n) \<in> sets (lborel_f n)"
proof -
  have "(\<lambda>f. f(n := y)) -` A \<inter> space (lborel_f n) \<in> sets (lborel_f n)"
    using measurable_sets[OF lborel_f_measurable_add_dim assms] by auto
  moreover have "(\<lambda>f. f(n := y)) -` A = {x. x(n := y) \<in> A}" by auto
  finally show ?thesis by metis
qed

lemma lborel_f_measurable_restrict:
assumes "m \<le> n"
shows "(\<lambda>f. restrict f {..<m}) \<in> measurable (lborel_f n) (lborel_f m)"
using measurable_restrict_subset lborel_f_def assms by auto

lemma lborel_measurable_sub_dim: "(\<lambda>f. restrict f {..<n}) \<in> measurable (lborel_f (Suc n)) (lborel_f n)"
using lborel_f_measurable_restrict[of "n" "Suc n"] by linarith

lemma measurable_lborel_component [measurable]:
assumes "k<n"
shows "(\<lambda>x. x k) \<in> borel_measurable (lborel_f n)"
  unfolding lborel_f_def using assms measurable_PiM_component_rev by simp_all

end


theory WhileLoopRule
  imports week09B_demo_monad
begin

text {*
 While Loop rules follow
*}

subsection "Basic induction helper lemmas"

lemma whileLoop_results_induct_lemma1:
  "\<lbrakk> (a, b) \<in> whileLoop_results C B; b = Some (x, y) \<rbrakk> \<Longrightarrow> \<not> C x y"
  apply (induct rule: whileLoop_results.induct, auto)
  done

lemma whileLoop_results_induct_lemma1':
  "\<lbrakk> (a, b) \<in> whileLoop_results C B; a \<noteq> b \<rbrakk> \<Longrightarrow> \<exists>x. a = Some x \<and> C (fst x) (snd x)"
  apply (induct rule: whileLoop_results.induct, auto)
  done

lemma whileLoop_results_induct_lemma2 [consumes 1]:
  "\<lbrakk> (a, b) \<in> whileLoop_results C B;
     a = Some (x :: 'a \<times> 'b); b = Some y;
     P x; \<And>s t. \<lbrakk> P s; t \<in> fst (B (fst s) (snd s)); C (fst s) (snd s) \<rbrakk> \<Longrightarrow> P t \<rbrakk> \<Longrightarrow> P y"
  apply (induct arbitrary: x y rule: whileLoop_results.induct)
    apply simp
   apply simp
  apply fastforce
  done

lemma whileLoop_results_induct_lemma3 [consumes 1]:
  assumes result: "(Some (r, s), Some (r', s')) \<in> whileLoop_results C B"
    and inv_start: "I r s"
    and inv_step: "\<And>r s r' s'. \<lbrakk> I r s; C r s; (r', s') \<in> fst (B r s) \<rbrakk> \<Longrightarrow> I r' s'"
  shows "I r' s'"
  apply (rule whileLoop_results_induct_lemma2 [where P="case_prod I" and y="(r', s')" and x="(r, s)",
        simplified split_def, simplified])
      apply (rule result)
     apply simp
    apply simp
   apply fact
  apply (erule (1) inv_step)
  apply clarsimp
  done

lemma whileLoop_cond_fail:
  "\<lbrakk> \<not> C x s \<rbrakk> \<Longrightarrow> (whileLoop C B x s) = (return x s)"
  apply (auto simp: return_def whileLoop_def
             intro: whileLoop_results.intros whileLoop_terminates.intros
             elim!: whileLoop_results.cases)
  done

definition
  condition :: "('s \<Rightarrow> bool)
      \<Rightarrow> ('s, 'r) nondet_monad
      \<Rightarrow> ('s, 'r) nondet_monad
      \<Rightarrow> ('s, 'r) nondet_monad"
  where
    "condition P L R \<equiv> \<lambda>s. if (P s) then (L s) else (R s)"

notation (output)
  condition  ("(condition (_)//  (_)//  (_))" [1000,1000,1000] 1000)

lemma monad_state_eqI [intro]:
  "\<lbrakk> \<And>r t. (r, t) \<in> fst (A s) \<Longrightarrow> (r, t) \<in> fst (B s');
     \<And>r t. (r, t) \<in> fst (B s') \<Longrightarrow> (r, t) \<in> fst (A s);
     snd (A s) = snd (B s') \<rbrakk>
  \<Longrightarrow> (A :: ('s, 'a) nondet_monad) s = B s'"
  apply (fastforce intro!: set_eqI prod_eqI)
  done

lemma whileLoop_unroll:
  "(whileLoop C B r) =  ((condition (C r) (B r >>= (whileLoop C B)) (return r)))"
  (is "?LHS r = ?RHS r")
proof -
  have cond_fail: "\<And>r s. \<not> C r s \<Longrightarrow> ?LHS r s = ?RHS r s"
    apply (subst whileLoop_cond_fail, simp)
    apply (clarsimp simp: condition_def bind_def return_def)
    done

  have cond_pass: "\<And>r s. C r s \<Longrightarrow> whileLoop C B r s = (B r >>= (whileLoop C B)) s"
    apply (rule monad_state_eqI)
      apply (clarsimp simp: whileLoop_def bind_def split_def)
      apply (subst (asm) whileLoop_results_simps_valid)
      apply fastforce
     apply (clarsimp simp: whileLoop_def bind_def split_def)
     apply (subst whileLoop_results.simps)
     apply fastforce
    apply (clarsimp simp: whileLoop_def bind_def split_def)
    apply (subst whileLoop_results.simps)
    apply (subst whileLoop_terminates.simps)
    apply fastforce
    done

  show ?thesis
    apply (rule ext)
    apply (metis cond_fail cond_pass condition_def)
    done
qed

subsection "Inductive reasoning about whileLoop results"

lemma in_whileLoop_induct [consumes 1]:
  assumes in_whileLoop: "(r', s') \<in> fst (whileLoop C B r s)"
    and init_I: "\<And> r s. \<not> C r s \<Longrightarrow> I r s r s"
    and step:
    "\<And>r s r' s' r'' s''.
        \<lbrakk> C r s; (r', s') \<in> fst (B r s);
          (r'', s'') \<in> fst (whileLoop C B r' s');
           I r' s' r'' s'' \<rbrakk> \<Longrightarrow> I r s r'' s''"
  shows "I r s r' s'"
proof cases
  assume "C r s"

  {
    obtain a where a_def: "a = Some (r, s)"
      by blast
    obtain b where b_def: "b = Some (r', s')"
      by blast

    have "\<lbrakk> (a, b) \<in> whileLoop_results C B; \<exists>x. a = Some x;  \<exists>x. b = Some x \<rbrakk>
        \<Longrightarrow> I (fst (the a)) (snd (the a)) (fst (the b)) (snd (the b))"
      apply (induct rule: whileLoop_results.induct)
        apply (auto simp: init_I whileLoop_def intro: step)
      done

    hence "(Some (r, s), Some (r', s')) \<in> whileLoop_results C B
                 \<Longrightarrow> I r s r' s'"
      by (clarsimp simp: a_def b_def)
  }

  thus ?thesis
    using in_whileLoop
    by (clarsimp simp: whileLoop_def)
next
  assume "\<not> C r s"

  hence "r' = r \<and> s' = s"
    using in_whileLoop
    by (subst (asm) whileLoop_unroll,
        clarsimp simp: condition_def return_def)

  thus ?thesis
    by (metis init_I `\<not> C r s`)
qed

lemma snd_whileLoop_induct [consumes 1]:
  assumes induct: "snd (whileLoop C B r s)"
    and terminates: "\<not> whileLoop_terminates C B r s \<Longrightarrow> I r s"
    and init: "\<And> r s. \<lbrakk> snd (B r s); C r s \<rbrakk> \<Longrightarrow> I r s"
    and step: "\<And>r s r' s' r'' s''.
        \<lbrakk> C r s; (r', s') \<in> fst (B r s);
           snd (whileLoop C B r' s');
           I r' s' \<rbrakk> \<Longrightarrow> I r s"
  shows "I r s"
  apply (insert init induct)
  apply atomize
  apply (unfold whileLoop_def)
  apply clarsimp
  apply (erule disjE)
   apply (erule rev_mp)
   apply (induct "Some (r, s)" "None :: ('a \<times> 'b) option" arbitrary: r s rule: whileLoop_results.induct)
    apply clarsimp
   apply clarsimp
   apply (erule (1) step)
    apply (clarsimp simp: whileLoop_def)
   apply clarsimp
  apply (metis terminates)
  done

subsection "Direct reasoning about whileLoop components"

lemma fst_whileLoop_cond_false:
  assumes loop_result: "(r', s') \<in> fst (whileLoop C B r s)"
  shows "\<not> C r' s'"
  using loop_result
  by (rule in_whileLoop_induct, auto)

lemma use_valid: "\<lbrakk>(r, s') \<in> fst (f s); \<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>; P s \<rbrakk> \<Longrightarrow> Q r s'"
  apply (simp add: valid_def)
  apply blast
  done

lemma valid_whileLoop:
  assumes first_step: "\<And>s. P r s \<Longrightarrow> I r s"
    and inv_step: "\<And>r. \<lbrace> \<lambda>s. I r s \<and> C r s \<rbrace> B r \<lbrace> I \<rbrace>"
    and final_step: "\<And>r s. \<lbrakk> I r s; \<not> C r s \<rbrakk> \<Longrightarrow> Q r s"
  shows "\<lbrace> P r \<rbrace> whileLoop C B r \<lbrace> Q \<rbrace>"
proof -
  {
    fix r' s' s
    assume inv: "I r s"
    assume step: "(r', s') \<in> fst (whileLoop C B r s)"

    have "I r' s'"
      using step inv
      apply (induct rule: in_whileLoop_induct)
      apply simp
      apply (drule use_valid, rule inv_step, auto)
      done
  }

  thus ?thesis
    apply (clarsimp simp: valid_def)
    apply (drule first_step)
    apply (rule final_step, simp)
    apply (metis fst_whileLoop_cond_false)
    done
qed

lemma whileLoop_wp:
  "\<lbrakk> \<And>r. \<lbrace> \<lambda>s. I r s \<and> C r s \<rbrace> B r \<lbrace> I \<rbrace>;
     \<And>r s. \<lbrakk> I r s; \<not> C r s \<rbrakk> \<Longrightarrow> Q r s \<rbrakk> \<Longrightarrow>
  \<lbrace> I r \<rbrace> whileLoop C B r \<lbrace> Q \<rbrace>"
  by (rule valid_whileLoop)

end


(******************************************************************************)
(* Project: Isabelle/UTP Toolkit                                              *)
(* File: Sequence.thy                                                         *)
(* Authors: Simon Foster and Frank Zeyda                                      *)
(* Emails: simon.foster@york.ac.uk and frank.zeyda@york.ac.uk                 *)
(******************************************************************************)

section \<open> Infinite Sequences \<close>

theory Sequence
imports
  HOL.Real
  List_Extra
  "HOL-Library.Sublist"
  "HOL-Library.Nat_Bijection"
begin

typedef 'a seq = "UNIV :: (nat \<Rightarrow> 'a) set"
  by (auto)

setup_lifting type_definition_seq

definition ssubstr :: "nat \<Rightarrow> nat \<Rightarrow> 'a seq \<Rightarrow> 'a list" where
"ssubstr i j xs = map (Rep_seq xs) [i ..< j]"

lift_definition nth_seq :: "'a seq \<Rightarrow> nat \<Rightarrow> 'a" (infixl "!\<^sub>s" 100)
is "\<lambda> f i. f i" .

abbreviation sinit :: "nat \<Rightarrow> 'a seq \<Rightarrow> 'a list" where
"sinit i xs \<equiv> ssubstr 0 i xs"

lemma sinit_len [simp]:
  "length (sinit i xs) = i"
  by (simp add: ssubstr_def)

lemma sinit_0 [simp]: "sinit 0 xs = []"
  by (simp add: ssubstr_def)

lemma prefix_upt_0 [intro]:
  "i \<le> j \<Longrightarrow> prefix [0..<i] [0..<j]"
  by (induct i, auto, metis append_prefixD le0 prefix_order.lift_Suc_mono_le prefix_order.order_refl upt_Suc)

lemma sinit_prefix:
  "i \<le> j \<Longrightarrow> prefix (sinit i xs) (sinit j xs)"
  by (simp add: map_mono_prefix prefix_upt_0 ssubstr_def)

lemma sinit_strict_prefix:
  "i < j \<Longrightarrow> strict_prefix (sinit i xs) (sinit j xs)"
  by (metis sinit_len sinit_prefix le_less nat_neq_iff prefix_order.dual_order.strict_iff_order)

lemma nth_sinit:
  "i < n \<Longrightarrow> sinit n xs ! i = xs !\<^sub>s i"
  apply (auto simp add: ssubstr_def)
  apply (transfer, auto)
  done

lemma sinit_append_split:
  assumes "i < j"
  shows "sinit j xs = sinit i xs @ ssubstr i j xs"
proof -
  have "[0..<i] @ [i..<j] = [0..<j]"
    by (metis assms le0 le_add_diff_inverse le_less upt_add_eq_append)
  thus ?thesis
    by (auto simp add: ssubstr_def, transfer, simp add: map_append[THEN sym])
qed

lemma sinit_linear_asym_lemma1:
  assumes "asym R" "i < j" "(sinit i xs, sinit i ys) \<in> lexord R" "(sinit j ys, sinit j xs) \<in> lexord R"
  shows False
proof -
  have sinit_xs: "sinit j xs = sinit i xs @ ssubstr i j xs"
    by (metis assms(2) sinit_append_split)
  have sinit_ys: "sinit j ys = sinit i ys @ ssubstr i j ys"
    by (metis assms(2) sinit_append_split)
  from sinit_xs sinit_ys assms(4)
  have "(sinit i ys, sinit i xs) \<in> lexord R \<or> (sinit i ys = sinit i xs \<and> (ssubstr i j ys, ssubstr i j xs) \<in> lexord R)"
    by (auto dest: lexord_append)
  with assms lexord_asymmetric show False
    by (force)
qed

lemma sinit_linear_asym_lemma2:
  assumes "asym R" "(sinit i xs, sinit i ys) \<in> lexord R" "(sinit j ys, sinit j xs) \<in> lexord R"
  shows False
proof (cases i j rule: linorder_cases)
  case less with assms show ?thesis
    by (auto dest: sinit_linear_asym_lemma1)
next
  case equal with assms show ?thesis
    by (simp add: lexord_asymmetric)
next
  case greater with assms show ?thesis
    by (auto dest: sinit_linear_asym_lemma1)
qed

lemma range_ext:
  assumes "\<forall>i :: nat. \<forall>x\<in>{0..<i}. f(x) = g(x)"
  shows "f = g"
proof (rule ext)
  fix x :: nat
  obtain i :: nat where "i > x"
    by (metis lessI)
  with assms show "f(x) = g(x)"
    by (auto)
qed

lemma sinit_ext:
  "(\<forall> i. sinit i xs = sinit i ys) \<Longrightarrow> xs = ys"
  by (simp add: ssubstr_def, transfer, auto intro: range_ext)

definition seq_lexord :: "'a rel \<Rightarrow> ('a seq) rel" where
"seq_lexord R = {(xs, ys). (\<exists> i. (sinit i xs, sinit i ys) \<in> lexord R)}"

lemma seq_lexord_irreflexive:
  "\<forall>x. (x, x) \<notin> R \<Longrightarrow> (xs, xs) \<notin> seq_lexord R"
  by (auto dest: lexord_irreflexive simp add: irrefl_def seq_lexord_def)

lemma seq_lexord_irrefl:
  "irrefl R \<Longrightarrow> irrefl (seq_lexord R)"
  by (simp add: irrefl_def seq_lexord_irreflexive)

lemma seq_lexord_transitive:
  assumes "trans R"
  shows "trans (seq_lexord R)"
unfolding seq_lexord_def
proof (rule transI, clarify)
  fix xs ys zs :: "'a seq" and m n :: nat
  assume las: "(sinit m xs, sinit m ys) \<in> lexord R" "(sinit n ys, sinit n zs) \<in> lexord R"
  hence inz: "m > 0"
    using gr0I by force
  from las(1) obtain i where sinitm: "(sinit m xs!i, sinit m ys!i) \<in> R" "i < m" "\<forall> j<i. sinit m xs!j = sinit m ys!j"
    using lexord_eq_length by force
  from las(2) obtain j where sinitn: "(sinit n ys!j, sinit n zs!j) \<in> R" "j < n" "\<forall> k<j. sinit n ys!k = sinit n zs!k"
    using lexord_eq_length by force
  show "\<exists>i. (sinit i xs, sinit i zs) \<in> lexord R"
  proof (cases "i \<le> j")
    case True note lt = this
    with sinitm sinitn have "(sinit n xs!i, sinit n zs!i) \<in> R"
      by (metis assms le_eq_less_or_eq le_less_trans nth_sinit transD)
    moreover from lt sinitm sinitn have "\<forall> j<i. sinit m xs!j = sinit m zs!j"
      by (metis less_le_trans less_trans nth_sinit)
    ultimately have "(sinit n xs, sinit n zs) \<in> lexord R" using sinitm(2) sinitn(2) lt
      apply (rule_tac lexord_intro_elems)
         apply (auto)
      apply (metis less_le_trans less_trans nth_sinit)
      done
    thus ?thesis by auto
  next
    case False
    then have ge: "i > j" by auto
    with assms sinitm sinitn have "(sinit n xs!j, sinit n zs!j) \<in> R"
      by (metis less_trans nth_sinit)
    moreover from ge sinitm sinitn have "\<forall> k<j. sinit m xs!k = sinit m zs!k"
      by (metis dual_order.strict_trans nth_sinit)
    ultimately have "(sinit n xs, sinit n zs) \<in> lexord R" using sinitm(2) sinitn(2) ge
      apply (rule_tac lexord_intro_elems)
         apply (auto)
      apply (metis less_trans nth_sinit)
      done
    thus ?thesis by auto
  qed
qed

lemma seq_lexord_trans:
  "\<lbrakk> (xs, ys) \<in> seq_lexord R; (ys, zs) \<in> seq_lexord R; trans R \<rbrakk> \<Longrightarrow> (xs, zs) \<in> seq_lexord R"
  by (meson seq_lexord_transitive transE)

lemma seq_lexord_antisym:
  "\<lbrakk> asym R; (a, b) \<in> seq_lexord R \<rbrakk> \<Longrightarrow> (b, a) \<notin> seq_lexord R"
  by (auto dest: sinit_linear_asym_lemma2 simp add: seq_lexord_def)

lemma seq_lexord_asym:
  assumes "asym R"
  shows "asym (seq_lexord R)"
  by (meson assms asym.simps seq_lexord_antisym seq_lexord_irrefl)

lemma seq_lexord_total:
  assumes "total R"
  shows "total (seq_lexord R)"
  using assms by (auto simp add: total_on_def seq_lexord_def, meson lexord_linear sinit_ext)

lemma seq_lexord_strict_linear_order:
  assumes "strict_linear_order R"
  shows "strict_linear_order (seq_lexord R)"
  using assms
  by (auto simp add: strict_linear_order_on_def partial_order_on_def preorder_on_def
           intro: seq_lexord_transitive seq_lexord_irrefl seq_lexord_total)

lemma seq_lexord_linear:
  assumes "(\<forall> a b. (a,b)\<in> R \<or> a = b \<or> (b,a) \<in> R)"
  shows "(x,y) \<in> seq_lexord R \<or> x = y \<or> (y,x) \<in> seq_lexord R"
proof -
  have "total R"
    using assms total_on_def by blast
  hence "total (seq_lexord R)"
    using seq_lexord_total by blast
  thus ?thesis
    by (auto simp add: total_on_def)
qed

instantiation seq :: (ord) ord
begin

definition less_seq :: "'a seq \<Rightarrow> 'a seq \<Rightarrow> bool" where
"less_seq xs ys \<longleftrightarrow> (xs, ys) \<in> seq_lexord {(xs, ys). xs < ys}"

definition less_eq_seq :: "'a seq \<Rightarrow> 'a seq \<Rightarrow> bool" where
"less_eq_seq xs ys = (xs = ys \<or> xs < ys)"

instance ..

end

instance seq :: (order) order
proof
  fix xs :: "'a seq"
  show "xs \<le> xs" by (simp add: less_eq_seq_def)
next
  fix xs ys zs :: "'a seq"
  assume "xs \<le> ys" and "ys \<le> zs"
  then show "xs \<le> zs"
    by (force dest: seq_lexord_trans simp add: less_eq_seq_def less_seq_def trans_def)
next
  fix xs ys :: "'a seq"
  assume "xs \<le> ys" and "ys \<le> xs"
  then show "xs = ys"
    apply (auto simp add: less_eq_seq_def less_seq_def)
    apply (rule seq_lexord_irreflexive [THEN notE])
     defer
     apply (rule seq_lexord_trans)
       apply (auto intro: transI)
    done
next
  fix xs ys :: "'a seq"
  show "xs < ys \<longleftrightarrow> xs \<le> ys \<and> \<not> ys \<le> xs"
    apply (auto simp add: less_seq_def less_eq_seq_def)
     defer
     apply (rule seq_lexord_irreflexive [THEN notE])
      apply auto
     apply (rule seq_lexord_irreflexive [THEN notE])
      defer
      apply (rule seq_lexord_trans)
        apply (auto intro: transI)
    apply (simp add: seq_lexord_irreflexive)
    done
qed

instance seq :: (linorder) linorder
proof
  fix xs ys :: "'a seq"
  have "(xs, ys) \<in> seq_lexord {(u, v). u < v} \<or> xs = ys \<or> (ys, xs) \<in> seq_lexord {(u, v). u < v}"
    by (rule seq_lexord_linear) auto
  then show "xs \<le> ys \<or> ys \<le> xs"
    by (auto simp add: less_eq_seq_def less_seq_def)
qed

lemma seq_lexord_mono [mono]:
  "(\<And> x y. f x y \<longrightarrow> g x y) \<Longrightarrow> (xs, ys) \<in> seq_lexord {(x, y). f x y} \<longrightarrow> (xs, ys) \<in> seq_lexord {(x, y). g x y}"
  apply (auto simp add: seq_lexord_def)
  apply (metis case_prodD case_prodI lexord_take_index_conv mem_Collect_eq)
done

fun insort_rel :: "'a rel \<Rightarrow> 'a \<Rightarrow> 'a list \<Rightarrow> 'a list" where
"insort_rel R x [] = [x]" |
"insort_rel R x (y # ys) = (if (x = y \<or> (x,y) \<in> R) then x # y # ys else y # insort_rel R x ys)"

inductive sorted_rel :: "'a rel \<Rightarrow> 'a list \<Rightarrow> bool" where
Nil_rel [iff]: "sorted_rel R []" |
Cons_rel: "\<forall> y \<in> set xs. (x = y \<or> (x, y) \<in> R) \<Longrightarrow> sorted_rel R xs \<Longrightarrow> sorted_rel R (x # xs)"

definition list_of_set :: "'a rel \<Rightarrow> 'a set \<Rightarrow> 'a list" where
"list_of_set R = folding.F (insort_rel R) []"

lift_definition seq_inj :: "'a seq seq \<Rightarrow> 'a seq" is
"\<lambda> f i. f (fst (prod_decode i)) (snd (prod_decode i))" .

lift_definition seq_proj :: "'a seq \<Rightarrow> 'a seq seq" is
"\<lambda> f i j. f (prod_encode (i, j))" .

lemma seq_inj_inverse: "seq_proj (seq_inj x) = x"
  by (transfer, simp)

lemma seq_proj_inverse: "seq_inj (seq_proj x) = x"
  by (transfer, simp)

lemma seq_inj: "inj seq_inj"
  by (metis injI seq_inj_inverse)

lemma seq_inj_surj: "bij seq_inj"
  apply (rule bijI)
   apply (auto simp add: seq_inj)
  apply (metis rangeI seq_proj_inverse)
  done
end


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

section\<open>The Gram-Schmidt algorithm\<close>

theory Gram_Schmidt
imports
 Miscellaneous_QR
 Projections
begin

subsection\<open>Gram-Schmidt algorithm\<close>

text\<open>
The algorithm is used to orthogonalise a set of vectors. The Gram-Schmidt process takes a set of vectors \<open>S\<close>
and generates another orthogonal set that spans the same subspace as \<open>S\<close>.

We present three ways to compute the Gram-Schmidt algorithm.

\begin{enumerate}
\item The fist one has been developed thinking about the simplicity of its formalisation.
    Given a list of vectors, the output is another list of orthogonal vectors with the same span.
    Such a list is constructed following the Gram-Schmidt process presented in any book, but in
    the reverse order (starting the process from the last element of the input list).

\item Based on previous formalization, another function has been defined
  to compute the process of the Gram-Schmidt algorithm in the natural order
  (starting from the first element of the input list).

\item The third way has as input and output a matrix. The algorithm is applied to the columns of a
  matrix, obtaining a matrix whose columns are orthogonal and where the column space is kept.
  This will be a previous step to compute the QR decomposition.
\end{enumerate}

Every function can be executed with arbitrary precision (using rational numbers).
\<close>

subsubsection\<open>First way\<close>

definition Gram_Schmidt_step :: "('a::{real_inner}^'b) => ('a^'b) list => ('a^'b) list"
  where "Gram_Schmidt_step a ys = ys @ [(a - proj_onto a (set ys))]"

definition "Gram_Schmidt xs = foldr Gram_Schmidt_step xs []"

lemma Gram_Schmidt_cons:
  "Gram_Schmidt (a#xs) = Gram_Schmidt_step a (Gram_Schmidt xs)"
  unfolding Gram_Schmidt_def by auto

lemma basis_orthogonal':
  fixes xs::"('a::{real_inner}^'b) list"
  shows "length (Gram_Schmidt xs) = length (xs) \<and>
        span (set (Gram_Schmidt xs)) = span (set xs) \<and>
        pairwise orthogonal (set (Gram_Schmidt xs))"
proof (induct xs)
  case Nil
  show ?case unfolding Gram_Schmidt_def pairwise_def by fastforce
next
  case (Cons a xs)
  have l: "length (Gram_Schmidt xs) = length xs"
    and s: "span (set (Gram_Schmidt xs)) = span (set xs)"
    and p: "pairwise orthogonal (set (Gram_Schmidt xs))" using Cons.hyps by auto
  show "length (Gram_Schmidt (a # xs)) = length (a # xs) \<and>
    span (set (Gram_Schmidt (a # xs))) = span (set (a # xs))
    \<and> pairwise orthogonal (set (Gram_Schmidt (a # xs)))"
  proof
    show "length (Gram_Schmidt (a # xs)) = length (a # xs)"
      unfolding Gram_Schmidt_cons unfolding Gram_Schmidt_step_def using l by auto
    show "span (set (Gram_Schmidt (a # xs)))
      = span (set (a # xs)) \<and> pairwise orthogonal (set (Gram_Schmidt (a # xs)))"
    proof
      have set_rw1: "set (a # xs) = insert a (set xs)" by simp
      have set_rw2: "set (Gram_Schmidt (a # xs))
        = (insert (a - (\<Sum>x\<in>set (Gram_Schmidt xs). (a \<bullet> x / (x \<bullet> x)) *\<^sub>R x)) (set (Gram_Schmidt xs)))"
        unfolding Gram_Schmidt_cons Gram_Schmidt_step_def proj_onto_def proj_def[abs_def] by auto
      define C where "C = set (Gram_Schmidt xs)"
      have finite_C: "finite C" unfolding C_def by auto
      {
        fix x k
        have th0: "!!(a::'a^'b) b c. a - (b - c) = c + (a - b)"
          by (simp add: field_simps)
        have "x - k *\<^sub>R (a - (\<Sum>x\<in>C. (a \<bullet> x / (x \<bullet>  x)) *\<^sub>R x)) \<in> span C
          \<longleftrightarrow> x - k *\<^sub>R a \<in> span C"
          apply (simp only: scaleR_right_diff_distrib th0)
          apply (rule span_add_eq)
          apply (rule span_mul)
          apply (rule span_sum)
          apply (rule span_mul)
          apply (rule span_base)
          apply assumption
          done
      }
      then show "span (set (Gram_Schmidt (a # xs))) = span (set (a # xs))"
        unfolding set_eq_iff set_rw2 set_rw1 span_breakdown_eq C_def s[symmetric]
        by auto
      with p show "pairwise orthogonal (set (Gram_Schmidt (a # xs)))"
        using pairwise_orthogonal_proj_set[OF finite_C]
        unfolding set_rw2 unfolding C_def proj_def[symmetric] proj_onto_def[symmetric] by simp
    qed
  qed
qed

lemma card_Gram_Schmidt:
  fixes xs::"('a::{real_inner}^'b) list"
  assumes "distinct xs"
  shows "card(set (Gram_Schmidt xs)) \<le> card (set (xs))"
  using assms
proof (induct xs)
  case Nil show ?case unfolding Gram_Schmidt_def by simp
next
  case (Cons x xs)
  define b where "b = (\<Sum>xa\<in>set (Gram_Schmidt xs). (x \<bullet> xa / (xa \<bullet> xa)) *\<^sub>R xa)"
  have distinct_xs: "distinct xs" using Cons.prems by auto
  show ?case
  proof (cases "x - b \<notin> set (Gram_Schmidt xs)")
    case True
    have "card (set (Gram_Schmidt (x # xs))) = card (insert (x - b) (set (Gram_Schmidt xs)))"
      unfolding Gram_Schmidt_cons Gram_Schmidt_step_def b_def
      unfolding proj_onto_def proj_def[abs_def] by simp
    also have "... = Suc (card (set (Gram_Schmidt xs)))"
    proof (rule card_insert_disjoint)
      show "finite (set (Gram_Schmidt xs))" by simp
      show "x - b \<notin> set (Gram_Schmidt xs)" using True .
    qed
    also have "... \<le> Suc (card (set xs))" using Cons.hyps[OF distinct_xs]  by simp
    also have "... = Suc (length (remdups xs))" unfolding List.card_set ..
    also have "... \<le> (length (remdups (x # xs)))"
      by (metis Cons.prems distinct_xs impossible_Cons not_less_eq_eq remdups_id_iff_distinct)
    also have "... \<le> (card (set (x # xs)))"
      by (metis dual_order.refl length_remdups_card_conv)
    finally show ?thesis .
  next
    case False
    have x_b_in: "x - b \<in> set (Gram_Schmidt xs)" using False by simp
    have "card (set (Gram_Schmidt (x # xs))) = card (insert (x - b) (set (Gram_Schmidt xs)))"
      unfolding Gram_Schmidt_cons Gram_Schmidt_step_def b_def
      unfolding proj_onto_def proj_def[abs_def] by simp
    also have "... = (card (set (Gram_Schmidt xs)))" by (metis False insert_absorb)
    also have "... \<le> (card (set xs))" using Cons.hyps[OF distinct_xs] .
    also have "... \<le> (card (set (x # xs)))" unfolding List.card_set by simp
    finally show ?thesis .
  qed
qed

lemma orthogonal_basis_exists:
  fixes V :: "(real^'b) list"
  assumes B: "is_basis (set V)"
  and d: "distinct V"
  shows "vec.independent (set (Gram_Schmidt V)) \<and> (set V) \<subseteq> vec.span (set (Gram_Schmidt V))
  \<and> (card (set (Gram_Schmidt V)) = vec.dim (set V)) \<and> pairwise orthogonal (set (Gram_Schmidt V))"
proof -
  have "(set V) \<subseteq> vec.span (set (Gram_Schmidt V))"
    using basis_orthogonal'[of V]
    using vec.span_superset[where ?'a=real, where ?'b='b]
    by (auto simp: span_vec_eq)
  moreover have "pairwise orthogonal (set (Gram_Schmidt V))"
    using basis_orthogonal'[of V] by blast
  moreover have c: "(card (set (Gram_Schmidt V)) = vec.dim (set V))"
  proof -
    have card_eq_dim: "card (set V) = vec.dim (set V)"
      by (metis B independent_is_basis vec.dim_span vec.indep_card_eq_dim_span)
    have "vec.dim (set V) \<le> (card (set (Gram_Schmidt V)))" using B unfolding is_basis_def
      using vec.independent_span_bound[of "(set (Gram_Schmidt V))" "set V"]
      using basis_orthogonal'[of V]
      by (simp add: calculation(1) local.card_eq_dim)
    moreover have "(card (set (Gram_Schmidt V))) \<le> vec.dim (set V)"
      using card_Gram_Schmidt[OF d] card_eq_dim by auto
    ultimately show ?thesis by auto
  qed
  moreover have "vec.independent (set (Gram_Schmidt V))"
  proof (rule vec.card_le_dim_spanning[of _ "UNIV::(real^'b) set"])
    show "set (Gram_Schmidt V) \<subseteq> (UNIV::(real^'b) set)" by simp
    show "UNIV \<subseteq> vec.span (set (Gram_Schmidt V))"
      using basis_orthogonal'[of V] using B unfolding is_basis_def
      by (simp add: span_vec_eq)
    show "finite (set (Gram_Schmidt V))" by simp
    show "card (set (Gram_Schmidt V)) \<le> vec.dim (UNIV::(real^'b) set)"
      by (metis c top_greatest vec.dim_subset)
  qed
  ultimately show ?thesis by simp
qed

corollary orthogonal_basis_exists':
  fixes V :: "(real^'b) list"
  assumes B: "is_basis (set V)"
  and d: "distinct V"
  shows "is_basis (set (Gram_Schmidt V))
  \<and> distinct (Gram_Schmidt V) \<and> pairwise orthogonal (set (Gram_Schmidt V))"
  using B orthogonal_basis_exists basis_orthogonal' card_distinct d
    vec.dim_unique distinct_card is_basis_def subset_refl
  by (metis span_vec_eq)

subsubsection\<open>Second way\<close>

text\<open>This definition applies the Gram Schmidt process starting from the first element of the list.\<close>

definition "Gram_Schmidt2 xs = Gram_Schmidt (rev xs)"

lemma basis_orthogonal2:
  fixes xs::"('a::{real_inner}^'b) list"
  shows "length (Gram_Schmidt2 xs) = length (xs)
  \<and> span (set (Gram_Schmidt2 xs)) = span (set xs)
  \<and> pairwise orthogonal (set (Gram_Schmidt2 xs))"
  by (metis Gram_Schmidt2_def basis_orthogonal' length_rev set_rev)

lemma card_Gram_Schmidt2:
  fixes xs::"('a::{real_inner}^'b) list"
  assumes "distinct xs"
  shows "card(set (Gram_Schmidt2 xs)) \<le> card (set (xs))"
  by (metis Gram_Schmidt2_def assms card_Gram_Schmidt distinct_rev set_rev)

lemma orthogonal_basis_exists2:
  fixes V :: "(real^'b) list"
  assumes B: "is_basis (set V)"
  and d: "distinct V"
  shows "vec.independent (set (Gram_Schmidt2 V)) \<and> (set V) \<subseteq> vec.span (set (Gram_Schmidt2 V))
  \<and> (card (set (Gram_Schmidt2 V)) = vec.dim (set V)) \<and> pairwise orthogonal (set (Gram_Schmidt2 V))"
  by (metis Gram_Schmidt.orthogonal_basis_exists Gram_Schmidt2_def distinct_rev set_rev
      B basis_orthogonal2 d)

subsubsection\<open>Third way\<close>

text\<open>The following definitions applies the Gram Schmidt process in the columns of a given matrix.
  It is previous step to the computation of the QR decomposition.\<close>

definition Gram_Schmidt_column_k :: "'a::{real_inner}^'cols::{mod_type}^'rows \<Rightarrow> nat
  \<Rightarrow> 'a^'cols::{mod_type}^'rows"
  where "Gram_Schmidt_column_k A k
  = (\<chi> a. (\<chi> b. (if b = from_nat k
  then (column b A - (proj_onto (column b A) {column i A|i. i < b}))
  else (column b A)) $ a))"

definition "Gram_Schmidt_upt_k A k = foldl Gram_Schmidt_column_k A [0..<(Suc k)]"
definition "Gram_Schmidt_matrix A = Gram_Schmidt_upt_k A (ncols A - 1)"

text\<open>Some definitions and lemmas in order to get execution.\<close>

definition "Gram_Schmidt_column_k_row A k a =
  vec_lambda(\<lambda>b. (if b = from_nat k then
  (column b A - (\<Sum>x\<in>{column i A|i. i < b}. ((column b A) \<bullet> x / (x \<bullet> x)) *\<^sub>R x))
  else (column b A)) $ a)"

lemma Gram_Schmidt_column_k_code[code abstract]:
  "vec_nth (Gram_Schmidt_column_k A k) = Gram_Schmidt_column_k_row A k"
  unfolding Gram_Schmidt_column_k_def unfolding Gram_Schmidt_column_k_row_def[abs_def]
  unfolding proj_onto_def proj_def[abs_def]
  by fastforce

text\<open>Proofs\<close>

lemma Gram_Schmidt_upt_k_suc:
  "Gram_Schmidt_upt_k A (Suc k) = (Gram_Schmidt_column_k (Gram_Schmidt_upt_k A k) (Suc k))"
proof -
  have rw: "[0..<Suc (Suc k)] = [0..<Suc k] @ [(Suc k)]" by simp
  show ?thesis unfolding Gram_Schmidt_upt_k_def
    unfolding rw unfolding foldl_append unfolding foldl.simps ..
qed

lemma column_Gram_Schmidt_upt_k_preserves:
  fixes A::"'a::{real_inner}^'cols::{mod_type}^'rows"
  assumes i_less_suc: "to_nat i<(Suc k)"
  and suc_less_card: "Suc k < CARD ('cols)"
  shows "column i (Gram_Schmidt_upt_k A (Suc k)) = column i (Gram_Schmidt_upt_k A k)"
proof -
  have "column i (Gram_Schmidt_upt_k A (Suc k))
    = column i (Gram_Schmidt_column_k (Gram_Schmidt_upt_k A k) (Suc k))"
    unfolding Gram_Schmidt_upt_k_suc ..
  also have "... = column i (Gram_Schmidt_upt_k A k)" unfolding Gram_Schmidt_column_k_def
    column_def using i_less_suc by (auto simp add: to_nat_from_nat_id[OF suc_less_card])
  finally show ?thesis .
qed

lemma column_set_Gram_Schmidt_upt_k:
  fixes A::"'a::{real_inner}^'cols::{mod_type}^'rows"
  assumes k: "Suc k < CARD ('cols)"
  shows "{column i (Gram_Schmidt_upt_k A (Suc k)) |i. to_nat i\<le>(Suc k)} =
  {column i (Gram_Schmidt_upt_k A k) |i. to_nat i\<le>k} \<union> {column (from_nat (Suc k)) (Gram_Schmidt_upt_k A k)
  - (\<Sum>x\<in>{column i (Gram_Schmidt_upt_k A k) |i. to_nat i\<le>k}. (x \<bullet> (column (from_nat (Suc k)) (Gram_Schmidt_upt_k A k)) / (x \<bullet> x)) *\<^sub>R x)}"
proof -
  have set_rw: "{\<chi> ia. Gram_Schmidt_upt_k A k $ ia $ i |i.
    i < from_nat (Suc k)} = {\<chi> ia. Gram_Schmidt_upt_k A k $ ia $ i |i. to_nat i \<le> k}"
  proof (auto, vector, metis less_Suc_eq_le to_nat_le)
    fix i::'cols
    assume "to_nat i \<le> k"
    hence "to_nat i < Suc k" by simp
    hence i_less_suc: "i < from_nat (Suc k)" using from_nat_le[OF _ k] by simp
    show "\<exists>l. (\<lambda>j. Gram_Schmidt_upt_k A k $ j $ i) = (\<lambda>j'. Gram_Schmidt_upt_k A k $ j' $ l) \<and>  l < mod_type_class.from_nat (Suc k)"
      by (rule exI[of _ i], simp add: i_less_suc)
  qed
  have rw: "[0..<Suc (Suc k)] = [0..<Suc k] @ [(Suc k)]" by simp
  have "{column i (Gram_Schmidt_upt_k A (Suc k)) |i. to_nat i\<le>(Suc k)}
    = {column i (Gram_Schmidt_column_k (Gram_Schmidt_upt_k A k) (Suc k)) |i. to_nat i \<le> Suc k}"
    unfolding Gram_Schmidt_upt_k_def
    unfolding rw unfolding foldl_append unfolding foldl.simps ..
  also have "... = {column i (Gram_Schmidt_upt_k A k) |i. to_nat i\<le>k} \<union> {column (from_nat (Suc k)) (Gram_Schmidt_upt_k A k)
    - (\<Sum>x\<in>{column i (Gram_Schmidt_upt_k A k) |i. to_nat i\<le>k}. (x \<bullet> (column (from_nat (Suc k)) (Gram_Schmidt_upt_k A k)) / (x \<bullet> x)) *\<^sub>R x)}"
  proof (auto)
    fix i::'cols
    assume ik: "to_nat i \<le> k"
    show "\<exists>ia. column i (Gram_Schmidt_upt_k A k)
      = column ia (Gram_Schmidt_column_k (Gram_Schmidt_upt_k A k) (Suc k)) \<and> to_nat ia \<le> Suc k"
    proof (rule exI[of _ i], rule conjI)
      have i_less_suc: "to_nat i < Suc k" using ik by auto
      thus "to_nat i \<le> Suc k" by simp
      show  "column i (Gram_Schmidt_upt_k A k) = column i (Gram_Schmidt_column_k (Gram_Schmidt_upt_k A k) (Suc k))"
        using column_Gram_Schmidt_upt_k_preserves[OF i_less_suc k, of A]
        unfolding Gram_Schmidt_upt_k_suc ..
    qed
  next
    show "\<exists>a. column (from_nat (Suc k)) (Gram_Schmidt_upt_k A k) -
      (\<Sum>x\<in>{column i (Gram_Schmidt_upt_k A k) |i.
      to_nat i \<le> k}. (x \<bullet> column (from_nat (Suc k)) (Gram_Schmidt_upt_k A k) / (x \<bullet> x)) *\<^sub>R x) =
      column a (Gram_Schmidt_column_k (Gram_Schmidt_upt_k A k) (Suc k)) \<and>
      to_nat a \<le> Suc k"
    proof (rule exI[of _ "from_nat (Suc k)::'cols"], rule conjI)

      show "to_nat (from_nat (Suc k)::'cols) \<le> Suc k" unfolding to_nat_from_nat_id[OF k] ..
      show "column (from_nat (Suc k)) (Gram_Schmidt_upt_k A k) -
        (\<Sum>x\<in>{column i (Gram_Schmidt_upt_k A k) |i.
        to_nat i \<le> k}. (x \<bullet> column (from_nat (Suc k)) (Gram_Schmidt_upt_k A k) / (x \<bullet> x)) *\<^sub>R x) =
        column (from_nat (Suc k)) (Gram_Schmidt_column_k (Gram_Schmidt_upt_k A k) (Suc k))"
        unfolding Gram_Schmidt_column_k_def column_def apply auto unfolding set_rw
        unfolding vector_scaleR_component[symmetric]
        unfolding sum_component[symmetric]
        unfolding proj_onto_def proj_def[abs_def]
        unfolding proj_onto_sum_rw
        by vector
    qed
  next
    fix i
    assume col_not_eq: "column i (Gram_Schmidt_column_k (Gram_Schmidt_upt_k A k) (Suc k)) \<noteq>
      column (from_nat (Suc k)) (Gram_Schmidt_upt_k A k) -
      (\<Sum>x\<in>{column i (Gram_Schmidt_upt_k A k) |i.
      to_nat i \<le> k}. (x \<bullet> column (from_nat (Suc k)) (Gram_Schmidt_upt_k A k) / (x \<bullet> x)) *\<^sub>R x)"
      and i: "to_nat i \<le> Suc k"
    have i_not_suc_k: "i \<noteq> from_nat (Suc k)"
    proof (rule ccontr, simp)
      assume i2: "i = from_nat (Suc k)"
      have "column i (Gram_Schmidt_column_k (Gram_Schmidt_upt_k A k) (Suc k)) =
        column (from_nat (Suc k)) (Gram_Schmidt_upt_k A k) -
        (\<Sum>x\<in>{column i (Gram_Schmidt_upt_k A k) |i.
        to_nat i \<le> k}. (x \<bullet> column (from_nat (Suc k)) (Gram_Schmidt_upt_k A k) / (x \<bullet> x)) *\<^sub>R x)"
        unfolding i2  Gram_Schmidt_column_k_def column_def
        apply auto
        unfolding set_rw
        unfolding vector_scaleR_component[symmetric]
        unfolding sum_component[symmetric]
        unfolding proj_onto_def proj_def[abs_def]
        unfolding proj_onto_sum_rw
        by vector
      thus False using col_not_eq by contradiction
    qed
    show "\<exists>ia. column i (Gram_Schmidt_column_k (Gram_Schmidt_upt_k A k) (Suc k))
      = column ia (Gram_Schmidt_upt_k A k) \<and> to_nat ia \<le> k"
    proof (rule exI[of _ i], rule conjI, unfold Gram_Schmidt_upt_k_suc[symmetric], rule column_Gram_Schmidt_upt_k_preserves)
      show "to_nat i < Suc k" using i i_not_suc_k by (metis le_imp_less_or_eq from_nat_to_nat_id)
      thus "to_nat i \<le> k" using less_Suc_eq_le by simp
      show "Suc k < CARD('cols)" using k .
    qed
  qed
  finally show ?thesis .
qed

lemma orthogonal_Gram_Schmidt_upt_k:
  assumes s: "k < ncols A"
  shows "pairwise orthogonal ({column i (Gram_Schmidt_upt_k A k) |i. to_nat i\<le>k})"
  using s
proof (induct k)
  case 0
  have set_rw: "{column i (Gram_Schmidt_upt_k A 0) |i. to_nat i \<le> 0} =  {column 0 (Gram_Schmidt_upt_k A 0)}"
    by (simp add: to_nat_eq_0)
  show ?case unfolding set_rw unfolding pairwise_def by auto
next
  case (Suc k)
  have rw: "[0..<Suc (Suc k)] = [0..<Suc k] @ [(Suc k)]" by simp
  show ?case
    unfolding column_set_Gram_Schmidt_upt_k[OF Suc.prems[unfolded ncols_def], of A]
    unfolding proj_onto_sum_rw
    by (auto simp add: proj_def[symmetric] proj_onto_def[symmetric])
       (rule pairwise_orthogonal_proj_set, auto simp add: Suc.hyps Suc.prems Suc_lessD)
qed

lemma columns_Gram_Schmidt_matrix_rw:
  "{column i (Gram_Schmidt_matrix A) |i. i \<in> UNIV}
  = {column i (Gram_Schmidt_upt_k A (ncols A - 1)) |i. to_nat i\<le> (ncols A - 1)}"
proof (auto)
  fix i
  show "\<exists>ia. column i (Gram_Schmidt_matrix A)
    = column ia (Gram_Schmidt_upt_k A (ncols A - Suc 0)) \<and> to_nat ia \<le> ncols A - Suc 0"
    apply (rule exI[of _ i]) unfolding Gram_Schmidt_matrix_def using to_nat_less_card[of i]
    unfolding ncols_def by fastforce
  show "\<exists>ia. column i (Gram_Schmidt_upt_k A (ncols A - Suc 0)) = column ia (Gram_Schmidt_matrix A)"
    unfolding Gram_Schmidt_matrix_def by auto
qed

corollary orthogonal_Gram_Schmidt_matrix:
  shows "pairwise orthogonal ({column i (Gram_Schmidt_matrix A) |i. i \<in> UNIV})"
  unfolding columns_Gram_Schmidt_matrix_rw
  by (rule orthogonal_Gram_Schmidt_upt_k, simp add: ncols_def)

corollary orthogonal_Gram_Schmidt_matrix2:
  shows "pairwise orthogonal (columns (Gram_Schmidt_matrix A))"
  unfolding columns_def using orthogonal_Gram_Schmidt_matrix .

lemma column_Gram_Schmidt_column_k:
  fixes A::"'a::{real_inner}^'n::{mod_type}^'m::{mod_type}"
  shows "column k (Gram_Schmidt_column_k A (to_nat k)) =
  (column k A) - (\<Sum>x\<in>{column i A|i. i < k}. (x \<bullet> (column k A) / (x \<bullet> x)) *\<^sub>R x)"
  unfolding Gram_Schmidt_column_k_def column_def
  unfolding from_nat_to_nat_id
  unfolding proj_onto_def proj_def[abs_def]
  unfolding proj_onto_sum_rw
  by vector

lemma column_Gram_Schmidt_column_k':
  fixes A::"'a::{real_inner}^'n::{mod_type}^'m::{mod_type}"
  assumes i_not_k: "i\<noteq>k"
  shows "column i (Gram_Schmidt_column_k A (to_nat k)) = (column i A)"
  using i_not_k
  unfolding Gram_Schmidt_column_k_def column_def
  unfolding from_nat_to_nat_id by vector

definition "cols_upt_k A k = {column i A|i. i\<le>from_nat k}"

lemma columns_eq_cols_upt_k:
  fixes A::"'a^'cols::{mod_type}^'rows::{mod_type}"
  shows "cols_upt_k A (ncols A - 1) = columns A"
proof (unfold cols_upt_k_def columns_def, auto)
  fix i
  show "\<exists>ia. column i A = column ia A \<and> ia \<le> from_nat (ncols A - Suc 0)"
  proof (rule exI[of _ i], simp)
    have "to_nat i < ncols A" using to_nat_less_card[of i] unfolding ncols_def by simp
    hence "to_nat i \<le> (ncols A - 1)" by simp
    hence "to_nat i \<le> to_nat (from_nat (ncols A - 1)::'cols)"
      using to_nat_from_nat_id[of "ncols A - 1", where ?'a='cols] unfolding ncols_def by simp
    thus "i \<le> from_nat (ncols A - Suc 0)"
      by (metis One_nat_def less_le_not_le linear to_nat_mono)
  qed
qed

lemma span_cols_upt_k_Gram_Schmidt_column_k:
  fixes A::"'a::{real_inner}^'n::{mod_type}^'m::{mod_type}"
  assumes "k < ncols A"
  and "j < ncols A"
  shows "span (cols_upt_k A k) = span (cols_upt_k (Gram_Schmidt_column_k A j) k)"
  using assms
proof (induct k)
  case 0
  have set_rw: "{\<chi> ia. A $ ia $ i |i. i < 0} = {}" using least_mod_type not_less by auto
  have set_rw2: "{column i (Gram_Schmidt_column_k A j) |i. i \<le> 0} = {column 0 (Gram_Schmidt_column_k A j)}"
    by (auto, metis eq_iff least_mod_type)
  have set_rw3: "{column i A |i. i \<le> 0} ={column 0 A}"  by (auto, metis eq_iff least_mod_type)
  have col_0_eq: "column 0 (Gram_Schmidt_column_k A j) = column 0 A"
    unfolding Gram_Schmidt_column_k_def column_def
    unfolding proj_onto_def proj_def[abs_def]
    by (simp add: set_rw)
  show ?case unfolding cols_upt_k_def from_nat_0 unfolding set_rw2 set_rw3 unfolding col_0_eq ..
next
  case (Suc k)
  have hyp: "span (cols_upt_k A k) = span (cols_upt_k (Gram_Schmidt_column_k A j) k)"
    using Suc.prems Suc.hyps by auto
  have set_rw1: "(cols_upt_k A (Suc k)) = insert (column (from_nat (Suc k)) A) (cols_upt_k A k)"
    using cols_upt_k_insert
    by (auto intro!: cols_upt_k_insert[OF Suc.prems(1)])
  have set_rw2: "(cols_upt_k (Gram_Schmidt_column_k A j) (Suc k)) =
    insert (column (from_nat (Suc k)) (Gram_Schmidt_column_k A j)) (cols_upt_k (Gram_Schmidt_column_k A j) k)"
    using cols_upt_k_insert  Suc.prems(1) unfolding ncols_def by auto
  show ?case
  proof (cases "j=Suc k")
    case False
    have suc_not_k: "from_nat (Suc k) \<noteq> (from_nat j::'n)"
    proof (rule ccontr, simp)
      assume "from_nat (Suc k) = (from_nat j::'n)"
      hence "Suc k = j" apply (rule from_nat_eq_imp_eq) using Suc.prems unfolding ncols_def .
      thus False using False by simp
    qed
    have tnfnj: "to_nat (from_nat j::'n) = j" using to_nat_from_nat_id[OF Suc.prems(2)[unfolded ncols_def]] .
    let ?a_suc_k = "column (from_nat (Suc k)) A"
    have col_eq: "column (from_nat (Suc k)) (Gram_Schmidt_column_k A j) = ?a_suc_k"
      using column_Gram_Schmidt_column_k'[OF suc_not_k] unfolding tnfnj .
    have k: "k<CARD('n)" using Suc.prems(1)[unfolded ncols_def] by simp
    show ?thesis unfolding set_rw1 set_rw2 col_eq unfolding span_insert unfolding hyp ..
  next
    case True
    define C where "C = cols_upt_k A k"
    define B where "B = cols_upt_k (Gram_Schmidt_column_k A j) k"
    define a where "a = column (from_nat (Suc k)) A"
    let ?a="a - sum (\<lambda>x. (x \<bullet> a / (x \<bullet> x)) *\<^sub>R x) C"
    let ?C="insert ?a C"
    have col_rw: "{column i A |i. i \<le> from_nat k} = {column i A |i. i < from_nat (Suc k)}"
    proof (auto)
      fix i::'n assume i: "i \<le> from_nat k"
      also have "... < from_nat (Suc k)" by (rule from_nat_mono[OF _ Suc.prems(1)[unfolded ncols_def]], simp)
      finally show "\<exists>ia. column i A = column ia A \<and> ia < from_nat (Suc k)" by auto
    next
      fix i::'n
      assume i: "i < from_nat (Suc k)"
      hence "i\<le> from_nat k" unfolding Suc_eq_plus1 unfolding from_nat_suc by (metis le_Suc not_less)
      thus " \<exists>ia. column i A = column ia A \<and> ia \<le> from_nat k" by auto
    qed
    have rw: "column (from_nat (Suc k)) (Gram_Schmidt_column_k A j) = (a - (\<Sum>x\<in>cols_upt_k A k. (x \<bullet> a / (x \<bullet> x)) *\<^sub>R x))"
      unfolding Gram_Schmidt_column_k_def True  unfolding cols_upt_k_def a_def C_def
      unfolding  column_def apply auto
      unfolding column_def[symmetric] col_rw minus_vec_def
      unfolding column_def vec_lambda_beta
      unfolding proj_onto_def proj_def[abs_def]
      unfolding proj_onto_sum_rw
      by auto
    have finite_C: "finite C" unfolding C_def cols_upt_k_def by auto
    {
      fix x b
      have th0: "!!(a::'a^'m::{mod_type}) b c. a - (b - c) = c + (a - b)"
        by (simp add: field_simps)
      have "x - b *\<^sub>R  (a - (\<Sum>x\<in>C. (x \<bullet> a / (x \<bullet> x))  *\<^sub>R  x)) \<in> span C \<longleftrightarrow> x - b  *\<^sub>R  a \<in> span C"
        apply (simp only: scaleR_right_diff_distrib th0)
        apply (rule span_add_eq)
        apply (rule span_mul)
        apply (rule span_sum)
        apply (rule span_mul)
        apply (rule span_base)
        apply assumption
        done
    }
    thus ?thesis unfolding set_eq_iff
      unfolding C_def B_def unfolding set_rw1 unfolding set_rw2
      unfolding span_breakdown_eq unfolding hyp
      by (metis (mono_tags) B_def a_def rw)
  qed
qed

corollary span_Gram_Schmidt_column_k:
  fixes A::"'a::{real_inner}^'n::{mod_type}^'m::{mod_type}"
  assumes "k<ncols A"
  shows "span (columns A) = span (columns (Gram_Schmidt_column_k A k))"
  unfolding columns_eq_cols_upt_k[symmetric]
  using span_cols_upt_k_Gram_Schmidt_column_k[of "ncols A - 1" A k]
  using assms unfolding ncols_def by auto

corollary span_Gram_Schmidt_upt_k:
  fixes A::"'a::{real_inner}^'n::{mod_type}^'m::{mod_type}"
  assumes "k<ncols A"
  shows "span (columns A) = span (columns (Gram_Schmidt_upt_k A k))"
  using assms
proof (induct k)
  case 0
  have "columns (Gram_Schmidt_column_k A 0) = columns A"
  proof (unfold columns_def, auto)
    fix i
    have set_rw: "{\<chi> ia. A $ ia $ i |i. i < from_nat 0} = {}"
      by (auto, metis less_le_not_le least_mod_type from_nat_0)
    thus "\<exists>ia. column i (Gram_Schmidt_column_k A 0) = column ia A"
      unfolding Gram_Schmidt_column_k_def column_def
      unfolding proj_onto_def proj_def[abs_def] by auto
    show "\<exists>ia. column i A = column ia (Gram_Schmidt_column_k A 0)"
      using set_rw unfolding Gram_Schmidt_column_k_def column_def
      unfolding from_nat_0
      unfolding proj_onto_def proj_def[abs_def]
      by force
  qed
  thus ?case unfolding Gram_Schmidt_upt_k_def by auto
next
  case (Suc k)
  have hyp: "span (columns A) = span (columns (Gram_Schmidt_upt_k A k))"
    using Suc.prems Suc.hyps by auto
  have "span (columns (Gram_Schmidt_upt_k A (Suc k)))
    = span (columns (Gram_Schmidt_column_k (Gram_Schmidt_upt_k A k) (Suc k)))"
    unfolding Gram_Schmidt_upt_k_suc ..
  also have "... = span (columns (Gram_Schmidt_upt_k A k))"
    using span_Gram_Schmidt_column_k[of "Suc k" "(Gram_Schmidt_upt_k A k)"]
    using Suc.prems unfolding ncols_def by auto
  finally show ?case using hyp by auto
qed

corollary span_Gram_Schmidt_matrix:
  fixes A::"'a::{real_inner}^'n::{mod_type}^'m::{mod_type}"
  shows "span (columns A) = span (columns (Gram_Schmidt_matrix A))"
  unfolding Gram_Schmidt_matrix_def
  by (simp add: span_Gram_Schmidt_upt_k ncols_def)

lemma is_basis_columns_Gram_Schmidt_matrix:
  fixes A::"real^'n::{mod_type}^'m::{mod_type}"
  assumes b: "is_basis (columns A)"
  and c: "card (columns A) = ncols A"
  shows "is_basis (columns (Gram_Schmidt_matrix A))
  \<and> card (columns (Gram_Schmidt_matrix A)) = ncols A"
proof -
  have span_UNIV: "vec.span (columns (Gram_Schmidt_matrix A)) = (UNIV::(real^'m::{mod_type}) set)"
    using span_Gram_Schmidt_matrix b unfolding is_basis_def
    by (metis span_vec_eq)
  moreover have c_eq: "card (columns (Gram_Schmidt_matrix A)) = ncols A"
  proof -
    have "card (columns A) \<le> card (columns (Gram_Schmidt_matrix A))"
      by (metis b is_basis_def finite_columns vec.independent_span_bound span_UNIV top_greatest)
    thus ?thesis using c using card_columns_le_ncols by (metis le_antisym ncols_def)
  qed
  moreover have "vec.independent (columns (Gram_Schmidt_matrix A))"
  proof (rule vec.card_le_dim_spanning[of _ "UNIV::(real^'m::{mod_type}) set"])
    show "columns (Gram_Schmidt_matrix A) \<subseteq> UNIV" by simp
    show "UNIV \<subseteq> vec.span (columns (Gram_Schmidt_matrix A))" using span_UNIV by auto
    show "finite (columns (Gram_Schmidt_matrix A))" using finite_columns .
    show "card (columns (Gram_Schmidt_matrix A)) \<le> vec.dim (UNIV::(real^'m::{mod_type}) set)"
      by (metis b c c_eq eq_iff is_basis_def vec.dim_span_eq_card_independent)
  qed
  ultimately show ?thesis unfolding is_basis_def by simp
qed

text\<open>From here on, we present some lemmas that will be useful for the formalisation of the QR
  decomposition.\<close>

lemma column_gr_k_Gram_Schmidt_upt:
  fixes A::"real^'n::{mod_type}^'m::{mod_type}"
  assumes "i>k"
  and i: "i<ncols A"
  shows "column (from_nat i) (Gram_Schmidt_upt_k A k) = column (from_nat i) A"
  using assms(1)
proof (induct k)
  assume "0 < i"
  hence "(from_nat i::'n) \<noteq> 0"
    unfolding from_nat_0[symmetric] using bij_from_nat[where ?'a='n] unfolding bij_betw_def
    by (metis from_nat_eq_imp_eq gr_implies_not0 i ncols_def neq0_conv)
  thus "column (from_nat i) (Gram_Schmidt_upt_k A 0) = column (from_nat i) A"
    unfolding Gram_Schmidt_upt_k_def
    by (simp add: Gram_Schmidt_column_k_def from_nat_0 column_def)
next
  case (Suc k)
  have hyp: "column (from_nat i) (Gram_Schmidt_upt_k A k) = column (from_nat i) A"
    using Suc.hyps Suc.prems by auto
  have to_nat_from_nat_suc_k: "(to_nat (from_nat (Suc k)::'n)) = Suc k"
    by (metis Suc.prems dual_order.strict_trans from_nat_not_eq i ncols_def)
  have "column (from_nat i) (Gram_Schmidt_upt_k A (Suc k))
    = column (from_nat i) (Gram_Schmidt_column_k (Gram_Schmidt_upt_k A k) (Suc k))"
    unfolding Gram_Schmidt_upt_k_suc ..
  also have "... =  column (from_nat i) (Gram_Schmidt_upt_k A k)"
  proof (rule column_Gram_Schmidt_column_k'
      [of "from_nat i" "from_nat (Suc k)" " (Gram_Schmidt_upt_k A k)", unfolded to_nat_from_nat_suc_k])
    show "from_nat i \<noteq> (from_nat (Suc k)::'n)"
      by (metis Suc.prems not_less_iff_gr_or_eq
        from_nat_not_eq i ncols_def to_nat_from_nat_suc_k)
  qed
  finally show ?case unfolding hyp .
qed

lemma columns_Gram_Schmidt_upt_k_rw:
  fixes A::"real^'n::{mod_type}^'m::{mod_type}"
  assumes k: "Suc k < ncols A"
  shows "{column i (Gram_Schmidt_upt_k A (Suc k)) |i. i < from_nat (Suc k)}
  = {column i (Gram_Schmidt_upt_k A k) |i. i < from_nat (Suc k)}"
proof (auto)
  fix i::'n assume i: "i < from_nat (Suc k)"
  have to_nat_from_nat_k: "to_nat (from_nat (Suc k)::'n) = Suc k"
    using to_nat_from_nat_id k unfolding ncols_def by auto
  show "\<exists>ia. column i (Gram_Schmidt_upt_k A (Suc k)) = column ia (Gram_Schmidt_upt_k A k) \<and> ia < from_nat (Suc k)"
    by (metis column_Gram_Schmidt_upt_k_preserves i k ncols_def to_nat_le)
  show "\<exists>ia. column i (Gram_Schmidt_upt_k A k) = column ia (Gram_Schmidt_upt_k A (Suc k)) \<and> ia < from_nat (Suc k)"
    by (metis column_Gram_Schmidt_upt_k_preserves i k ncols_def to_nat_le)
qed

lemma column_Gram_Schmidt_upt_k:
  fixes A::"real^'n::{mod_type}^'m::{mod_type}"
  assumes "k<ncols A"
  shows "column (from_nat k) (Gram_Schmidt_upt_k A k) =
  (column (from_nat k) A) - (\<Sum>x\<in>{column i (Gram_Schmidt_upt_k A k)|i. i < (from_nat k)}. (x \<bullet> (column (from_nat k) A) / (x \<bullet> x)) *\<^sub>R x)"
  using assms
proof (induct k, unfold from_nat_0)
  have set_rw: "{column i (Gram_Schmidt_upt_k A 0) |i. i < 0} = {}" by (auto, metis least_mod_type not_le)
  have set_rw2: "{column i A |i. i < 0} = {}"  by (auto, metis least_mod_type not_le)
  have col_rw: "column 0 A = column 0 (Gram_Schmidt_upt_k A 0)"
    unfolding Gram_Schmidt_upt_k_def apply auto unfolding Gram_Schmidt_column_k_def from_nat_0
    unfolding column_def
    using set_rw2 unfolding proj_onto_def proj_def[abs_def]
    by vector
  show "column 0 (Gram_Schmidt_upt_k A 0)
    = column 0 A - (\<Sum>x\<in>{column i (Gram_Schmidt_upt_k A 0) |i. i < 0}. (x \<bullet> column 0 A / (x \<bullet> x)) *\<^sub>R x)"
    unfolding set_rw col_rw by simp
next
  case (Suc k)
  let ?ak="column (from_nat k) A"
  let ?uk="column (from_nat k) (Gram_Schmidt_upt_k A k)"
  let ?a_suck= "column (from_nat (Suc k)) A"
  let ?u_suck="column (from_nat (Suc k)) (Gram_Schmidt_upt_k A (Suc k))"
  have to_nat_from_nat_k: "to_nat (from_nat (Suc k)::'n) = (Suc k)"
    using to_nat_from_nat_id Suc.prems unfolding ncols_def by auto
  have a_suc_rw: "column (from_nat (Suc k)) (Gram_Schmidt_upt_k A k) = ?a_suck"
    by (rule column_gr_k_Gram_Schmidt_upt, auto simp add: Suc.prems)
  have set_rw: "{column i (Gram_Schmidt_upt_k A (Suc k)) |i. i < from_nat (Suc k)}
    = {column i (Gram_Schmidt_upt_k A k) |i. i < from_nat (Suc k)}"
    by (rule columns_Gram_Schmidt_upt_k_rw[OF Suc.prems])
  have "?u_suck = column (from_nat (Suc k)) (Gram_Schmidt_upt_k A k) -
    (\<Sum>x\<in>{column i (Gram_Schmidt_upt_k A k) |i.
    i < from_nat (Suc k)}. (x \<bullet> column (from_nat (Suc k)) (Gram_Schmidt_upt_k A k) / (x \<bullet> x)) *\<^sub>R x)"
    unfolding Gram_Schmidt_upt_k_suc
    using column_Gram_Schmidt_column_k[of "from_nat (Suc k)" "(Gram_Schmidt_upt_k A k)"]
    unfolding to_nat_from_nat_k by auto
  also have "... = ?a_suck -
    (\<Sum>x\<in>{column i (Gram_Schmidt_upt_k A k) |i.
    i < from_nat (Suc k)}. (x \<bullet> ?a_suck / (x \<bullet> x)) *\<^sub>R x)" unfolding a_suc_rw ..
  finally show "?u_suck = ?a_suck - (\<Sum>x\<in>{column i (Gram_Schmidt_upt_k A (Suc k)) |i.
    i < from_nat (Suc k)}. (x \<bullet> ?a_suck / (x \<bullet> x)) *\<^sub>R x)"
    unfolding set_rw .
qed

lemma column_Gram_Schmidt_upt_k_preserves2:
  fixes A::"real^'n::{mod_type}^'m::{mod_type}"
  assumes "a\<le>(from_nat i)"
  and "i \<le> j"
  and "j<ncols A"
  shows "column a (Gram_Schmidt_upt_k A i) = column a (Gram_Schmidt_upt_k A j)"
  using assms
proof (induct j)
  case 0
  show "column a (Gram_Schmidt_upt_k A i) = column a (Gram_Schmidt_upt_k A 0)" by (metis "0.prems"(2) le_0_eq)
next
  case (Suc j)
  show ?case
  proof (cases "a=from_nat (Suc j)")
    case False note a_not_suc_j=False
    have rw1: "(to_nat (from_nat (Suc j)::'n)) = Suc j"
      using to_nat_from_nat_id Suc.prems unfolding ncols_def by auto
    show ?thesis unfolding Gram_Schmidt_upt_k_suc using column_Gram_Schmidt_column_k'[OF a_not_suc_j] unfolding rw1
      by (metis Gram_Schmidt_upt_k_suc Suc.hyps Suc.prems(2) Suc.prems(3) Suc_le_lessD assms(1) le_Suc_eq nat_less_le)
  next
    case True
    have "(from_nat i::'n) \<le> from_nat (Suc j)" by (rule from_nat_mono'[OF Suc.prems(2) Suc.prems(3)[unfolded ncols_def]])
    hence "from_nat i = (from_nat (Suc j)::'n)" using Suc.prems(1) unfolding True by simp
    hence i_eq_suc: "i=Suc j" apply (rule from_nat_eq_imp_eq) using Suc.prems unfolding ncols_def by auto
    show ?thesis unfolding True i_eq_suc ..
  qed
qed

lemma set_columns_Gram_Schmidt_matrix:
  fixes A::"real^'n::{mod_type}^'m::{mod_type}"
  shows "{column i (Gram_Schmidt_matrix A)|i. i < k} = {column i (Gram_Schmidt_upt_k A (to_nat k))|i. i < k}"
proof (auto)
  fix i assume i: "i<k"
  show "\<exists>ia. column i (Gram_Schmidt_matrix A) = column ia (Gram_Schmidt_upt_k A (to_nat k)) \<and> ia < k"
  proof (rule exI[of _ i], rule conjI)
    show "column i (Gram_Schmidt_matrix A) = column i (Gram_Schmidt_upt_k A (to_nat k))"
      unfolding Gram_Schmidt_matrix_def
    proof (rule column_Gram_Schmidt_upt_k_preserves2[symmetric])
      show "i \<le> from_nat (to_nat k)" using i unfolding from_nat_to_nat_id by auto
      show "to_nat k \<le> ncols A - 1" unfolding ncols_def using to_nat_less_card[of k] by auto
      show "ncols A - 1 < ncols A" unfolding ncols_def by simp
    qed
    show "i < k" using i .
  qed
  show "\<exists>ia. column i (Gram_Schmidt_upt_k A (to_nat k)) = column ia (Gram_Schmidt_matrix A) \<and> ia < k"
  proof (rule exI[of _ i], rule conjI)
    show "column i (Gram_Schmidt_upt_k A (to_nat k)) = column i (Gram_Schmidt_matrix A)"
      unfolding Gram_Schmidt_matrix_def
    proof (rule column_Gram_Schmidt_upt_k_preserves2)
      show "i \<le> from_nat (to_nat k)" using i unfolding from_nat_to_nat_id by auto
      show "to_nat k \<le> ncols A - 1" unfolding ncols_def using to_nat_less_card[of k] by auto
      show "ncols A - 1 < ncols A" unfolding ncols_def by simp
    qed
    show "i < k" using i .
  qed
qed

lemma column_Gram_Schmidt_matrix:
  fixes A::"real^'n::{mod_type}^'m::{mod_type}"
  shows "column k (Gram_Schmidt_matrix A)
  = (column k A) - (\<Sum>x\<in>{column i (Gram_Schmidt_matrix A)|i. i < k}. (x \<bullet> (column k A) / (x \<bullet> x)) *\<^sub>R x)"
proof -
  have k: "to_nat k < ncols A" using to_nat_less_card[of k] unfolding ncols_def by simp
  have "column k (Gram_Schmidt_matrix A) = column k (Gram_Schmidt_upt_k A (ncols A - 1))"
    unfolding Gram_Schmidt_matrix_def ..
  also have "... = column k (Gram_Schmidt_upt_k A (to_nat k))"
  proof (rule column_Gram_Schmidt_upt_k_preserves2[symmetric])
    show "k \<le> from_nat (to_nat k)" unfolding from_nat_to_nat_id ..
    show "to_nat k \<le> ncols A - 1" unfolding ncols_def using to_nat_less_card[where ?'a='n]
      by (metis Nat.le_diff_conv2 add_leE less_diff_conv less_imp_le_nat  less_le_not_le
        nat_le_linear suc_not_zero to_nat_plus_one_less_card')
    show "ncols A - 1 < ncols A" unfolding ncols_def by auto
  qed
  also have "... = column k A - (\<Sum>x\<in>{column i (Gram_Schmidt_upt_k A (to_nat k)) |i. i < k}. (x \<bullet> column k A / (x \<bullet> x)) *\<^sub>R x)"
    using column_Gram_Schmidt_upt_k[OF k] unfolding from_nat_to_nat_id by auto
  also have "... = column k A - (\<Sum>x\<in>{column i (Gram_Schmidt_matrix A) |i. i < k}. (x \<bullet> column k A / (x \<bullet> x)) *\<^sub>R x)"
    unfolding set_columns_Gram_Schmidt_matrix[symmetric] ..
  finally show ?thesis .
qed

corollary column_Gram_Schmidt_matrix2:
  fixes A::"real^'n::{mod_type}^'m::{mod_type}"
  shows "(column k A) = column k (Gram_Schmidt_matrix A)
  + (\<Sum>x\<in>{column i (Gram_Schmidt_matrix A)|i. i < k}. (x \<bullet> (column k A) / (x \<bullet> x)) *\<^sub>R x)"
  using column_Gram_Schmidt_matrix[of k A] by simp

lemma independent_columns_Gram_Schmidt_matrix:
  fixes A::"real^'n::{mod_type}^'m::{mod_type}"
  assumes b: "vec.independent (columns A)"
  and c: "card (columns A) = ncols A"
  shows "vec.independent (columns (Gram_Schmidt_matrix A)) \<and> card (columns (Gram_Schmidt_matrix A)) = ncols A"
  using  b c card_columns_le_ncols vec.card_eq_dim_span_indep vec.dim_span eq_iff finite_columns
    vec.independent_span_bound ncols_def span_Gram_Schmidt_matrix
  by (metis (no_types, lifting) vec.card_ge_dim_independent vec.dim_span_eq_card_independent span_vec_eq)

lemma column_eq_Gram_Schmidt_matrix:
  fixes A::"real^'n::{mod_type}^'m::{mod_type}"
  assumes r: "rank A = ncols A"
  and c: "column i (Gram_Schmidt_matrix A) = column ia (Gram_Schmidt_matrix A)"
  shows "i = ia"
proof (rule ccontr)
  assume i_not_ia: "i \<noteq> ia"
  have "columns (Gram_Schmidt_matrix A) = (\<lambda>x. column x (Gram_Schmidt_matrix A))` (UNIV::('n::{mod_type}) set)"
    unfolding columns_def by auto
  also have "... = (\<lambda>x. column x (Gram_Schmidt_matrix A))` ((UNIV::('n::{mod_type}) set)-{ia})"
  proof (unfold image_def, auto)
    fix xa
    show "\<exists>x\<in>UNIV - {ia}. column xa (Gram_Schmidt_matrix A) = column x (Gram_Schmidt_matrix A)"
    proof (cases "xa = ia")
      case True thus ?thesis using c i_not_ia by (metis DiffI UNIV_I empty_iff insert_iff)
    next
      case False thus ?thesis by auto
    qed
  qed
  finally have columns_rw: "columns (Gram_Schmidt_matrix A) = (\<lambda>x. column x (Gram_Schmidt_matrix A)) ` (UNIV - {ia})" .
  have "ncols A = card (columns (Gram_Schmidt_matrix A))"
    by (metis full_rank_imp_is_basis2 independent_columns_Gram_Schmidt_matrix r)
  also have "... \<le> card (UNIV - {ia})" unfolding columns_rw by (rule card_image_le, simp)
  also have "... = card (UNIV::'n set) - 1" by (simp add: card_Diff_singleton)
  finally show False unfolding ncols_def
    by (metis Nat.add_0_right Nat.le_diff_conv2 One_nat_def Suc_n_not_le_n add_Suc_right one_le_card_finite)
qed

lemma scaleR_columns_Gram_Schmidt_matrix:
  fixes A::"real^'n::{mod_type}^'m::{mod_type}"
  assumes "i \<noteq> j"
  and "rank A = ncols A"
  shows "column j (Gram_Schmidt_matrix A) \<bullet> column i (Gram_Schmidt_matrix A) = 0"
proof -
  have "column j (Gram_Schmidt_matrix A) \<noteq> column i (Gram_Schmidt_matrix A)"
    using column_eq_Gram_Schmidt_matrix assms by auto
  thus ?thesis using orthogonal_Gram_Schmidt_matrix2 unfolding pairwise_def orthogonal_def columns_def
    by blast
qed

subsubsection\<open>Examples of execution\<close>

text\<open>Code lemma\<close>
lemmas Gram_Schmidt_step_def[unfolded proj_onto_def proj_def[abs_def],code]

value "let a = map (list_to_vec::real list=> real^4) [[4,-2,-1,2],
  [-6,3,4,-8], [5,-5,-3,-4]] in
  map vec_to_list (Gram_Schmidt a)"

value "let a = map (list_to_vec::real list=> real^4) [[4,-2,-1,2],
  [-6,3,4,-8], [5,-5,-3,-4]] in
  map vec_to_list (Gram_Schmidt2 a)"

value "let A = list_of_list_to_matrix [[4,-2,-1,2],
  [-6,3,4,-8], [5,-5,-3,-4]]::real^4^3 in
  matrix_to_list_of_list (Gram_Schmidt_matrix A)"

end


(* Title: Examples/SML_Relativization/Lattices/SML_Linorders.thy
   Author: Mihails Milehins
   Copyright 2021 (C) Mihails Milehins
*)
section\<open>Relativization of the results about linear orders\<close>
theory SML_Linorders
  imports SML_Semilattices
begin

subsection\<open>Linear orders\<close>

subsubsection\<open>Definitions and further properties\<close>

locale linorder_ow = order_ow +
  assumes linear: "\<lbrakk> x \<in> U; y \<in> U \<rbrakk> \<Longrightarrow> x \<le>\<^sub>o\<^sub>w y \<or> y \<le>\<^sub>o\<^sub>w x"
begin

sublocale min:
  semilattice_order_ow U \<open>(\<lambda>x y. (with (\<le>\<^sub>o\<^sub>w) : \<guillemotleft>min\<guillemotright> x y))\<close> \<open>(\<le>\<^sub>o\<^sub>w)\<close> \<open>(<\<^sub>o\<^sub>w)\<close>
  apply unfold_locales
  subgoal unfolding min.with_def by simp
  subgoal by (metis linear order_trans min.with_def)
  subgoal unfolding min.with_def by (auto dest: linear simp: antisym)
  subgoal unfolding min.with_def by simp
  subgoal unfolding min.with_def by (simp add: eq_iff)
  subgoal unfolding min.with_def by (simp add: less_le)
  done

sublocale max:
  semilattice_order_ow U \<open>(\<lambda>x y. (with (\<le>\<^sub>o\<^sub>w) : \<guillemotleft>max\<guillemotright> x y))\<close> \<open>(\<ge>\<^sub>o\<^sub>w)\<close> \<open>(>\<^sub>o\<^sub>w)\<close>
  apply unfold_locales
  subgoal unfolding max.with_def by simp
  subgoal by (metis linear order_trans max.with_def)
  subgoal unfolding max.with_def by (auto dest: linear simp: antisym)
  subgoal unfolding max.with_def by simp
  subgoal unfolding max.with_def by (auto dest: linear simp: antisym)
  subgoal unfolding max.with_def by (auto dest: linear simp: less_le_not_le)
  done

end

locale ord_linorder_ow =
  ord?: ord_ow U\<^sub>1 le\<^sub>1 ls\<^sub>1 + lo?: linorder_ow U\<^sub>2 le\<^sub>2 ls\<^sub>2
  for U\<^sub>1 :: "'ao set" and le\<^sub>1 ls\<^sub>1 and U\<^sub>2 :: "'bo set" and le\<^sub>2 ls\<^sub>2
begin

sublocale ord_order_ow ..

end

locale preorder_linorder_ow =
  po?: preorder_ow U\<^sub>1 le\<^sub>1 ls\<^sub>1 + lo?: linorder_ow U\<^sub>2 le\<^sub>2 ls\<^sub>2
  for U\<^sub>1 :: "'ao set" and le\<^sub>1 ls\<^sub>1 and U\<^sub>2 :: "'bo set" and le\<^sub>2 ls\<^sub>2
begin

sublocale preorder_order_ow ..

end

locale order_linorder_ow =
  order?: order_ow U\<^sub>1 le\<^sub>1 ls\<^sub>1 + lo?: linorder_ow U\<^sub>2 le\<^sub>2 ls\<^sub>2
  for U\<^sub>1 :: "'ao set" and le\<^sub>1 ls\<^sub>1 and U\<^sub>2 :: "'bo set" and le\<^sub>2 ls\<^sub>2
begin

sublocale order_pair_ow ..

end

locale linorder_pair_ow =
  lo\<^sub>1?: linorder_ow U\<^sub>1 le\<^sub>1 ls\<^sub>1 + lo\<^sub>2?: linorder_ow U\<^sub>2 le\<^sub>2 ls\<^sub>2
  for U\<^sub>1 :: "'ao set" and le\<^sub>1 ls\<^sub>1 and U\<^sub>2 :: "'bo set" and le\<^sub>2 ls\<^sub>2
begin

sublocale order_linorder_ow ..

end

subsubsection\<open>Transfer rules\<close>

context
  includes lifting_syntax
begin

lemma linorder_transfer[transfer_rule]:
  assumes [transfer_rule]: "bi_unique A" "right_total A"
  shows
    "((A ===> A ===> (=)) ===> (A ===> A ===> (=)) ===> (=))
      (linorder_ow (Collect (Domainp A))) class.linorder"
  unfolding
    linorder_ow_def class.linorder_def
    linorder_ow_axioms_def class.linorder_axioms_def
  apply transfer_prover_start
  apply transfer_step+
  by simp

end

subsubsection\<open>Relativization\<close>

context linorder_ow
begin

tts_context
  tts: (?'a to U)
  rewriting ctr_simps
  substituting linorder_ow_axioms
  eliminating through simp
begin

tts_lemma le_less_linear:
  assumes "x \<in> U" and "y \<in> U"
  shows "x \<le>\<^sub>o\<^sub>w y \<or> y <\<^sub>o\<^sub>w x"
  is linorder_class.le_less_linear.

tts_lemma not_less:
  assumes "x \<in> U" and "y \<in> U"
  shows "(\<not> x <\<^sub>o\<^sub>w y) = (y \<le>\<^sub>o\<^sub>w x)"
    is linorder_class.not_less.

tts_lemma not_le:
  assumes "x \<in> U" and "y \<in> U"
  shows "(\<not> x \<le>\<^sub>o\<^sub>w y) = (y <\<^sub>o\<^sub>w x)"
    is linorder_class.not_le.

tts_lemma lessThan_minus_lessThan:
  assumes "n \<in> U" and "m \<in> U"
  shows "{..<\<^sub>o\<^sub>wn} - {..<\<^sub>o\<^sub>wm} = (on U with (\<le>\<^sub>o\<^sub>w) (<\<^sub>o\<^sub>w) : {m..<n})"
    is linorder_class.lessThan_minus_lessThan.

tts_lemma Ici_subset_Ioi_iff:
  assumes "a \<in> U" and "b \<in> U"
  shows "({a..\<^sub>o\<^sub>w} \<subseteq> {b<\<^sub>o\<^sub>w..}) = (b <\<^sub>o\<^sub>w a)"
    is linorder_class.Ici_subset_Ioi_iff.

tts_lemma Iic_subset_Iio_iff:
  assumes "a \<in> U" and "b \<in> U"
  shows "({..\<^sub>o\<^sub>wa} \<subseteq> {..<\<^sub>o\<^sub>wb}) = (a <\<^sub>o\<^sub>w b)"
    is linorder_class.Iic_subset_Iio_iff.

tts_lemma leI:
  assumes "x \<in> U" and "y \<in> U" and "\<not> x <\<^sub>o\<^sub>w y"
  shows "y \<le>\<^sub>o\<^sub>w x"
    is linorder_class.leI.

tts_lemma not_le_imp_less:
  assumes "y \<in> U" and "x \<in> U" and "\<not> y \<le>\<^sub>o\<^sub>w x"
  shows "x <\<^sub>o\<^sub>w y"
    is linorder_class.not_le_imp_less.

tts_lemma Int_atMost:
  assumes "a \<in> U" and "b \<in> U"
  shows "{..\<^sub>o\<^sub>wa} \<inter> {..\<^sub>o\<^sub>wb} = {..\<^sub>o\<^sub>wmin a b}"
    is linorder_class.Int_atMost.

tts_lemma lessThan_Int_lessThan:
  assumes "a \<in> U" and "b \<in> U"
  shows "{a<\<^sub>o\<^sub>w..} \<inter> {b<\<^sub>o\<^sub>w..} = {max a b<\<^sub>o\<^sub>w..}"
    is linorder_class.lessThan_Int_lessThan.

tts_lemma greaterThan_Int_greaterThan:
  assumes "a \<in> U" and "b \<in> U"
  shows "{..<\<^sub>o\<^sub>wa} \<inter> {..<\<^sub>o\<^sub>wb} = {..<\<^sub>o\<^sub>wmin a b}"
    is linorder_class.greaterThan_Int_greaterThan.

tts_lemma less_linear:
  assumes "x \<in> U" and "y \<in> U"
  shows "x <\<^sub>o\<^sub>w y \<or> x = y \<or> y <\<^sub>o\<^sub>w x"
    is linorder_class.less_linear.

tts_lemma Int_atLeastAtMostR2:
  assumes "a \<in> U" and "c \<in> U" and "d \<in> U"
  shows "{a..\<^sub>o\<^sub>w} \<inter> {c..\<^sub>o\<^sub>wd} = {max a c..\<^sub>o\<^sub>wd}"
    is linorder_class.Int_atLeastAtMostR2.

tts_lemma Int_atLeastAtMostR1:
  assumes "b \<in> U" and "c \<in> U" and "d \<in> U"
  shows "{..\<^sub>o\<^sub>wb} \<inter> {c..\<^sub>o\<^sub>wd} = {c..\<^sub>o\<^sub>wmin b d}"
    is linorder_class.Int_atLeastAtMostR1.

tts_lemma Int_atLeastAtMostL2:
  assumes "a \<in> U" and "b \<in> U" and "c \<in> U"
  shows "{a..\<^sub>o\<^sub>wb} \<inter> {c..\<^sub>o\<^sub>w} = {max a c..\<^sub>o\<^sub>wb}"
    is linorder_class.Int_atLeastAtMostL2.

tts_lemma Int_atLeastAtMostL1:
  assumes "a \<in> U" and "b \<in> U" and "d \<in> U"
  shows "{a..\<^sub>o\<^sub>wb} \<inter> {..\<^sub>o\<^sub>wd} = {a..\<^sub>o\<^sub>wmin b d}"
    is linorder_class.Int_atLeastAtMostL1.

tts_lemma neq_iff:
  assumes "x \<in> U" and "y \<in> U"
  shows "(x \<noteq> y) = (x <\<^sub>o\<^sub>w y \<or> y <\<^sub>o\<^sub>w x)"
    is linorder_class.neq_iff.

tts_lemma not_less_iff_gr_or_eq:
  assumes "x \<in> U" and "y \<in> U"
  shows "(\<not> x <\<^sub>o\<^sub>w y) = (y <\<^sub>o\<^sub>w x \<or> x = y)"
    is linorder_class.not_less_iff_gr_or_eq.

tts_lemma max_min_distrib2:
  assumes "a \<in> U" and "b \<in> U" and "c \<in> U"
  shows "max a (min b c) = min (max a b) (max a c)"
    is linorder_class.max_min_distrib2.

tts_lemma max_min_distrib1:
  assumes "b \<in> U" and "c \<in> U" and "a \<in> U"
  shows "max (min b c) a = min (max b a) (max c a)"
    is linorder_class.max_min_distrib1.

tts_lemma min_max_distrib2:
  assumes "a \<in> U" and "b \<in> U" and "c \<in> U"
  shows "min a (max b c) = max (min a b) (min a c)"
    is linorder_class.min_max_distrib2.

tts_lemma min_max_distrib1:
  assumes "b \<in> U" and "c \<in> U" and "a \<in> U"
  shows "min (max b c) a = max (min b a) (min c a)"
    is linorder_class.min_max_distrib1.

tts_lemma atLeastAtMost_diff_ends:
  assumes "a \<in> U" and "b \<in> U"
  shows "{a..\<^sub>o\<^sub>wb} - {a, b} = {a<\<^sub>o\<^sub>w..<\<^sub>o\<^sub>wb}"
    is linorder_class.atLeastAtMost_diff_ends.

tts_lemma less_max_iff_disj:
  assumes "z \<in> U" and "x \<in> U" and "y \<in> U"
  shows "(z <\<^sub>o\<^sub>w max x y) = (z <\<^sub>o\<^sub>w x \<or> z <\<^sub>o\<^sub>w y)"
    is linorder_class.less_max_iff_disj.

tts_lemma min_less_iff_conj:
  assumes "z \<in> U" and "x \<in> U" and "y \<in> U"
  shows "(z <\<^sub>o\<^sub>w min x y) = (z <\<^sub>o\<^sub>w x \<and> z <\<^sub>o\<^sub>w y)"
    is linorder_class.min_less_iff_conj.

tts_lemma max_less_iff_conj:
  assumes "x \<in> U" and "y \<in> U" and "z \<in> U"
  shows "(max x y <\<^sub>o\<^sub>w z) = (x <\<^sub>o\<^sub>w z \<and> y <\<^sub>o\<^sub>w z)"
    is linorder_class.max_less_iff_conj.

tts_lemma min_less_iff_disj:
  assumes "x \<in> U" and "y \<in> U" and "z \<in> U"
  shows "(min x y <\<^sub>o\<^sub>w z) = (x <\<^sub>o\<^sub>w z \<or> y <\<^sub>o\<^sub>w z)"
    is linorder_class.min_less_iff_disj.

tts_lemma le_max_iff_disj:
  assumes "z \<in> U" and "x \<in> U" and "y \<in> U"
  shows "(z \<le>\<^sub>o\<^sub>w max x y) = (z \<le>\<^sub>o\<^sub>w x \<or> z \<le>\<^sub>o\<^sub>w y)"
    is linorder_class.le_max_iff_disj.

tts_lemma min_le_iff_disj:
  assumes "x \<in> U" and "y \<in> U" and "z \<in> U"
  shows "(min x y \<le>\<^sub>o\<^sub>w z) = (x \<le>\<^sub>o\<^sub>w z \<or> y \<le>\<^sub>o\<^sub>w z)"
    is linorder_class.min_le_iff_disj.

tts_lemma antisym_conv3:
  assumes "y \<in> U" and "x \<in> U" and "\<not> y <\<^sub>o\<^sub>w x"
  shows "(\<not> x <\<^sub>o\<^sub>w y) = (x = y)"
    is linorder_class.antisym_conv3.

tts_lemma Int_atLeastAtMost:
  assumes "a \<in> U" and "b \<in> U" and "c \<in> U" and "d \<in> U"
  shows "{a..\<^sub>o\<^sub>wb} \<inter> {c..\<^sub>o\<^sub>wd} = {max a c..\<^sub>o\<^sub>wmin b d}"
    is linorder_class.Int_atLeastAtMost.

tts_lemma Int_atLeastLessThan:
  assumes "a \<in> U" and "b \<in> U" and "c \<in> U" and "d \<in> U"
  shows
    "(on U with (\<le>\<^sub>o\<^sub>w) (<\<^sub>o\<^sub>w) : {a..<b}) \<inter> (on U with (\<le>\<^sub>o\<^sub>w) (<\<^sub>o\<^sub>w) : {c..<d}) =
      (on U with (\<le>\<^sub>o\<^sub>w) (<\<^sub>o\<^sub>w) : {(max a c)..<(min b d)})"
    is linorder_class.Int_atLeastLessThan.

tts_lemma Int_greaterThanAtMost:
  assumes "a \<in> U" and "b \<in> U" and "c \<in> U" and "d \<in> U"
  shows "{a<\<^sub>o\<^sub>w..b} \<inter> {c<\<^sub>o\<^sub>w..d} = {max a c<\<^sub>o\<^sub>w..min b d}"
    is linorder_class.Int_greaterThanAtMost.

tts_lemma Int_greaterThanLessThan:
  assumes "a \<in> U" and "b \<in> U" and "c \<in> U" and "d \<in> U"
  shows "{a<\<^sub>o\<^sub>w..<\<^sub>o\<^sub>wb} \<inter> {c<\<^sub>o\<^sub>w..<\<^sub>o\<^sub>wd} = {max a c<\<^sub>o\<^sub>w..<\<^sub>o\<^sub>wmin b d}"
    is linorder_class.Int_greaterThanLessThan.

tts_lemma le_cases:
  assumes "x \<in> U" and "y \<in> U" and "x \<le>\<^sub>o\<^sub>w y \<Longrightarrow> P" and "y \<le>\<^sub>o\<^sub>w x \<Longrightarrow> P"
  shows P
    is linorder_class.le_cases.

tts_lemma split_max:
  assumes "i \<in> U" and "j \<in> U"
  shows "P (max i j) = ((i \<le>\<^sub>o\<^sub>w j \<longrightarrow> P j) \<and> (\<not> i \<le>\<^sub>o\<^sub>w j \<longrightarrow> P i))"
    is linorder_class.split_max.

tts_lemma split_min:
  assumes "i \<in> U" and "j \<in> U"
  shows "P (min i j) = ((i \<le>\<^sub>o\<^sub>w j \<longrightarrow> P i) \<and> (\<not> i \<le>\<^sub>o\<^sub>w j \<longrightarrow> P j))"
    is linorder_class.split_min.

tts_lemma Ioc_subset_iff:
  assumes "a \<in> U" and "b \<in> U" and "c \<in> U" and "d \<in> U"
  shows "({a<\<^sub>o\<^sub>w..b} \<subseteq> {c<\<^sub>o\<^sub>w..d}) = (b \<le>\<^sub>o\<^sub>w a \<or> b \<le>\<^sub>o\<^sub>w d \<and> c \<le>\<^sub>o\<^sub>w a)"
    is linorder_class.Ioc_subset_iff.

tts_lemma atLeastLessThan_subset_iff:
  assumes "a \<in> U"
    and "b \<in> U"
    and "c \<in> U"
    and "d \<in> U"
    and "(on U with (\<le>\<^sub>o\<^sub>w) (<\<^sub>o\<^sub>w) : {a..<b}) \<subseteq> (on U with (\<le>\<^sub>o\<^sub>w) (<\<^sub>o\<^sub>w) : {c..<d})"
  shows "b \<le>\<^sub>o\<^sub>w a \<or> b \<le>\<^sub>o\<^sub>w d \<and> c \<le>\<^sub>o\<^sub>w a"
    is linorder_class.atLeastLessThan_subset_iff.

tts_lemma Ioc_inj:
  assumes "a \<in> U" and "b \<in> U" and "c \<in> U" and "d \<in> U"
  shows "({a<\<^sub>o\<^sub>w..b} = {c<\<^sub>o\<^sub>w..d}) = (b \<le>\<^sub>o\<^sub>w a \<and> d \<le>\<^sub>o\<^sub>w c \<or> a = c \<and> b = d)"
    is linorder_class.Ioc_inj.

tts_lemma neqE:
  assumes "x \<in> U"
    and "y \<in> U"
    and "x \<noteq> y"
    and "x <\<^sub>o\<^sub>w y \<Longrightarrow> R"
    and "y <\<^sub>o\<^sub>w x \<Longrightarrow> R"
  shows R
    is linorder_class.neqE.

tts_lemma Ioc_disjoint:
  assumes "a \<in> U" and "b \<in> U" and "c \<in> U" and "d \<in> U"
  shows
    "({a<\<^sub>o\<^sub>w..b} \<inter> {c<\<^sub>o\<^sub>w..d} = {}) = (b \<le>\<^sub>o\<^sub>w a \<or> d \<le>\<^sub>o\<^sub>w c \<or> b \<le>\<^sub>o\<^sub>w c \<or> d \<le>\<^sub>o\<^sub>w a)"
    is linorder_class.Ioc_disjoint.

tts_lemma linorder_cases:
  assumes "x \<in> U"
    and "y \<in> U"
    and "x <\<^sub>o\<^sub>w y \<Longrightarrow> P"
    and "x = y \<Longrightarrow> P"
    and "y <\<^sub>o\<^sub>w x \<Longrightarrow> P"
  shows P
    is linorder_class.linorder_cases.

tts_lemma le_cases3:
  assumes "x \<in> U"
    and "y \<in> U"
    and "z \<in> U"
    and "\<lbrakk>x \<le>\<^sub>o\<^sub>w y; y \<le>\<^sub>o\<^sub>w z\<rbrakk> \<Longrightarrow> P"
    and "\<lbrakk>y \<le>\<^sub>o\<^sub>w x; x \<le>\<^sub>o\<^sub>w z\<rbrakk> \<Longrightarrow> P"
    and "\<lbrakk>x \<le>\<^sub>o\<^sub>w z; z \<le>\<^sub>o\<^sub>w y\<rbrakk> \<Longrightarrow> P"
    and "\<lbrakk>z \<le>\<^sub>o\<^sub>w y; y \<le>\<^sub>o\<^sub>w x\<rbrakk> \<Longrightarrow> P"
    and "\<lbrakk>y \<le>\<^sub>o\<^sub>w z; z \<le>\<^sub>o\<^sub>w x\<rbrakk> \<Longrightarrow> P"
    and "\<lbrakk>z \<le>\<^sub>o\<^sub>w x; x \<le>\<^sub>o\<^sub>w y\<rbrakk> \<Longrightarrow> P"
  shows P
    is linorder_class.le_cases3.

end

end

subsection\<open>Dense linear orders\<close>

subsubsection\<open>Definitions and further properties\<close>

locale dense_linorder_ow = linorder_ow U le ls + dense_order_ow U le ls
  for U :: "'ao set" and le (infix \<open>\<le>\<^sub>o\<^sub>w\<close> 50) and ls (infix \<open><\<^sub>o\<^sub>w\<close> 50)

subsubsection\<open>Transfer rules\<close>

context
  includes lifting_syntax
begin

lemma dense_linorder_transfer[transfer_rule]:
  assumes [transfer_rule]: "bi_unique A" "right_total A"
  shows
    "((A ===> A ===> (=)) ===> (A ===> A ===> (=))  ===> (=))
      (dense_linorder_ow (Collect (Domainp A))) class.dense_linorder"
  unfolding dense_linorder_ow_def class.dense_linorder_def
  apply transfer_prover_start
  apply transfer_step+
  by auto

end

subsubsection\<open>Relativization\<close>

context dense_linorder_ow
begin

tts_context
  tts: (?'a to U)
  rewriting ctr_simps
  substituting dense_linorder_ow_axioms
  eliminating through simp
begin

tts_lemma infinite_Icc:
  assumes "a \<in> U" and "b \<in> U" and "a <\<^sub>o\<^sub>w b"
  shows "infinite {a..\<^sub>o\<^sub>wb}"
    is dense_linorder_class.infinite_Icc.

tts_lemma infinite_Ico:
  assumes "a \<in> U" and "b \<in> U" and "a <\<^sub>o\<^sub>w b"
  shows "infinite (on U with (\<le>\<^sub>o\<^sub>w) (<\<^sub>o\<^sub>w) : {a..<b})"
    is dense_linorder_class.infinite_Ico.

tts_lemma infinite_Ioc:
  assumes "a \<in> U" and "b \<in> U" and "a <\<^sub>o\<^sub>w b"
  shows "infinite {a<\<^sub>o\<^sub>w..b}"
    is dense_linorder_class.infinite_Ioc.

tts_lemma infinite_Ioo:
  assumes "a \<in> U" and "b \<in> U" and "a <\<^sub>o\<^sub>w b"
  shows "infinite {a<\<^sub>o\<^sub>w..<\<^sub>o\<^sub>wb}"
    is dense_linorder_class.infinite_Ioo.

tts_lemma atLeastLessThan_subseteq_atLeastAtMost_iff:
  assumes "a \<in> U" and "b \<in> U" and "c \<in> U" and "d \<in> U"
  shows
    "((on U with (\<le>\<^sub>o\<^sub>w) (<\<^sub>o\<^sub>w) : {a..<b}) \<subseteq> {c..\<^sub>o\<^sub>wd}) =
      (a <\<^sub>o\<^sub>w b \<longrightarrow> b \<le>\<^sub>o\<^sub>w d \<and> c \<le>\<^sub>o\<^sub>w a)"
    is dense_linorder_class.atLeastLessThan_subseteq_atLeastAtMost_iff.

tts_lemma greaterThanAtMost_subseteq_atLeastAtMost_iff:
  assumes "a \<in> U" and "b \<in> U" and "c \<in> U" and "d \<in> U"
  shows "({a<\<^sub>o\<^sub>w..b} \<subseteq> {c..\<^sub>o\<^sub>wd}) = (a <\<^sub>o\<^sub>w b \<longrightarrow> b \<le>\<^sub>o\<^sub>w d \<and> c \<le>\<^sub>o\<^sub>w a)"
    is dense_linorder_class.greaterThanAtMost_subseteq_atLeastAtMost_iff.

tts_lemma greaterThanAtMost_subseteq_atLeastLessThan_iff:
  assumes "a \<in> U"
    and "b \<in> U"
    and "c \<in> U"
    and "d \<in> U"
  shows "({a<\<^sub>o\<^sub>w..b} \<subseteq> (on U with (\<le>\<^sub>o\<^sub>w) (<\<^sub>o\<^sub>w) : {c..<d})) =
    (a <\<^sub>o\<^sub>w b \<longrightarrow> b <\<^sub>o\<^sub>w d \<and> c \<le>\<^sub>o\<^sub>w a)"
    is dense_linorder_class.greaterThanAtMost_subseteq_atLeastLessThan_iff.

tts_lemma greaterThanLessThan_subseteq_atLeastAtMost_iff:
  assumes "a \<in> U" and "b \<in> U" and "c \<in> U" and "d \<in> U"
  shows "({a<\<^sub>o\<^sub>w..<\<^sub>o\<^sub>wb} \<subseteq> {c..\<^sub>o\<^sub>wd}) = (a <\<^sub>o\<^sub>w b \<longrightarrow> b \<le>\<^sub>o\<^sub>w d \<and> c \<le>\<^sub>o\<^sub>w a)"
    is dense_linorder_class.greaterThanLessThan_subseteq_atLeastAtMost_iff.

tts_lemma greaterThanLessThan_subseteq_atLeastLessThan_iff:
  assumes "a \<in> U" and "b \<in> U" and "c \<in> U" and "d \<in> U"
  shows
    "({a<\<^sub>o\<^sub>w..<\<^sub>o\<^sub>wb} \<subseteq> (on U with (\<le>\<^sub>o\<^sub>w) (<\<^sub>o\<^sub>w) : {c..<d})) =
      (a <\<^sub>o\<^sub>w b \<longrightarrow> b \<le>\<^sub>o\<^sub>w d \<and> c \<le>\<^sub>o\<^sub>w a)"
    is dense_linorder_class.greaterThanLessThan_subseteq_atLeastLessThan_iff.

tts_lemma greaterThanLessThan_subseteq_greaterThanAtMost_iff:
  assumes "a \<in> U" and "b \<in> U" and "c \<in> U" and "d \<in> U"
  shows "({a<\<^sub>o\<^sub>w..<\<^sub>o\<^sub>wb} \<subseteq> {c<\<^sub>o\<^sub>w..d}) = (a <\<^sub>o\<^sub>w b \<longrightarrow> b \<le>\<^sub>o\<^sub>w d \<and> c \<le>\<^sub>o\<^sub>w a)"
    is dense_linorder_class.greaterThanLessThan_subseteq_greaterThanAtMost_iff.

tts_lemma greaterThanLessThan_subseteq_greaterThanLessThan:
  assumes "a \<in> U" and "b \<in> U" and "c \<in> U" and "d \<in> U"
  shows "({a<\<^sub>o\<^sub>w..<\<^sub>o\<^sub>wb} \<subseteq> {c<\<^sub>o\<^sub>w..<\<^sub>o\<^sub>wd}) = (a <\<^sub>o\<^sub>w b \<longrightarrow> b \<le>\<^sub>o\<^sub>w d \<and> c \<le>\<^sub>o\<^sub>w a)"
    is dense_linorder_class.greaterThanLessThan_subseteq_greaterThanLessThan.

end

end

text\<open>\newpage\<close>

end