(*
  File:     Regexp_Constructions.thy
  Author:   Manuel Eberl <eberlm@in.tum.de>

  Some simple constructions on regular expressions to illustrate closure properties of regular
  languages: reversal, substitution, prefixes, suffixes, subwords ("fragments")
*)
section \<open>Basic constructions on regular expressions\<close>
theory Regexp_Constructions
imports
  Main
  "HOL-Library.Sublist"
  Regular_Exp
begin

subsection \<open>Reverse language\<close>

lemma rev_conc [simp]: "rev ` (A @@ B) = rev ` B @@ rev ` A"
  unfolding conc_def image_def by force

lemma rev_compower [simp]: "rev ` (A ^^ n) = (rev ` A) ^^ n"
  by (induction n) (simp_all add: conc_pow_comm)

lemma rev_star [simp]: "rev ` star A = star (rev ` A)"
  by (simp add: star_def image_UN)

subsection \<open>Substituting characters in a language\<close>

definition subst_word :: "('a \<Rightarrow> 'b list) \<Rightarrow> 'a list \<Rightarrow> 'b list" where
  "subst_word f xs = concat (map f xs)"

lemma subst_word_Nil [simp]: "subst_word f [] = []"
  by (simp add: subst_word_def)

lemma subst_word_singleton [simp]: "subst_word f [x] = f x"
  by (simp add: subst_word_def)

lemma subst_word_append [simp]: "subst_word f (xs @ ys) = subst_word f xs @ subst_word f ys"
  by (simp add: subst_word_def)

lemma subst_word_Cons [simp]: "subst_word f (x # xs) = f x @ subst_word f xs"
  by (simp add: subst_word_def)

lemma subst_word_conc [simp]: "subst_word f ` (A @@ B) = subst_word f ` A @@ subst_word f ` B"
  unfolding conc_def image_def by force

lemma subst_word_compower [simp]: "subst_word f ` (A ^^ n) = (subst_word f ` A) ^^ n"
  by (induction n) simp_all

lemma subst_word_star [simp]: "subst_word f ` (star A) = star (subst_word f ` A)"
  by (simp add: star_def image_UN)

text \<open>Suffix language\<close>

definition Suffixes :: "'a list set \<Rightarrow> 'a list set" where
  "Suffixes A = {w. \<exists>q. q @ w \<in> A}"

lemma Suffixes_altdef [code]: "Suffixes A = (\<Union>w\<in>A. set (suffixes w))"
  unfolding Suffixes_def set_suffixes_eq suffix_def by blast

lemma Suffixes_empty [simp]: "Suffixes {} = {}"
  by (auto simp: Suffixes_def)

lemma Suffixes_empty_iff [simp]: "Suffixes A = {} \<longleftrightarrow> A = {}"
  by (auto simp: Suffixes_altdef)

lemma Suffixes_singleton [simp]: "Suffixes {xs} = set (suffixes xs)"
  by (auto simp: Suffixes_altdef)

lemma Suffixes_insert: "Suffixes (insert xs A) = set (suffixes xs) \<union> Suffixes A"
  by (simp add: Suffixes_altdef)

lemma Suffixes_conc [simp]: "A \<noteq> {} \<Longrightarrow> Suffixes (A @@ B) = Suffixes B \<union> (Suffixes A @@ B)"
  unfolding Suffixes_altdef conc_def by (force simp: suffix_append)

lemma Suffixes_union [simp]: "Suffixes (A \<union> B) = Suffixes A \<union> Suffixes B"
  by (auto simp: Suffixes_def)

lemma Suffixes_UNION [simp]: "Suffixes (\<Union>(f ` A)) = \<Union>((\<lambda>x. Suffixes (f x)) ` A)"
  by (auto simp: Suffixes_def)

lemma Suffixes_compower:
  assumes "A \<noteq> {}"
  shows   "Suffixes (A ^^ n) = insert [] (Suffixes A @@ (\<Union>k<n. A ^^ k))"
proof (induction n)
  case (Suc n)
  from Suc have "Suffixes (A ^^ Suc n) =
                   insert [] (Suffixes A @@ ((\<Union>k<n. A ^^ k) \<union> A ^^ n))"
    by (simp_all add: assms conc_Un_distrib)
  also have "(\<Union>k<n. A ^^ k) \<union> A ^^ n = (\<Union>k\<in>insert n {..<n}. A ^^ k)"  by blast
  also have "insert n {..<n} = {..<Suc n}" by auto
  finally show ?case .
qed simp_all

lemma Suffixes_star [simp]:
  assumes "A \<noteq> {}"
  shows   "Suffixes (star A) = Suffixes A @@ star A"
proof -
  have "star A = (\<Union>n. A ^^ n)" unfolding star_def ..
  also have "Suffixes \<dots> = (\<Union>x. Suffixes (A ^^ x))" by simp
  also have "\<dots> = (\<Union>n. insert [] (Suffixes A @@ (\<Union>k<n. A ^^ k)))"
    using assms by (subst Suffixes_compower) auto
  also have "\<dots> = insert [] (Suffixes A @@ (\<Union>n. (\<Union>k<n. A ^^ k)))"
    by (simp_all add: conc_UNION_distrib)
  also have "(\<Union>n. (\<Union>k<n. A ^^ k)) = (\<Union>n. A ^^ n)" by auto
  also have "\<dots> = star A" unfolding star_def ..
  also have "insert [] (Suffixes A @@ star A) = Suffixes A @@ star A"
    using assms by auto
  finally show ?thesis .
qed

text \<open>Prefix language\<close>

definition Prefixes :: "'a list set \<Rightarrow> 'a list set" where
  "Prefixes A = {w. \<exists>q. w @ q \<in> A}"

lemma Prefixes_altdef [code]: "Prefixes A = (\<Union>w\<in>A. set (prefixes w))"
  unfolding Prefixes_def set_prefixes_eq prefix_def by blast

lemma Nil_in_Prefixes_iff [simp]: "[] \<in> Prefixes A \<longleftrightarrow> A \<noteq> {}"
  by (auto simp: Prefixes_def)

lemma Prefixes_conc [simp]: "B \<noteq> {} \<Longrightarrow> Prefixes (A @@ B) = Prefixes A \<union> (A @@ Prefixes B)"
  unfolding Prefixes_altdef conc_def by (force simp: prefix_append)

lemma Prefixes_union [simp]: "Prefixes (A \<union> B) = Prefixes A \<union> Prefixes B"
  by (auto simp: Prefixes_def)

lemma Prefixes_UNION [simp]: "Prefixes (\<Union>(f ` A)) = \<Union>((\<lambda>x. Prefixes (f x)) ` A)"
  by (auto simp: Prefixes_def)

lemma Prefixes_rev: "Prefixes (rev ` A) = rev ` Suffixes A"
  by (auto simp: Prefixes_altdef prefixes_rev Suffixes_altdef)

lemma Suffixes_rev: "Suffixes (rev ` A) = rev ` Prefixes A"
  by (auto simp: Prefixes_altdef suffixes_rev Suffixes_altdef)

lemma Prefixes_compower:
  assumes "A \<noteq> {}"
  shows   "Prefixes (A ^^ n) = insert [] ((\<Union>k<n. A ^^ k) @@ Prefixes A)"
proof -
  have "A ^^ n = rev ` ((rev ` A) ^^ n)" by (simp add: image_image)
  also have "Prefixes \<dots> = insert [] ((\<Union>k<n. A ^^ k) @@ Prefixes A)"
    unfolding Prefixes_rev
    by (subst Suffixes_compower) (simp_all add: image_UN image_image Suffixes_rev assms)
  finally show ?thesis .
qed

lemma Prefixes_star [simp]:
  assumes "A \<noteq> {}"
  shows   "Prefixes (star A) = star A @@ Prefixes A"
proof -
  have "star A = rev ` star (rev ` A)" by (simp add: image_image)
  also have "Prefixes \<dots> = star A @@ Prefixes A"
    unfolding Prefixes_rev
    by (subst Suffixes_star) (simp_all add: assms image_image Suffixes_rev)
  finally show ?thesis .
qed

subsection \<open>Subword language\<close>

text \<open>
  The language of all sub-words, i.e. all words that are a contiguous sublist of a word in
  the original language.
\<close>
definition Sublists :: "'a list set \<Rightarrow> 'a list set" where
  "Sublists A = {w. \<exists>q\<in>A. sublist w q}"

lemma Sublists_altdef [code]: "Sublists A = (\<Union>w\<in>A. set (sublists w))"
  by (auto simp: Sublists_def)

lemma Sublists_empty [simp]: "Sublists {} = {}"
  by (auto simp: Sublists_def)

lemma Sublists_singleton [simp]: "Sublists {w} = set (sublists w)"
  by (auto simp: Sublists_altdef)

lemma Sublists_insert: "Sublists (insert w A) = set (sublists w) \<union> Sublists A"
  by (auto simp: Sublists_altdef)

lemma Sublists_Un [simp]: "Sublists (A \<union> B) = Sublists A \<union> Sublists B"
  by (auto simp: Sublists_altdef)

lemma Sublists_UN [simp]: "Sublists (\<Union>(f ` A)) = \<Union>((\<lambda>x. Sublists (f x)) ` A)"
  by (auto simp: Sublists_altdef)

lemma Sublists_conv_Prefixes: "Sublists A = Prefixes (Suffixes A)"
  by (auto simp: Sublists_def Prefixes_def Suffixes_def sublist_def)

lemma Sublists_conv_Suffixes: "Sublists A = Suffixes (Prefixes A)"
  by (auto simp: Sublists_def Prefixes_def Suffixes_def sublist_def)

lemma Sublists_conc [simp]:
  assumes "A \<noteq> {}" "B \<noteq> {}"
  shows   "Sublists (A @@ B) = Sublists A \<union> Sublists B \<union> Suffixes A @@ Prefixes B"
  using assms unfolding Sublists_conv_Suffixes by auto

lemma star_not_empty [simp]: "star A \<noteq> {}"
  by auto

lemma Sublists_star:
  "A \<noteq> {} \<Longrightarrow> Sublists (star A) = Sublists A \<union> Suffixes A @@ star A @@ Prefixes A"
  by (simp add: Sublists_conv_Prefixes)

lemma Prefixes_subset_Sublists: "Prefixes A \<subseteq> Sublists A"
  unfolding Prefixes_def Sublists_def by auto

lemma Suffixes_subset_Sublists: "Suffixes A \<subseteq> Sublists A"
  unfolding Suffixes_def Sublists_def by auto

subsection \<open>Fragment language\<close>

text \<open>
  The following is the fragment language of a given language, i.e. the set of all words that
  are (not necessarily contiguous) sub-sequences of a word in the original language.
\<close>
definition Subseqs where "Subseqs A = (\<Union>w\<in>A. set (subseqs w))"

lemma Subseqs_empty [simp]: "Subseqs {} = {}"
  by (simp add: Subseqs_def)

lemma Subseqs_insert [simp]: "Subseqs (insert xs A) = set (subseqs xs) \<union> Subseqs A"
  by (simp add: Subseqs_def)

lemma Subseqs_singleton [simp]: "Subseqs {xs} = set (subseqs xs)"
  by simp

lemma Subseqs_Un [simp]: "Subseqs (A \<union> B) = Subseqs A \<union> Subseqs B"
  by (simp add: Subseqs_def)

lemma Subseqs_UNION [simp]: "Subseqs (\<Union>(f ` A)) = \<Union>((\<lambda>x. Subseqs (f x)) ` A)"
  by (simp add: Subseqs_def)

lemma Subseqs_conc [simp]: "Subseqs (A @@ B) = Subseqs A @@ Subseqs B"
proof safe
  fix xs assume "xs \<in> Subseqs (A @@ B)"
  then obtain ys zs where *: "ys \<in> A" "zs \<in> B" "subseq xs (ys @ zs)"
    by (auto simp: Subseqs_def conc_def)
  from *(3) obtain xs1 xs2 where "xs = xs1 @ xs2" "subseq xs1 ys" "subseq xs2 zs"
    by (rule subseq_appendE)
  with *(1,2) show "xs \<in> Subseqs A @@ Subseqs B" by (auto simp: Subseqs_def set_subseqs_eq)
next
  fix xs assume "xs \<in> Subseqs A @@ Subseqs B"
  then obtain xs1 xs2 ys zs
    where "xs = xs1 @ xs2" "subseq xs1 ys" "subseq xs2 zs" "ys \<in> A" "zs \<in> B"
    by (auto simp: conc_def Subseqs_def)
  thus "xs \<in> Subseqs (A @@ B)" by (force simp: Subseqs_def conc_def intro: list_emb_append_mono)
qed

lemma Subseqs_compower [simp]: "Subseqs (A ^^ n) = Subseqs A ^^ n"
  by (induction n) simp_all

lemma Subseqs_star [simp]: "Subseqs (star A) = star (Subseqs A)"
  by (simp add: star_def)

lemma Sublists_subset_Subseqs: "Sublists A \<subseteq> Subseqs A"
  by (auto simp: Sublists_def Subseqs_def dest!: sublist_imp_subseq)

subsection \<open>Various regular expression constructions\<close>

text \<open>A construction for language reversal of a regular expression:\<close>

primrec rexp_rev where
  "rexp_rev Zero = Zero"
| "rexp_rev One = One"
| "rexp_rev (Atom x) = Atom x"
| "rexp_rev (Plus r s) = Plus (rexp_rev r) (rexp_rev s)"
| "rexp_rev (Times r s) = Times (rexp_rev s) (rexp_rev r)"
| "rexp_rev (Star r) = Star (rexp_rev r)"

lemma lang_rexp_rev [simp]: "lang (rexp_rev r) = rev ` lang r"
  by (induction r) (simp_all add: image_Un)

text \<open>The obvious construction for a singleton-language regular expression:\<close>

fun rexp_of_word where
  "rexp_of_word [] = One"
| "rexp_of_word [x] = Atom x"
| "rexp_of_word (x#xs) = Times (Atom x) (rexp_of_word xs)"

lemma lang_rexp_of_word [simp]: "lang (rexp_of_word xs) = {xs}"
  by (induction xs rule: rexp_of_word.induct) (simp_all add: conc_def)

lemma size_rexp_of_word [simp]: "size (rexp_of_word xs) = Suc (2 * (length xs - 1))"
  by (induction xs rule: rexp_of_word.induct) auto

text \<open>Character substitution in a regular expression:\<close>

primrec rexp_subst where
  "rexp_subst f Zero = Zero"
| "rexp_subst f One = One"
| "rexp_subst f (Atom x) = rexp_of_word (f x)"
| "rexp_subst f (Plus r s) = Plus (rexp_subst f r) (rexp_subst f s)"
| "rexp_subst f (Times r s) = Times (rexp_subst f r) (rexp_subst f s)"
| "rexp_subst f (Star r) = Star (rexp_subst f r)"

lemma lang_rexp_subst: "lang (rexp_subst f r) = subst_word f ` lang r"
  by (induction r) (simp_all add: image_Un)

text \<open>Suffix language of a regular expression:\<close>

primrec suffix_rexp :: "'a rexp \<Rightarrow> 'a rexp" where
  "suffix_rexp Zero = Zero"
