(*:maxLineLen=78:*)

section \<open>Example: First-Order Logic\<close>

theory %visible First_Order_Logic
imports Base  (* FIXME Pure!? *)
begin

text \<open>
  In order to commence a new object-logic within Isabelle/Pure we introduce
  abstract syntactic categories \<open>i\<close> for individuals and \<open>o\<close> for
  object-propositions. The latter is embedded into the language of Pure
  propositions by means of a separate judgment.
\<close>

typedecl i
typedecl o

judgment Trueprop :: "o \<Rightarrow> prop"    ("_" 5)

text \<open>
  Note that the object-logic judgment is implicit in the syntax: writing
  \<^prop>\<open>A\<close> produces \<^term>\<open>Trueprop A\<close> internally. From the Pure
  perspective this means ``\<^prop>\<open>A\<close> is derivable in the object-logic''.
\<close>

subsection \<open>Equational reasoning \label{sec:framework-ex-equal}\<close>

text \<open>
  Equality is axiomatized as a binary predicate on individuals, with
  reflexivity as introduction, and substitution as elimination principle. Note
  that the latter is particularly convenient in a framework like Isabelle,
  because syntactic congruences are implicitly produced by unification of
  \<open>B x\<close> against expressions containing occurrences of \<open>x\<close>.
\<close>

axiomatization equal :: "i \<Rightarrow> i \<Rightarrow> o"  (infix "=" 50)
  where refl [intro]: "x = x"
    and subst [elim]: "x = y \<Longrightarrow> B x \<Longrightarrow> B y"

text \<open>
  Substitution is very powerful, but also hard to control in full generality.
  We derive some common symmetry~/ transitivity schemes of \<^term>\<open>equal\<close> as
  particular consequences.
\<close>

theorem sym [sym]:
  assumes "x = y"
  shows "y = x"
proof -
  have "x = x" ..
  with \<open>x = y\<close> show "y = x" ..
qed

theorem forw_subst [trans]:
  assumes "y = x" and "B x"
  shows "B y"
proof -
  from \<open>y = x\<close> have "x = y" ..
  from this and \<open>B x\<close> show "B y" ..
qed

theorem back_subst [trans]:
  assumes "B x" and "x = y"
  shows "B y"
proof -
  from \<open>x = y\<close> and \<open>B x\<close>
  show "B y" ..
qed

theorem trans [trans]:
  assumes "x = y" and "y = z"
  shows "x = z"
proof -
  from \<open>y = z\<close> and \<open>x = y\<close>
  show "x = z" ..
qed

subsection \<open>Basic group theory\<close>

text \<open>
  As an example for equational reasoning we consider some bits of group
  theory. The subsequent locale definition postulates group operations and
  axioms; we also derive some consequences of this specification.
\<close>

locale group =
  fixes prod :: "i \<Rightarrow> i \<Rightarrow> i"  (infix "\<circ>" 70)
    and inv :: "i \<Rightarrow> i"  ("(_\<inverse>)" [1000] 999)
    and unit :: i  ("1")
  assumes assoc: "(x \<circ> y) \<circ> z = x \<circ> (y \<circ> z)"
    and left_unit:  "1 \<circ> x = x"
    and left_inv: "x\<inverse> \<circ> x = 1"
begin

theorem right_inv: "x \<circ> x\<inverse> = 1"
proof -
  have "x \<circ> x\<inverse> = 1 \<circ> (x \<circ> x\<inverse>)" by (rule left_unit [symmetric])
  also have "\<dots> = (1 \<circ> x) \<circ> x\<inverse>" by (rule assoc [symmetric])
  also have "1 = (x\<inverse>)\<inverse> \<circ> x\<inverse>" by (rule left_inv [symmetric])
  also have "\<dots> \<circ> x = (x\<inverse>)\<inverse> \<circ> (x\<inverse> \<circ> x)" by (rule assoc)
  also have "x\<inverse> \<circ> x = 1" by (rule left_inv)
  also have "((x\<inverse>)\<inverse> \<circ> \<dots>) \<circ> x\<inverse> = (x\<inverse>)\<inverse> \<circ> (1 \<circ> x\<inverse>)" by (rule assoc)
  also have "1 \<circ> x\<inverse> = x\<inverse>" by (rule left_unit)
  also have "(x\<inverse>)\<inverse> \<circ> \<dots> = 1" by (rule left_inv)
  finally show "x \<circ> x\<inverse> = 1" .
qed

theorem right_unit: "x \<circ> 1 = x"
proof -
  have "1 = x\<inverse> \<circ> x" by (rule left_inv [symmetric])
  also have "x \<circ> \<dots> = (x \<circ> x\<inverse>) \<circ> x" by (rule assoc [symmetric])
  also have "x \<circ> x\<inverse> = 1" by (rule right_inv)
  also have "\<dots> \<circ> x = x" by (rule left_unit)
  finally show "x \<circ> 1 = x" .
qed

text \<open>
  Reasoning from basic axioms is often tedious. Our proofs work by producing
  various instances of the given rules (potentially the symmetric form) using
  the pattern ``\<^theory_text>\<open>have eq by (rule r)\<close>'' and composing the chain of results
  via \<^theory_text>\<open>also\<close>/\<^theory_text>\<open>finally\<close>. These steps may involve any of the transitivity
  rules declared in \secref{sec:framework-ex-equal}, namely @{thm trans} in
  combining the first two results in @{thm right_inv} and in the final steps
  of both proofs, @{thm forw_subst} in the first combination of @{thm
  right_unit}, and @{thm back_subst} in all other calculational steps.

  Occasional substitutions in calculations are adequate, but should not be
  over-emphasized. The other extreme is to compose a chain by plain
  transitivity only, with replacements occurring always in topmost position.
  For example:
\<close>

(*<*)
theorem "\<And>A. PROP A \<Longrightarrow> PROP A"
proof -
  assume [symmetric, defn]: "\<And>x y. (x \<equiv> y) \<equiv> Trueprop (x = y)"
  fix x
(*>*)
  have "x \<circ> 1 = x \<circ> (x\<inverse> \<circ> x)" unfolding left_inv ..
  also have "\<dots> = (x \<circ> x\<inverse>) \<circ> x" unfolding assoc ..
  also have "\<dots> = 1 \<circ> x" unfolding right_inv ..
  also have "\<dots> = x" unfolding left_unit ..
  finally have "x \<circ> 1 = x" .
(*<*)
qed
(*>*)

text \<open>
  Here we have re-used the built-in mechanism for unfolding definitions in
  order to normalize each equational problem. A more realistic object-logic
  would include proper setup for the Simplifier (\secref{sec:simplifier}), the
  main automated tool for equational reasoning in Isabelle. Then ``\<^theory_text>\<open>unfolding
  left_inv ..\<close>'' would become ``\<^theory_text>\<open>by (simp only: left_inv)\<close>'' etc.
\<close>

end

subsection \<open>Propositional logic \label{sec:framework-ex-prop}\<close>

text \<open>
  We axiomatize basic connectives of propositional logic: implication,
  disjunction, and conjunction. The associated rules are modeled after
  Gentzen's system of Natural Deduction \<^cite>\<open>"Gentzen:1935"\<close>.
\<close>

axiomatization imp :: "o \<Rightarrow> o \<Rightarrow> o"  (infixr "\<longrightarrow>" 25)
  where impI [intro]: "(A \<Longrightarrow> B) \<Longrightarrow> A \<longrightarrow> B"
    and impD [dest]: "(A \<longrightarrow> B) \<Longrightarrow> A \<Longrightarrow> B"

axiomatization disj :: "o \<Rightarrow> o \<Rightarrow> o"  (infixr "\<or>" 30)
  where disjI\<^sub>1 [intro]: "A \<Longrightarrow> A \<or> B"
    and disjI\<^sub>2 [intro]: "B \<Longrightarrow> A \<or> B"
    and disjE [elim]: "A \<or> B \<Longrightarrow> (A \<Longrightarrow> C) \<Longrightarrow> (B \<Longrightarrow> C) \<Longrightarrow> C"

axiomatization conj :: "o \<Rightarrow> o \<Rightarrow> o"  (infixr "\<and>" 35)
  where conjI [intro]: "A \<Longrightarrow> B \<Longrightarrow> A \<and> B"
    and conjD\<^sub>1: "A \<and> B \<Longrightarrow> A"
    and conjD\<^sub>2: "A \<and> B \<Longrightarrow> B"

text \<open>
  The conjunctive destructions have the disadvantage that decomposing \<^prop>\<open>A \<and> B\<close> involves an immediate decision which component should be projected.
  The more convenient simultaneous elimination \<^prop>\<open>A \<and> B \<Longrightarrow> (A \<Longrightarrow> B \<Longrightarrow> C) \<Longrightarrow>
  C\<close> can be derived as follows:
\<close>

theorem conjE [elim]:
  assumes "A \<and> B"
  obtains A and B
proof
  from \<open>A \<and> B\<close> show A by (rule conjD\<^sub>1)
  from \<open>A \<and> B\<close> show B by (rule conjD\<^sub>2)
qed

text \<open>
  Here is an example of swapping conjuncts with a single intermediate
  elimination step:
\<close>

(*<*)
lemma "\<And>A. PROP A \<Longrightarrow> PROP A"
proof -
  fix A B
(*>*)
  assume "A \<and> B"
  then obtain B and A ..
  then have "B \<and> A" ..
(*<*)
qed
(*>*)

text \<open>
  Note that the analogous elimination rule for disjunction ``\<^theory_text>\<open>assumes "A \<or> B"
  obtains A \<BBAR> B\<close>'' coincides with the original axiomatization of @{thm
  disjE}.

  \<^medskip>
  We continue propositional logic by introducing absurdity with its
  characteristic elimination. Plain truth may then be defined as a proposition
  that is trivially true.
\<close>

axiomatization false :: o  ("\<bottom>")
  where falseE [elim]: "\<bottom> \<Longrightarrow> A"

definition true :: o  ("\<top>")
  where "\<top> \<equiv> \<bottom> \<longrightarrow> \<bottom>"

theorem trueI [intro]: \<top>
  unfolding true_def ..

text \<open>
  \<^medskip>
  Now negation represents an implication towards absurdity:
\<close>

definition not :: "o \<Rightarrow> o"  ("\<not> _" [40] 40)
  where "\<not> A \<equiv> A \<longrightarrow> \<bottom>"

theorem notI [intro]:
  assumes "A \<Longrightarrow> \<bottom>"
  shows "\<not> A"
unfolding not_def
proof
  assume A
  then show \<bottom> by (rule \<open>A \<Longrightarrow> \<bottom>\<close>)
qed

theorem notE [elim]:
  assumes "\<not> A" and A
  shows B
proof -
  from \<open>\<not> A\<close> have "A \<longrightarrow> \<bottom>" unfolding not_def .
  from \<open>A \<longrightarrow> \<bottom>\<close> and \<open>A\<close> have \<bottom> ..
  then show B ..
qed

subsection \<open>Classical logic\<close>

text \<open>
  Subsequently we state the principle of classical contradiction as a local
  assumption. Thus we refrain from forcing the object-logic into the classical
  perspective. Within that context, we may derive well-known consequences of
  the classical principle.
\<close>

locale classical =
  assumes classical: "(\<not> C \<Longrightarrow> C) \<Longrightarrow> C"
begin

theorem double_negation:
  assumes "\<not> \<not> C"
  shows C
proof (rule classical)
  assume "\<not> C"
  with \<open>\<not> \<not> C\<close> show C ..
qed

theorem tertium_non_datur: "C \<or> \<not> C"
proof (rule double_negation)
  show "\<not> \<not> (C \<or> \<not> C)"
  proof
    assume "\<not> (C \<or> \<not> C)"
    have "\<not> C"
    proof
      assume C then have "C \<or> \<not> C" ..
      with \<open>\<not> (C \<or> \<not> C)\<close> show \<bottom> ..
    qed
    then have "C \<or> \<not> C" ..
    with \<open>\<not> (C \<or> \<not> C)\<close> show \<bottom> ..
  qed
qed

text \<open>
  These examples illustrate both classical reasoning and non-trivial
  propositional proofs in general. All three rules characterize classical
  logic independently, but the original rule is already the most convenient to
  use, because it leaves the conclusion unchanged. Note that \<^prop>\<open>(\<not> C \<Longrightarrow> C)
  \<Longrightarrow> C\<close> fits again into our format for eliminations, despite the additional
  twist that the context refers to the main conclusion. So we may write @{thm
  classical} as the Isar statement ``\<^theory_text>\<open>obtains \<not> thesis\<close>''. This also explains
  nicely how classical reasoning really works: whatever the main \<open>thesis\<close>
  might be, we may always assume its negation!
\<close>

end

subsection \<open>Quantifiers \label{sec:framework-ex-quant}\<close>

text \<open>
  Representing quantifiers is easy, thanks to the higher-order nature of the
  underlying framework. According to the well-known technique introduced by
  Church \<^cite>\<open>"church40"\<close>, quantifiers are operators on predicates, which
  are syntactically represented as \<open>\<lambda>\<close>-terms of type \<^typ>\<open>i \<Rightarrow> o\<close>. Binder
  notation turns \<open>All (\<lambda>x. B x)\<close> into \<open>\<forall>x. B x\<close> etc.
\<close>

axiomatization All :: "(i \<Rightarrow> o) \<Rightarrow> o"  (binder "\<forall>" 10)
  where allI [intro]: "(\<And>x. B x) \<Longrightarrow> \<forall>x. B x"
    and allD [dest]: "(\<forall>x. B x) \<Longrightarrow> B a"

axiomatization Ex :: "(i \<Rightarrow> o) \<Rightarrow> o"  (binder "\<exists>" 10)
  where exI [intro]: "B a \<Longrightarrow> (\<exists>x. B x)"
    and exE [elim]: "(\<exists>x. B x) \<Longrightarrow> (\<And>x. B x \<Longrightarrow> C) \<Longrightarrow> C"

text \<open>
  The statement of @{thm exE} corresponds to ``\<^theory_text>\<open>assumes "\<exists>x. B x" obtains x
  where "B x"\<close>'' in Isar. In the subsequent example we illustrate quantifier
  reasoning involving all four rules:
\<close>

theorem
  assumes "\<exists>x. \<forall>y. R x y"
  shows "\<forall>y. \<exists>x. R x y"
proof    \<comment> \<open>\<open>\<forall>\<close> introduction\<close>
  obtain x where "\<forall>y. R x y" using \<open>\<exists>x. \<forall>y. R x y\<close> ..    \<comment> \<open>\<open>\<exists>\<close> elimination\<close>
  fix y have "R x y" using \<open>\<forall>y. R x y\<close> ..    \<comment> \<open>\<open>\<forall>\<close> destruction\<close>
  then show "\<exists>x. R x y" ..    \<comment> \<open>\<open>\<exists>\<close> introduction\<close>
qed

subsection \<open>Canonical reasoning patterns\<close>

text \<open>
  The main rules of first-order predicate logic from
  \secref{sec:framework-ex-prop} and \secref{sec:framework-ex-quant} can now
  be summarized as follows, using the native Isar statement format of
  \secref{sec:framework-stmt}.

  \<^medskip>
  \begin{tabular}{l}
  \<^theory_text>\<open>impI: assumes "A \<Longrightarrow> B" shows "A \<longrightarrow> B"\<close> \\
  \<^theory_text>\<open>impD: assumes "A \<longrightarrow> B" and A shows B\<close> \\[1ex]

  \<^theory_text>\<open>disjI\<^sub>1: assumes A shows "A \<or> B"\<close> \\
  \<^theory_text>\<open>disjI\<^sub>2: assumes B shows "A \<or> B"\<close> \\
  \<^theory_text>\<open>disjE: assumes "A \<or> B" obtains A \<BBAR> B\<close> \\[1ex]

  \<^theory_text>\<open>conjI: assumes A and B shows A \<and> B\<close> \\
  \<^theory_text>\<open>conjE: assumes "A \<and> B" obtains A and B\<close> \\[1ex]

  \<^theory_text>\<open>falseE: assumes \<bottom> shows A\<close> \\
  \<^theory_text>\<open>trueI: shows \<top>\<close> \\[1ex]

  \<^theory_text>\<open>notI: assumes "A \<Longrightarrow> \<bottom>" shows "\<not> A"\<close> \\
  \<^theory_text>\<open>notE: assumes "\<not> A" and A shows B\<close> \\[1ex]

  \<^theory_text>\<open>allI: assumes "\<And>x. B x" shows "\<forall>x. B x"\<close> \\
  \<^theory_text>\<open>allE: assumes "\<forall>x. B x" shows "B a"\<close> \\[1ex]

  \<^theory_text>\<open>exI: assumes "B a" shows "\<exists>x. B x"\<close> \\
  \<^theory_text>\<open>exE: assumes "\<exists>x. B x" obtains a where "B a"\<close>
  \end{tabular}
  \<^medskip>

  This essentially provides a declarative reading of Pure rules as Isar
  reasoning patterns: the rule statements tells how a canonical proof outline
  shall look like. Since the above rules have already been declared as
  @{attribute (Pure) intro}, @{attribute (Pure) elim}, @{attribute (Pure)
  dest} --- each according to its particular shape --- we can immediately
  write Isar proof texts as follows:
\<close>

(*<*)
theorem "\<And>A. PROP A \<Longrightarrow> PROP A"
proof -
(*>*)

  text_raw \<open>\begin{minipage}[t]{0.4\textwidth}\<close>(*<*)next(*>*)

  have "A \<longrightarrow> B"
  proof
    assume A
    show B \<proof>
  qed

  text_raw \<open>\end{minipage}\qquad\begin{minipage}[t]{0.4\textwidth}\<close>(*<*)next(*>*)

  have "A \<longrightarrow> B" and A \<proof>
  then have B ..

  text_raw \<open>\end{minipage}\\[3ex]\begin{minipage}[t]{0.4\textwidth}\<close>(*<*)next(*>*)

  have A \<proof>
  then have "A \<or> B" ..

  have B \<proof>
  then have "A \<or> B" ..

  text_raw \<open>\end{minipage}\qquad\begin{minipage}[t]{0.4\textwidth}\<close>(*<*)next(*>*)

  have "A \<or> B" \<proof>
  then have C
  proof
    assume A
    then show C \<proof>
  next
    assume B
    then show C \<proof>
  qed

  text_raw \<open>\end{minipage}\\[3ex]\begin{minipage}[t]{0.4\textwidth}\<close>(*<*)next(*>*)

  have A and B \<proof>
  then have "A \<and> B" ..

  text_raw \<open>\end{minipage}\qquad\begin{minipage}[t]{0.4\textwidth}\<close>(*<*)next(*>*)

  have "A \<and> B" \<proof>
  then obtain A and B ..

  text_raw \<open>\end{minipage}\\[3ex]\begin{minipage}[t]{0.4\textwidth}\<close>(*<*)next(*>*)

  have "\<bottom>" \<proof>
  then have A ..

  text_raw \<open>\end{minipage}\qquad\begin{minipage}[t]{0.4\textwidth}\<close>(*<*)next(*>*)

  have "\<top>" ..

  text_raw \<open>\end{minipage}\\[3ex]\begin{minipage}[t]{0.4\textwidth}\<close>(*<*)next(*>*)

  have "\<not> A"
  proof
    assume A
    then show "\<bottom>" \<proof>
  qed

  text_raw \<open>\end{minipage}\qquad\begin{minipage}[t]{0.4\textwidth}\<close>(*<*)next(*>*)

  have "\<not> A" and A \<proof>
  then have B ..

  text_raw \<open>\end{minipage}\\[3ex]\begin{minipage}[t]{0.4\textwidth}\<close>(*<*)next(*>*)

  have "\<forall>x. B x"
  proof
    fix x
    show "B x" \<proof>
  qed

  text_raw \<open>\end{minipage}\qquad\begin{minipage}[t]{0.4\textwidth}\<close>(*<*)next(*>*)

  have "\<forall>x. B x" \<proof>
  then have "B a" ..

  text_raw \<open>\end{minipage}\\[3ex]\begin{minipage}[t]{0.4\textwidth}\<close>(*<*)next(*>*)

  have "\<exists>x. B x"
  proof
    show "B a" \<proof>
  qed

  text_raw \<open>\end{minipage}\qquad\begin{minipage}[t]{0.4\textwidth}\<close>(*<*)next(*>*)

  have "\<exists>x. B x" \<proof>
  then obtain a where "B a" ..

  text_raw \<open>\end{minipage}\<close>

(*<*)
qed
(*>*)

text \<open>
  \<^bigskip>
  Of course, these proofs are merely examples. As sketched in
  \secref{sec:framework-subproof}, there is a fair amount of flexibility in
  expressing Pure deductions in Isar. Here the user is asked to express
  himself adequately, aiming at proof texts of literary quality.
\<close>

end %visible


(*
Title:KoenigsbergBridge.thy
Author:Wenda Li
*)

theory KoenigsbergBridge imports MoreGraph
begin

section\<open>Definition of Eulerian trails and circuits\<close>

definition (in valid_unMultigraph) is_Eulerian_trail:: "'v\<Rightarrow>('v,'w) path\<Rightarrow>'v\<Rightarrow> bool" where
  "is_Eulerian_trail v ps v'\<equiv> is_trail v ps v' \<and> edges (rem_unPath ps G) = {}"

definition (in valid_unMultigraph) is_Eulerian_circuit:: "'v \<Rightarrow> ('v,'w) path \<Rightarrow> 'v \<Rightarrow> bool" where
  "is_Eulerian_circuit v ps v'\<equiv> (v=v') \<and> (is_Eulerian_trail v ps v')"

section\<open>Necessary conditions for Eulerian trails and circuits\<close>

lemma (in valid_unMultigraph) euclerian_rev:
  "is_Eulerian_trail v' (rev_path ps) v=is_Eulerian_trail v ps v' "
proof -
  have "is_trail v' (rev_path ps) v=is_trail v ps v'"
    by (metis is_trail_rev)
  moreover have "edges (rem_unPath (rev_path ps) G)=edges (rem_unPath ps G)"
    by (metis rem_unPath_graph)
  ultimately show ?thesis unfolding is_Eulerian_trail_def by auto
qed

(*Necessary conditions for Eulerian circuits*)
theorem (in valid_unMultigraph) euclerian_cycle_ex:
  assumes "is_Eulerian_circuit v ps v'" "finite V" "finite E"
  shows "\<forall>v\<in>V. even (degree v G)"