| "suffix_rexp One = One"
| "suffix_rexp (Atom a) = Plus (Atom a) One"
| "suffix_rexp (Plus r s) = Plus (suffix_rexp r) (suffix_rexp s)"
| "suffix_rexp (Times r s) =
    (if rexp_empty r then Zero else Plus (Times (suffix_rexp r) s) (suffix_rexp s))"
| "suffix_rexp (Star r) =
    (if rexp_empty r then One else Times (suffix_rexp r) (Star r))"

theorem lang_suffix_rexp [simp]:
  "lang (suffix_rexp r) = Suffixes (lang r)"
  by (induction r) (auto simp: rexp_empty_iff)

text \<open>Prefix language of a regular expression:\<close>

primrec prefix_rexp :: "'a rexp \<Rightarrow> 'a rexp" where
  "prefix_rexp Zero = Zero"
| "prefix_rexp One = One"
| "prefix_rexp (Atom a) = Plus (Atom a) One"
| "prefix_rexp (Plus r s) = Plus (prefix_rexp r) (prefix_rexp s)"
| "prefix_rexp (Times r s) =
    (if rexp_empty s then Zero else Plus (Times r (prefix_rexp s)) (prefix_rexp r))"
| "prefix_rexp (Star r) =
    (if rexp_empty r then One else Times (Star r) (prefix_rexp r))"

theorem lang_prefix_rexp [simp]:
  "lang (prefix_rexp r) = Prefixes (lang r)"
  by (induction r) (auto simp: rexp_empty_iff)

text \<open>Sub-word language of a regular expression\<close>

primrec sublist_rexp :: "'a rexp \<Rightarrow> 'a rexp" where
  "sublist_rexp Zero = Zero"
| "sublist_rexp One = One"
| "sublist_rexp (Atom a) = Plus (Atom a) One"
| "sublist_rexp (Plus r s) = Plus (sublist_rexp r) (sublist_rexp s)"
| "sublist_rexp (Times r s) =
    (if rexp_empty r \<or> rexp_empty s then Zero else
       Plus (sublist_rexp r) (Plus (sublist_rexp s) (Times (suffix_rexp r) (prefix_rexp s))))"
| "sublist_rexp (Star r) =
    (if rexp_empty r then One else
       Plus (sublist_rexp r) (Times (suffix_rexp r) (Times (Star r) (prefix_rexp r))))"

theorem lang_sublist_rexp [simp]:
  "lang (sublist_rexp r) = Sublists (lang r)"
  by (induction r) (auto simp: rexp_empty_iff Sublists_star)

text \<open>Fragment language of a regular expression:\<close>

primrec subseqs_rexp :: "'a rexp \<Rightarrow> 'a rexp" where
  "subseqs_rexp Zero = Zero"
| "subseqs_rexp One = One"
| "subseqs_rexp (Atom x) = Plus (Atom x) One"
| "subseqs_rexp (Plus r s) = Plus (subseqs_rexp r) (subseqs_rexp s)"
| "subseqs_rexp (Times r s) = Times (subseqs_rexp r) (subseqs_rexp s)"
| "subseqs_rexp (Star r) = Star (subseqs_rexp r)"

lemma lang_subseqs_rexp [simp]: "lang (subseqs_rexp r) = Subseqs (lang r)"
  by (induction r) auto

text \<open>Subword language of a regular expression\<close>

end


(*<*)
theory tmpl0arun7
  imports Main "HOL-Data_Structures.Sorting"
begin
(*>*)

hide_const (open) inv (*inv is used as a constant in isabelle, renaming it pretty prints the const
with the long name if the const is not hidden*)

text {* \ExerciseSheet{7}{25.~5.~2018} *}

text {* \Exercise{Interval Lists}

 Sets of natural numbers can be implemented as lists of intervals, where
an interval is simply a pair of numbers.  For example the set @{term "{2, 3, 5,
7, 8, 9::nat}"} can be represented by the list @{term "[(2, 3), (5, 5),
(7::nat, 9::nat)]"}.  A typical application is the list of free blocks of
dynamically allocated memory. *}

text {* We introduce the type *}

type_synonym intervals = "(nat*nat) list"

text {* Next, define an \emph{invariant}
that characterizes valid interval lists:
For efficiency reasons intervals should be sorted in ascending order, the lower
bound of each interval should be less than or equal to the upper bound, and the
intervals should be chosen as large as possible, i.e.\ no two adjacent
intervals should overlap or even touch each other.  It turns out to be
convenient to define @{term inv} in terms of a more general function
such that the additional argument is a lower bound for the intervals in
the list:*}

fun inv' :: "nat \<Rightarrow> intervals \<Rightarrow> bool" where
  "inv' n [] \<longleftrightarrow> True"|
  "inv' n ((a,b)#ivs) \<longleftrightarrow> n\<le>a \<and> a\<le>b \<and> inv' (b+2) ivs"

definition inv where "inv = inv' 0"

text {* To relate intervals back to sets define an \emph{abstraction function}*}

fun set_of :: "intervals => nat set"
where
  "set_of [] = {}"|
  "set_of ((a,b)#ivs) = {a..b} \<union> set_of ivs"
(*{a..<b} for non inclusive bound*)

text \<open>Define a function to add a single element to the interval list,
  and show its correctness\<close>

fun merge_aux where
  "merge_aux a b [] = [(a,b)]"|
  "merge_aux a b ((c,d)#ivs) = (if b+1 = c then (a,d)#ivs else (a,b)#(c,d)#ivs)"

fun add :: "nat \<Rightarrow> intervals \<Rightarrow> intervals"
  where
  "add i [] = [(i,i)]"|
(*i can be less than a, a-1, between a and b, b+1, greater than b. if b+1 might need to merge with next element too*)
  "add i ((a,b)#ivs) = (
    if i+1 < a then (i,i)#(a,b)#ivs
    else if i+1 = a then (i,b)#ivs
    else if i\<le>b then (a,b)#ivs
    else if i = b+1 then merge_aux a i ivs
    else (a,b)#add i ivs
)"