proof -
  obtain v ps v' where cycle:"is_Eulerian_circuit v ps v'" using assms by auto
  hence "edges (rem_unPath ps G) = {}"
    unfolding is_Eulerian_circuit_def is_Eulerian_trail_def
    by simp
  moreover have "nodes (rem_unPath ps G)=nodes G" by auto
  ultimately have "rem_unPath ps G = G \<lparr>edges:={}\<rparr>" by auto
  hence "num_of_odd_nodes (rem_unPath ps G) = 0" by (metis assms(2) odd_nodes_no_edge)
  moreover have "v=v'"
    by (metis \<open>is_Eulerian_circuit v ps v'\<close> is_Eulerian_circuit_def)
  hence "num_of_odd_nodes (rem_unPath ps G)=num_of_odd_nodes G"
    by (metis assms(2) assms(3) cycle is_Eulerian_circuit_def
        is_Eulerian_trail_def rem_UnPath_cycle)
  ultimately have "num_of_odd_nodes G=0" by auto
  moreover have "finite(odd_nodes_set G)"
    using \<open>finite V\<close> unfolding odd_nodes_set_def by auto
  ultimately have "odd_nodes_set G = {}" unfolding num_of_odd_nodes_def by auto
  thus ?thesis unfolding odd_nodes_set_def by auto
qed

(*Necessary conditions for Eulerian trails*)
theorem (in valid_unMultigraph) euclerian_path_ex:
  assumes "is_Eulerian_trail v ps v'" "finite V" "finite E"
  shows "(\<forall>v\<in>V. even (degree v G)) \<or> (num_of_odd_nodes G =2)"
proof -
  obtain v ps v' where path:"is_Eulerian_trail v ps v'" using assms by auto
  hence "edges (rem_unPath ps G) = {}"
    unfolding  is_Eulerian_trail_def
    by simp
  moreover have "nodes (rem_unPath ps G)=nodes G" by auto
  ultimately have "rem_unPath ps G = G \<lparr>edges:={}\<rparr>" by auto
  hence odd_nodes: "num_of_odd_nodes (rem_unPath ps G) = 0"
    by (metis assms(2) odd_nodes_no_edge)
  have "v\<noteq>v' \<Longrightarrow> ?thesis"
    proof (cases "even(degree v' G)")
      case True
      assume "v\<noteq>v'"
      have "is_trail v ps v'" by (metis is_Eulerian_trail_def path)
      hence "num_of_odd_nodes (rem_unPath ps G) = num_of_odd_nodes G
          + (if even (degree v G) then 2 else 0)"
        using rem_UnPath_even True \<open>finite V\<close> \<open>finite E\<close> \<open>v\<noteq>v'\<close> by auto
      hence "num_of_odd_nodes G + (if even (degree v G) then 2 else 0)=0"
        using odd_nodes by auto
      hence "num_of_odd_nodes G = 0" by auto
      moreover have "finite(odd_nodes_set G)"
        using \<open>finite V\<close> unfolding odd_nodes_set_def by auto
      ultimately have "odd_nodes_set G = {}" unfolding num_of_odd_nodes_def by auto
      thus ?thesis unfolding odd_nodes_set_def by auto
    next
      case False
      assume "v\<noteq>v'"
      have "is_trail v ps v'" by (metis is_Eulerian_trail_def path)
      hence "num_of_odd_nodes (rem_unPath ps G) = num_of_odd_nodes G
          + (if odd (degree v G) then -2 else 0)"
        using rem_UnPath_odd False \<open>finite V\<close> \<open>finite E\<close> \<open>v\<noteq>v'\<close> by auto
      hence odd_nodes_if: "num_of_odd_nodes G + (if odd (degree v G) then -2 else 0)=0"
        using odd_nodes by auto
      have "odd (degree v G) \<Longrightarrow> ?thesis"
        proof -
          assume "odd (degree v G)"
          hence "num_of_odd_nodes G = 2" using odd_nodes_if by auto
          thus ?thesis by simp
        qed
      moreover have "even(degree v G) \<Longrightarrow> ?thesis"
        proof -
          assume "even (degree v G)"
          hence "num_of_odd_nodes G = 0" using odd_nodes_if by auto
          moreover have "finite(odd_nodes_set G)"
            using \<open>finite V\<close> unfolding odd_nodes_set_def by auto
          ultimately have "odd_nodes_set G = {}" unfolding num_of_odd_nodes_def by auto
          thus ?thesis unfolding odd_nodes_set_def by auto
        qed
      ultimately show ?thesis by auto
    qed
  moreover have "v=v'\<Longrightarrow> ?thesis"
    by (metis assms(2) assms(3) euclerian_cycle_ex is_Eulerian_circuit_def path)
  ultimately show ?thesis by auto
qed

section\<open>Specific case of the Konigsberg Bridge Problem\<close>

(*to denote the four landmasses*)
datatype kon_node = a | b | c | d

(*to denote the seven bridges*)
datatype kon_bridge = ab1 | ab2 | ac1 | ac2 | ad1 | bd1 | cd1

definition kon_graph :: "(kon_node,kon_bridge) graph" where
  "kon_graph\<equiv>\<lparr>nodes={a,b,c,d},
              edges={(a,ab1,b), (b,ab1,a),
                     (a,ab2,b), (b,ab2,a),
                     (a,ac1,c), (c,ac1,a),
                     (a,ac2,c), (c,ac2,a),
                     (a,ad1,d), (d,ad1,a),
                     (b,bd1,d), (d,bd1,b),
                     (c,cd1,d), (d,cd1,c)} \<rparr>"

instantiation kon_node :: enum
begin
definition [simp]:  "enum_class.enum =[a,b,c,d]"
definition  [simp]: "enum_class.enum_all P \<longleftrightarrow> P a \<and> P b \<and> P c \<and> P d"
definition   [simp]:"enum_class.enum_ex P \<longleftrightarrow> P a \<or> P b \<or> P c \<or> P d"
instance proof qed (auto,(case_tac x,auto)+)
end

instantiation kon_bridge :: enum
begin
definition [simp]:"enum_class.enum =[ab1,ab2,ac1,ac2,ad1,cd1,bd1]"
definition  [simp]:"enum_class.enum_all P \<longleftrightarrow> P ab1 \<and> P ab2 \<and> P ac1 \<and> P ac2 \<and> P ad1  \<and> P bd1
    \<and> P cd1"
definition   [simp]:"enum_class.enum_ex P \<longleftrightarrow>  P ab1 \<or> P ab2 \<or> P ac1 \<or> P ac2 \<or> P ad1  \<or> P bd1
    \<or> P cd1"
instance proof qed (auto,(case_tac x,auto)+)
end

interpretation   kon_graph: valid_unMultigraph kon_graph
proof (unfold_locales)
  show "fst ` edges kon_graph \<subseteq> nodes kon_graph" by eval
next
  show "snd ` snd ` edges kon_graph \<subseteq> nodes kon_graph"  by eval
next
  have " \<forall>v w u'. ((v, w, u') \<in> edges kon_graph) = ((u', w, v) \<in> edges kon_graph)"
    by eval
  thus "\<And>v w u'. ((v, w, u') \<in> edges kon_graph) = ((u', w, v) \<in> edges kon_graph)" by simp
next
  have "\<forall>v w. (v, w, v) \<notin> edges kon_graph"  by eval
  thus "\<And>v w. (v, w, v) \<notin> edges kon_graph" by simp
qed

(*The specific case of the Konigsberg Bridge Problem does not have a solution*)
theorem "\<not>kon_graph.is_Eulerian_trail v1 p v2"
proof
  assume "kon_graph.is_Eulerian_trail  v1 p v2"
  moreover have "finite (nodes kon_graph)" by (metis finite_code)
  moreover have "finite (edges kon_graph)" by (metis finite_code)
  ultimately have contra:
    "(\<forall>v\<in>nodes kon_graph. even (degree v kon_graph)) \<or>(num_of_odd_nodes kon_graph =2)"
    by (metis kon_graph.euclerian_path_ex)
  have "odd(degree a kon_graph)" by eval
  moreover have "odd(degree b kon_graph)" by eval
  moreover have "odd(degree c kon_graph)" by eval
  moreover have "odd(degree d kon_graph)" by eval
  ultimately have "\<not>(num_of_odd_nodes kon_graph =2)" by eval
  moreover have "\<not>(\<forall>v\<in>nodes kon_graph. even (degree v kon_graph))" by eval
  ultimately show False using contra by auto
qed

section\<open>Sufficient conditions for Eulerian trails and circuits\<close>

lemma (in valid_unMultigraph) eulerian_cons:
  assumes
    "valid_unMultigraph.is_Eulerian_trail (del_unEdge v0 w v1 G) v1 ps v2"
    "(v0,w,v1)\<in> E"
  shows "is_Eulerian_trail v0 ((v0,w,v1)#ps) v2"
proof -
  have valid:"valid_unMultigraph (del_unEdge v0 w v1 G)"
    using  valid_unMultigraph_axioms by auto
  hence distinct:"valid_unMultigraph.is_trail (del_unEdge v0 w v1 G) v1 ps v2"
    using assms unfolding valid_unMultigraph.is_Eulerian_trail_def[OF valid]
    by auto
  hence "set ps \<subseteq> edges (del_unEdge v0 w v1 G)"
    using valid_unMultigraph.path_in_edges[OF valid] by auto
  moreover have "(v0,w,v1)\<notin>edges (del_unEdge v0 w v1 G)"
    unfolding del_unEdge_def by auto
  moreover have "(v1,w,v0)\<notin>edges (del_unEdge v0 w v1 G)"
    unfolding del_unEdge_def by auto
  ultimately have "(v0,w,v1)\<notin>set ps" "(v1,w,v0)\<notin>set ps"  by auto
  moreover have "is_trail v1 ps v2"
    using distinct_path_intro[OF distinct] .
  ultimately have "is_trail v0 ((v0,w,v1)#ps) v2"
    using \<open>(v0,w,v1)\<in> E\<close> by auto
  moreover have "edges (rem_unPath ps (del_unEdge v0 w v1 G)) ={}"
    using assms unfolding valid_unMultigraph.is_Eulerian_trail_def[OF valid]
    by auto
  hence "edges (rem_unPath ((v0,w,v1)#ps) G)={}"
    by (metis rem_unPath.simps(2))
  ultimately show ?thesis unfolding is_Eulerian_trail_def by auto
qed

lemma (in valid_unMultigraph) eulerian_cons':
  assumes
    "valid_unMultigraph.is_Eulerian_trail (del_unEdge v2 w v3 G) v1 ps v2"
    "(v2,w,v3)\<in> E"
  shows "is_Eulerian_trail v1 (ps@[(v2,w,v3)]) v3"
proof -
  have valid:"valid_unMultigraph (del_unEdge v3 w v2 G)"
    using valid_unMultigraph_axioms del_unEdge_valid by auto
  have "del_unEdge v2 w v3 G=del_unEdge v3 w v2 G"
    by (metis delete_edge_sym)
  hence "valid_unMultigraph.is_Eulerian_trail (del_unEdge v3 w v2 G) v2
        (rev_path ps) v1" using assms valid_unMultigraph.euclerian_rev[OF valid]
    by auto
  hence "is_Eulerian_trail v3 ((v3,w,v2)#(rev_path ps)) v1"
    using eulerian_cons by (metis assms(2) corres)
  hence "is_Eulerian_trail v1 (rev_path((v3,w,v2)#(rev_path ps))) v3"
    using euclerian_rev by auto
  moreover have "rev_path((v3,w,v2)#(rev_path ps)) = rev_path(rev_path ps)@[(v2,w,v3)]"
    unfolding rev_path_def by auto
  hence "rev_path((v3,w,v2)#(rev_path ps))=ps@[(v2,w,v3)]" by auto
  ultimately show ?thesis by auto
qed

lemma eulerian_split:
  assumes "nodes G1 \<inter> nodes G2 = {}" "edges G1 \<inter> edges G2={}"
    "valid_unMultigraph G1" "valid_unMultigraph G2"
    "valid_unMultigraph.is_Eulerian_trail  G1 v1 ps1 v1'"
    "valid_unMultigraph.is_Eulerian_trail  G2 v2 ps2 v2'"
  shows "valid_unMultigraph.is_Eulerian_trail \<lparr>nodes=nodes G1 \<union> nodes G2,
          edges=edges G1 \<union> edges G2 \<union> {(v1',w,v2),(v2,w,v1')}\<rparr> v1 (ps1@(v1',w,v2)#ps2) v2'"
proof -
  have "valid_graph G1" using \<open>valid_unMultigraph G1\<close> valid_unMultigraph_def by auto
  have "valid_graph G2" using \<open>valid_unMultigraph G2\<close> valid_unMultigraph_def by auto
  obtain G where G:"G=\<lparr>nodes=nodes G1 \<union> nodes G2, edges=edges G1 \<union> edges G2
      \<union> {(v1',w,v2),(v2,w,v1')}\<rparr>"
    by metis
  have "v1'\<in>nodes G1"
    by (metis (full_types) \<open>valid_graph G1\<close> assms(3) assms(5) valid_graph.is_path_memb
        valid_unMultigraph.is_trail_intro valid_unMultigraph.is_Eulerian_trail_def)
  moreover have "v2\<in>nodes G2"
    by (metis (full_types) \<open>valid_graph G2\<close> assms(4) assms(6) valid_graph.is_path_memb
        valid_unMultigraph.is_trail_intro valid_unMultigraph.is_Eulerian_trail_def)
  ultimately have "valid_unMultigraph \<lparr>nodes=nodes G1 \<union> nodes G2, edges=edges G1 \<union> edges G2 \<union>
                   {(v1',w,v2),(v2,w,v1')}\<rparr>"
    using
      valid_unMultigraph.corres[OF \<open>valid_unMultigraph G1\<close>]
      valid_unMultigraph.no_id[OF \<open>valid_unMultigraph G1\<close>]
      valid_unMultigraph.corres[OF \<open>valid_unMultigraph G2\<close>]
      valid_unMultigraph.no_id[OF \<open>valid_unMultigraph G2\<close>]
      valid_graph.E_validD[OF \<open>valid_graph G1\<close>]
      valid_graph.E_validD[OF \<open>valid_graph G2\<close>]
      \<open>nodes G1 \<inter> nodes G2 = {}\<close>
    proof (unfold_locales,auto)
      fix aa ab ba
      assume  "(aa, ab, ba) \<in> edges G1"
      thus "ba \<in> nodes G1" by (metis \<open>\<And>v' v e. (v, e, v') \<in> edges G1 \<Longrightarrow> v' \<in> nodes G1\<close>)
    next
      fix aa ab ba
      assume "ba \<notin> nodes G2"  "(aa, ab, ba) \<in> edges G2"
      thus "ba \<in> nodes G1" by (metis \<open>valid_graph G2\<close> valid_graph.E_validD(2))
    qed
  hence valid: "valid_unMultigraph G" using G by auto
  hence valid':"valid_graph G" using valid_unMultigraph_def by auto
  moreover have "valid_unMultigraph.is_trail G v1 (ps1@((v1',w,v2)#ps2)) v2'"
    proof -
      have ps1_G:"valid_unMultigraph.is_trail G v1 ps1 v1'"
        proof -
          have "valid_unMultigraph.is_trail G1 v1 ps1 v1'" using assms
            by (metis valid_unMultigraph.is_Eulerian_trail_def)
          moreover have "edges G1 \<subseteq> edges G" by (metis G UnI1 Un_assoc select_convs(2) subrelI)
          moreover have "nodes G1 \<subseteq> nodes G" by (metis G inf_sup_absorb le_iff_inf select_convs(1))
          ultimately show ?thesis
            using distinct_path_subset[of G1 G,OF \<open>valid_unMultigraph G1\<close> valid] by auto
        qed
      have ps2_G:"valid_unMultigraph.is_trail G v2 ps2 v2'"
        proof -
          have "valid_unMultigraph.is_trail G2 v2 ps2 v2'" using assms
            by (metis valid_unMultigraph.is_Eulerian_trail_def)
          moreover have "edges G2 \<subseteq> edges G" by (metis G inf_sup_ord(3) le_supE select_convs(2))
          moreover have "nodes G2 \<subseteq> nodes G" by (metis G inf_sup_ord(4) select_convs(1))
          ultimately show ?thesis
            using distinct_path_subset[of G2 G,OF \<open>valid_unMultigraph G2\<close> valid] by auto
        qed
      have "valid_graph.is_path G v1 (ps1@((v1',w,v2)#ps2)) v2'"
        proof -
          have "valid_graph.is_path  G v1 ps1 v1'"
            by (metis ps1_G valid valid_unMultigraph.is_trail_intro)
          moreover have "valid_graph.is_path G v2 ps2 v2'"
            by (metis ps2_G valid valid_unMultigraph.is_trail_intro)
          moreover have "(v1',w,v2) \<in> edges G"
            using G by auto
          ultimately show ?thesis
            using valid_graph.is_path_split'[OF valid',of v1 ps1 v1' w v2 ps2 v2'] by auto
        qed
      moreover have "distinct (ps1@((v1',w,v2)#ps2))"
        proof -
          have "distinct ps1" by (metis ps1_G valid valid_unMultigraph.is_trail_path)
          moreover have "distinct ps2"
            by (metis ps2_G valid valid_unMultigraph.is_trail_path)
          moreover have "set ps1 \<inter> set ps2 = {}"
            proof -
              have "set ps1 \<subseteq>edges G1"
                by (metis assms(3) assms(5) valid_unMultigraph.is_Eulerian_trail_def
                    valid_unMultigraph.path_in_edges)
              moreover have "set ps2 \<subseteq> edges G2"
                by (metis assms(4) assms(6) valid_unMultigraph.is_Eulerian_trail_def
                    valid_unMultigraph.path_in_edges)
              ultimately show ?thesis using \<open>edges G1 \<inter> edges G2={}\<close> by auto
            qed
          moreover have "(v1',w,v2)\<notin>edges G1"
            using \<open>v2 \<in> nodes G2\<close> \<open>valid_graph G1\<close>
            by (metis Int_iff  all_not_in_conv assms(1) valid_graph.E_validD(2))
          hence "(v1',w,v2)\<notin>set ps1"
            by (metis (full_types) assms(3) assms(5) subsetD valid_unMultigraph.path_in_edges
                valid_unMultigraph.is_Eulerian_trail_def )
          moreover have "(v1',w,v2)\<notin>edges G2"
            using \<open>v1' \<in> nodes G1\<close> \<open>valid_graph G2\<close>
            by (metis  assms(1) disjoint_iff_not_equal valid_graph.E_validD(1))
          hence  "(v1',w,v2)\<notin>set ps2"
            by (metis (full_types)  assms(4) assms(6) in_mono valid_unMultigraph.path_in_edges
                valid_unMultigraph.is_Eulerian_trail_def )
          ultimately show ?thesis using distinct_append by auto
        qed
      moreover have "set (ps1@((v1',w,v2)#ps2)) \<inter> set (rev_path (ps1@((v1',w,v2)#ps2))) = {}"
        proof -
          have "set ps1 \<inter> set (rev_path ps1) = {}"
            by (metis ps1_G valid valid_unMultigraph.is_trail_path)
          moreover have "set (rev_path ps2) \<subseteq> edges G2"
            by (metis assms(4) assms(6) valid_unMultigraph.is_trail_rev
                valid_unMultigraph.is_Eulerian_trail_def valid_unMultigraph.path_in_edges)
          hence "set ps1 \<inter> set (rev_path ps2) = {}"
            using assms
              valid_unMultigraph.path_in_edges[OF \<open>valid_unMultigraph G1\<close>, of v1 ps1 v1']
              valid_unMultigraph.path_in_edges[OF \<open>valid_unMultigraph G2\<close>, of v2 ps2 v2']
            unfolding valid_unMultigraph.is_Eulerian_trail_def[OF \<open>valid_unMultigraph G1\<close>]
              valid_unMultigraph.is_Eulerian_trail_def[OF \<open>valid_unMultigraph G2\<close>]
            by auto
          moreover have "set ps2 \<inter> set (rev_path ps2) = {}"
            by (metis ps2_G valid valid_unMultigraph.is_trail_path)
          moreover have "set (rev_path ps1) \<subseteq>edges G1"
            by (metis assms(3) assms(5) valid_unMultigraph.is_Eulerian_trail_def
                valid_unMultigraph.path_in_edges valid_unMultigraph.euclerian_rev)
          hence "set ps2 \<inter> set (rev_path ps1) = {}"
            by (metis calculation(2) distinct_append distinct_rev_path ps1_G ps2_G rev_path_append
              rev_path_double valid valid_unMultigraph.is_trail_path)
          moreover have "(v2,w,v1')\<notin>set (ps1@((v1',w,v2)#ps2))"
            proof -
              have "(v2,w,v1')\<notin>edges G1"
                using \<open>v2 \<in> nodes G2\<close> \<open>valid_graph G1\<close>
                by (metis Int_iff  all_not_in_conv assms(1) valid_graph.E_validD(1))
              hence "(v2,w,v1')\<notin>set ps1"
                by (metis assms(3) assms(5) split_list valid_unMultigraph.is_trail_split'
                    valid_unMultigraph.is_Eulerian_trail_def)
              moreover have "(v2,w,v1')\<notin>edges G2"
                using \<open>v1' \<in> nodes G1\<close> \<open>valid_graph G2\<close>
                by (metis IntI assms(1) empty_iff valid_graph.E_validD(2))
              hence "(v2,w,v1')\<notin>set ps2"
                by (metis (full_types) assms(4) assms(6) in_mono  valid_unMultigraph.path_in_edges
                    valid_unMultigraph.is_Eulerian_trail_def)
              moreover have "(v2,w,v1')\<noteq>(v1',w,v2)"
                using \<open>v1' \<in> nodes G1\<close> \<open>v2 \<in> nodes G2\<close>
                by (metis IntI Pair_inject  assms(1) assms(5) bex_empty)
              ultimately show ?thesis by auto
            qed
          ultimately show ?thesis using rev_path_append by auto
        qed
      ultimately show ?thesis using valid_unMultigraph.is_trail_path[OF valid]
        by auto
    qed
  moreover have "edges (rem_unPath (ps1@((v1',w,v2)#ps2)) G)= {}"
    proof -
      have "edges (rem_unPath (ps1@((v1',w,v2)#ps2)) G)=edges G -
           (set (ps1@((v1',w,v2)#ps2)) \<union> set (rev_path (ps1@((v1',w,v2)#ps2))))"
        by (metis rem_unPath_edges)
      also have "...=edges G - (set ps1 \<union> set ps2 \<union> set (rev_path ps1) \<union> set (rev_path ps2)
                 \<union> {(v1',w,v2),(v2,w,v1')})" using rev_path_append by auto
      finally have "edges (rem_unPath (ps1@((v1',w,v2)#ps2)) G) = edges G - (set ps1 \<union>
                    set ps2 \<union> set (rev_path ps1) \<union> set (rev_path ps2) \<union> {(v1',w,v2),(v2,w,v1')})" .
      moreover have "edges (rem_unPath ps1 G1)={}"
        by (metis assms(3) assms(5) valid_unMultigraph.is_Eulerian_trail_def)
      hence "edges G1 - (set ps1 \<union> set (rev_path ps1))={}"
        by (metis rem_unPath_edges)
      moreover have "edges (rem_unPath ps2 G2)={}"
        by (metis assms(4) assms(6) valid_unMultigraph.is_Eulerian_trail_def)
      hence "edges G2 - (set ps2 \<union> set (rev_path ps2))={}"
        by (metis rem_unPath_edges)
      ultimately show ?thesis using G by auto
    qed
  ultimately show ?thesis by (metis G valid valid_unMultigraph.is_Eulerian_trail_def)
qed


section \<open>CCW for Nonaligned Points in the Plane\<close>
theory Counterclockwise_2D_Strict
  imports
    Counterclockwise_Vector
    Affine_Arithmetic_Auxiliarities
begin
text \<open>\label{sec:counterclockwise2d}\<close>

subsection \<open>Determinant\<close>

type_synonym point = "real*real"

fun det3::"point \<Rightarrow> point \<Rightarrow> point \<Rightarrow> real" where "det3 (xp, yp) (xq, yq) (xr, yr) =
  xp * yq + yp * xr + xq * yr - yq * xr - yp * xq - xp * yr"

lemma det3_def':
  "det3 p q r = fst p * snd q + snd p * fst r + fst q * snd r -
    snd q * fst r - snd p * fst q - fst p * snd r"
  by (cases p q r rule: prod.exhaust[case_product prod.exhaust[case_product prod.exhaust]]) auto

lemma det3_eq_det: "det3 (xa, ya) (xb, yb) (xc, yc) =
  det (vector [vector [xa, ya, 1], vector [xb, yb, 1], vector [xc, yc, 1]]::real^3^3)"
  unfolding Determinants.det_def UNIV_3
  by (auto simp: sum_over_permutations_insert
    vector_3 sign_swap_id permutation_swap_id sign_compose)

declare det3.simps[simp del]

lemma det3_self23[simp]: "det3 a b b = 0"
  and det3_self12[simp]: "det3 b b a = 0"
  by (auto simp: det3_def')

lemma
  coll_ex_scaling:
  assumes "b \<noteq> c"
  assumes d: "det3 a b c = 0"
  shows "\<exists>r. a = b + r *\<^sub>R (c - b)"
proof -
  from assms have "fst b \<noteq> fst c \<or> snd b \<noteq> snd c" by (auto simp: prod_eq_iff)
  thus ?thesis
  proof
    assume neq: "fst b \<noteq> fst c"
    with d have "snd a = ((fst a - fst b) * snd c + (fst c - fst a) * snd b) / (fst c - fst b)"
      by (auto simp: det3_def' field_simps)
    hence "snd a = ((fst a - fst b)/ (fst c - fst b)) * snd c +
      ((fst c - fst a)/ (fst c - fst b)) * snd b"
      by (simp add: add_divide_distrib)
    hence "snd a = snd b + (fst a - fst b) * snd c / (fst c - fst b) +
      ((fst c - fst a) - (fst c - fst b)) * snd b / (fst c - fst b)"
      using neq
      by (simp add: field_simps)
    hence "snd a = snd b + ((fst a - fst b) * snd c + (- fst a + fst b) * snd b) / (fst c - fst b)"
      unfolding add_divide_distrib
      by (simp add: algebra_simps)
    also
    have "(fst a - fst b) * snd c + (- fst a + fst b) * snd b = (fst a - fst b) * (snd c - snd b)"
      by (simp add: algebra_simps)
    finally have "snd a = snd b + (fst a - fst b) / (fst c - fst b) * (snd c - snd b)"
      by simp
    moreover
    hence "fst a = fst b + (fst a - fst b) / (fst c - fst b) * (fst c - fst b)"
      using neq by simp
    ultimately have "a = b + ((fst a - fst b) / (fst c - fst b)) *\<^sub>R (c - b)"
      by (auto simp: prod_eq_iff)
    thus ?thesis by blast
  next
    assume neq: "snd b \<noteq> snd c"
    with d have "fst a = ((snd a - snd b) * fst c + (snd c - snd a) * fst b) / (snd c - snd b)"
      by (auto simp: det3_def' field_simps)
    hence "fst a = ((snd a - snd b)/ (snd c - snd b)) * fst c +
      ((snd c - snd a)/ (snd c - snd b)) * fst b"
      by (simp add: add_divide_distrib)
    hence "fst a = fst b + (snd a - snd b) * fst c / (snd c - snd b) +
      ((snd c - snd a) - (snd c - snd b)) * fst b / (snd c - snd b)"
      using neq
      by (simp add: field_simps)
    hence "fst a = fst b + ((snd a - snd b) * fst c + (- snd a + snd b) * fst b) / (snd c - snd b)"
      unfolding add_divide_distrib
      by (simp add: algebra_simps)
    also
    have "(snd a - snd b) * fst c + (- snd a + snd b) * fst b = (snd a - snd b) * (fst c - fst b)"
      by (simp add: algebra_simps)
    finally have "fst a = fst b + (snd a - snd b) / (snd c - snd b) * (fst c - fst b)"
      by simp
    moreover
    hence "snd a = snd b + (snd a - snd b) / (snd c - snd b) * (snd c - snd b)"
      using neq by simp
    ultimately have "a = b + ((snd a - snd b) / (snd c - snd b)) *\<^sub>R (c - b)"
      by (auto simp: prod_eq_iff)
    thus ?thesis by blast
  qed
qed

lemma cramer: "\<not>det3 s t q = 0 \<Longrightarrow>
  (det3 t p r) = ((det3 t q r) * (det3 s t p) + (det3 t p q) * (det3 s t r))/(det3 s t q)"
  by (auto simp: det3_def' field_simps)

lemma convex_comb_dets:
  assumes "det3 p q r > 0"
  shows "s = (det3 s q r / det3 p q r) *\<^sub>R p + (det3 p s r /  det3 p q r) *\<^sub>R q +
      (det3 p q s / det3 p q r) *\<^sub>R r"
    (is "?lhs = ?rhs")
proof -
  from assms have "det3 p q r *\<^sub>R ?lhs = det3 p q r *\<^sub>R ?rhs"
    by (simp add: field_simps prod_eq_iff scaleR_add_right) (simp add: algebra_simps det3_def')
  thus ?thesis using assms by simp
qed

lemma four_points_aligned:
  assumes c: "det3 t p q = 0" "det3 t q r = 0"
  assumes distinct: "distinct5 t s p q r"
  shows "det3 t r p = 0" "det3 p q r = 0"
proof -
  from distinct have d: "p \<noteq> q" "q \<noteq> r" by (auto)
  from coll_ex_scaling[OF d(1) c(1)] obtain s1 where s1: "t = p + s1 *\<^sub>R (q - p)" by auto
  from coll_ex_scaling[OF d(2) c(2)] obtain s2 where s2: "t = q + s2 *\<^sub>R (r - q)" by auto
  from distinct s1 have ne: "1 - s1 \<noteq> 0" by auto
  from s1 s2 have "(1 - s1) *\<^sub>R p = (1 - s1 - s2) *\<^sub>R q + s2 *\<^sub>R r"
    by (simp add: algebra_simps)
  hence "(1 - s1) *\<^sub>R p /\<^sub>R (1 - s1)= ((1 - s1 - s2) *\<^sub>R q + s2 *\<^sub>R r) /\<^sub>R (1 - s1)"
    by simp
  with ne have p: "p = ((1 - s1 - s2) / (1 - s1)) *\<^sub>R q + (s2 / (1 - s1)) *\<^sub>R r"
    using ne
    by (simp add: prod_eq_iff inverse_eq_divide add_divide_distrib)
  define k1 where "k1 = (1 - s1 - s2) / (1 - s1)"
  define k2 where "k2 = s2 / (1 - s1)"
  have "det3 t r p = det3 0 (k1 *\<^sub>R q + (k2 - 1) *\<^sub>R r)
    (k1 *\<^sub>R q + (k2 - 1) *\<^sub>R r + (- s1 * (k1 - 1)) *\<^sub>R q - (s1 * k2) *\<^sub>R r)"
    unfolding s1 p k1_def[symmetric] k2_def[symmetric]
    by (simp add: algebra_simps det3_def')
  also have "- s1 * (k1 - 1) = s1 * k2"
    using ne by (auto simp: k1_def field_simps k2_def)
  also
  have "1 - k1 = k2"
    using ne
    by (auto simp: k2_def k1_def field_simps)
  have k21: "k2 - 1 = -k1"
    using ne
    by (auto simp: k2_def k1_def field_simps)
  finally have "det3 t r p = det3 0 (k1 *\<^sub>R (q - r)) ((k1 + (s1 * k2)) *\<^sub>R (q - r))"
    by (auto simp: algebra_simps)
  also have "\<dots> = 0"
    by (simp add: algebra_simps det3_def')
  finally show "det3 t r p = 0" .
  have "det3 p q r = det3 (k1 *\<^sub>R q + k2 *\<^sub>R r) q r"
    unfolding p k1_def[symmetric] k2_def[symmetric] ..
  also have "\<dots> = det3 0 (r - q) (k1 *\<^sub>R q + (-k1) *\<^sub>R r)"
    unfolding k21[symmetric]
    by (auto simp: algebra_simps det3_def')
  also have "\<dots> = det3 0 (r - q) (-k1 *\<^sub>R (r - q))"
    by (auto simp: det3_def' algebra_simps)
  also have "\<dots> = 0"
    by (auto simp: det3_def')
  finally show "det3 p q r = 0" .
qed

lemma det_identity:
  "det3 t p q * det3 t s r + det3 t q r * det3 t s p + det3 t r p * det3 t s q = 0"
  by (auto simp: det3_def' algebra_simps)

lemma det3_eq_zeroI:
  assumes "p = q + x *\<^sub>R (t - q)"
  shows "det3 q t p = 0"
  unfolding assms
  by (auto simp: det3_def' algebra_simps)

lemma det3_rotate: "det3 a b c = det3 c a b"
  by (auto simp: det3_def')

lemma det3_switch: "det3 a b c = - det3 a c b"
  by (auto simp: det3_def')

lemma det3_switch': "det3 a b c = - det3 b a c"
  by (auto simp: det3_def')

lemma det3_pos_transitive_coll:
  "det3 t s p > 0 \<Longrightarrow> det3 t s r \<ge> 0 \<Longrightarrow> det3 t p q \<ge> 0 \<Longrightarrow>
  det3 t q r > 0 \<Longrightarrow> det3 t s q = 0 \<Longrightarrow> det3 t p r > 0"
  using det_identity[of t p q s r]
  by (metis add.commute add_less_same_cancel1 det3_switch det3_switch' less_eq_real_def
    less_not_sym monoid_add_class.add.left_neutral mult_pos_pos mult_zero_left mult_zero_right)

lemma det3_pos_transitive:
  "det3 t s p > 0 \<Longrightarrow> det3 t s q \<ge> 0 \<Longrightarrow> det3 t s r \<ge> 0 \<Longrightarrow> det3 t p q \<ge> 0 \<Longrightarrow>
  det3 t q r > 0 \<Longrightarrow> det3 t p r > 0"
  apply (cases "det3 t s q \<noteq> 0")
   using cramer[of q t s p r]
   apply (force simp: det3_rotate[of q t p] det3_rotate[of p q t] det3_switch[of t p s]
     det3_switch'[of q t r] det3_rotate[of q t s] det3_rotate[of s q t]
     intro!: divide_pos_pos add_nonneg_pos)
  apply (metis det3_pos_transitive_coll)
  done

lemma det3_zero_translate_plus[simp]: "det3 (a + x) (b + x) (c + x) = 0 \<longleftrightarrow> det3 a b c = 0"
  by (auto simp: algebra_simps det3_def')

lemma det3_zero_translate_plus'[simp]: "det3 (a) (a + b) (a + c) = 0 \<longleftrightarrow> det3 0 b c = 0"
  by (auto simp: algebra_simps det3_def')

lemma
  det30_zero_scaleR1:
  "0 < e \<Longrightarrow> det3 0 xr P = 0 \<Longrightarrow> det3 0 (e *\<^sub>R xr) P = 0"
  by (auto simp: zero_prod_def algebra_simps det3_def')

lemma det3_same[simp]: "det3 a x x = 0"
  by (auto simp: det3_def')

lemma
  det30_zero_scaleR2:
  "0 < e \<Longrightarrow> det3 0 P xr = 0 \<Longrightarrow> det3 0 P (e *\<^sub>R xr) = 0"
  by (auto simp: zero_prod_def algebra_simps det3_def')

lemma det30_plus_scaled3[simp]: "det3 0 a (b + x *\<^sub>R a) = 0 \<longleftrightarrow> det3 0 a b = 0"
  by (auto simp: det3_def' algebra_simps)

lemma det30_plus_scaled2[simp]:
  shows "det3 0 (a + x *\<^sub>R a) b = 0 \<longleftrightarrow> (if x = -1 then True else det3 0 a b = 0)"
    (is "?lhs = ?rhs")
proof
  assume "det3 0 (a + x *\<^sub>R a) b = 0"
  hence "fst a * snd b * (1 + x) = fst b * snd a * (1 + x)"
    by (simp add: algebra_simps det3_def')
  thus ?rhs
    by (auto simp add: det3_def')
qed (auto simp: det3_def' algebra_simps split: if_split_asm)

lemma det30_uminus2[simp]: "det3 0 (-a) (b) = 0 \<longleftrightarrow> det3 0 a b = 0"
  and det30_uminus3[simp]: "det3 0 a (-b) = 0 \<longleftrightarrow> det3 0 a b = 0"
  by (auto simp: det3_def' algebra_simps)

lemma det30_minus_scaled3[simp]: "det3 0 a (b - x *\<^sub>R a) = 0 \<longleftrightarrow> det3 0 a b = 0"
  using det30_plus_scaled3[of a b "-x"] by simp

lemma det30_scaled_minus3[simp]: "det3 0 a (e *\<^sub>R a - b) = 0 \<longleftrightarrow> det3 0 a b = 0"
  using det30_plus_scaled3[of a "-b" e]
  by (simp add: algebra_simps)

lemma det30_minus_scaled2[simp]:
  "det3 0 (a - x *\<^sub>R a) b = 0 \<longleftrightarrow> (if x = 1 then True else det3 0 a b = 0)"
  using det30_plus_scaled2[of a  "-x" b] by simp

lemma det3_nonneg_scaleR1:
  "0 < e \<Longrightarrow> det3 0 xr P \<ge> 0 \<Longrightarrow> det3 0 (e*\<^sub>Rxr) P \<ge> 0"
  by (auto simp add: det3_def' algebra_simps)

lemma det3_nonneg_scaleR1_eq:
  "0 < e \<Longrightarrow> det3 0 (e*\<^sub>Rxr) P \<ge> 0 \<longleftrightarrow> det3 0 xr P \<ge> 0"
  by (auto simp add: det3_def' algebra_simps)

lemma det3_translate_origin: "NO_MATCH 0 p \<Longrightarrow> det3 p q r = det3 0 (q - p) (r - p)"
  by (auto simp: det3_def' algebra_simps)

lemma det3_nonneg_scaleR_segment2:
  assumes "det3 x y z \<ge> 0"
  assumes "a > 0"
  shows "det3 x ((1 - a) *\<^sub>R x + a *\<^sub>R y) z \<ge> 0"
proof -
  from assms have "0 \<le> det3 0 (a *\<^sub>R (y - x)) (z - x)"
    by (intro det3_nonneg_scaleR1) (simp_all add: det3_translate_origin)
  thus ?thesis
    by (simp add: algebra_simps det3_translate_origin)
qed

lemma det3_nonneg_scaleR_segment1:
  assumes "det3 x y z \<ge> 0"
  assumes "0 \<le> a" "a < 1"
  shows "det3 ((1 - a) *\<^sub>R x + a *\<^sub>R y) y z \<ge> 0"
proof -
  from assms have "det3 0 ((1 - a) *\<^sub>R (y - x)) (z - x + (- a) *\<^sub>R (y - x)) \<ge> 0"
    by (subst det3_nonneg_scaleR1_eq) (auto simp add: det3_def' algebra_simps)
  thus ?thesis
    by (auto simp: algebra_simps det3_translate_origin)
qed

subsection \<open>Strict CCW Predicate\<close>

definition "ccw' p q r \<longleftrightarrow> 0 < det3 p q r"

interpretation ccw': ccw_vector_space ccw'
  by unfold_locales (auto simp: ccw'_def det3_def' algebra_simps)

interpretation ccw': linorder_list0 "ccw' x" for x .

lemma ccw'_contra: "ccw' t r q \<Longrightarrow> ccw' t q r = False"
  by (auto simp: ccw'_def det3_def' algebra_simps)

lemma not_ccw'_eq: "\<not> ccw' t p s \<longleftrightarrow> ccw' t s p \<or> det3 t s p = 0"
  by (auto simp: ccw'_def det3_def' algebra_simps)

lemma neq_left_right_of: "ccw' a b c \<Longrightarrow> ccw' a c d \<Longrightarrow> b \<noteq> d"
  by (auto simp: ccw'_def det3_def' algebra_simps)

lemma ccw'_subst_collinear:
  assumes "det3 t r s = 0"
  assumes "s \<noteq> t"
  assumes "ccw' t r p"
  shows "ccw' t s p \<or> ccw' t p s"
proof cases
  assume "r \<noteq> s"
  from assms have "det3 r s t = 0"
    by (auto simp: algebra_simps det3_def')
  from coll_ex_scaling[OF assms(2) this]
  obtain x where s: "r = s + x *\<^sub>R (t - s)" by auto
  from assms(3)[simplified ccw'_def s]
  have "0 < det3 0 (s + x *\<^sub>R (t - s) - t) (p - t)"
    by (auto simp: algebra_simps det3_def')
  also have "s + x *\<^sub>R (t - s) - t = (1 - x) *\<^sub>R (s - t)"
    by (simp add: algebra_simps)
  finally have ccw': "ccw' 0 ((1 - x) *\<^sub>R (s - t)) (p - t)"
    by (simp add: ccw'_def)
  hence "x \<noteq> 1" by (auto simp add: det3_def' ccw'_def)
  {
    assume "x < 1"
    hence ?thesis using ccw'
      by (auto simp: not_ccw'_eq ccw'.translate_origin)
  } moreover {
    assume "x > 1"
    hence ?thesis using ccw'
      by (auto simp: not_ccw'_eq ccw'.translate_origin)
  } ultimately show ?thesis using \<open>x \<noteq> 1\<close> by arith
qed (insert assms, simp)

lemma ccw'_sorted_scaleR: "ccw'.sortedP 0 xs \<Longrightarrow> r > 0 \<Longrightarrow> ccw'.sortedP 0 (map ((*\<^sub>R) r) xs)"
  by (induct xs) (auto intro!: ccw'.sortedP.Cons  elim!: ccw'.sortedP_Cons simp del: scaleR_Pair)

subsection \<open>Collinearity\<close>

abbreviation "coll a b c \<equiv> det3 a b c = 0"

lemma coll_zero[intro, simp]: "coll 0 z 0"
  by (auto simp: det3_def')

lemma coll_zero1[intro, simp]: "coll 0 0 z"
  by (auto simp: det3_def')

lemma coll_self[intro, simp]: "coll 0 z z"
  by (auto simp: )

lemma ccw'_not_coll:
  "ccw' a b c \<Longrightarrow> \<not>coll a b c"
  "ccw' a b c \<Longrightarrow> \<not>coll a c b"
  "ccw' a b c \<Longrightarrow> \<not>coll b a c"
  "ccw' a b c \<Longrightarrow> \<not>coll b c a"
  "ccw' a b c \<Longrightarrow> \<not>coll c a b"
  "ccw' a b c \<Longrightarrow> \<not>coll c b a"
  by (auto simp: det3_def' ccw'_def algebra_simps)

lemma coll_add: "coll 0 x y \<Longrightarrow> coll 0 x z \<Longrightarrow> coll 0 x (y + z)"
  by (auto simp: det3_def' algebra_simps)

lemma coll_scaleR_left_eq[simp]: "coll 0 (r *\<^sub>R x) y \<longleftrightarrow> r = 0 \<or> coll 0 x y"
  by (auto simp: det3_def' algebra_simps)

lemma coll_scaleR_right_eq[simp]: "coll 0 y (r *\<^sub>R x) \<longleftrightarrow> r = 0 \<or> coll 0 y x"
  by (auto simp: det3_def' algebra_simps)

lemma coll_scaleR: "coll 0 x y \<Longrightarrow> coll 0 (r *\<^sub>R x) y"
  by (auto simp: det3_def' algebra_simps)

lemma coll_sum_list: "(\<And>y. y \<in> set ys \<Longrightarrow> coll 0 x y) \<Longrightarrow> coll 0 x (sum_list ys)"
  by (induct ys) (auto intro!: coll_add)

lemma scaleR_left_normalize:
  fixes a ::real and b c::"'a::real_vector"
  shows "a *\<^sub>R b = c \<longleftrightarrow> (if a = 0 then c = 0 else b = c /\<^sub>R a)"
  by (auto simp: field_simps)

lemma coll_scale: "coll 0 r q \<Longrightarrow> r \<noteq> 0 \<Longrightarrow> (\<exists>x. q = x *\<^sub>R r)"
  using coll_scale_pair[of "fst r" "snd r" "fst q" "snd q"]
  by simp

lemma coll_add_trans:
  assumes "coll 0 x (y + z)"
  assumes "coll 0 y z"
  assumes "x \<noteq> 0"
  assumes "y \<noteq> 0"
  assumes "z \<noteq> 0"
  assumes "y + z \<noteq> 0"
  shows "coll 0 x z"
proof (cases "snd z = 0")
  case True
  hence "snd y = 0"
    using assms
    by (cases z) (auto simp add: zero_prod_def det3_def')
  with True assms have "snd x = 0"
    by (cases y, cases z) (auto simp add: zero_prod_def det3_def')
  from \<open>snd x = 0\<close> \<open>snd y = 0\<close> \<open>snd z = 0\<close>
  show ?thesis
    by (auto simp add: zero_prod_def det3_def')
next
  case False
  note z = False
  hence "snd y \<noteq> 0"
    using assms
    by (cases y) (auto simp add: zero_prod_def det3_def')
  with False assms have "snd x \<noteq> 0"
    apply (cases x)
    apply (cases y)
    apply (cases z)
    apply (auto simp add: zero_prod_def det3_def')
    apply (metis mult.commute mult_eq_0_iff ring_class.ring_distribs(1))
    done
  with False assms \<open>snd y \<noteq> 0\<close> have yz: "snd (y + z) \<noteq> 0"
    by (cases x; cases y; cases z) (auto simp add: det3_def' zero_prod_def)
  from coll_scale[OF assms(1) assms(3)] coll_scale[OF assms(2) assms(4)]
  obtain r s where rs: "y + z = r *\<^sub>R x" "z = s *\<^sub>R y"
    by auto
  with z have "s \<noteq> 0"
    by (cases x; cases y; cases z) (auto simp: zero_prod_def)
  with rs z yz have "r \<noteq> 0"
    by (cases x; cases y; cases z) (auto simp: zero_prod_def)
  from \<open>s \<noteq> 0\<close> rs have "y = r *\<^sub>R x - z" "y = z /\<^sub>R s"
    by (auto simp: inverse_eq_divide algebra_simps)
  hence "r *\<^sub>R x - z = z /\<^sub>R s" by simp
  hence "r *\<^sub>R x = (1 + inverse s) *\<^sub>R z"
    by (auto simp: inverse_eq_divide algebra_simps)
  hence "x = (inverse r * (1 + inverse s)) *\<^sub>R z"
    using \<open>r \<noteq> 0\<close> \<open>s \<noteq> 0\<close>
    by (auto simp: field_simps scaleR_left_normalize)
  from this
  show ?thesis
    by (auto intro: coll_scaleR)
qed

lemma coll_commute: "coll 0 a b \<longleftrightarrow> coll 0 b a"
  by (metis det3_rotate det3_switch' diff_0 diff_self)

lemma coll_add_cancel: "coll 0 a (a + b) \<Longrightarrow> coll 0 a b"
  by (cases a, cases b) (auto simp: det3_def' algebra_simps)

lemma coll_trans:
  "coll 0 a b \<Longrightarrow> coll 0 a c \<Longrightarrow> a \<noteq> 0 \<Longrightarrow> coll 0 b c"
  by (metis coll_scale coll_scaleR)

lemma sum_list_posI:
  fixes xs::"'a::ordered_comm_monoid_add list"
  shows "(\<And>x. x \<in> set xs \<Longrightarrow> x > 0) \<Longrightarrow> xs \<noteq> [] \<Longrightarrow> sum_list xs > 0"
proof (induct xs)
  case (Cons x xs)
  thus ?case
    by (cases "xs = []") (auto intro!: add_pos_pos)
qed simp

lemma nonzero_fstI[intro, simp]: "fst x \<noteq> 0 \<Longrightarrow> x \<noteq> 0"
  and nonzero_sndI[intro, simp]: "snd x \<noteq> 0 \<Longrightarrow> x \<noteq> 0"
  by auto

lemma coll_sum_list_trans:
  "xs \<noteq> [] \<Longrightarrow> coll 0 a (sum_list xs) \<Longrightarrow> (\<And>x. x \<in> set xs \<Longrightarrow> coll 0 x y) \<Longrightarrow>
    (\<And>x. x \<in> set xs \<Longrightarrow> coll 0 x (sum_list xs)) \<Longrightarrow>
    (\<And>x. x \<in> set xs \<Longrightarrow> snd x > 0) \<Longrightarrow> a \<noteq> 0 \<Longrightarrow> coll 0 a y"
proof (induct xs rule: list_nonempty_induct)
  case (single x)
  from single(1) single(2)[of x] single(4)[of x] have "coll 0 x a" "coll 0 x y" "x \<noteq> 0"
    by (auto simp: coll_commute)
  thus ?case by (rule coll_trans)
next
  case (cons x xs)
  from cons(5)[of x] \<open>a \<noteq> 0\<close> cons(6)[of x]
  have *: "coll 0 x (sum_list xs)" "a \<noteq> 0" "x \<noteq> 0" by (force simp add: coll_add_cancel)+
  have "0 < snd (sum_list (x#xs))"
    unfolding snd_sum_list
    by (rule sum_list_posI) (auto intro!: add_pos_pos cons simp: snd_sum_list)
  hence "x + sum_list xs \<noteq> 0" by simp
  from coll_add_trans[OF cons(3)[simplified] * _ this]
  have cH: "coll 0 a (sum_list xs)"
    by (cases "sum_list xs = 0") auto
  from cons(4) have cy: "(\<And>x. x \<in> set xs \<Longrightarrow> coll 0 x y)" by simp
  {
    fix y assume "y \<in> set xs"
    hence "snd (sum_list xs) > 0"
      unfolding snd_sum_list
      by (intro sum_list_posI) (auto intro!: add_pos_pos cons simp: snd_sum_list)
    hence "sum_list xs \<noteq> 0" by simp
    from cons(5)[of x] have "coll 0 x (sum_list xs)"
      by (simp add: coll_add_cancel)
    from cons(5)[of y]
    have "coll 0 y (sum_list xs)"
      using \<open>y \<in> set xs\<close> cons(6)[of y] \<open>x + sum_list xs \<noteq> 0\<close>
      apply (cases "y = x")
      subgoal by (force simp add: coll_add_cancel)
      subgoal by (force simp: dest!: coll_add_trans[OF _ *(1) _ *(3)])
      done
  } note cl = this
  show ?case
    by (rule cons(2)[OF cH cy cl cons(6) \<open>a \<noteq> 0\<close>]) auto
qed

lemma sum_list_coll_ex_scale:
  assumes coll: "\<And>x. x \<in> set xs \<Longrightarrow> coll 0 z x"
  assumes nz: "z \<noteq> 0"
  shows "\<exists>r. sum_list xs = r *\<^sub>R z"
proof -
  {
    fix i assume i: "i < length xs"
    hence nth: "xs ! i \<in> set xs" by simp
    note coll_scale[OF coll[OF nth] \<open>z \<noteq> 0\<close>]
  } then obtain r where r: "\<And>i. i < length xs \<Longrightarrow> r i *\<^sub>R z = xs ! i"
    by metis
  have "xs = map ((!) xs) [0..<length xs]" by (simp add: map_nth)
  also have "\<dots> = map (\<lambda>i. r i *\<^sub>R z) [0..<length xs]"
    by (auto simp: r)
  also have "sum_list \<dots> = (\<Sum>i\<leftarrow>[0..<length xs]. r i) *\<^sub>R z"
    by (simp add: sum_list_sum_nth scaleR_sum_left)
  finally show ?thesis ..
qed

lemma sum_list_filter_coll_ex_scale: "z \<noteq> 0 \<Longrightarrow> \<exists>r. sum_list (filter (coll 0 z) zs) = r *\<^sub>R z"
  by (rule sum_list_coll_ex_scale) simp

end


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

section \<open>Algebraic operations on sets\<close>

theory Set_Algebras
  imports Main
begin

text \<open>
  This library lifts operations like addition and multiplication to sets. It
  was designed to support asymptotic calculations. See the comments at the top
  of \<^file>\<open>BigO.thy\<close>.
\<close>

instantiation set :: (plus) plus
begin

definition plus_set :: "'a::plus set \<Rightarrow> 'a set \<Rightarrow> 'a set"
  where set_plus_def: "A + B = {c. \<exists>a\<in>A. \<exists>b\<in>B. c = a + b}"

instance ..

end

instantiation set :: (times) times
begin

definition times_set :: "'a::times set \<Rightarrow> 'a set \<Rightarrow> 'a set"
  where set_times_def: "A * B = {c. \<exists>a\<in>A. \<exists>b\<in>B. c = a * b}"

instance ..

end

instantiation set :: (zero) zero
begin

definition set_zero[simp]: "(0::'a::zero set) = {0}"

instance ..

end

instantiation set :: (one) one
begin

definition set_one[simp]: "(1::'a::one set) = {1}"

instance ..

end

definition elt_set_plus :: "'a::plus \<Rightarrow> 'a set \<Rightarrow> 'a set"  (infixl "+o" 70)
  where "a +o B = {c. \<exists>b\<in>B. c = a + b}"

definition elt_set_times :: "'a::times \<Rightarrow> 'a set \<Rightarrow> 'a set"  (infixl "*o" 80)
  where "a *o B = {c. \<exists>b\<in>B. c = a * b}"

abbreviation (input) elt_set_eq :: "'a \<Rightarrow> 'a set \<Rightarrow> bool"  (infix "=o" 50)
  where "x =o A \<equiv> x \<in> A"

instance set :: (semigroup_add) semigroup_add
  by standard (force simp add: set_plus_def add.assoc)

instance set :: (ab_semigroup_add) ab_semigroup_add
  by standard (force simp add: set_plus_def add.commute)

instance set :: (monoid_add) monoid_add
  by standard (simp_all add: set_plus_def)

instance set :: (comm_monoid_add) comm_monoid_add
  by standard (simp_all add: set_plus_def)

instance set :: (semigroup_mult) semigroup_mult
  by standard (force simp add: set_times_def mult.assoc)

instance set :: (ab_semigroup_mult) ab_semigroup_mult
  by standard (force simp add: set_times_def mult.commute)

instance set :: (monoid_mult) monoid_mult
  by standard (simp_all add: set_times_def)

instance set :: (comm_monoid_mult) comm_monoid_mult
  by standard (simp_all add: set_times_def)

lemma sumset_empty [simp]: "A + {} = {}" "{} + A = {}"
  by (auto simp: set_plus_def)

lemma Un_set_plus: "(A \<union> B) + C = (A+C) \<union> (B+C)" and set_plus_Un: "C + (A \<union> B) = (C+A) \<union> (C+B)"
  by (auto simp: set_plus_def)

lemma
  fixes A :: "'a::comm_monoid_add set"
  shows insert_set_plus: "(insert a A) + B = (A+B) \<union> (((+)a) ` B)" and set_plus_insert: "B + (insert a A) = (B+A) \<union> (((+)a) ` B)"
  using add.commute by (auto simp: set_plus_def)

lemma set_add_0 [simp]:
  fixes A :: "'a::comm_monoid_add set"
  shows "{0} + A = A"
  by (metis comm_monoid_add_class.add_0 set_zero)

lemma set_add_0_right [simp]:
  fixes A :: "'a::comm_monoid_add set"
  shows "A + {0} = A"
  by (metis add.comm_neutral set_zero)

lemma card_plus_sing:
  fixes A :: "'a::ab_group_add set"
  shows "card (A + {a}) = card A"
proof (rule bij_betw_same_card)
  show "bij_betw ((+) (-a)) (A + {a}) A"
    by (fastforce simp: set_plus_def bij_betw_def image_iff)
qed

lemma set_plus_intro [intro]: "a \<in> C \<Longrightarrow> b \<in> D \<Longrightarrow> a + b \<in> C + D"
  by (auto simp add: set_plus_def)

lemma set_plus_elim:
  assumes "x \<in> A + B"
  obtains a b where "x = a + b" and "a \<in> A" and "b \<in> B"
  using assms unfolding set_plus_def by fast

lemma set_plus_intro2 [intro]: "b \<in> C \<Longrightarrow> a + b \<in> a +o C"
  by (auto simp add: elt_set_plus_def)

lemma set_plus_rearrange: "(a +o C) + (b +o D) = (a + b) +o (C + D)"
  for a b :: "'a::comm_monoid_add"
    by (auto simp: elt_set_plus_def set_plus_def; metis group_cancel.add1 group_cancel.add2)

lemma set_plus_rearrange2: "a +o (b +o C) = (a + b) +o C"
  for a b :: "'a::semigroup_add"
  by (auto simp add: elt_set_plus_def add.assoc)

lemma set_plus_rearrange3: "(a +o B) + C = a +o (B + C)"
  for a :: "'a::semigroup_add"
  by (auto simp add: elt_set_plus_def set_plus_def; metis add.assoc)

theorem set_plus_rearrange4: "C + (a +o D) = a +o (C + D)"
  for a :: "'a::comm_monoid_add"
  by (metis add.commute set_plus_rearrange3)

lemmas set_plus_rearranges = set_plus_rearrange set_plus_rearrange2
  set_plus_rearrange3 set_plus_rearrange4

lemma set_plus_mono [intro!]: "C \<subseteq> D \<Longrightarrow> a +o C \<subseteq> a +o D"
  by (auto simp add: elt_set_plus_def)

lemma set_plus_mono2 [intro]: "C \<subseteq> D \<Longrightarrow> E \<subseteq> F \<Longrightarrow> C + E \<subseteq> D + F"
  for C D E F :: "'a::plus set"
  by (auto simp add: set_plus_def)

lemma set_plus_mono3 [intro]: "a \<in> C \<Longrightarrow> a +o D \<subseteq> C + D"
  by (auto simp add: elt_set_plus_def set_plus_def)

lemma set_plus_mono4 [intro]: "a \<in> C \<Longrightarrow> a +o D \<subseteq> D + C"
  for a :: "'a::comm_monoid_add"
  by (auto simp add: elt_set_plus_def set_plus_def ac_simps)

lemma set_plus_mono5: "a \<in> C \<Longrightarrow> B \<subseteq> D \<Longrightarrow> a +o B \<subseteq> C + D"
  using order_subst2 by blast

lemma set_plus_mono_b: "C \<subseteq> D \<Longrightarrow> x \<in> a +o C \<Longrightarrow> x \<in> a +o D"
  using set_plus_mono by blast

lemma set_zero_plus [simp]: "0 +o C = C"
  for C :: "'a::comm_monoid_add set"
  by (auto simp add: elt_set_plus_def)

lemma set_zero_plus2: "0 \<in> A \<Longrightarrow> B \<subseteq> A + B"
  for A B :: "'a::comm_monoid_add set"
  using set_plus_intro by fastforce

lemma set_plus_imp_minus: "a \<in> b +o C \<Longrightarrow> a - b \<in> C"
  for a b :: "'a::ab_group_add"
  by (auto simp add: elt_set_plus_def ac_simps)

lemma set_minus_imp_plus: "a - b \<in> C \<Longrightarrow> a \<in> b +o C"
  for a b :: "'a::ab_group_add"
  by (metis add.commute diff_add_cancel set_plus_intro2)

lemma set_minus_plus: "a - b \<in> C \<longleftrightarrow> a \<in> b +o C"
  for a b :: "'a::ab_group_add"
  by (meson set_minus_imp_plus set_plus_imp_minus)

lemma set_times_intro [intro]: "a \<in> C \<Longrightarrow> b \<in> D \<Longrightarrow> a * b \<in> C * D"
  by (auto simp add: set_times_def)

lemma set_times_elim:
  assumes "x \<in> A * B"
  obtains a b where "x = a * b" and "a \<in> A" and "b \<in> B"
  using assms unfolding set_times_def by fast

lemma set_times_intro2 [intro!]: "b \<in> C \<Longrightarrow> a * b \<in> a *o C"
  by (auto simp add: elt_set_times_def)

lemma set_times_rearrange: "(a *o C) * (b *o D) = (a * b) *o (C * D)"
  for a b :: "'a::comm_monoid_mult"
  by (auto simp add: elt_set_times_def set_times_def; metis mult.assoc mult.left_commute)

lemma set_times_rearrange2: "a *o (b *o C) = (a * b) *o C"
  for a b :: "'a::semigroup_mult"
  by (auto simp add: elt_set_times_def mult.assoc)

lemma set_times_rearrange3: "(a *o B) * C = a *o (B * C)"
  for a :: "'a::semigroup_mult"
  by (auto simp add: elt_set_times_def set_times_def; metis mult.assoc)

theorem set_times_rearrange4: "C * (a *o D) = a *o (C * D)"
  for a :: "'a::comm_monoid_mult"
  by (metis mult.commute set_times_rearrange3)

lemmas set_times_rearranges = set_times_rearrange set_times_rearrange2
  set_times_rearrange3 set_times_rearrange4

lemma set_times_mono [intro]: "C \<subseteq> D \<Longrightarrow> a *o C \<subseteq> a *o D"
  by (auto simp add: elt_set_times_def)

lemma set_times_mono2 [intro]: "C \<subseteq> D \<Longrightarrow> E \<subseteq> F \<Longrightarrow> C * E \<subseteq> D * F"
  for C D E F :: "'a::times set"
  by (auto simp add: set_times_def)

lemma set_times_mono3 [intro]: "a \<in> C \<Longrightarrow> a *o D \<subseteq> C * D"
  by (auto simp add: elt_set_times_def set_times_def)

lemma set_times_mono4 [intro]: "a \<in> C \<Longrightarrow> a *o D \<subseteq> D * C"
  for a :: "'a::comm_monoid_mult"
  by (auto simp add: elt_set_times_def set_times_def ac_simps)

lemma set_times_mono5: "a \<in> C \<Longrightarrow> B \<subseteq> D \<Longrightarrow> a *o B \<subseteq> C * D"
  by (meson dual_order.trans set_times_mono set_times_mono3)

lemma set_one_times [simp]: "1 *o C = C"
  for C :: "'a::comm_monoid_mult set"
  by (auto simp add: elt_set_times_def)

lemma set_times_plus_distrib: "a *o (b +o C) = (a * b) +o (a *o C)"
  for a b :: "'a::semiring"
  by (auto simp add: elt_set_plus_def elt_set_times_def ring_distribs)

lemma set_times_plus_distrib2: "a *o (B + C) = (a *o B) + (a *o C)"
  for a :: "'a::semiring"
  by (auto simp: set_plus_def elt_set_times_def; metis distrib_left)

lemma set_times_plus_distrib3: "(a +o C) * D \<subseteq> a *o D + C * D"
  for a :: "'a::semiring"
  using distrib_right
  by (fastforce simp add: elt_set_plus_def elt_set_times_def set_times_def set_plus_def)

lemmas set_times_plus_distribs =
  set_times_plus_distrib
  set_times_plus_distrib2

lemma set_neg_intro: "a \<in> (- 1) *o C \<Longrightarrow> - a \<in> C"
  for a :: "'a::ring_1"
  by (auto simp add: elt_set_times_def)

lemma set_neg_intro2: "a \<in> C \<Longrightarrow> - a \<in> (- 1) *o C"
  for a :: "'a::ring_1"
  by (auto simp add: elt_set_times_def)

lemma set_plus_image: "S + T = (\<lambda>(x, y). x + y) ` (S \<times> T)"
  by (fastforce simp: set_plus_def image_iff)

lemma set_times_image: "S * T = (\<lambda>(x, y). x * y) ` (S \<times> T)"
  by (fastforce simp: set_times_def image_iff)

lemma finite_set_plus: "finite s \<Longrightarrow> finite t \<Longrightarrow> finite (s + t)"
  by (simp add: set_plus_image)

lemma finite_set_times: "finite s \<Longrightarrow> finite t \<Longrightarrow> finite (s * t)"
  by (simp add: set_times_image)

lemma set_sum_alt:
  assumes fin: "finite I"
  shows "sum S I = {sum s I |s. \<forall>i\<in>I. s i \<in> S i}"
    (is "_ = ?sum I")
  using fin
proof induct
  case empty
  then show ?case by simp
next
  case (insert x F)
  have "sum S (insert x F) = S x + ?sum F"
    using insert.hyps by auto
  also have "\<dots> = {s x + sum s F |s. \<forall> i\<in>insert x F. s i \<in> S i}"
    unfolding set_plus_def
  proof safe
    fix y s
    assume "y \<in> S x" "\<forall>i\<in>F. s i \<in> S i"
    then show "\<exists>s'. y + sum s F = s' x + sum s' F \<and> (\<forall>i\<in>insert x F. s' i \<in> S i)"
      using insert.hyps
      by (intro exI[of _ "\<lambda>i. if i \<in> F then s i else y"]) (auto simp add: set_plus_def)
  qed auto
  finally show ?case
    using insert.hyps by auto
qed

lemma sum_set_cond_linear:
  fixes f :: "'a::comm_monoid_add set \<Rightarrow> 'b::comm_monoid_add set"
  assumes [intro!]: "\<And>A B. P A  \<Longrightarrow> P B  \<Longrightarrow> P (A + B)" "P {0}"
    and f: "\<And>A B. P A  \<Longrightarrow> P B \<Longrightarrow> f (A + B) = f A + f B" "f {0} = {0}"
  assumes all: "\<And>i. i \<in> I \<Longrightarrow> P (S i)"
  shows "f (sum S I) = sum (f \<circ> S) I"
proof (cases "finite I")
  case True
  from this all show ?thesis
  proof induct
    case empty
    then show ?case by (auto intro!: f)
  next
    case (insert x F)
    from \<open>finite F\<close> \<open>\<And>i. i \<in> insert x F \<Longrightarrow> P (S i)\<close> have "P (sum S F)"
      by induct auto
    with insert show ?case
      by (simp, subst f) auto
  qed
next
  case False
  then show ?thesis by (auto intro!: f)
qed

lemma sum_set_linear:
  fixes f :: "'a::comm_monoid_add set \<Rightarrow> 'b::comm_monoid_add set"
  assumes "\<And>A B. f(A) + f(B) = f(A + B)" "f {0} = {0}"
  shows "f (sum S I) = sum (f \<circ> S) I"
  using sum_set_cond_linear[of "\<lambda>x. True" f I S] assms by auto

lemma set_times_Un_distrib:
  "A * (B \<union> C) = A * B \<union> A * C"
  "(A \<union> B) * C = A * C \<union> B * C"
  by (auto simp: set_times_def)

lemma set_times_UNION_distrib:
  "A * \<Union>(M ` I) = (\<Union>i\<in>I. A * M i)"
  "\<Union>(M ` I) * A = (\<Union>i\<in>I. M i * A)"
  by (auto simp: set_times_def)

end


section"Derangements"
theory Derangements_Enum
  imports
    "HOL-Combinatorics.Multiset_Permutations"
    "Common_Lemmas"
   (* "Derangements.Derangements" *)
begin

subsection"Definition"

fun no_overlap :: "'a list \<Rightarrow> 'a list \<Rightarrow> bool" where
  "no_overlap _ [] = True"
| "no_overlap [] _ = True"
| "no_overlap (x#xs) (y#ys) = (x \<noteq> y \<and> no_overlap xs ys)"

lemma no_overlap_nth: "length xs = length ys \<Longrightarrow> i < length xs \<Longrightarrow> no_overlap xs ys \<Longrightarrow> xs ! i \<noteq> ys ! i"
  by(induct xs ys arbitrary: i rule: list_induct2) (auto simp: less_Suc_eq_0_disj)

lemma nth_no_overlap: "length xs = length ys \<Longrightarrow> \<forall> i < length xs. xs ! i \<noteq> ys ! i \<Longrightarrow> no_overlap xs ys"
proof (induct xs ys rule: list_induct2)
  case (Cons x xs y ys)
  then show ?case using Suc_less_eq nth_Cons_Suc by fastforce
qed simp

definition derangements :: "'a list \<Rightarrow> 'a list set" where
  "derangements xs = {ys. distinct ys \<and> length xs = length ys \<and> set xs = set ys \<and> no_overlap xs ys }"
text "A derangement of a list is a permutation where every element changes its position,
  assuming all elements are distinguishable."
text \<open>An alternative definition exists in \<open>Derangements.Derangements\<close> \cite{AFPderan}.\<close>
text "Cardinality: \<open>count_derangements (length xs)\<close> (from \<open>Derangements.Derangements\<close>)"
text "Example: \<open>derangements [0,1,2] = {[1,2,0], [2,0,1]}\<close>"

subsection"Algorithm"
fun derangement_enum_aux :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list list" where
  "derangement_enum_aux [] ys = [[]]"
| "derangement_enum_aux (x#xs) ys = [y#r . y \<leftarrow> ys, r \<leftarrow> derangement_enum_aux xs (remove1 y ys), y \<noteq> x]"

fun derangement_enum :: "'a list  \<Rightarrow> 'a list list" where
 "derangement_enum xs = derangement_enum_aux xs xs"

subsection"Verification"

subsubsection"Correctness"

lemma derangement_enum_aux_elem_length: "zs \<in> set (derangement_enum_aux xs ys) \<Longrightarrow> length xs = length zs"
  by(induct xs arbitrary: ys zs) auto

lemma derangement_enum_aux_not_in: "y \<notin> set ys \<Longrightarrow> zs \<in> set (derangement_enum_aux xs ys) \<Longrightarrow> y \<notin> set zs"
proof(induct xs arbitrary: ys zs)
  case Nil
  then show ?case by simp
next
  case (Cons x xs)
  then obtain z zs2 where ob: "zs = z#zs2"
    by auto
  have "zs2 \<in> set (derangement_enum_aux xs (remove1 z ys)) \<Longrightarrow> y \<notin> set zs2"
    using Cons notin_set_remove1 by fast
  then show ?case using Cons ob
    by auto
qed

lemma derangement_enum_aux_in: "y \<in> set zs \<Longrightarrow> zs \<in> set (derangement_enum_aux xs ys) \<Longrightarrow> y \<in> set ys"
  using derangement_enum_aux_not_in by fast

lemma derangement_enum_aux_distinct_elem: "distinct ys \<Longrightarrow> zs \<in> set (derangement_enum_aux xs ys) \<Longrightarrow> distinct zs"
proof(induct xs arbitrary: ys zs)
  case Nil
  then show ?case by simp
next
  case (Cons x xs)
  obtain z zs2 where ob: "zs = z#zs2"
    using Cons by auto
  then have ev: "zs2 \<in> set (derangement_enum_aux xs (remove1 z ys))"
    using Cons ob by auto

  have "distinct zs2"
    using ev Cons distinct_remove1 by fast
  moreover have "z \<notin> set zs2"
    using ev Cons(2) derangement_enum_aux_in by fastforce
  ultimately show ?case using ob by simp
qed

lemma derangement_enum_aux_no_overlap: "zs \<in> set (derangement_enum_aux xs ys) \<Longrightarrow> no_overlap xs zs"
  by(induct xs arbitrary: zs ys) auto

lemma derangement_enum_aux_set:
  "length xs = length ys \<Longrightarrow> zs \<in> set (derangement_enum_aux xs ys) \<Longrightarrow> set zs = set ys"
proof(induct xs ys arbitrary: zs rule: derangement_enum_aux.induct)
  case (1 ys)
  then show ?case by simp
next
  case (2 x xs ys)
  obtain z zs2 where ob: "zs = z#zs2"
    using 2 by auto
  have ev1: "zs2 \<in> set (derangement_enum_aux xs (remove1 z ys))"
    using 2 ob  by simp
  have ev2:"z \<in> set ys"
    using 2 ob by simp

  have "length xs = length (remove1 z ys)"
    using ev2 Suc_length_remove1 "2.prems"(1) by force
  then have "set zs2 = set (remove1 z ys)"
    using "2.hyps"[of z zs2] ev1 ev2  by simp

  then show ?case
    using ob notin_set_remove1 ev2 in_set_remove1 by fastforce
qed

lemma derangement_enum_correct_aux1:
  "\<lbrakk>distinct zs;length ys = length zs; length ys = length xs; set ys = set zs; no_overlap xs zs\<rbrakk>
   \<Longrightarrow> zs \<in> set (derangement_enum_aux xs ys)"
proof(induct xs arbitrary: zs ys)
  case Nil
  then show ?case by simp
next
  case (Cons x xs)
  obtain z zs2 where ob: "zs = z#zs2"
    using Cons length_0_conv neq_Nil_conv by metis

  have e1: "z \<noteq> x"
    using Cons.prems(5) ob  by auto

  have "distinct zs2"
    using Cons.prems(1) ob by auto
  moreover have "length (remove1 z ys) = length zs2" using Cons.prems ob
    by (simp add: length_remove1)
  moreover have "length (remove1 z ys) = length xs"
    by (simp add: Cons.prems(3) Cons.prems(4) length_remove1 ob)
  moreover have "set (remove1 z ys) = set zs2"
    using Cons ob by (metis distinct_card distinct_remdups length_remdups_eq remove1.simps(2) set_remdups set_remove1_eq)
  moreover have "no_overlap xs zs2"
    using Cons.prems(5) ob by fastforce

  ultimately have "zs2 \<in> set (derangement_enum_aux xs (remove1 z ys))"
    using Cons.hyps[of zs2 "(remove1 z ys)"] by simp
  then show ?case
    using ob e1 Cons by simp
qed

theorem derangement_enum_correct: "distinct xs \<Longrightarrow> derangements xs = set (derangement_enum xs)"
proof(standard)
  show "distinct xs \<Longrightarrow> derangements xs \<subseteq> set (derangement_enum xs)"
    unfolding derangements_def using derangement_enum_correct_aux1 by auto
next
  show "distinct xs \<Longrightarrow> set (derangement_enum xs) \<subseteq> derangements xs"
    unfolding derangements_def
    using derangement_enum_aux_set derangement_enum_aux_distinct_elem derangement_enum_aux_elem_length derangement_enum_aux_no_overlap
    by auto
qed

subsubsection"Distinctness"

lemma derangement_enum_aux_distinct: "distinct ys \<Longrightarrow> distinct (derangement_enum_aux xs ys)"
proof(induct xs arbitrary: ys)
  case Nil
  then show ?case by simp
next
  case (Cons x xs)
  show ?case
    using inj2_distinct_concat_map_function_filter[of
        "Cons"
         ys
         "\<lambda>y. derangement_enum_aux xs (remove1 y ys)"
        "\<lambda>y. y \<noteq> x"
      ]
    using Cons Cons_inj2
    by (simp)
qed

theorem derangement_enum_distinct: "distinct xs \<Longrightarrow> distinct (derangement_enum xs)"
  using derangement_enum_aux_distinct by auto

(*
subsubsection"Cardinality"
should be provable with Derangements.Derangements
*)

end


(*
  File:    Pochhammer_Polynomials.thy
  Author:  Manuel Eberl, TU München
*)
section \<open>Falling factorial as a polynomial\<close>
theory Pochhammer_Polynomials
imports
  Complex_Main
  "HOL-Combinatorics.Stirling"
  "HOL-Computational_Algebra.Polynomial"
begin

definition pochhammer_poly :: "nat \<Rightarrow> 'a :: {comm_semiring_1} poly" where
  "pochhammer_poly n = Poly [of_nat (stirling n k). k \<leftarrow> [0..<Suc n]]"

lemma pochhammer_poly_code [code abstract]:
  "coeffs (pochhammer_poly n) = map of_nat (stirling_row n)"
  by (simp add: pochhammer_poly_def stirling_row_def Let_def)

lemma coeff_pochhammer_poly: "coeff (pochhammer_poly n) k = of_nat (stirling n k)"
  by (simp add: pochhammer_poly_def nth_default_def del: upt_Suc)

lemma degree_pochhammer_poly [simp]: "degree (pochhammer_poly n) = n"
  by (simp add: degree_eq_length_coeffs pochhammer_poly_def)

lemma pochhammer_poly_0 [simp]: "pochhammer_poly 0 = 1"
  by (simp add: pochhammer_poly_def)

lemma pochhammer_poly_Suc: "pochhammer_poly (Suc n) = [:of_nat n,1:] * pochhammer_poly n"
  by (cases "n = 0") (simp_all add: poly_eq_iff coeff_pochhammer_poly coeff_pCons split: nat.split)

lemma pochhammer_poly_altdef: "pochhammer_poly n = (\<Prod>i<n. [:of_nat i,1:])"
  by (induction n) (simp_all add: pochhammer_poly_Suc)

lemma eval_pochhammer_poly: "poly (pochhammer_poly n) k = pochhammer k n"
  by (cases n) (auto simp add: pochhammer_poly_altdef poly_prod add_ac lessThan_Suc_atMost
                               pochhammer_Suc_prod atLeast0AtMost)

lemma pochhammer_poly_Suc':
    "pochhammer_poly (Suc n) = pCons 0 (pcompose (pochhammer_poly n) [:1,1:])"
  by (simp add: pochhammer_poly_altdef prod.lessThan_Suc_shift pcompose_prod pcompose_pCons add_ac del: prod.lessThan_Suc)

end


(*  Title:      Restricted_Measure_Space.thy
    Author:     Mnacho Echenim, Univ. Grenoble Alpes
*)

section \<open>Generated subalgebras\<close>

text \<open>This section contains definitions and properties related to generated subalgebras.\<close>

theory Generated_Subalgebra imports "HOL-Probability.Probability"

begin

definition gen_subalgebra where
"gen_subalgebra M G = sigma (space M) G"

lemma gen_subalgebra_space:
  shows "space (gen_subalgebra M G) = space M"
by (simp add: gen_subalgebra_def space_measure_of_conv)

lemma gen_subalgebra_sets:
  assumes "G \<subseteq> sets M"
  and "A \<in> G"
  shows "A \<in> sets (gen_subalgebra M G)"
by (metis assms gen_subalgebra_def sets.space_closed sets_measure_of sigma_sets.Basic subset_trans)

lemma gen_subalgebra_sig_sets:
  assumes "G \<subseteq> Pow (space M)"
  shows "sets (gen_subalgebra M G) = sigma_sets (space M) G" unfolding gen_subalgebra_def
by (metis assms gen_subalgebra_def sets_measure_of)

lemma  gen_subalgebra_sigma_sets:
  assumes "G \<subseteq> sets M"
  and "sigma_algebra (space M) G"
  shows "sets (gen_subalgebra M G) = G"
using assms by (simp add: gen_subalgebra_def sigma_algebra.sets_measure_of_eq)

lemma gen_subalgebra_is_subalgebra:
  assumes sub: "G \<subseteq> sets M"
  and sigal:"sigma_algebra (space M) G"
  shows "subalgebra M (gen_subalgebra M G)" (is "subalgebra M ?N")
unfolding subalgebra_def
proof (intro conjI)
  show "space ?N = space M" using space_measure_of_conv[of "(space M)"]  unfolding gen_subalgebra_def by simp
  have geqn: "G = sets ?N" using assms by (simp add:gen_subalgebra_sigma_sets)
  thus "sets ?N \<subseteq> sets M" using assms by simp
qed

definition  fct_gen_subalgebra :: "'a measure \<Rightarrow> 'b measure \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> 'a measure" where
  "fct_gen_subalgebra M N X = gen_subalgebra M (sigma_sets (space M) {X -` B \<inter> (space M) | B. B \<in> sets N})"

lemma fct_gen_subalgebra_sets:
  shows "sets (fct_gen_subalgebra M N X) = sigma_sets (space M) {X -` B \<inter> space M |B. B \<in> sets N}"
unfolding fct_gen_subalgebra_def gen_subalgebra_def
proof -
  have "{X -` B \<inter> space M |B. B \<in> sets N} \<subseteq> Pow (space M)"
    by blast
  then show "sets (sigma (space M) (sigma_sets (space M) {X -` B \<inter> space M |B. B \<in> sets N})) = sigma_sets (space M) {X -` B \<inter> space M |B. B \<in> sets N}"
    by (meson sigma_algebra.sets_measure_of_eq sigma_algebra_sigma_sets)
qed

lemma fct_gen_subalgebra_space:
  shows "space (fct_gen_subalgebra M N X) = space M"
  unfolding fct_gen_subalgebra_def by (simp add: gen_subalgebra_space)

lemma fct_gen_subalgebra_eq_sets:
  assumes "sets M = sets P"
  shows "fct_gen_subalgebra M N X = fct_gen_subalgebra P N X"
proof -
  have "space M = space P" using sets_eq_imp_space_eq assms by auto
  thus ?thesis unfolding fct_gen_subalgebra_def gen_subalgebra_def by simp
qed

lemma fct_gen_subalgebra_sets_mem:
  assumes "B\<in> sets N"
  shows "X -` B \<inter> (space M) \<in> sets (fct_gen_subalgebra M N X)" unfolding fct_gen_subalgebra_def
proof -
  have f1: "{X -` A \<inter> space M |A. A \<in> sets N} \<subseteq> Pow (space M)"
    by blast
  have "\<exists>A. X -` B \<inter> space M = X -` A \<inter> space M \<and> A \<in> sets N"
    by (metis assms)
  then show "X -` B \<inter> space M \<in> sets (gen_subalgebra M (sigma_sets (space M) {X -` A \<inter> space M |A. A \<in> sets N}))"
    using f1 by (simp add: gen_subalgebra_def sigma_algebra.sets_measure_of_eq sigma_algebra_sigma_sets)
qed

lemma fct_gen_subalgebra_is_subalgebra:
  assumes "X\<in> measurable M N"
  shows "subalgebra M (fct_gen_subalgebra M N X)"
unfolding fct_gen_subalgebra_def
proof (rule gen_subalgebra_is_subalgebra)
  show "sigma_sets (space M) {X -` B \<inter> space M |B. B \<in> sets N} \<subseteq> sets M" (is "?L \<subseteq> ?R")
  proof (rule sigma_algebra.sigma_sets_subset)
    show "{X -` B \<inter> space M |B. B \<in> sets N} \<subseteq> sets M"
    proof
      fix a
      assume "a \<in> {X -` B \<inter> (space M) | B. B \<in> sets N}"
      then obtain B where "B \<in> sets N" and "a = X -` B \<inter> (space M)" by auto
      thus "a \<in> sets M" using measurable_sets assms by simp
    qed
    show "sigma_algebra (space M) (sets M)" using measure_space by (auto simp add: measure_space_def)
  qed
  show "sigma_algebra (space M) ?L"
  proof (rule sigma_algebra_sigma_sets)
    let ?preimages = "{X -` B \<inter> (space M) | B. B \<in> sets N}"
    show "?preimages \<le> Pow (space M)" using assms by auto
  qed
qed

lemma fct_gen_subalgebra_fct_measurable:
  assumes "X \<in> space M \<rightarrow> space N"
  shows "X\<in> measurable (fct_gen_subalgebra M N X) N"
unfolding measurable_def
proof ((intro CollectI), (intro conjI))
  have speq: "space M = space (fct_gen_subalgebra M N X)"
      by (simp add: fct_gen_subalgebra_space)
  show "X \<in> space (fct_gen_subalgebra M N X) \<rightarrow> space N"
  proof -
    have "X \<in> space M \<rightarrow> space N"  using assms by simp
    thus ?thesis using speq by simp
  qed
  show "\<forall>y\<in>sets N.
       X -` y \<inter> space (fct_gen_subalgebra M N X) \<in> sets (fct_gen_subalgebra M N X)"
  using  fct_gen_subalgebra_sets_mem speq by metis
qed

lemma fct_gen_subalgebra_min:
  assumes "subalgebra M P"
  and "f\<in> measurable P N"
  shows "subalgebra P (fct_gen_subalgebra M N f)"
unfolding subalgebra_def
proof (intro conjI)
  let ?Mf = "fct_gen_subalgebra M N f"
  show "space ?Mf = space P" using assms
    by (simp add: fct_gen_subalgebra_def gen_subalgebra_space subalgebra_def)
  show inc: "sets ?Mf \<subseteq> sets P"
  proof -
    have "space M = space P" using assms by (simp add:subalgebra_def)
    have "f\<in> measurable M N" using assms using measurable_from_subalg by blast
    have "sigma_algebra (space P) (sets P)" using assms measure_space measure_space_def by auto
    have "\<forall> A \<in> sets N. f-`A \<inter> space P \<in> sets P" using assms by simp
    hence "{f -` A \<inter> (space M) | A. A \<in> sets N} \<subseteq> sets P" using \<open>space M = space P\<close> by auto
    hence "sigma_sets (space M) {f -` A \<inter> (space M) | A. A \<in> sets N} \<subseteq> sets P"
      by (simp add: \<open>sigma_algebra (space P) (sets P)\<close> \<open>space M = space P\<close> sigma_algebra.sigma_sets_subset)
    thus ?thesis using fct_gen_subalgebra_sets \<open>f \<in> M \<rightarrow>\<^sub>M N\<close> \<open>space M = space P\<close> assms(2)
      measurable_sets mem_Collect_eq sets.sigma_sets_subset subsetI by blast
  qed
qed

lemma fct_preimage_sigma_sets:
  assumes "X\<in> space M \<rightarrow> space N"
  shows "sigma_sets (space M) {X -` B \<inter> space M |B. B \<in> sets N} = {X -` B \<inter> space M |B. B \<in> sets N}" (is "?L = ?R")
proof
  show "?R\<subseteq> ?L" by blast
  show "?L\<subseteq> ?R"
  proof
    fix A
    assume "A\<in> ?L"
    thus "A\<in> ?R"
    proof (induct rule:sigma_sets.induct, auto)
      {
        fix B
        assume "B\<in> sets N"
        let ?cB = "space N - B"
        have "?cB \<in> sets N" by (simp add: \<open>B \<in> sets N\<close> sets.compl_sets)
        have "space M - X -` B \<inter> space M = X -` ?cB \<inter> space M"
        proof
          show "space M - X -` B \<inter> space M \<subseteq> X -` (space N - B) \<inter> space M"
          proof
            fix w
            assume "w \<in> space M - X -` B \<inter> space M"
            hence "X w \<in> (space N - B)" using assms by blast
            thus "w\<in> X -` (space N - B) \<inter> space M" using \<open>w \<in> space M - X -` B \<inter> space M\<close> by blast
          qed
          show "X -` (space N - B) \<inter> space M \<subseteq> space M - X -` B \<inter> space M"
          proof
            fix w
            assume "w\<in> X -` (space N - B) \<inter> space M"
            thus "w \<in> space M - X -` B \<inter> space M" by blast
          qed
        qed
        thus "\<exists>Ba. space M - X -` B \<inter> space M = X -` Ba \<inter> space M \<and> Ba \<in> sets N" using \<open>?cB \<in> sets N\<close> by auto
      }
      {
        fix S::"nat \<Rightarrow> 'a set"
        assume "(\<And>i. \<exists>B. S i = X -` B \<inter> space M \<and> B \<in> sets N)"
        hence "(\<forall>i. \<exists>B. S i = X -` B \<inter> space M \<and> B \<in> sets N)" by auto
        hence "\<exists> f. \<forall> x. S x = X -`(f x) \<inter> space M \<and> (f x) \<in> sets N"
          using choice[of "\<lambda>i B . S i = X -` B \<inter> space M \<and> B \<in> sets N"] by simp
        from this obtain rep where "\<forall>i. S i = X -` (rep i) \<inter> space M \<and> (rep i) \<in> sets N" by auto note rProp = this
        let ?uB = "\<Union>i\<in> UNIV. rep i"
        have "?uB \<in> sets N"
          by (simp add: \<open>\<forall>i. S i = X -` rep i \<inter> space M \<and> rep i \<in> sets N\<close> countable_Un_Int(1))
        have "(\<Union>x. S x) = X -` ?uB \<inter> space M"
        proof
          show "(\<Union>x. S x) \<subseteq> X -` (\<Union>i. rep i) \<inter> space M"
          proof
            fix w
            assume "w\<in> (\<Union>x. S x)"
            hence "\<exists>x. w \<in> S x" by auto
            from this obtain x where "w \<in> S x" by auto
            hence "w\<in>  X -` rep x \<inter> space M" using rProp by simp
            hence "w\<in> (\<Union>i. (X -`(rep i)\<inter> space M))" by blast
            also have "... = X -` (\<Union>i. rep i) \<inter> space M" by auto
            finally show "w \<in> X -` (\<Union>i. rep i) \<inter> space M" .
          qed
          show "X -` (\<Union>i. rep i) \<inter> space M \<subseteq> (\<Union>x. S x)"
          proof
            fix w
            assume "w\<in> X -` (\<Union>i. rep i) \<inter> space M"
            hence "\<exists> x. w\<in> X -` (rep x) \<inter> space M" by auto
            from this obtain x where "w\<in> X -` (rep x) \<inter> space M" by auto
            hence "w\<in> S x" using rProp by simp
            thus "w\<in> (\<Union>x. S x)" by blast
          qed
        qed
        thus "\<exists>B. (\<Union>x. S x) = X -` B \<inter> space M \<and> B \<in> sets N" using \<open>?uB \<in> sets N\<close> by auto
      }
    qed
  qed
qed

lemma fct_gen_subalgebra_sigma_sets:
  assumes "X\<in> space M \<rightarrow> space N"
  shows "sets (fct_gen_subalgebra M N X) = {X -` B \<inter> space M |B. B \<in> sets N}"
  by (simp add: assms fct_gen_subalgebra_sets fct_preimage_sigma_sets)

lemma fct_gen_subalgebra_info:
  assumes "f\<in> space M \<rightarrow> space N"
  and "x\<in> space M"
  and "w\<in> space M"
  and "f x = f w"
  shows "\<And>A. A\<in> sets (fct_gen_subalgebra M N f) \<Longrightarrow> (x\<in> A) = (w\<in> A)"
proof -
  {fix A
  assume "A \<in> sigma_sets (space M)  {f -` B \<inter> (space M) | B. B \<in> sets N}"
  from this have  "(x\<in> A) = (w\<in> A)"
  proof (induct rule:sigma_sets.induct)
    {
      fix a
      assume "a \<in> {f -` B \<inter> space M |B. B \<in> sets N}"
      hence "\<exists> B\<in> sets N. a = f -` B \<inter> space M" by auto
      from this obtain B where "B\<in> sets N" and "a = f -` B \<inter> space M" by blast note bhyps = this
      show "(x\<in> a) = (w\<in> a)" by (simp add: assms(2) assms(3) assms(4) bhyps(2))
    }
    {
      fix a
      assume "a \<in> sigma_sets (space M) {f -` B \<inter> space M |B. B \<in> sets N}"
      and "(x \<in> a) = (w \<in> a)" note xh = this
      show "(x \<in> space M - a) = (w \<in> space M - a)" by (simp add: assms(2) assms(3) xh(2))
    }
    {
      fix a::"nat \<Rightarrow> 'a set"
      assume "(\<And>i. a i \<in> sigma_sets (space M) {f -` B \<inter> space M |B. B \<in> sets N})"
      and "(\<And>i. (x \<in> a i) = (w \<in> a i))"
      show "(x \<in> \<Union>(a ` UNIV)) = (w \<in> \<Union>(a ` UNIV))" by (simp add: \<open>\<And>i. (x \<in> a i) = (w \<in> a i)\<close>)
    }
    {show "(x\<in> {}) = (w\<in> {})" by simp}
  qed} note eqsig = this
  fix A
  assume "A\<in> sets (fct_gen_subalgebra M N f)"
  hence "A \<in> sigma_sets (space M)  {f -` B \<inter> (space M) | B. B \<in> sets N}"
    using assms(1) fct_gen_subalgebra_sets by blast
  thus "(x\<in> A) = (w\<in> A)" using eqsig by simp
qed

subsection \<open>Independence between a random variable and a subalgebra.\<close>

definition (in prob_space) subalgebra_indep_var :: "('a \<Rightarrow> real) \<Rightarrow> 'a measure \<Rightarrow> bool" where
  "subalgebra_indep_var X N \<longleftrightarrow>
    X\<in> borel_measurable M &
    (subalgebra M N) &
    (indep_set (sigma_sets (space M) { X -` A \<inter> space M | A. A \<in> sets borel}) (sets N))"

lemma (in prob_space) indep_set_mono:
  assumes "indep_set A B"
  assumes "A' \<subseteq> A"
  assumes "B' \<subseteq> B"
  shows "indep_set A' B'"
by (meson indep_sets2_eq assms subsetCE subset_trans)

lemma (in prob_space) subalgebra_indep_var_indicator:
  fixes X::"'a\<Rightarrow>real"
  assumes "subalgebra_indep_var X N"
  and "X \<in> borel_measurable M"
  and "A \<in> sets N"
  shows "indep_var borel X borel (indicator A)"
proof ((rule indep_var_eq[THEN iffD2]), (intro conjI))
  let ?IA = "(indicator A)::'a\<Rightarrow> real"
  show bm:"random_variable borel X" by (simp add: assms(2))
  show "random_variable borel ?IA" using assms indep_setD_ev2 unfolding subalgebra_indep_var_def by auto
  show "indep_set (sigma_sets (space M) {X -` A \<inter> space M |A. A \<in> sets borel})
   (sigma_sets (space M) {?IA -` Aa \<inter> space M |Aa. Aa \<in> sets borel})"
  proof (rule indep_set_mono)
    show "sigma_sets (space M) {X -` A \<inter> space M |A. A \<in> sets borel} \<subseteq> sigma_sets (space M) {X -` A \<inter> space M |A. A \<in> sets borel}" by simp
    show "sigma_sets (space M) {?IA -` B \<inter> space M |B. B \<in> sets borel} \<subseteq> sets N"
    proof -
      have "sigma_algebra (space M) (sets N)" using assms
        by (metis subalgebra_indep_var_def sets.sigma_algebra_axioms subalgebra_def)
      have "sigma_sets (space M) {?IA -` B \<inter> space M |B. B \<in> sets borel} \<subseteq> sigma_sets (space M) (sets N)"
      proof (rule sigma_sets_subseteq)
        show "{?IA -` B \<inter> space M |B. B \<in> sets borel} \<subseteq> sets N"
        proof
          fix x
          assume "x \<in> {?IA -` B \<inter> space M |B. B \<in> sets borel}"
          then obtain B where "B \<in> sets borel" and "x = ?IA -` B \<inter> space M" by auto
          thus "x \<in> sets N"
            by (metis (no_types, lifting) assms(1) assms(3) borel_measurable_indicator measurable_sets subalgebra_indep_var_def subalgebra_def)
        qed
      qed
      also have "... = sets N"
        by (simp add: \<open>sigma_algebra (space M) (sets N)\<close> sigma_algebra.sigma_sets_eq)
      finally show "sigma_sets (space M) {?IA -` B \<inter> space M |B. B \<in> sets borel} \<subseteq> sets N" .
    qed
    show "indep_set (sigma_sets (space M) {X -` A \<inter> space M |A. A \<in> sets borel}) (sets N) "
      using assms unfolding subalgebra_indep_var_def by simp
  qed
qed

lemma fct_gen_subalgebra_cong:
  assumes "space M = space P"
  and "sets N = sets Q"
  shows "fct_gen_subalgebra M N X = fct_gen_subalgebra P Q X"
proof -
  have "space M = space P" using assms by simp
  thus ?thesis using assms unfolding fct_gen_subalgebra_def gen_subalgebra_def by simp
qed

end