(* the (a,b)#add i ivs uses ivs which might cause infinite case splits on ivs when originally
the case split on ivs is done in the add function itself, therefore we write a different function for
the case splitting
 else if i = b+1 then case ivs of
      [] \<Rightarrow> [(a,i)]|
      (c,d)#ivs' \<Rightarrow> if i+1 = c then (a,d)#ivs' else (a,i)#ivs*)

lemma add_pres_inv': "n\<le>x \<Longrightarrow> inv' n itl \<Longrightarrow> inv' n (add x itl)"
  apply(induction itl arbitrary: n) (*arbitrary n as the value of n changes in the inv' function definition*)
   apply simp (*simp here keeps induction step as (add x (a #itl)) instead of (a,b) *)
  apply auto (*after this sledgehammer can solve this, auto case splits on products not on anything else,
              hence we need to case split on merge_aux*)
  apply (case_tac itl) (*case split by apply (case_tac itl) but it is unstable so don't use except to verify*)
  apply auto
  done

lemma add_pres_inv: "n\<le>x \<Longrightarrow> inv' n itl \<Longrightarrow> inv' n (add x itl)"
proof (induction itl arbitrary:n)
  case Nil
  then show ?case by auto
next
  case (Cons a itl)
  then show ?case
    apply (cases a)
    apply (cases itl)
    apply auto
    done
qed

lemma set_of_add:
  assumes "n\<le>x"
  assumes "inv' n itl"
  shows "set_of (add x itl) = {x} \<union> set_of itl"
  using assms
proof (induction itl arbitrary:n)
case Nil
  then show ?case by auto
next
  case (Cons a itl)
  then show ?case
    apply (cases a)
    apply (cases itl)
     apply (auto split: if_splits)  (*the apply auto without splitting on ifs shows 10 subcases where it shows all
                                      the if cases in each subcase split: if_splits/if_split_asm where asm is
                                      assumptions*)
    done
qed
(*not in ex but done in class*)
consts
  a :: "nat"
  b :: "nat set"
  c :: "nat set"

lemma A: "{a} \<union> b = c" sorry

lemma B: "{a} \<union> b \<union> d = c \<union> d"
  using A apply simp (*doing apply (simp add: A) will simplify it to insert a (b \<union> d) = c \<union> d *)
  done
(*not in ex*)
lemma add_correct:
  assumes "inv itl"
  shows "inv (add x itl)" "set_of (add x itl) = insert x (set_of itl)"
  using add_pres_inv' assms tmpl0arun7.inv_def apply fastforce
  using assms set_of_add tmpl0arun7.inv_def by fastforce

text \<open>Hints:
  \<^item> Sketch the different cases (position of element relative to the first interval of the list)
    on paper first
  \<^item> In one case, you will also need information about the second interval of the list.
    Do this case split via an auxiliary function! Otherwise, you may end up with a recursion equation of the form
      \<open>f (x#xs) = \<dots> case xs of x'#xs' \<Rightarrow> \<dots> f (x'#xs') \<dots>\<close>
    combined with \<open>split: list.splits\<close> this will make the simplifier loop!

\<close>

text \<open>\Exercise{Optimized Mergesort}

  Import @{theory "Sorting"} for this exercise.
  The @{const msort} function recomputes the length of the list in each iteration.
  Implement an optimized version that has an additional parameter keeping track
  of the length, and show that it is equal to the original @{const msort}.
\<close>

(* Optimized mergesort *)

fun msort2 :: "nat \<Rightarrow> 'a::linorder list \<Rightarrow> 'a list" where
  "msort2 n xs = (
    if n \<le> 1 then xs
    else merge (msort2 (n div 2) (take (n div 2) xs)) (msort2 (n - n div 2) (drop (n div 2) xs)))"

declare msort2.simps [simp del]

lemma "n = length xs \<Longrightarrow> msort2 n xs = msort xs"
proof (induction n xs rule:msort2.induct)
  case (1 n xs)
  then show ?case
    apply (auto simp: msort.simps[of xs] msort2.simps[of _ xs]) (*simplifier works innermost to out and  using
                                                                  substitutes instead*)
    done
qed

text \<open>Hint:
  Use @{thm [source] msort.simps} only when instantiated to a particular \<open>xs\<close>
  (@{thm [source] msort.simps[of xs]}),
  otherwise the simplifier will loop!
\<close>

text \<open> \NumHomework{Deletion from Interval Lists}{June 1}

  Implement and prove correct a delete function.

  Hints:
    \<^item> The correctness lemma is analogous to the one for add.
    \<^item> A monotonicity property on \<open>inv'\<close> may be useful, i.e.,
      @{prop \<open>inv' m is \<Longrightarrow> inv' m' is\<close>} if @{prop \<open>m'\<le>m\<close>}
    \<^item> A bounding lemma, relating \<open>m\<close> and the elements of @{term \<open>set_of is\<close>}
      if @{prop \<open>inv' m is\<close>}, may be useful.
\<close>

fun del :: "nat \<Rightarrow> intervals \<Rightarrow> intervals"
where
  "del _ _ = undefined"

lemma del_correct: "Come up with a meaningful spec yourself" oops

text \<open> \NumHomework{Addition of Interval to Interval List}{June 1}
  For 3 \<^bold>\<open>bonus points\<close>, implement and prove correct a function
  to add a whole interval to an interval list. The runtime must
  not depend on the size of the interval, e.g., iterating over the
  interval and adding the elements separately is not allowed!
\<close>

fun addi :: "nat \<Rightarrow> nat \<Rightarrow> intervals \<Rightarrow> intervals"
where
  "addi i j is = undefined"

lemma addi_correct:
  assumes "inv is" "i\<le>j"
  shows "inv (addi i j is)" "set_of (addi i j is) = {i..j} \<union> (set_of is)"
  sorry

(*<*)
end
(*>*)


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

section\<open>Least and Greatest Fixed Points; the Knaster-Tarski Theorem\<close>

theory Fixedpt imports equalities begin

definition
  (*monotone operator from Pow(D) to itself*)
  bnd_mono :: "[i,i\<Rightarrow>i]\<Rightarrow>o"  where
     "bnd_mono(D,h) \<equiv> h(D)<=D \<and> (\<forall>W X. W<=X \<longrightarrow> X<=D \<longrightarrow> h(W) \<subseteq> h(X))"

definition
  lfp      :: "[i,i\<Rightarrow>i]\<Rightarrow>i"  where
     "lfp(D,h) \<equiv> \<Inter>({X: Pow(D). h(X) \<subseteq> X})"

definition
  gfp      :: "[i,i\<Rightarrow>i]\<Rightarrow>i"  where
     "gfp(D,h) \<equiv> \<Union>({X: Pow(D). X \<subseteq> h(X)})"

text\<open>The theorem is proved in the lattice of subsets of \<^term>\<open>D\<close>,
      namely \<^term>\<open>Pow(D)\<close>, with Inter as the greatest lower bound.\<close>

subsection\<open>Monotone Operators\<close>

lemma bnd_monoI:
    "\<lbrakk>h(D)<=D;
        \<And>W X. \<lbrakk>W<=D;  X<=D;  W<=X\<rbrakk> \<Longrightarrow> h(W) \<subseteq> h(X)
\<rbrakk> \<Longrightarrow> bnd_mono(D,h)"
by (unfold bnd_mono_def, clarify, blast)

lemma bnd_monoD1: "bnd_mono(D,h) \<Longrightarrow> h(D) \<subseteq> D"
  unfolding bnd_mono_def
apply (erule conjunct1)
done

lemma bnd_monoD2: "\<lbrakk>bnd_mono(D,h);  W<=X;  X<=D\<rbrakk> \<Longrightarrow> h(W) \<subseteq> h(X)"
by (unfold bnd_mono_def, blast)

lemma bnd_mono_subset:
    "\<lbrakk>bnd_mono(D,h);  X<=D\<rbrakk> \<Longrightarrow> h(X) \<subseteq> D"
by (unfold bnd_mono_def, clarify, blast)

lemma bnd_mono_Un:
     "\<lbrakk>bnd_mono(D,h);  A \<subseteq> D;  B \<subseteq> D\<rbrakk> \<Longrightarrow> h(A) \<union> h(B) \<subseteq> h(A \<union> B)"
  unfolding bnd_mono_def
apply (rule Un_least, blast+)
done

(*unused*)
lemma bnd_mono_UN:
     "\<lbrakk>bnd_mono(D,h);  \<forall>i\<in>I. A(i) \<subseteq> D\<rbrakk>
      \<Longrightarrow> (\<Union>i\<in>I. h(A(i))) \<subseteq> h((\<Union>i\<in>I. A(i)))"
  unfolding bnd_mono_def
apply (rule UN_least)
apply (elim conjE)
apply (drule_tac x="A(i)" in spec)
apply (drule_tac x="(\<Union>i\<in>I. A(i))" in spec)
apply blast
done

(*Useful??*)
lemma bnd_mono_Int:
     "\<lbrakk>bnd_mono(D,h);  A \<subseteq> D;  B \<subseteq> D\<rbrakk> \<Longrightarrow> h(A \<inter> B) \<subseteq> h(A) \<inter> h(B)"
apply (rule Int_greatest)
apply (erule bnd_monoD2, rule Int_lower1, assumption)
apply (erule bnd_monoD2, rule Int_lower2, assumption)
done

subsection\<open>Proof of Knaster-Tarski Theorem using \<^term>\<open>lfp\<close>\<close>

(*lfp is contained in each pre-fixedpoint*)
lemma lfp_lowerbound:
    "\<lbrakk>h(A) \<subseteq> A;  A<=D\<rbrakk> \<Longrightarrow> lfp(D,h) \<subseteq> A"
by (unfold lfp_def, blast)

(*Unfolding the defn of Inter dispenses with the premise bnd_mono(D,h)!*)
lemma lfp_subset: "lfp(D,h) \<subseteq> D"
by (unfold lfp_def Inter_def, blast)

(*Used in datatype package*)
lemma def_lfp_subset:  "A \<equiv> lfp(D,h) \<Longrightarrow> A \<subseteq> D"
apply simp
apply (rule lfp_subset)
done

lemma lfp_greatest:
    "\<lbrakk>h(D) \<subseteq> D;  \<And>X. \<lbrakk>h(X) \<subseteq> X;  X<=D\<rbrakk> \<Longrightarrow> A<=X\<rbrakk> \<Longrightarrow> A \<subseteq> lfp(D,h)"
by (unfold lfp_def, blast)

lemma lfp_lemma1:
    "\<lbrakk>bnd_mono(D,h);  h(A)<=A;  A<=D\<rbrakk> \<Longrightarrow> h(lfp(D,h)) \<subseteq> A"
apply (erule bnd_monoD2 [THEN subset_trans])
apply (rule lfp_lowerbound, assumption+)
done

lemma lfp_lemma2: "bnd_mono(D,h) \<Longrightarrow> h(lfp(D,h)) \<subseteq> lfp(D,h)"
apply (rule bnd_monoD1 [THEN lfp_greatest])
apply (rule_tac [2] lfp_lemma1)
apply (assumption+)
done

lemma lfp_lemma3:
    "bnd_mono(D,h) \<Longrightarrow> lfp(D,h) \<subseteq> h(lfp(D,h))"
apply (rule lfp_lowerbound)
apply (rule bnd_monoD2, assumption)
apply (rule lfp_lemma2, assumption)
apply (erule_tac [2] bnd_mono_subset)
apply (rule lfp_subset)+
done

(*Definition form, to control unfolding*)
lemma def_lfp_unfold:
    "\<lbrakk>A\<equiv>lfp(D,h);  bnd_mono(D,h)\<rbrakk> \<Longrightarrow> A = h(A)"
apply simp
apply (erule lfp_unfold)
done

subsection\<open>General Induction Rule for Least Fixedpoints\<close>

lemma Collect_is_pre_fixedpt:
    "\<lbrakk>bnd_mono(D,h);  \<And>x. x \<in> h(Collect(lfp(D,h),P)) \<Longrightarrow> P(x)\<rbrakk>
     \<Longrightarrow> h(Collect(lfp(D,h),P)) \<subseteq> Collect(lfp(D,h),P)"
by (blast intro: lfp_lemma2 [THEN subsetD] bnd_monoD2 [THEN subsetD]
                 lfp_subset [THEN subsetD])

(*This rule yields an induction hypothesis in which the components of a
  data structure may be assumed to be elements of lfp(D,h)*)
lemma induct:
    "\<lbrakk>bnd_mono(D,h);  a \<in> lfp(D,h);
        \<And>x. x \<in> h(Collect(lfp(D,h),P)) \<Longrightarrow> P(x)
\<rbrakk> \<Longrightarrow> P(a)"
apply (rule Collect_is_pre_fixedpt
              [THEN lfp_lowerbound, THEN subsetD, THEN CollectD2])
apply (rule_tac [3] lfp_subset [THEN Collect_subset [THEN subset_trans]],
       blast+)
done

(*Definition form, to control unfolding*)
lemma def_induct:
    "\<lbrakk>A \<equiv> lfp(D,h);  bnd_mono(D,h);  a:A;
        \<And>x. x \<in> h(Collect(A,P)) \<Longrightarrow> P(x)
\<rbrakk> \<Longrightarrow> P(a)"
by (rule induct, blast+)

(*This version is useful when "A" is not a subset of D
  second premise could simply be h(D \<inter> A) \<subseteq> D or \<And>X. X<=D \<Longrightarrow> h(X)<=D *)
lemma lfp_Int_lowerbound:
    "\<lbrakk>h(D \<inter> A) \<subseteq> A;  bnd_mono(D,h)\<rbrakk> \<Longrightarrow> lfp(D,h) \<subseteq> A"
apply (rule lfp_lowerbound [THEN subset_trans])
apply (erule bnd_mono_subset [THEN Int_greatest], blast+)
done

(*Monotonicity of lfp, where h precedes i under a domain-like partial order
  monotonicity of h is not strictly necessary; h must be bounded by D*)
lemma lfp_mono:
  assumes hmono: "bnd_mono(D,h)"
      and imono: "bnd_mono(E,i)"
      and subhi: "\<And>X. X<=D \<Longrightarrow> h(X) \<subseteq> i(X)"
    shows "lfp(D,h) \<subseteq> lfp(E,i)"
apply (rule bnd_monoD1 [THEN lfp_greatest])
apply (rule imono)
apply (rule hmono [THEN [2] lfp_Int_lowerbound])
apply (rule Int_lower1 [THEN subhi, THEN subset_trans])
apply (rule imono [THEN bnd_monoD2, THEN subset_trans], auto)
done

(*This (unused) version illustrates that monotonicity is not really needed,
  but both lfp's must be over the SAME set D;  Inter is anti-monotonic!*)
lemma lfp_mono2:
    "\<lbrakk>i(D) \<subseteq> D;  \<And>X. X<=D \<Longrightarrow> h(X) \<subseteq> i(X)\<rbrakk> \<Longrightarrow> lfp(D,h) \<subseteq> lfp(D,i)"
apply (rule lfp_greatest, assumption)
apply (rule lfp_lowerbound, blast, assumption)
done

lemma lfp_cong:
     "\<lbrakk>D=D'; \<And>X. X \<subseteq> D' \<Longrightarrow> h(X) = h'(X)\<rbrakk> \<Longrightarrow> lfp(D,h) = lfp(D',h')"
apply (simp add: lfp_def)
apply (rule_tac t=Inter in subst_context)
apply (rule Collect_cong, simp_all)
done

subsection\<open>Proof of Knaster-Tarski Theorem using \<^term>\<open>gfp\<close>\<close>

(*gfp contains each post-fixedpoint that is contained in D*)
lemma gfp_upperbound: "\<lbrakk>A \<subseteq> h(A);  A<=D\<rbrakk> \<Longrightarrow> A \<subseteq> gfp(D,h)"
  unfolding gfp_def
apply (rule PowI [THEN CollectI, THEN Union_upper])
apply (assumption+)
done

lemma gfp_subset: "gfp(D,h) \<subseteq> D"
by (unfold gfp_def, blast)

(*Used in datatype package*)
lemma def_gfp_subset: "A\<equiv>gfp(D,h) \<Longrightarrow> A \<subseteq> D"
apply simp
apply (rule gfp_subset)
done

lemma gfp_least:
    "\<lbrakk>bnd_mono(D,h);  \<And>X. \<lbrakk>X \<subseteq> h(X);  X<=D\<rbrakk> \<Longrightarrow> X<=A\<rbrakk> \<Longrightarrow>
     gfp(D,h) \<subseteq> A"
  unfolding gfp_def
apply (blast dest: bnd_monoD1)
done

lemma gfp_lemma1:
    "\<lbrakk>bnd_mono(D,h);  A<=h(A);  A<=D\<rbrakk> \<Longrightarrow> A \<subseteq> h(gfp(D,h))"
apply (rule subset_trans, assumption)
apply (erule bnd_monoD2)
apply (rule_tac [2] gfp_subset)
apply (simp add: gfp_upperbound)
done

lemma gfp_lemma2: "bnd_mono(D,h) \<Longrightarrow> gfp(D,h) \<subseteq> h(gfp(D,h))"
apply (rule gfp_least)
apply (rule_tac [2] gfp_lemma1)
apply (assumption+)
done

lemma gfp_lemma3:
    "bnd_mono(D,h) \<Longrightarrow> h(gfp(D,h)) \<subseteq> gfp(D,h)"
apply (rule gfp_upperbound)
apply (rule bnd_monoD2, assumption)
apply (rule gfp_lemma2, assumption)
apply (erule bnd_mono_subset, rule gfp_subset)+
done

lemma gfp_unfold: "bnd_mono(D,h) \<Longrightarrow> gfp(D,h) = h(gfp(D,h))"
apply (rule equalityI)
apply (erule gfp_lemma2)
apply (erule gfp_lemma3)
done

(*Definition form, to control unfolding*)
lemma def_gfp_unfold:
    "\<lbrakk>A\<equiv>gfp(D,h);  bnd_mono(D,h)\<rbrakk> \<Longrightarrow> A = h(A)"
apply simp
apply (erule gfp_unfold)
done

subsection\<open>Coinduction Rules for Greatest Fixed Points\<close>

(*weak version*)
lemma weak_coinduct: "\<lbrakk>a: X;  X \<subseteq> h(X);  X \<subseteq> D\<rbrakk> \<Longrightarrow> a \<in> gfp(D,h)"
by (blast intro: gfp_upperbound [THEN subsetD])

lemma coinduct_lemma:
    "\<lbrakk>X \<subseteq> h(X \<union> gfp(D,h));  X \<subseteq> D;  bnd_mono(D,h)\<rbrakk> \<Longrightarrow>
     X \<union> gfp(D,h) \<subseteq> h(X \<union> gfp(D,h))"
apply (erule Un_least)
apply (rule gfp_lemma2 [THEN subset_trans], assumption)
apply (rule Un_upper2 [THEN subset_trans])
apply (rule bnd_mono_Un, assumption+)
apply (rule gfp_subset)
done

(*strong version*)
lemma coinduct:
     "\<lbrakk>bnd_mono(D,h);  a: X;  X \<subseteq> h(X \<union> gfp(D,h));  X \<subseteq> D\<rbrakk>
      \<Longrightarrow> a \<in> gfp(D,h)"
apply (rule weak_coinduct)
apply (erule_tac [2] coinduct_lemma)
apply (simp_all add: gfp_subset Un_subset_iff)
done

(*Definition form, to control unfolding*)
lemma def_coinduct:
    "\<lbrakk>A \<equiv> gfp(D,h);  bnd_mono(D,h);  a: X;  X \<subseteq> h(X \<union> A);  X \<subseteq> D\<rbrakk> \<Longrightarrow>
     a \<in> A"
apply simp
apply (rule coinduct, assumption+)
done

(*The version used in the induction/coinduction package*)
lemma def_Collect_coinduct:
    "\<lbrakk>A \<equiv> gfp(D, \<lambda>w. Collect(D,P(w)));  bnd_mono(D, \<lambda>w. Collect(D,P(w)));
        a: X;  X \<subseteq> D;  \<And>z. z: X \<Longrightarrow> P(X \<union> A, z)\<rbrakk> \<Longrightarrow>
     a \<in> A"
apply (rule def_coinduct, assumption+, blast+)
done

(*Monotonicity of gfp!*)
lemma gfp_mono:
    "\<lbrakk>bnd_mono(D,h);  D \<subseteq> E;
        \<And>X. X<=D \<Longrightarrow> h(X) \<subseteq> i(X)\<rbrakk> \<Longrightarrow> gfp(D,h) \<subseteq> gfp(E,i)"
apply (rule gfp_upperbound)
apply (rule gfp_lemma2 [THEN subset_trans], assumption)
apply (blast del: subsetI intro: gfp_subset)
apply (blast del: subsetI intro: subset_trans gfp_subset)
done

end


section \<open>Function \textit{isin} for Search_Tree2\<close>

theory Isin2
imports
  Search_Tree2
  Cmp
  Set_Specs
begin

fun isin :: "('a::linorder*'b) search_tree \<Rightarrow> 'a \<Rightarrow> bool" where
"isin Leaf x = False" |
"isin (Node l (a,_) r) x =
  (case cmp x a of
     LT \<Rightarrow> isin l x |
     EQ \<Rightarrow> True |
     GT \<Rightarrow> isin r x)"

lemma isin_set_inorder: "sorted(inorder t) \<Longrightarrow> isin t x = (x \<in> set(inorder t))"
by (induction t rule: search_tree2_induct) (auto simp: isin_simps)

lemma isin_set_tree: "bst t \<Longrightarrow> isin t x \<longleftrightarrow> x \<in> set_search_tree t"
by(induction t rule: search_tree2_induct) auto

end


theory Counting_Tiles
  imports
    "HOL-Library.Code_Target_Numeral"
    "HOL-Library.Product_Lexorder"
    "HOL-Library.RBT_Mapping"
    "../state_monad/State_Main"
    Example_Misc
begin

subsection \<open>A Counting Problem\<close>

text \<open>
  This formalization contains verified solutions for Project Euler problems
    \<^item> \<open>#\<close>114 (\<^url>\<open>https://projecteuler.net/problem=114\<close>) and
    \<^item> \<open>#\<close>115 (\<^url>\<open>https://projecteuler.net/problem=115\<close>).

  This is the problem description for \<open>#\<close>115:
  \begin{quote}
  A row measuring n units in length has red blocks with a minimum length of m units placed on it,
  such that any two red blocks (which are allowed to be different lengths) are separated
  by at least one black square.
  Let the fill-count function, F(m, n), represent the number of ways that a row can be filled.

  For example, F(3, 29) = 673135 and F(3, 30) = 1089155.

  That is, for m = 3, it can be seen that n = 30 is the smallest value for which the fill-count
  function first exceeds one million.
  In the same way, for m = 10, it can be verified that F(10, 56) = 880711 and F(10, 57) = 1148904,
  so n = 57 is the least value for which the fill-count function first exceeds one million.

  For m = 50, find the least value of n for which the fill-count function first exceeds one million.
  \end{quote}
\<close>

subsubsection \<open>Misc\<close>

(* Duplicate from Refine_Misc with slightly nicer proof *)

(* Duplicate from Refine_Misc *)
lemma disjE1:
  "A \<or> B \<Longrightarrow> (A \<Longrightarrow> P) \<Longrightarrow> (\<not> A \<Longrightarrow> B \<Longrightarrow> P) \<Longrightarrow> P"
  by metis

subsubsection \<open>Problem Specification\<close>

text \<open>Colors\<close>

datatype color = R | B

text \<open>Direct natural definition of a valid line\<close>

context
  fixes m :: nat
begin

inductive valid where
  "valid []" |
  "valid xs \<Longrightarrow> valid (B # xs)" |
  "valid xs \<Longrightarrow> n \<ge> m \<Longrightarrow> valid (replicate n R @ xs)"

text \<open>Definition of the fill-count function\<close>

definition "F n = card {l. length l = n \<and> valid l}"

subsubsection \<open>Combinatorial Identities\<close>

text \<open>This alternative variant helps us to prove the split lemma below.\<close>
inductive valid' where
  "valid' []" |
  "n \<ge> m \<Longrightarrow> valid' (replicate n R)" |
  "valid' xs \<Longrightarrow> valid' (B # xs)" |
  "valid' xs \<Longrightarrow> n \<ge> m \<Longrightarrow> valid' (replicate n R @ B # xs)"

lemma valid_valid':
  "valid l \<Longrightarrow> valid' l"
  by (induction rule: valid.induct)
     (auto 4 4 intro: valid'.intros elim: valid'.cases
       simp: replicate_add[symmetric] append_assoc[symmetric]
     )

lemmas valid_red = valid.intros(3)[OF valid.intros(1), simplified]

lemma valid'_valid:
  "valid' l \<Longrightarrow> valid l"
  by (induction rule: valid'.induct) (auto intro: valid.intros valid_red)

lemma valid_eq_valid':
  "valid' l = valid l"
  using valid_valid' valid'_valid by metis

text \<open>Additional Facts on Replicate\<close>

lemma replicate_iff:
  "(\<forall>i<length l. l ! i = R) \<longleftrightarrow> (\<exists> n. l = replicate n R)"
  by auto (metis (full_types) in_set_conv_nth replicate_eqI)

lemma replicate_iff2:
  "(\<forall>i<n. l ! i = R) \<longleftrightarrow> (\<exists> l'. l = replicate n R @ l')" if "n < length l"
  using that by (auto simp: list_eq_iff_nth_eq nth_append intro: exI[where x = "drop n l"])

lemma replicate_Cons_eq:
  "replicate n x = y # ys \<longleftrightarrow> (\<exists> n'. n = Suc n' \<and> x = y \<and> replicate n' x = ys)"
  by (cases n) auto

text \<open>Main Case Analysis on \<open>@term valid\<close>\<close>

lemma valid_split:
  "valid l \<longleftrightarrow>
    l = [] \<or>
    (l!0 = B \<and> valid (tl l)) \<or>
    length l \<ge> m \<and> (\<forall> i < length l. l ! i = R) \<or>
    (\<exists> j < length l. j \<ge> m \<and> (\<forall> i < j. l ! i = R) \<and> l ! j = B \<and> valid (drop (j + 1) l))"
  unfolding valid_eq_valid'[symmetric]
  apply standard
  subgoal
    by (erule valid'.cases) (auto simp: nth_append nth_Cons split: nat.splits)
  subgoal
    apply (auto intro: valid'.intros simp: replicate_iff elim!: disjE1)
      apply (fastforce intro: valid'.intros simp: neq_Nil_conv)
     apply (subst (asm) replicate_iff2; fastforce intro: valid'.intros simp: neq_Nil_conv nth_append)+
    done
  done

text \<open>Base cases\<close>

lemma valid_line_just_B:
  "valid (replicate n B)"
  by (induction n) (auto intro: valid.intros)

lemma F_base_0_aux:
  "{l. l = [] \<and> valid l} = {[]}"
  by (auto intro: valid.intros)

lemma F_base_0: "F 0 = 1"
  by (auto simp: F_base_0_aux F_def)

lemma F_base_aux: "{l. length l=n \<and> valid l} = {replicate n B}" if "n > 0" "n < m"
  using that
proof (induction n)
  case 0
  then show ?case
    by simp
next
  case (Suc n)
  show ?case
  proof (cases "n = 0")
    case True
    with Suc.prems show ?thesis
      by (auto intro: valid.intros elim: valid.cases)
  next
    case False
    with Suc.prems show ?thesis
      apply safe
      using Suc.IH
        apply -
        apply (erule valid.cases)
          apply (auto intro: valid.intros elim: valid.cases)
      done
  qed
qed

lemma F_base_1:
  "F n = 1" if "n > 0" "n < m"
  using that unfolding F_def by (simp add: F_base_aux)

lemma valid_m_Rs [simp]:
  "valid (replicate m R)"
  using valid_red[of m, simplified] by simp

lemma F_base_aux_2: "{l. length l=m \<and> valid l} = {replicate m R, replicate m B}"
  apply (auto simp: valid_line_just_B)
  apply (erule Counting_Tiles.valid.cases)
    apply auto
  subgoal for xs
    using F_base_aux[of "length xs"] by (cases "xs = []") auto
  done

lemma F_base_2:
  "F m = 2" if "0 < m"
  using that unfolding F_def by (simp add: F_base_aux_2)

text \<open>The recursion case\<close>

lemma finite_valid_length:
  "finite {l. length l = n \<and> valid l}" (is "finite ?S")
proof -
  have "?S \<subseteq> lists {R, B} \<inter> {l. length l = n}"
    by (auto intro: color.exhaust)
  moreover have "finite \<dots>"
    by (auto intro: lists_of_len_fin1)
  ultimately show ?thesis
    by (rule finite_subset)
qed

lemma valid_line_aux:
  "{l. length l = n \<and> valid l} \<noteq> {}" (is "?S \<noteq> {}")
  using valid_line_just_B[of n] by force

lemma replicate_unequal_aux:
  "replicate x R @ B # l \<noteq> replicate y R @ B # l'" (is "?l \<noteq> ?r") if \<open>x < y\<close> for l l'
proof -
  have "?l ! x = B" "?r ! x = R"
    using that by (auto simp: nth_append)
  then show ?thesis
    by auto
qed

lemma valid_prepend_B_iff:
  "valid (B # xs) \<longleftrightarrow> valid xs" if "m > 0"
  using that
  by (auto 4 3 intro: valid.intros elim: valid.cases simp: Cons_replicate_eq Cons_eq_append_conv)

lemma F_rec: "F n = F (n-1) + 1 + (\<Sum>i=m..<n. F (n-i-1))" if \<open>n>m\<close> "m > 0"
proof -
  have "{l. length l = n \<and> valid l}
          = {l. length l = n \<and> valid (tl l) \<and> l!0=B}
          \<union> {l. length l = n \<and>
              (\<exists> i. i < n \<and> i \<ge> m \<and> (\<forall> k < i. l!k = R) \<and> l!i = B \<and> valid (drop (i + 1) l))}
          \<union> {l. length l = n \<and> (\<forall>i<n. l!i=R)}
          " (is "?A = ?B \<union> ?D \<union> ?C")
    using \<open>n > m\<close> by (subst valid_split) auto

  let ?B1 = "((#) B) ` {l. length l = n - Suc 0 \<and> valid l}"
  from \<open>n > m\<close> have "?B = ?B1"
    apply safe
    subgoal for l
      by (cases l) (auto simp: valid_prepend_B_iff)
    by auto
  have 1: "card ?B1 = F (n-1)"
    unfolding F_def by (auto intro: card_image)

  have "?C = {replicate n R}"
    by (auto simp: nth_equalityI)
  have 2: "card {replicate n R} = 1"
    by auto

  let ?D1="(\<Union> i \<in> {m..<n}. (\<lambda> l. replicate i R @ B # l)` {l. length l = n - i - 1 \<and> valid l})"
  have "?D =
        (\<Union>i \<in> {m..<n}. {l. length l = n \<and> (\<forall> k < i. l!k = R) \<and> l!i = B \<and> valid (drop (i + 1) l)})"
    by auto
  have "{l. length l = n \<and> (\<forall> k < i. l!k = R) \<and> l!i = B \<and> valid (drop (i + 1) l)}
              = (\<lambda> l. replicate i R @ B # l)` {l. length l = n - i - 1 \<and> valid l}"
    if "i < n" for i
    apply safe
    subgoal for l
      apply (rule image_eqI[where x = "drop (i + 1) l"])
       apply (rule nth_equalityI)
      using that
        apply (simp_all split: nat.split add: nth_Cons nth_append)
      using add_diff_inverse_nat apply fastforce
      done
    using that by (simp add: nth_append; fail)+

  then have D_eq: "?D = ?D1"
    unfolding \<open>?D = _\<close> by auto

  have inj: "inj_on (\<lambda>l. replicate x R @ B # l) {l. length l = n - Suc x \<and> valid l}" for x
    unfolding inj_on_def by auto

  have *:
    "(\<lambda>l. replicate x R @ B # l) ` {l. length l = n - Suc x \<and> valid l} \<inter>
         (\<lambda>l. replicate y R @ B # l) ` {l. length l = n - Suc y \<and> valid l} = {}"
    if "m \<le> x" "x < y" "y < n" for x y
    using that replicate_unequal_aux[OF \<open>x < y\<close>] by auto

  have 3: "card ?D1 = (\<Sum>i=m..<n. F (n-i-1))"
  proof (subst card_Union_disjoint, goal_cases)
    case 1
    show ?case
      unfolding pairwise_def disjnt_def
    proof (clarsimp, goal_cases)
      case prems: (1 x y)
      from prems show ?case
        apply -
        apply (rule linorder_cases[of x y])
          apply (rule *; assumption)
         apply (simp; fail)
        apply (subst Int_commute; rule *; assumption)
        done
    qed
  next
    case 3
    show ?case
    proof (subst sum.reindex, unfold inj_on_def, clarsimp, goal_cases)
      case prems: (1 x y)
      with *[of y x] *[of x y] valid_line_aux[of "n - Suc x"] show ?case
        by - (rule linorder_cases[of x y], auto)
    next
      case 2
      then show ?case
        by (simp add: F_def card_image[OF inj])
    qed
  qed (auto intro: finite_subset[OF _ finite_valid_length])

  show ?thesis
    apply (subst F_def)
    unfolding \<open>?A = _\<close> \<open>?B = _\<close> \<open>?C = _\<close> D_eq
    apply (subst card_Un_disjoint)
      (* Finiteness *)
       apply (blast intro: finite_subset[OF _ finite_valid_length])+
      (* Disjointness *)
    subgoal
      using Cons_replicate_eq[of B _ n R] replicate_unequal_aux by fastforce
    apply (subst card_Un_disjoint)
      (* Finiteness *)
       apply (blast intro: finite_subset[OF _ finite_valid_length])+
      (* Disjointness & final rewriting *)
    unfolding 1 2 3 using \<open>m > 0\<close> by (auto simp: Cons_replicate_eq Cons_eq_append_conv)
qed

subsubsection \<open>Computing the Fill-Count Function\<close>

fun lcount :: "nat \<Rightarrow> nat" where
  "lcount n = (
    if n < m then 1
    else if n = m then 2
    else lcount (n - 1) + 1 + (\<Sum>i \<leftarrow> [m..<n]. lcount (n - i - 1))
  )"

lemmas [simp del] = lcount.simps

lemma lcount_correct:
  "lcount n = F n" if "m > 0"
proof (induction n rule: less_induct)
  case (less n)
  from \<open>m > 0\<close> show ?case
    apply (cases "n = 0")
    subgoal
      by (simp add: lcount.simps F_base_0)
    by (subst lcount.simps)
      (simp add: less.IH F_base_1 F_base_2 F_rec interv_sum_list_conv_sum_set_nat)
qed

subsubsection \<open>Memoization\<close>

memoize_fun lcount\<^sub>m: lcount with_memory dp_consistency_mapping monadifies (state) lcount.simps

memoize_correct
  by memoize_prover

lemmas [code] = lcount\<^sub>m.memoized_correct

end (* Fixed block size *)

subsubsection \<open>Problem solutions\<close>

text \<open>Example and solution for problem \<open>#\<close>114\<close>
value "lcount 3 7"
value "lcount 3 50"

text \<open>Examples for problem \<open>#\<close>115\<close>
value "lcount 3 29"
value "lcount 3 30"
value "lcount 10 56"
value "lcount 10 57"

text \<open>Binary search for the solution of problem \<open>#\<close>115\<close>
value "lcount 50 100"
value "lcount 50 150"
value "lcount 50 163"
value "lcount 50 166"
value "lcount 50 167"
value "lcount 50 168" \<comment> \<open>The solution\<close>
value "lcount 50 169"
value "lcount 50 175"
value "lcount 50 200"
value "lcount 50 300"
value "lcount 50 500"
value "lcount 50 1000"

text \<open>We prove that 168 is the solution for problem \<open>#\<close>115\<close>
theorem
  "(LEAST n. F 50 n > 1000000) = 168"
proof -
  have "lcount 50 168 > 1000000"
    by eval
  moreover have "\<forall> n \<in> {0..<168}. lcount 50 n < 1000000"
    by eval
  ultimately show ?thesis
    by - (rule Least_equality; rule ccontr; force simp: not_le lcount_correct)
qed

end


theory Ch2
imports Complex_Main
begin

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

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

theorem add_assoc [simp]: "add a (add b c) = add (add a b) c"
  apply(induction a)
  apply(auto)
done

lemma add_n_0 [simp]: "add n 0 = n"
  apply(induction n)
  apply(auto)
done

lemma add_n_suc [simp]: "add n (Suc m) = Suc (add n m)"
  apply(induction n)
  apply(auto)
done

theorem add_comm [simp]: "add a b = add b a"
  apply(induction a)
  apply(auto)
done

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

theorem double_add [simp]: "double n = n + n"
  apply(induction n)
  apply(auto)
done

(* 2.3 *)
fun count :: "'a \<Rightarrow> 'a list \<Rightarrow> nat" where
  "count x [] = 0" |
  "count x (y # ys) = (if x = y then 1 else 0) + count x ys"

theorem count_lt_length [simp]: "count x xs \<le> length xs"
  apply(induction xs)
  apply(auto)
done

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

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

lemma reverse_snoc [simp]: "reverse (snoc xs a) = a # reverse xs"
  apply(induction xs)
  apply(auto)
done

theorem reverse_reverse [simp]: "reverse (reverse xs) = xs"
  apply(induction xs)
  apply(auto)
done

(* 2.5 *)
fun sum_upto :: "nat \<Rightarrow> nat" where
  "sum_upto 0 = 0" |
  "sum_upto n = n + sum_upto (n - 1)"

theorem sum_upto_nn1d2 [simp]: "sum_upto n = n * (n + 1) div 2"
  apply(induction n)
  apply(auto)
done

(* 2.6 *)
datatype 'a tree = Tip | Node  "'a tree"  'a  "'a tree"

fun mirror :: "'a tree \<Rightarrow> 'a tree" where
  "mirror Tip = Tip" |
  "mirror (Node l a r ) = Node (mirror r ) a (mirror l)"

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

fun sum_tree :: "nat tree \<Rightarrow> nat" where
  "sum_tree Tip = 0" |
  "sum_tree (Node l x r) = x + sum_tree l + sum_tree r"

theorem sum_tree_sum_list_contents [simp]: "sum_tree t = sum_list (contents t)"
  apply(induction t)
  apply(auto)
done

(* 2.7 *)
fun pre_order :: "'a tree \<Rightarrow> 'a list" where
  "pre_order Tip = []" |
  "pre_order (Node l x r) = x # pre_order l @ pre_order r"

fun post_order :: "'a tree \<Rightarrow> 'a list" where
  "post_order Tip = []" |
  "post_order (Node l x r) = post_order l @ post_order r @ [x]"

theorem pre_order_rev_post_order [simp]: "pre_order (mirror t) = rev (post_order t)"
  apply(induction t)
  apply(auto)
done

(* 2.8 *)
fun intersperse :: "'a \<Rightarrow> 'a list \<Rightarrow> 'a list" where
  "intersperse a [] = []" |
  "intersperse a [x] = [x]" |
  "intersperse a (x1 # x2 # xs) = x1 # a # intersperse a (x2 # xs)"

theorem map_intersperse_intersperse_map [simp]:
    "map f (intersperse a xs) = intersperse (f a) (map f xs)"
  apply(induction xs rule: intersperse.induct)
  apply(auto)
done

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

theorem itadd_add [simp]: "itadd m n = add m n"
  apply(induction m arbitrary: n)
  apply(auto)
done

(* 2.10 *)
datatype tree0 = Tip | Node tree0 tree0

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

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

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

(* 2.11 *)
datatype exp = Var | Const int | Add exp exp | Mult exp exp

fun eval :: "exp \<Rightarrow> int \<Rightarrow> int" where
  "eval Var v = v" |
  "eval (Const c) _ = c" |
  "eval (Add e1 e2) v = eval e1 v + eval e2 v" |
  "eval (Mult e1 e2) v = eval e1 v * eval e2 v"

fun evalp :: "int list \<Rightarrow> int \<Rightarrow> int" where
  "evalp [] v = 0" |
  "evalp (x # xs) v = x + v * evalp xs v"

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

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

fun multp :: "int list \<Rightarrow> int list \<Rightarrow> int list" where
  "multp [] _ = []" |
  "multp _ [] = []" |
  "multp (x # xs) ys = addp (mults x ys) (0 # multp xs ys)"

fun coeffs :: "exp \<Rightarrow> int list" where
  "coeffs Var = [0, 1]" |
  "coeffs (Const c) = [c]" |
  "coeffs (Add e1 e2) = addp (coeffs e1) (coeffs e2)" |
  "coeffs (Mult e1 e2) = multp (coeffs e1) (coeffs e2)"

lemma evalp_addp [simp]: "evalp (addp xs ys) v = evalp xs v + evalp ys v"
  apply(induction xs ys rule: addp.induct)
  apply(auto simp add: algebra_simps)
done

lemma addp_nil [simp]: "addp xs [] = xs"
  apply(induction xs)
  apply(auto)
done

lemma multp_mults [simp]: "multp [x] ys = mults x ys"
  apply(induction ys)
  apply(auto simp add: algebra_simps)
done

lemma evalp_mults [simp]: "evalp (mults x ys) v = x * evalp ys v"
  apply(induction ys)
  apply(auto simp add: algebra_simps)
done

lemma evalp_multp_cons [simp]: "evalp (multp (x # xs) ys) v = x * evalp ys v + v * evalp (multp xs ys) v"
  apply(induction xs ys rule: multp.induct)
  apply(auto simp add: algebra_simps)
done

lemma evalp_multp [simp]: "evalp (multp xs ys) v = evalp xs v * evalp ys v"
  apply(induction xs arbitrary: ys)
  apply(auto simp add: algebra_simps)
done

theorem evalp_coeffs [simp]: "evalp (coeffs e) x = eval e x"
  apply(induction e rule: coeffs.induct)
  apply(auto simp add: algebra_simps)
done

end


theory General_Operations
  imports "HOL-Analysis.Sigma_Algebra"
begin

section "Basics from Measure Theory"

subsection "Sets"

subsubsection "Set Operations"

definition disjoint :: "'a set \<Rightarrow> 'a set \<Rightarrow> bool"
  where "disjoint A B \<equiv> \<not>(\<exists>x. x\<in>A \<and> x\<in>B)"

lemma disj_iff_empty_inter: "(disjoint A B) = (A \<inter> B = {})"
  by (simp add: disjoint_def disjoint_iff)

(* Power set is Pow. *)

definition non_decreasing :: "(nat \<Rightarrow> 'a set) \<Rightarrow> bool"
  where "non_decreasing A\<^sub>n \<equiv> \<forall>n. A\<^sub>n n \<subseteq> A\<^sub>n (n + 1)"

lemma non_decreasing_multistep:
  assumes non_dec: "non_decreasing A\<^sub>n"
      and leq: "n \<le> m"
    shows "A\<^sub>n n \<subseteq> A\<^sub>n m"
proof -
  have "\<forall>n y. y \<in> A\<^sub>n n \<longrightarrow> y \<in> A\<^sub>n (Suc n)"
    using non_dec non_decreasing_def Suc_eq_plus1 subset_iff by metis
  hence "\<forall>n. \<forall>d\<ge>0. (A\<^sub>n n \<subseteq> A\<^sub>n (n+d))"
      using add.commute le_add2 lift_Suc_mono_le subset_iff by metis
  thus "A\<^sub>n n \<subseteq> A\<^sub>n m"
    by (metis bot_nat_0.extremum le_iff_add leq)
qed

lemma non_decreasing_stay_in:
  assumes non_dec: "non_decreasing A\<^sub>n"
      and base: "x \<in> A\<^sub>n n"
    shows "\<forall>m\<ge>n. x \<in> A\<^sub>n m"
  using base non_dec non_decreasing_multistep by auto

definition non_increasing :: "(nat \<Rightarrow> 'a set) \<Rightarrow> bool"
  where "non_increasing A\<^sub>n \<equiv> \<forall>n. A\<^sub>n (n + 1) \<subseteq> A\<^sub>n n"

lemma non_increasing_multistep:
  assumes non_inc: "non_increasing A\<^sub>n"
      and leq: "n \<le> m"
    shows "A\<^sub>n m \<subseteq> A\<^sub>n n"
proof -
  have "\<forall>n y. y \<in> A\<^sub>n (Suc n) \<longrightarrow> y \<in> A\<^sub>n n"
    using non_inc non_increasing_def Suc_eq_plus1 subset_iff by metis
  hence "\<forall>n. \<forall>d\<ge>0. (A\<^sub>n (n+d) \<subseteq> A\<^sub>n n)"
      using add.commute le_add2 subset_iff lift_Suc_antimono_le by metis
  thus "A\<^sub>n m \<subseteq> A\<^sub>n n"
    by (metis bot_nat_0.extremum le_iff_add leq)
qed

lemma non_increasing_stay_out:
  assumes non_inc: "non_increasing A\<^sub>n"
      and base: "x \<notin> A\<^sub>n n"
    shows "\<forall>m\<ge>n. x \<notin> A\<^sub>n m"
  using base non_inc non_increasing_multistep by auto

definition general_union :: "'a set set \<Rightarrow> 'a set"
  where "general_union A = {x. \<exists>S. S \<in> A \<and> x \<in> S}"

lemma notin_general_union:
  assumes x_notin: "x \<notin> general_union A"
  shows "\<forall>S\<in>A. x \<notin> S"
  using x_notin general_union_def by fastforce

lemma general_union_empty: "general_union {} = {}"
proof -
  have "\<not>(\<exists>x. x \<in> {y. \<exists>A. A \<in> {} \<and> y \<in> A})"
    by simp
  hence "\<not>(\<exists>x. x \<in> general_union {})"
    using general_union_def by metis
  thus ?thesis
    by simp
qed

lemma general_union_singleton: "general_union {A} = A"
  by (simp add: general_union_def)

lemma general_union_binary:
  "general_union {A, B} = A \<union> B"
proof -
  have "general_union {A, B} = {x. \<exists>S. S \<in> {A, B} \<and> x \<in> S}"
    by (simp add: general_union_def)
  hence "general_union {A, B} = {x. x \<in> A \<or> x \<in> B}"
    by fast
  thus ?thesis
    by auto
qed

lemma general_union_UNIV: "general_union UNIV = UNIV"
  using general_union_def by fast

lemma general_union_sequence: "general_union {A. \<exists>n. A = A\<^sub>n n} =
                                      {x. \<exists>n. x \<in> A\<^sub>n n}"
proof
  show "general_union {A. \<exists>n. A = A\<^sub>n n} \<subseteq> {x. \<exists>n. x \<in> A\<^sub>n n}"
  proof
    fix x
    assume "x \<in> general_union {A. \<exists>n. A = A\<^sub>n n}"
    hence "\<exists>S. S \<in> {A. \<exists>n. A = A\<^sub>n n} \<and> x \<in> S"
      by (simp add: general_union_def)
    thus "x \<in> {x. \<exists>n. x \<in> A\<^sub>n n}"
      by auto
  qed
next
  show "{x. \<exists>n. x \<in> A\<^sub>n n} \<subseteq> general_union {A. \<exists>n. A = A\<^sub>n n}"
  proof
    fix x
    assume "x \<in> {x. \<exists>n. x \<in> A\<^sub>n n}"
    hence "\<exists>S. S \<in> {A. \<exists>n. A = A\<^sub>n n} \<and> x \<in> S"
      by auto
    thus "x \<in> general_union {A. \<exists>n. A = A\<^sub>n n}"
      by (simp add: general_union_def)
  qed
qed

definition general_intersection :: "'a set set \<Rightarrow> 'a set"
  where "general_intersection A = {x. \<forall>S. S \<in> A \<longrightarrow> x \<in> S}"

lemma general_intersection_binary:
  "general_intersection {A, B} = A \<inter> B"
proof -
  have "general_intersection {A, B} = {x. \<forall>S. S \<in> {A, B} \<longrightarrow> x \<in> S}"
    by (simp add: general_intersection_def)
  hence "general_intersection {A, B} = {x. x \<in> A \<and> x \<in> B}"
    by fast
  thus ?thesis
    by auto
qed

lemma notin_general_intersection:
  shows "(x \<notin> general_intersection A) = (\<exists>S\<in>A. x \<notin> S)"
  using general_intersection_def by fast

lemma general_intersection_empty: "general_intersection {} = UNIV"
proof -
  have "\<not>(\<exists>x. x \<notin> {y. \<forall>A. A \<in> {} \<longrightarrow> y \<in> A})"
    by simp
  hence "\<not>(\<exists>x. x \<notin> general_intersection {})"
    using general_intersection_def by metis
  thus ?thesis
    by auto
qed

lemma general_intersection_singleton: "general_intersection {A} = A"
  by (simp add: general_intersection_def)

lemma general_intersection_UNIV: "general_intersection UNIV = {}"
proof -
  have "\<forall>x. x \<notin> {y. \<forall>A. A \<in> UNIV \<longrightarrow> y \<in> A}"
    by auto
  hence "\<forall>x. x \<notin> general_intersection UNIV"
    using general_intersection_def by metis
  thus ?thesis
    by simp
qed

lemma general_intersection_sequence: "general_intersection {A. \<exists>n. A = A\<^sub>n n} =
                                      {x. \<forall>n. x \<in> A\<^sub>n n}"
proof
  show "general_intersection {A. \<exists>n. A = A\<^sub>n n} \<subseteq> {x. \<forall>n. x \<in> A\<^sub>n n}"
  proof
    fix x
    assume "x \<in> general_intersection {A. \<exists>n. A = A\<^sub>n n}"
    hence "\<forall>S. S \<in> {A. \<exists>n. A = A\<^sub>n n} \<longrightarrow> x \<in> S"
      by (simp add: general_intersection_def)
    thus "x \<in> {x. \<forall>n. x \<in> A\<^sub>n n}"
      by auto
  qed
next
  show "{x. \<forall>n. x \<in> A\<^sub>n n} \<subseteq> general_intersection {A. \<exists>n. A = A\<^sub>n n}"
  proof
    fix x
    assume "x \<in> {x. \<forall>n. x \<in> A\<^sub>n n}"
    hence "\<forall>S. S \<in> {A. \<exists>n. A = A\<^sub>n n} \<longrightarrow> x \<in> S"
      by auto
    thus "x \<in> general_intersection {A. \<exists>n. A = A\<^sub>n n}"
      by (simp add: general_intersection_def)
  qed
qed

(* The union/intersection of a set collection is a subset of any set that all members belong to.*)
lemma collection_union_subseq:
  assumes subseq: "\<forall>A\<in>\<A>. A \<subseteq> \<Omega>"
  shows "general_union \<A> \<subseteq> \<Omega>"
proof
  fix x
  assume "x \<in> general_union \<A>"
  hence "\<exists>S. S \<in> \<A> \<and> x \<in> S"
    by (simp add: general_union_def)
  then obtain S where "S \<in> \<A> \<and> x \<in> S"
    by fast
  moreover have "S \<subseteq> \<Omega>"
    by (simp add: calculation subseq)
  ultimately show "x \<in> \<Omega>"
    by auto
qed

lemma collection_inter_subseq:
  assumes subseq: "\<forall>A\<in>\<A>. A \<subseteq> \<Omega>"
      and non_empty: "\<A> \<noteq> {}"
  shows "general_intersection \<A> \<subseteq> \<Omega>"
proof
  fix x
  assume x_in_inter: "x \<in> general_intersection \<A>"
  hence "\<forall>S. S \<in> \<A> \<longrightarrow> x \<in> S"
    by (simp add: general_intersection_def)
  then obtain S where "S \<in> \<A> \<and> x \<in> S"
    using non_empty by fast
  moreover have "S \<subseteq> \<Omega>"
    by (simp add: calculation subseq)
  ultimately show "x \<in> \<Omega>"
    by auto
qed

definition set_complement :: "'a set \<Rightarrow> 'a set \<Rightarrow> 'a set"
  where "set_complement A \<Omega> = (THE B. B = {x\<in>\<Omega>. x \<notin> A} \<and> A \<subseteq> \<Omega>)"

lemma set_complement_meaning:
  assumes subseq: "A \<subseteq> B"
  shows "set_complement A B = {x\<in>B. x \<notin> A}"
  by (simp add: set_complement_def subseq)

lemma set_complement_diff:
  assumes subseq: "A \<subseteq> B"
  shows "set_complement A B = B - A"
  using Diff_iff subseq set_complement_meaning by auto

lemma set_complement_self_inverse:
  assumes subseq: "A \<subseteq> B"
    shows "set_complement (set_complement A B) B = A"
  by (simp add: double_diff set_complement_diff subseq)

lemma de_morgan_general_1:
  assumes subseq: "\<forall>A\<in>\<A>. A \<subseteq> \<Omega>"
      and non_empty_collection: "\<A> \<noteq> {}"
  shows "set_complement (general_union \<A>) \<Omega> =
         general_intersection {C. \<exists>S\<in>\<A>. C = set_complement S \<Omega>}"
proof
  show "set_complement (general_union \<A>) \<Omega> \<subseteq> general_intersection {C. \<exists>S\<in>\<A>. C = set_complement S \<Omega>}"
  proof
    fix x
    assume "x \<in> set_complement (general_union \<A>) \<Omega>"
    moreover have "(general_union \<A>) \<subseteq> \<Omega>"
      using subseq collection_union_subseq by auto
    hence "set_complement (general_union \<A>) \<Omega> = {x\<in>\<Omega>. x \<notin> (general_union \<A>)}"
      using set_complement_meaning by auto
    ultimately have "x \<in> \<Omega> \<and> x \<notin> general_union \<A>"
      by simp
    hence "x \<in> \<Omega> \<and> \<not>(\<exists>S. S \<in> \<A> \<and> x \<in> S)"
      using general_union_def by fast
    hence "x \<in> \<Omega> \<and> (\<forall>S. S \<notin> \<A> \<or> x \<notin> S)"
      by auto
    hence "\<forall>S\<in>\<A>. x \<in> set_complement S \<Omega>"
      by (simp add: set_complement_meaning subseq)
    thus "x \<in> general_intersection {C. \<exists>S\<in>\<A>. C = set_complement S \<Omega>}"
      using general_intersection_def by fastforce
  qed
next
  show "general_intersection {C. \<exists>S\<in>\<A>. C = set_complement S \<Omega>} \<subseteq> set_complement (general_union \<A>) \<Omega>"
  proof
    fix x
    assume "x \<in> general_intersection {C. \<exists>S\<in>\<A>. C = set_complement S \<Omega>}"
    hence "\<forall>C. (\<exists>S\<in>\<A>. C = set_complement S \<Omega>) \<longrightarrow> x \<in> C"
      by (simp add: general_intersection_def)
    hence "\<forall>S\<in>\<A>. x \<in> set_complement S \<Omega>"
      by auto
    moreover have "\<forall>S\<in>\<A>. set_complement S \<Omega> = {x\<in>\<Omega>. x \<notin> S}"
      using set_complement_meaning subseq by auto
    ultimately have "\<forall>S\<in>\<A>. (x \<in> \<Omega> \<and> x \<notin> S)"
      by simp
    hence "x \<in> \<Omega> \<and> (\<forall>S\<in>\<A>. x \<notin> S)"
      using non_empty_collection by auto
    hence "x \<in> \<Omega> \<and> x \<notin> general_union \<A>"
      by (simp add: general_union_def)
    thus "x \<in> set_complement (general_union \<A>) \<Omega>"
      by (simp add: collection_union_subseq set_complement_meaning subseq)
  qed
qed

lemma de_morgan_general_2:
  assumes subseq: "\<forall>A\<in>\<A>. A \<subseteq> \<Omega>"
      and non_empty_collection: "\<A> \<noteq> {}"
    shows "set_complement (general_intersection \<A>) \<Omega> =
           general_union {C. \<exists>S\<in>\<A>. C = set_complement S \<Omega>}"
proof
  show "set_complement (general_intersection \<A>) \<Omega> \<subseteq> general_union {C. \<exists>S\<in>\<A>. C = set_complement S \<Omega>}"
  proof
    fix x
    assume "x \<in> set_complement (general_intersection \<A>) \<Omega>"
    moreover have "(general_intersection \<A>) \<subseteq> \<Omega>"
      using subseq non_empty_collection collection_inter_subseq by auto
    hence "set_complement (general_intersection \<A>) \<Omega> = {x\<in>\<Omega>. x \<notin> (general_intersection \<A>)}"
      using set_complement_meaning by auto
    ultimately have "x \<in> \<Omega> \<and> x \<notin> general_intersection \<A>"
      by simp
    hence "\<exists>S\<in>\<A>. x \<notin> S \<and> x \<in> \<Omega>"
      by (metis notin_general_intersection)
    hence "\<exists>S\<in>\<A>. x \<in> set_complement S \<Omega>"
      by (simp add: set_complement_meaning subseq)
    thus "x \<in> general_union {C. \<exists>S\<in>\<A>. C = set_complement S \<Omega>}"
      using general_union_def by fast
  qed
next
  show "general_union {C. \<exists>S\<in>\<A>. C = set_complement S \<Omega>} \<subseteq> set_complement (general_intersection \<A>) \<Omega>"
  proof
    fix x
    assume "x \<in> general_union {C. \<exists>S\<in>\<A>. C = set_complement S \<Omega>}"
    hence "\<exists>C. \<exists>S\<in>\<A>. C = set_complement S \<Omega> \<and> x \<in> C"
      by (simp add: general_union_def)
    hence "\<exists>S\<in>\<A>. x \<in> set_complement S \<Omega>"
      by auto
    hence "x \<in> \<Omega> \<and> (\<exists>S\<in>\<A>. x \<notin> S)"
      by (simp add: subseq set_complement_meaning)
    hence "x \<in> \<Omega> \<and> x \<notin> general_intersection \<A>"
      by (simp add: notin_general_intersection)
    thus "x \<in> set_complement (general_intersection \<A>) \<Omega>"
      by (simp add: collection_inter_subseq non_empty_collection set_complement_diff subseq)
  qed
qed

lemma de_morgan_binary_1:
assumes A_subseq: "A \<subseteq> \<Omega>"
    and B_subseq: "B \<subseteq> \<Omega>"
  shows "set_complement (A \<union> B) \<Omega> = (set_complement A \<Omega>) \<inter> (set_complement B \<Omega>)"
proof -
  have "A \<union> B = general_union {A, B}"
    by (simp add: general_union_binary)
  moreover have "(set_complement A \<Omega>) \<inter> (set_complement B \<Omega>) =
                 general_intersection {set_complement A \<Omega>, set_complement B \<Omega>}"
    by (simp add: general_intersection_binary)
  moreover have "{set_complement A \<Omega>, set_complement B \<Omega>} = {C. \<exists>S\<in>{A, B}. C = set_complement S \<Omega>}"
    by auto
  moreover have "set_complement (general_union {A, B}) \<Omega> =
                 general_intersection {C. \<exists>S\<in>{A, B}. C = set_complement S \<Omega>}"
    by (simp add: A_subseq B_subseq de_morgan_general_1)
  ultimately show ?thesis
    by simp
qed

lemma de_morgan_binary_2:
assumes A_subseq: "A \<subseteq> \<Omega>"
    and B_subseq: "B \<subseteq> \<Omega>"
  shows "set_complement (A \<inter> B) \<Omega> = (set_complement A \<Omega>) \<union> (set_complement B \<Omega>)"
proof -
  have "A \<inter> B = general_intersection {A, B}"
    by (simp add: general_intersection_binary)
  moreover have "(set_complement A \<Omega>) \<union> (set_complement B \<Omega>) =
                 general_union {set_complement A \<Omega>, set_complement B \<Omega>}"
    by (simp add: general_union_binary)
  moreover have "{set_complement A \<Omega>, set_complement B \<Omega>} = {C. \<exists>S\<in>{A, B}. C = set_complement S \<Omega>}"
    by auto
  moreover have "set_complement (general_intersection {A, B}) \<Omega> =
                 general_union {C. \<exists>S\<in>{A, B}. C = set_complement S \<Omega>}"
    by (simp add: A_subseq B_subseq de_morgan_general_2)
  ultimately show ?thesis
    by simp
qed

subsubsection "Limits of Sets"

definition liminf :: "(nat \<Rightarrow> 'a set) \<Rightarrow> 'a set"
  where "liminf A =
         general_union {B. \<exists>n. B = general_intersection {C. \<exists>k. k \<ge> n \<and> C = A k}}"

lemma liminf_greater_n: "(x \<in> liminf A) = (\<exists>n. \<forall>k. (k \<ge> n \<longrightarrow> x \<in> A k))"
proof -
  have "(x \<in> liminf A) =
         (\<exists>S. \<exists>n. S = general_intersection {C. \<exists>k. k \<ge> n \<and> C = A k} \<and> x \<in> S)"
    by (simp add: liminf_def general_union_def)
  hence "(x \<in> liminf A) = (\<exists>n. x \<in> general_intersection {C. \<exists>k. k \<ge> n \<and> C = A k})"
    by auto
  hence "(x \<in> liminf A) = (\<exists>n. \<forall>S. (S \<in> {C. \<exists>k. k \<ge> n \<and> C = A k} \<longrightarrow> x \<in> S))"
    by (simp add: general_intersection_def)
  thus ?thesis
    by auto
qed

lemma liminf_greater_n_set: "liminf A = {x. \<exists>n. \<forall>k. k \<ge> n \<longrightarrow> x \<in> A k}"
proof
  show "liminf A \<subseteq> {x. \<exists>n. \<forall>k\<ge>n. x \<in> A k}"
  proof
    fix x
    assume "x \<in> liminf A"
    hence "\<exists>n. \<forall>k. (k \<ge> n \<longrightarrow> x \<in> A k)"
      by (simp add: liminf_greater_n)
    thus "x \<in> {x. \<exists>n. \<forall>k. k \<ge> n \<longrightarrow> x \<in> A k}"
      by auto
  qed
next
  show "{x. \<exists>n. \<forall>k\<ge>n. x \<in> A k} \<subseteq> liminf A"
  proof
    fix x
    assume "x \<in> {x. \<exists>n. \<forall>k\<ge>n. x \<in> A k}"
    hence "\<exists>n. \<forall>k. (k \<ge> n \<longrightarrow> x \<in> A k)"
      by auto
    thus "x \<in> liminf A"
      by (simp add: liminf_greater_n)
  qed
qed

definition limsup :: "(nat \<Rightarrow> 'a set) \<Rightarrow> 'a set"
  where "limsup A = general_intersection {B. \<exists>n. B = general_union {C. \<exists>m. m \<ge> n \<and> C = A m}}"

lemma limsup_greater_n: "(x \<in> limsup A) = (\<forall>n. \<exists>m. m \<ge> n \<and> x \<in> A m)"
proof -
  have "(x \<in> limsup A) =
        (x \<in> general_intersection {B. \<exists>n. B = general_union {C. \<exists>m. m \<ge> n \<and> C = A m}})"
    using limsup_def by fast
  hence "(x \<in> limsup A) = (\<forall>S. (\<exists>n. S = {x. \<exists>S'. S' \<in> {C. \<exists>m. m \<ge> n \<and> C = A m} \<and> x \<in> S'}) \<longrightarrow> x \<in> S)"
    by (simp add: general_union_def general_intersection_def)
  hence "(x \<in> limsup A) = (\<forall>n. \<exists>S'. (\<exists>m. m \<ge> n \<and> S' = A m) \<and> x \<in> S')"
    by auto
  thus ?thesis
    by fast
qed

lemma limsup_greater_n_set: "limsup A = {x. \<forall>n. \<exists>m. m \<ge> n \<and> x \<in> A m}"
proof
  show "limsup A \<subseteq> {x. \<forall>n. \<exists>m. m \<ge> n \<and> x \<in> A m}"
  proof
    fix x
    assume "x \<in> limsup A"
    hence "\<forall>n. \<exists>m. m \<ge> n \<and> x \<in> A m"
      by (simp add: limsup_greater_n)
    thus "x \<in> {x. \<forall>n. \<exists>m. m \<ge> n \<and> x \<in> A m}"
      by auto
  qed
next
  show "{x. \<forall>n. \<exists>m. m \<ge> n \<and> x \<in> A m} \<subseteq> limsup A"
  proof
    fix x
    assume "x \<in> {x. \<forall>n. \<exists>m. m \<ge> n \<and> x \<in> A m}"
    hence "\<forall>n. \<exists>m. m \<ge> n \<and> x \<in> A m"
      by auto
    thus "x \<in> limsup A"
      by (simp add: limsup_greater_n)
  qed
qed

lemma liminf_sub_limsup: "liminf A \<subseteq> limsup A"
proof
  fix x
  assume "x \<in> liminf A"
  hence "\<exists>n. \<forall>m. (m \<ge> n \<longrightarrow> x \<in> A m)"
    by (simp add: liminf_greater_n)
  hence "\<forall>n. \<exists>m. m \<ge> n \<and> x \<in> A m"
    by (meson nat_le_linear)
  thus "x \<in> limsup A"
    by (simp add: limsup_greater_n)
qed

lemma liminf_limsup_eq_cond:
  assumes limsup_sub_liminf: "limsup A \<subseteq> liminf A"
  shows "liminf A = limsup A"
  by (simp add: limsup_sub_liminf liminf_sub_limsup subset_antisym)

definition set_limit :: "(nat \<Rightarrow> 'a set) \<Rightarrow> 'a set"
  where "set_limit A = (THE S. S = liminf A \<and> S = limsup A)"

lemma set_limit_eq_liminf:
  assumes lim_defined: "liminf A = limsup A"
  shows "set_limit A = liminf A"
  by (simp add: lim_defined set_limit_def)

lemma set_limit_eq_limsup:
  assumes lim_defined: "liminf A = limsup A"
  shows "set_limit A = limsup A"
  by (simp add: lim_defined set_limit_def)

lemma non_decreasing_set_limit:
  assumes non_decreasing: "non_decreasing A\<^sub>n"
  shows "set_limit A\<^sub>n = general_union {A. \<exists>n. A = A\<^sub>n n}"
proof -
  have "limsup A\<^sub>n = general_union {A. \<exists>n. A = A\<^sub>n n}"
  proof
    show "limsup A\<^sub>n \<subseteq> general_union {A. \<exists>n. A = A\<^sub>n n}"
    proof
      fix x
      assume "x \<in> limsup A\<^sub>n"
      hence "(\<exists>m. m \<ge> 1 \<and> x \<in> A\<^sub>n m)"
        by (simp add: limsup_greater_n)
      hence "(\<exists>m. x \<in> A\<^sub>n m)"
        by auto
      thus "x \<in> general_union {A. \<exists>n. A = A\<^sub>n n}"
        using general_union_sequence by fast
    qed
  next
    show "general_union {A. \<exists>n. A = A\<^sub>n n} \<subseteq> limsup A\<^sub>n"
    proof
      fix x
      assume "x \<in> general_union {A. \<exists>n. A = A\<^sub>n n}"
      hence "x \<in> {x. \<exists>n. x \<in> A\<^sub>n n}"
        using general_union_sequence by metis
      hence "\<exists>n. x \<in> A\<^sub>n n"
        by auto
      then obtain n where "x \<in> A\<^sub>n n"
        by auto
      hence "\<forall>m\<ge>n. x \<in> A\<^sub>n m"
        by (meson non_decreasing non_decreasing_stay_in)
      thus "x \<in> limsup A\<^sub>n"
        by (meson limsup_greater_n nat_le_linear)
    qed
  qed

  moreover have "limsup A\<^sub>n = liminf A\<^sub>n"
  proof -
    have "limsup A\<^sub>n \<subseteq> liminf A\<^sub>n"
    proof
      fix x
      assume "x \<in> limsup A\<^sub>n"
      hence "\<forall>n. \<exists>m. m \<ge> n \<and> x \<in> A\<^sub>n m"
        by (simp add: limsup_greater_n)
      hence "\<exists>n. \<forall>k. (k \<ge> n \<longrightarrow> x \<in> A\<^sub>n k)"
        by (meson non_decreasing non_decreasing_stay_in)
      thus "x \<in> liminf A\<^sub>n"
        by (simp add: liminf_greater_n)
    qed
    thus ?thesis
      using liminf_limsup_eq_cond by auto
  qed

  ultimately show ?thesis
    by (simp add: set_limit_eq_limsup)
qed

lemma non_increasing_set_limit:
  assumes non_increasing: "non_increasing A\<^sub>n"
  shows "set_limit A\<^sub>n = general_intersection {A. \<exists>n. A = A\<^sub>n n}"
proof -
  have "limsup A\<^sub>n = general_intersection {A. \<exists>n. A = A\<^sub>n n}"
  proof
    show "limsup A\<^sub>n \<subseteq> general_intersection {A. \<exists>n. A = A\<^sub>n n}"
    proof
      fix x
      assume "x \<in> limsup A\<^sub>n"
      hence "\<forall>n. \<exists>m. m \<ge> n \<and> x \<in> A\<^sub>n m"
        by (simp add: limsup_greater_n)
      hence "\<forall>m. x \<in> A\<^sub>n m"
        using non_increasing non_increasing_stay_out by metis
      thus "x \<in> general_intersection {A. \<exists>n. A = A\<^sub>n n}"
        using general_intersection_sequence by fast
    qed
  next
    show "general_intersection {A. \<exists>n. A = A\<^sub>n n} \<subseteq> limsup A\<^sub>n"
    proof
      fix x
      assume "x \<in> general_intersection {A. \<exists>n. A = A\<^sub>n n}"
      hence "\<forall>n. x \<in> A\<^sub>n n"
        using general_intersection_sequence by fast
      thus "x \<in> limsup A\<^sub>n"
        by (meson limsup_greater_n order_refl)
    qed
  qed

  moreover have "limsup A\<^sub>n = liminf A\<^sub>n"
  proof -
    have "limsup A\<^sub>n \<subseteq> liminf A\<^sub>n"
    proof
      fix x
      assume "x \<in> limsup A\<^sub>n"
      hence "\<forall>n. \<exists>m. m \<ge> n \<and> x \<in> A\<^sub>n m"
        by (simp add: limsup_greater_n)
      hence "\<exists>n. \<forall>k\<ge>n. x \<in> A\<^sub>n k"
        by (meson non_increasing non_increasing_stay_out)
      thus "x \<in> liminf A\<^sub>n"
        by (simp add: liminf_greater_n)
    qed
    thus ?thesis
      using liminf_limsup_eq_cond by auto
  qed

  ultimately show ?thesis
    by (simp add: set_limit_eq_limsup)
qed

subsection "Collections of Sets"

definition complement_stable :: "'a set set \<Rightarrow> 'a set \<Rightarrow> bool"
  where "complement_stable \<A> \<Omega> \<equiv> \<A> \<noteq> {} \<and> (\<forall>A\<in>\<A>. set_complement A \<Omega> \<in> \<A>)"

definition finite_union_stable :: "'a set set \<Rightarrow> bool"
  where "finite_union_stable \<A> \<equiv> \<A> \<noteq> {} \<and> (\<forall>A\<in>\<A>. \<forall>B\<in>\<A>. A\<union>B \<in> \<A>)"

definition finite_inter_stable :: "'a set set \<Rightarrow> bool"
  where "finite_inter_stable \<A> \<equiv> \<A> \<noteq> {} \<and> (\<forall>A\<in>\<A>. \<forall>B\<in>\<A>. A\<inter>B \<in> \<A>)"

lemma c_fu_imp_fi_stable:
  assumes c_stable: "complement_stable \<A> \<Omega>"
      and fu_stable: "finite_union_stable \<A>"
      and subseq: "\<forall>S\<in>\<A>. S \<subseteq> \<Omega>"
    shows "finite_inter_stable \<A>"
proof -
  have "\<A> \<noteq> {}"
    using fu_stable finite_union_stable_def by auto

  moreover have "\<forall>A\<in>\<A>. \<forall>B\<in>\<A>. A\<inter>B \<in> \<A>"
  proof
    fix A
    assume A_in: "A \<in> \<A>"
    show "\<forall>B\<in>\<A>. A \<inter> B \<in> \<A>"
    proof
      fix B
      assume B_in: "B \<in> \<A>"
      have "set_complement A \<Omega> \<in> \<A>"
        using A_in c_stable complement_stable_def by auto
      moreover have "set_complement B \<Omega> \<in> \<A>"
        using B_in c_stable complement_stable_def by auto
      ultimately have "(set_complement A \<Omega>) \<union> (set_complement B \<Omega>) \<in> \<A>"
        using finite_union_stable_def fu_stable by fast
      moreover have "(set_complement A \<Omega>) \<union> (set_complement B \<Omega>) = set_complement (A \<inter> B) \<Omega>"
        by (simp add: A_in B_in de_morgan_binary_2 subseq)
      ultimately have "set_complement (set_complement (A \<inter> B) \<Omega>) \<Omega> \<in> \<A>"
        using c_stable complement_stable_def by auto
      thus "A \<inter> B \<in> \<A>"
        by (metis A_in le_sup_iff set_complement_self_inverse subseq sup_inf_absorb)
    qed
  qed

  ultimately show "finite_inter_stable \<A>"
    by (simp add: finite_inter_stable_def)
qed

(* TODO: c_fi_imp_fu_stable*)

definition set_diff_stable :: "'a set set \<Rightarrow> bool"
  where "set_diff_stable \<A> \<equiv> \<A> \<noteq> {} \<and> (\<forall>A\<in>\<A>. \<forall>B\<in>\<A>. B \<subseteq> A \<longrightarrow> A-B \<in> \<A>)"

definition countable_union_stable :: "'a set set \<Rightarrow> bool"
  where "countable_union_stable \<A> \<equiv> \<A> \<noteq> {} \<and> (\<forall>A\<^sub>n. (\<forall>n::nat. A\<^sub>n n \<in> \<A>) \<longrightarrow>
  (general_union {S. \<exists>n. S = A\<^sub>n n} \<in> \<A>))"

(* TODO - disjoint_countable_union_stable *)

definition countable_inter_stable :: "'a set set \<Rightarrow> bool"
  where "countable_inter_stable \<A> \<equiv> \<A> \<noteq> {} \<and> (\<forall>A\<^sub>n. (\<forall>n::nat. A\<^sub>n n \<in> \<A>) \<longrightarrow>
  (general_intersection {S. \<exists>n. S = A\<^sub>n n} \<in> \<A>))"

end


theory Circlines_Angle
  imports Oriented_Circlines Elementary_Complex_Geometry
begin

(* ----------------------------------------------------------------- *)
subsection \<open>Angle between circlines\<close>
(* ----------------------------------------------------------------- *)

text \<open>Angle between circlines can be defined in purely algebraic terms (following Schwerdtfeger
\<^cite>\<open>"schwerdtfeger"\<close>) and using this definitions many properties can be easily proved.\<close>

fun mat_det_12 :: "complex_mat \<Rightarrow> complex_mat \<Rightarrow> complex" where
  "mat_det_12 (A1, B1, C1, D1) (A2, B2, C2, D2) = A1*D2 + A2*D1 - B1*C2 - B2*C1"

lemma mat_det_12_mm_l [simp]:
  shows "mat_det_12 (M *\<^sub>m\<^sub>m A) (M *\<^sub>m\<^sub>m B) = mat_det M * mat_det_12 A B"
  by (cases M, cases A, cases B) (simp add: field_simps)

lemma mat_det_12_mm_r [simp]:
  shows "mat_det_12 (A *\<^sub>m\<^sub>m M) (B *\<^sub>m\<^sub>m M) = mat_det M * mat_det_12 A B"
  by (cases M, cases A, cases B) (simp add: field_simps)

lemma mat_det_12_sm_l [simp]:
  shows "mat_det_12 (k *\<^sub>s\<^sub>m A) B = k * mat_det_12 A B"
  by (cases A, cases B) (simp add: field_simps)

lemma mat_det_12_sm_r [simp]:
  shows "mat_det_12 A (k *\<^sub>s\<^sub>m B) = k * mat_det_12 A B"
  by (cases A, cases B) (simp add: field_simps)

lemma mat_det_12_congruence [simp]:
  shows "mat_det_12 (congruence M A) (congruence M B) = (cor ((cmod (mat_det M))\<^sup>2)) * mat_det_12 A B"
  unfolding congruence_def
  by ((subst mult_mm_assoc[symmetric])+, subst mat_det_12_mm_l, subst mat_det_12_mm_r, subst mat_det_adj) (auto simp add: field_simps complex_mult_cnj_cmod)

definition cos_angle_cmat :: "complex_mat \<Rightarrow> complex_mat \<Rightarrow> real" where
  [simp]: "cos_angle_cmat H1 H2 = - Re (mat_det_12 H1 H2) / (2 * (sqrt (Re (mat_det H1 * mat_det H2))))"

lift_definition cos_angle_clmat :: "circline_mat \<Rightarrow> circline_mat \<Rightarrow> real" is cos_angle_cmat
  done

lemma cos_angle_den_scale [simp]:
  assumes "k1 > 0" and "k2 > 0"
  shows "sqrt (Re ((k1\<^sup>2 * mat_det H1) * (k2\<^sup>2 * mat_det H2))) =
         k1 * k2 * sqrt (Re (mat_det H1 * mat_det H2))"
proof-
  let ?lhs = "(k1\<^sup>2 * mat_det H1) * (k2\<^sup>2 * mat_det H2)"
  let ?rhs = "mat_det H1 * mat_det H2"
  have 1: "?lhs = (k1\<^sup>2*k2\<^sup>2) * ?rhs"
    by simp
  hence "Re ?lhs = (k1\<^sup>2*k2\<^sup>2) * Re ?rhs"
    by (simp add: field_simps)
  thus ?thesis
    using assms
    by (simp add: real_sqrt_mult)
qed

lift_definition cos_angle :: "ocircline \<Rightarrow> ocircline \<Rightarrow> real" is cos_angle_clmat
proof transfer
  fix H1 H2 H1' H2'
  assume "ocircline_eq_cmat H1 H1'" "ocircline_eq_cmat H2 H2'"
  then obtain k1 k2 :: real where
  *:  "k1 > 0" "H1' = cor k1 *\<^sub>s\<^sub>m H1"
      "k2 > 0" "H2' = cor k2 *\<^sub>s\<^sub>m H2"
    by auto
  thus "cos_angle_cmat H1 H2 = cos_angle_cmat H1' H2'"
    unfolding cos_angle_cmat_def
    apply (subst *)+
    apply (subst mat_det_12_sm_l, subst mat_det_12_sm_r)
    apply (subst mat_det_mult_sm)+
    apply (subst power2_eq_square[symmetric])+
    apply (subst cos_angle_den_scale, simp, simp)
    apply simp
    done
qed

text \<open>Möbius transformations are conformal, meaning that they preserve oriented angle between
oriented circlines.\<close>

lemma cos_angle_opposite1 [simp]:
  shows "cos_angle (opposite_ocircline H) H' = - cos_angle H H'"
  by (transfer, transfer, simp)

lemma cos_angle_opposite2 [simp]:
  shows "cos_angle H (opposite_ocircline H') = - cos_angle H H'"
  by (transfer, transfer, simp)

(* ----------------------------------------------------------------- *)
subsubsection \<open>Connection with the elementary angle definition between circles\<close>
(* ----------------------------------------------------------------- *)

text\<open>We want to connect algebraic definition of an angle with a traditional one and
to prove equivalency between these two definitions. For the traditional definition of
an angle we follow the approach suggested by Needham \<^cite>\<open>"needham"\<close>.\<close>

lemma Re_mult_real3:
  assumes "is_real z1" and "is_real z2" and "is_real z3"
  shows "Re (z1 * z2 * z3) = Re z1 * Re z2 * Re z3"
  using assms
  by (metis Re_mult_real mult_reals)

lemma sgn_sqrt [simp]:
  shows "sgn (sqrt x) = sgn x"
  by (simp add: sgn_root sqrt_def)

lemma real_circle_sgn_r:
  assumes "is_circle H" and "(a, r) = euclidean_circle H"
  shows "sgn r = - circline_type H"
  using assms
proof (transfer, transfer)
  fix H :: complex_mat and a r
  assume hh: "hermitean H \<and> H \<noteq> mat_zero"
  obtain A B C D where HH: "H = (A, B, C, D)"
    by (cases H) auto
  hence "is_real A" "is_real D"
    using hermitean_elems hh
    by auto
  assume "\<not> circline_A0_cmat H" "(a, r) = euclidean_circle_cmat H"
  hence "A \<noteq> 0"
    using \<open>\<not> circline_A0_cmat H\<close> HH
    by simp
  hence "Re A * Re A > 0"
    using \<open>is_real A\<close>
    using complex_eq_if_Re_eq not_real_square_gt_zero
    by fastforce
  thus "sgn r = - circline_type_cmat H"
    using HH \<open>(a, r) = euclidean_circle_cmat H\<close> \<open>is_real A\<close> \<open>is_real D\<close> \<open>A \<noteq> 0\<close>
    by (simp add: Re_divide_real sgn_minus[symmetric])
qed

text \<open>The definition of an angle using algebraic terms is not intuitive, and we want to connect it to
the more common definition given earlier that defines an
angle between circlines as the angle between tangent vectors in the point of the intersection of the
circlines.\<close>

lemma cos_angle_eq_cos_ang_circ:
  assumes
  "is_circle (of_ocircline H1)" and "is_circle (of_ocircline H2)" and
  "circline_type (of_ocircline H1) < 0" and "circline_type (of_ocircline H2) < 0"
  "(a1, r1) = euclidean_circle (of_ocircline H1)" and "(a2, r2) = euclidean_circle (of_ocircline H2)" and
  "of_complex E \<in> ocircline_set H1 \<inter> ocircline_set H2"
  shows "cos_angle H1 H2 = cos (ang_circ E a1 a2 (pos_oriented H1) (pos_oriented H2))"
proof-
  let ?p1 = "pos_oriented H1" and ?p2 = "pos_oriented H2"
  have "E \<in> circle a1 r1" "E \<in> circle a2 r2"
    using classic_circle[of "of_ocircline H1" a1 r1]  classic_circle[of "of_ocircline H2" a2 r2]
    using assms of_complex_inj
    by auto
  hence *: "cdist E a1 = r1" "cdist E a2 = r2"
    unfolding circle_def
    by (simp_all add: norm_minus_commute)
  have "r1 > 0" "r2 > 0"
    using assms(1-6) real_circle_sgn_r[of "of_ocircline H1" a1 r1]  real_circle_sgn_r[of "of_ocircline H2" a2 r2]
    using sgn_greater
    by fastforce+
  hence "E \<noteq> a1" "E \<noteq> a2"
    using \<open>cdist E a1 = r1\<close> \<open>cdist E a2 = r2\<close>
    by auto

  let ?k = "sgn_bool (?p1 = ?p2)"
  let ?xx = "?k * (r1\<^sup>2 + r2\<^sup>2 - (cdist a2 a1)\<^sup>2) / (2 * r1 * r2)"

  have "cos (ang_circ E a1 a2 ?p1 ?p2) = ?xx"
    using law_of_cosines[of a2 a1 E] * \<open>r1 > 0\<close> \<open>r2 > 0\<close> cos_ang_circ_simp[OF \<open>E \<noteq> a1\<close> \<open>E \<noteq> a2\<close>]
    by (subst (asm) ang_vec_opposite_opposite'[OF \<open>E \<noteq> a1\<close>[symmetric] \<open>E \<noteq> a2\<close>[symmetric], symmetric]) simp
  moreover
  have "cos_angle H1 H2 = ?xx"
    using \<open>r1 > 0\<close> \<open>r2 > 0\<close>
    using \<open>(a1, r1) = euclidean_circle (of_ocircline H1)\<close> \<open>(a2, r2) = euclidean_circle (of_ocircline H2)\<close>
    using \<open>is_circle (of_ocircline H1)\<close> \<open>is_circle (of_ocircline H2)\<close>
    using \<open>circline_type (of_ocircline H1) < 0\<close> \<open>circline_type (of_ocircline H2) < 0\<close>
  proof (transfer, transfer)
    fix a1 r1 H1 H2 a2 r2
    assume hh: "hermitean H1 \<and> H1 \<noteq> mat_zero" "hermitean H2 \<and> H2 \<noteq> mat_zero"
    obtain A1 B1 C1 D1 where HH1: "H1 = (A1, B1, C1, D1)"
      by (cases H1) auto
    obtain A2 B2 C2 D2 where HH2: "H2 = (A2, B2, C2, D2)"
      by (cases H2) auto
    have *: "is_real A1" "is_real A2" "is_real D1" "is_real D2" "cnj B1 = C1" "cnj B2 = C2"
      using hh hermitean_elems[of A1 B1 C1 D1] hermitean_elems[of A2 B2 C2 D2] HH1 HH2
      by auto
    have "cnj A1 = A1" "cnj A2 = A2"
      using \<open>is_real A1\<close> \<open>is_real A2\<close>
      by (case_tac[!] A1, case_tac[!] A2, auto simp add: Complex_eq)

    assume "\<not> circline_A0_cmat (id H1)" "\<not> circline_A0_cmat (id H2)"
    hence "A1 \<noteq> 0" "A2 \<noteq> 0"
      using HH1 HH2
      by auto
    hence "Re A1 \<noteq> 0" "Re A2 \<noteq> 0"
      using \<open>is_real A1\<close> \<open>is_real A2\<close>
      using complex.expand
      by auto

    assume "circline_type_cmat (id H1) < 0" "circline_type_cmat (id H2) < 0"
    assume "(a1, r1) = euclidean_circle_cmat (id H1)" "(a2, r2) = euclidean_circle_cmat (id H2)"
    assume "r1 > 0" "r2 > 0"

    let ?D12 = "mat_det_12 H1 H2" and ?D1 = "mat_det H1" and ?D2 = "mat_det H2"
    let ?x1 = "(cdist a2 a1)\<^sup>2 - r1\<^sup>2 - r2\<^sup>2" and ?x2 = "2*r1*r2"
    let ?x = "?x1 / ?x2"
    have *:  "Re (?D12) / (2 * (sqrt (Re (?D1 * ?D2)))) = Re (sgn A1) * Re (sgn A2) * ?x"
    proof-
      let ?M1 = "(A1, B1, C1, D1)" and ?M2 = "(A2, B2, C2, D2)"
      let ?d1 = "B1 * C1 - A1 * D1" and ?d2 = "B2 * C2 - A2 * D2"
      have "Re ?d1 > 0" "Re ?d2 > 0"
        using HH1 HH2 \<open>circline_type_cmat (id H1) < 0\<close>  \<open>circline_type_cmat (id H2) < 0\<close>
        by auto
      hence **: "Re (?d1 / (A1 * A1)) > 0" "Re (?d2 / (A2 * A2)) > 0"
        using \<open>is_real A1\<close> \<open>is_real A2\<close> \<open>A1 \<noteq> 0\<close> \<open>A2 \<noteq> 0\<close>
        by (subst Re_divide_real, simp_all add: complex_neq_0 power2_eq_square)+
      have ***: "is_real (?d1 / (A1 * A1)) \<and> is_real (?d2 / (A2 * A2))"
        using \<open>is_real A1\<close>  \<open>is_real A2\<close> \<open>A1 \<noteq> 0\<close> \<open>A2 \<noteq> 0\<close> \<open>cnj B1 = C1\<close>[symmetric] \<open>cnj B2 = C2\<close>[symmetric] \<open>is_real D1\<close> \<open>is_real D2\<close>
        by (subst div_reals, simp, simp, simp)+

      have "cor ?x = mat_det_12 ?M1 ?M2 / (2 * sgn A1 * sgn A2 * cor (sqrt (Re ?d1) * sqrt (Re ?d2)))"
      proof-
        have "A1*A2*cor ?x1 = mat_det_12 ?M1 ?M2"
        proof-
          have 1: "A1*A2*(cor ((cdist a2 a1)\<^sup>2)) = ((B2*A1 - A2*B1)*(C2*A1 - C1*A2)) / (A1*A2)"
            using \<open>(a1, r1) = euclidean_circle_cmat (id H1)\<close> \<open>(a2, r2) = euclidean_circle_cmat (id H2)\<close>
            unfolding cdist_def cmod_square
            using HH1 HH2 * \<open>A1 \<noteq> 0\<close> \<open>A2 \<noteq> 0\<close> \<open>cnj A1 = A1\<close> \<open>cnj A2 = A2\<close>
            unfolding Let_def
            apply (subst complex_of_real_Re)
            apply (simp add: field_simps)
            apply (simp add: complex_mult_cnj_cmod power2_eq_square)
            apply (simp add: field_simps)
            done
          have 2: "A1*A2*cor (-r1\<^sup>2) = A2*D1 - B1*C1*A2/A1"
            using \<open>(a1, r1) = euclidean_circle_cmat (id H1)\<close>
            using HH1 ** * *** \<open>A1 \<noteq> 0\<close>
            by (simp add: power2_eq_square field_simps)
          have 3: "A1*A2*cor (-r2\<^sup>2) = A1*D2 - B2*C2*A1/A2"
            using \<open>(a2, r2) = euclidean_circle_cmat (id H2)\<close>
            using HH2 ** * *** \<open>A2 \<noteq> 0\<close>
            by (simp add: power2_eq_square field_simps)
          have "A1*A2*cor((cdist a2 a1)\<^sup>2) + A1*A2*cor(-r1\<^sup>2) + A1*A2*cor(-r2\<^sup>2) = mat_det_12 ?M1 ?M2"
            using \<open>A1 \<noteq> 0\<close> \<open>A2 \<noteq> 0\<close>
            by (subst 1, subst 2, subst 3) (simp add: field_simps)
          thus ?thesis
            by (simp add: field_simps)
        qed

        moreover

        have "A1 * A2 * cor (?x2) = 2 * sgn A1 * sgn A2 * cor (sqrt (Re ?d1) * sqrt (Re ?d2))"
        proof-
          have 1: "sqrt (Re (?d1/ (A1 * A1))) = sqrt (Re ?d1) / \<bar>Re A1\<bar>"
            using \<open>A1 \<noteq> 0\<close> \<open>is_real A1\<close>
            by (subst Re_divide_real, simp, simp, subst real_sqrt_divide, simp)

          have 2: "sqrt (Re (?d2/ (A2 * A2))) = sqrt (Re ?d2) / \<bar>Re A2\<bar>"
            using \<open>A2 \<noteq> 0\<close> \<open>is_real A2\<close>
            by (subst Re_divide_real, simp, simp, subst real_sqrt_divide, simp)
          have "sgn A1 = A1 / cor \<bar>Re A1\<bar>"
            using \<open>is_real A1\<close>
            unfolding sgn_eq
            by (simp add: cmod_eq_Re)
          moreover
          have "sgn A2 = A2 / cor \<bar>Re A2\<bar>"
            using \<open>is_real A2\<close>
            unfolding sgn_eq
            by (simp add: cmod_eq_Re)
          ultimately
          show ?thesis
            using \<open>(a1, r1) = euclidean_circle_cmat (id H1)\<close> \<open>(a2, r2) = euclidean_circle_cmat (id H2)\<close>  HH1 HH2
            using *** \<open>is_real A1\<close> \<open>is_real A2\<close>
            by simp (subst 1, subst 2, simp)
        qed

        ultimately

        have "(A1 * A2 * cor ?x1) / (A1 * A2 * (cor ?x2)) =
               mat_det_12 ?M1 ?M2 / (2 * sgn A1 * sgn A2 * cor (sqrt (Re ?d1) * sqrt (Re ?d2)))"
          by simp
        thus ?thesis
          using \<open>A1 \<noteq> 0\<close> \<open>A2 \<noteq> 0\<close>
          by simp
      qed
      hence "cor ?x * sgn A1 * sgn A2 = mat_det_12 ?M1 ?M2 / (2 * cor (sqrt (Re ?d1) * sqrt (Re ?d2)))"
        using \<open>A1 \<noteq> 0\<close> \<open>A2 \<noteq> 0\<close>
        by (simp add: sgn_zero_iff)
      moreover
      have "Re (cor ?x * sgn A1 * sgn A2) = Re (sgn A1) * Re (sgn A2) * ?x"
      proof-
        have "is_real (cor ?x)" "is_real (sgn A1)" "is_real (sgn A2)"
          using \<open>is_real A1\<close> \<open>is_real A2\<close> Im_complex_of_real[of ?x]
          by auto
        thus ?thesis
          using Re_complex_of_real[of ?x]
          by (subst Re_mult_real3, auto simp add: field_simps)
      qed
      moreover
      have *: "sqrt (Re ?D1) * sqrt (Re ?D2) = sqrt (Re ?d1) * sqrt (Re ?d2)"
        using HH1 HH2
        by (subst real_sqrt_mult[symmetric])+ (simp add: field_simps)
      have "2 * (sqrt (Re (?D1 * ?D2))) \<noteq> 0"
        using \<open>Re ?d1 > 0\<close>  \<open>Re ?d2 > 0\<close> HH1 HH2 \<open>is_real A1\<close> \<open>is_real A2\<close>  \<open>is_real D1\<close> \<open>is_real D2\<close>
        using hh mat_det_hermitean_real[of "H1"]
        by (subst Re_mult_real, auto)
      hence **: "Re (?D12 / (2 * cor (sqrt (Re (?D1 * ?D2))))) = Re (?D12) / (2 * (sqrt (Re (?D1 * ?D2))))"
        using \<open>Re ?d1 > 0\<close>  \<open>Re ?d2 > 0\<close> HH1 HH2 \<open>is_real A1\<close> \<open>is_real A2\<close>  \<open>is_real D1\<close> \<open>is_real D2\<close>
        by (subst Re_divide_real) auto
      have "Re (mat_det_12 ?M1 ?M2 / (2 * cor (sqrt (Re ?d1) * sqrt (Re ?d2)))) = Re (?D12) / (2 * (sqrt (Re (?D1 * ?D2))))"
        using HH1 HH2 hh mat_det_hermitean_real[of "H1"]
        by (subst **[symmetric], subst Re_mult_real, simp, subst real_sqrt_mult, subst *, simp)
      ultimately
      show ?thesis
        by simp
    qed
    have **: "pos_oriented_cmat H1 \<longleftrightarrow> Re A1 > 0"  "pos_oriented_cmat H2 \<longleftrightarrow> Re A2 > 0"
      using \<open>Re A1 \<noteq> 0\<close> HH1  \<open>Re A2 \<noteq> 0\<close> HH2
      by auto
    show "cos_angle_cmat H1 H2 = sgn_bool (pos_oriented_cmat H1 = pos_oriented_cmat H2) * (r1\<^sup>2 + r2\<^sup>2 - (cdist a2 a1)\<^sup>2) /  (2 * r1 * r2)"
      unfolding Let_def
      using \<open>r1 > 0\<close> \<open>r2 > 0\<close>
      unfolding cos_angle_cmat_def
      apply (subst divide_minus_left)
      apply (subst *)
      apply (subst Re_sgn[OF \<open>is_real A1\<close> \<open>A1 \<noteq> 0\<close>], subst Re_sgn[OF \<open>is_real A2\<close> \<open>A2 \<noteq> 0\<close>])
      apply (subst **, subst **)
      apply (simp add: field_simps)
      done
  qed
  ultimately
  show ?thesis
    by simp
qed

(* ----------------------------------------------------------------- *)
subsection \<open>Perpendicularity\<close>
(* ----------------------------------------------------------------- *)

text \<open>Two circlines are perpendicular if the intersect at right angle i.e., the angle with the cosine
0.\<close>

definition perpendicular where
  "perpendicular H1 H2 \<longleftrightarrow> cos_angle (of_circline H1) (of_circline H2) = 0"

lemma perpendicular_sym:
  shows "perpendicular H1 H2 \<longleftrightarrow> perpendicular H2 H1"
  unfolding perpendicular_def
  by (transfer, transfer, auto simp add: field_simps)

(* ----------------------------------------------------------------- *)
subsection \<open>Möbius transforms preserve angles and perpendicularity\<close>
(* ----------------------------------------------------------------- *)

text \<open>Möbius transformations are \emph{conformal} i.e., they preserve angles between circlines.\<close>

lemma perpendicular_moebius [simp]:
  assumes "perpendicular H1 H2"
  shows "perpendicular (moebius_circline M H1) (moebius_circline M H2)"
  using assms
  unfolding perpendicular_def
  using moebius_preserve_circline_angle[of M "of_circline H1" "of_circline H2"]
  using moebius_ocircline_circline[of M "of_circline H1"]
  using moebius_ocircline_circline[of M "of_circline H2"]
  by (auto simp del: moebius_preserve_circline_angle)

end


(*  Title:      HOL/Isar_Examples/Group_Context.thy
    Author:     Makarius
*)

section \<open>Some algebraic identities derived from group axioms -- theory context version\<close>

theory Group_Context
  imports Main
begin

text \<open>hypothetical group axiomatization\<close>

context
  fixes prod :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"  (infixl "\<odot>" 70)
    and one :: "'a"
    and inverse :: "'a \<Rightarrow> 'a"
  assumes assoc: "(x \<odot> y) \<odot> z = x \<odot> (y \<odot> z)"
    and left_one: "one \<odot> x = x"
    and left_inverse: "inverse x \<odot> x = one"
begin

text \<open>some consequences\<close>

lemma right_inverse: "x \<odot> inverse x = one"
proof -
  have "x \<odot> inverse x = one \<odot> (x \<odot> inverse x)"
    by (simp only: left_one)
  also have "\<dots> = one \<odot> x \<odot> inverse x"
    by (simp only: assoc)
  also have "\<dots> = inverse (inverse x) \<odot> inverse x \<odot> x \<odot> inverse x"
    by (simp only: left_inverse)
  also have "\<dots> = inverse (inverse x) \<odot> (inverse x \<odot> x) \<odot> inverse x"
    by (simp only: assoc)
  also have "\<dots> = inverse (inverse x) \<odot> one \<odot> inverse x"
    by (simp only: left_inverse)
  also have "\<dots> = inverse (inverse x) \<odot> (one \<odot> inverse x)"
    by (simp only: assoc)
  also have "\<dots> = inverse (inverse x) \<odot> inverse x"
    by (simp only: left_one)
  also have "\<dots> = one"
    by (simp only: left_inverse)
  finally show ?thesis .
qed

lemma right_one: "x \<odot> one = x"
proof -
  have "x \<odot> one = x \<odot> (inverse x \<odot> x)"
    by (simp only: left_inverse)
  also have "\<dots> = x \<odot> inverse x \<odot> x"
    by (simp only: assoc)
  also have "\<dots> = one \<odot> x"
    by (simp only: right_inverse)
  also have "\<dots> = x"
    by (simp only: left_one)
  finally show ?thesis .
qed

lemma one_equality:
  assumes eq: "e \<odot> x = x"
  shows "one = e"
proof -
  have "one = x \<odot> inverse x"
    by (simp only: right_inverse)
  also have "\<dots> = (e \<odot> x) \<odot> inverse x"
    by (simp only: eq)
  also have "\<dots> = e \<odot> (x \<odot> inverse x)"
    by (simp only: assoc)
  also have "\<dots> = e \<odot> one"
    by (simp only: right_inverse)
  also have "\<dots> = e"
    by (simp only: right_one)
  finally show ?thesis .
qed

lemma inverse_equality:
  assumes eq: "x' \<odot> x = one"
  shows "inverse x = x'"
proof -
  have "inverse x = one \<odot> inverse x"
    by (simp only: left_one)
  also have "\<dots> = (x' \<odot> x) \<odot> inverse x"
    by (simp only: eq)
  also have "\<dots> = x' \<odot> (x \<odot> inverse x)"
    by (simp only: assoc)
  also have "\<dots> = x' \<odot> one"
    by (simp only: right_inverse)
  also have "\<dots> = x'"
    by (simp only: right_one)
  finally show ?thesis .
qed

end

end