theory Synopsis
imports Base Main
begin

chapter \<open>Synopsis\<close>

section \<open>Notepad\<close>

text \<open>
  An Isar proof body serves as mathematical notepad to compose logical
  content, consisting of types, terms, facts.
\<close>

subsection \<open>Types and terms\<close>

notepad
begin
  txt \<open>Locally fixed entities:\<close>
  fix x   -- \<open>local constant, without any type information yet\<close>
  fix x :: 'a  -- \<open>variant with explicit type-constraint for subsequent use\<close>

  fix a b
  assume "a = b"  -- \<open>type assignment at first occurrence in concrete term\<close>

  txt \<open>Definitions (non-polymorphic):\<close>
  def x \<equiv> "t::'a"

  txt \<open>Abbreviations (polymorphic):\<close>
  let ?f = "\<lambda>x. x"
  term "?f ?f"

  txt \<open>Notation:\<close>
  write x  ("***")
end

subsection \<open>Facts\<close>

text \<open>
  A fact is a simultaneous list of theorems.
\<close>

subsubsection \<open>Producing facts\<close>

notepad
begin

  txt \<open>Via assumption (``lambda''):\<close>
  assume a: A

  txt \<open>Via proof (``let''):\<close>
  have b: B sorry

  txt \<open>Via abbreviation (``let''):\<close>
  note c = a b

end

subsubsection \<open>Referencing facts\<close>

notepad
begin
  txt \<open>Via explicit name:\<close>
  assume a: A
  note a

  txt \<open>Via implicit name:\<close>
  assume A
  note this

  txt \<open>Via literal proposition (unification with results from the proof text):\<close>
  assume A
  note \<open>A\<close>

  assume "\<And>x. B x"
  note \<open>B a\<close>
  note \<open>B b\<close>
end

subsubsection \<open>Manipulating facts\<close>

notepad
begin
  txt \<open>Instantiation:\<close>
  assume a: "\<And>x. B x"
  note a
  note a [of b]
  note a [where x = b]

  txt \<open>Backchaining:\<close>
  assume 1: A
  assume 2: "A \<Longrightarrow> C"
  note 2 [OF 1]
  note 1 [THEN 2]

  txt \<open>Symmetric results:\<close>
  assume "x = y"
  note this [symmetric]

  assume "x \<noteq> y"
  note this [symmetric]

  txt \<open>Adhoc-simplification (take care!):\<close>
  assume "P ([] @ xs)"
  note this [simplified]
end

subsubsection \<open>Projections\<close>

text \<open>
  Isar facts consist of multiple theorems.  There is notation to project
  interval ranges.
\<close>

notepad
begin
  assume stuff: A B C D
  note stuff(1)
  note stuff(2-3)
  note stuff(2-)
end

subsubsection \<open>Naming conventions\<close>

text \<open>
  \begin{itemize}

  \item Lower-case identifiers are usually preferred.

  \item Facts can be named after the main term within the proposition.

  \item Facts should \emph{not} be named after the command that
  introduced them (@{command "assume"}, @{command "have"}).  This is
  misleading and hard to maintain.

  \item Natural numbers can be used as ``meaningless'' names (more
  appropriate than @{text "a1"}, @{text "a2"} etc.)

  \item Symbolic identifiers are supported (e.g. @{text "*"}, @{text
  "**"}, @{text "***"}).

  \end{itemize}
\<close>

subsection \<open>Block structure\<close>

text \<open>
  The formal notepad is block structured.  The fact produced by the last
  entry of a block is exported into the outer context.
\<close>

notepad
begin
  {
    have a: A sorry
    have b: B sorry
    note a b
  }
  note this
  note \<open>A\<close>
  note \<open>B\<close>
end

text \<open>Explicit blocks as well as implicit blocks of nested goal
  statements (e.g.\ @{command have}) automatically introduce one extra
  pair of parentheses in reserve.  The @{command next} command allows
  to ``jump'' between these sub-blocks.\<close>

notepad
begin

  {
    have a: A sorry
  next
    have b: B
    proof -
      show B sorry
    next
      have c: C sorry
    next
      have d: D sorry
    qed
  }

  txt \<open>Alternative version with explicit parentheses everywhere:\<close>

  {
    {
      have a: A sorry
    }
    {
      have b: B
      proof -
        {
          show B sorry
        }
        {
          have c: C sorry
        }
        {
          have d: D sorry
        }
      qed
    }
  }

end

section \<open>Calculational reasoning \label{sec:calculations-synopsis}\<close>

text \<open>
  For example, see @{file "~~/src/HOL/Isar_Examples/Group.thy"}.
\<close>

subsection \<open>Special names in Isar proofs\<close>

text \<open>
  \begin{itemize}

  \item term @{text "?thesis"} --- the main conclusion of the
  innermost pending claim

  \item term @{text "\<dots>"} --- the argument of the last explicitly
    stated result (for infix application this is the right-hand side)

  \item fact @{text "this"} --- the last result produced in the text

  \end{itemize}
\<close>

notepad
begin
  have "x = y"
  proof -
    term ?thesis
    show ?thesis sorry
    term ?thesis  -- \<open>static!\<close>
  qed
  term "\<dots>"
  thm this
end

text \<open>Calculational reasoning maintains the special fact called
  ``@{text calculation}'' in the background.  Certain language
  elements combine primary @{text this} with secondary @{text
  calculation}.\<close>

subsection \<open>Transitive chains\<close>

text \<open>The Idea is to combine @{text this} and @{text calculation}
  via typical @{text trans} rules (see also @{command
  print_trans_rules}):\<close>

thm trans
thm less_trans
thm less_le_trans

notepad
begin
  txt \<open>Plain bottom-up calculation:\<close>
  have "a = b" sorry
  also
  have "b = c" sorry
  also
  have "c = d" sorry
  finally
  have "a = d" .

  txt \<open>Variant using the @{text "\<dots>"} abbreviation:\<close>
  have "a = b" sorry
  also
  have "\<dots> = c" sorry
  also
  have "\<dots> = d" sorry
  finally
  have "a = d" .

  txt \<open>Top-down version with explicit claim at the head:\<close>
  have "a = d"
  proof -
    have "a = b" sorry
    also
    have "\<dots> = c" sorry
    also
    have "\<dots> = d" sorry
    finally
    show ?thesis .
  qed
next
  txt \<open>Mixed inequalities (require suitable base type):\<close>
  fix a b c d :: nat

  have "a < b" sorry
  also
  have "b \<le> c" sorry
  also
  have "c = d" sorry
  finally
  have "a < d" .
end

subsubsection \<open>Notes\<close>

text \<open>
  \begin{itemize}

  \item The notion of @{text trans} rule is very general due to the
  flexibility of Isabelle/Pure rule composition.

  \item User applications may declare their own rules, with some care
  about the operational details of higher-order unification.

  \end{itemize}
\<close>

subsection \<open>Degenerate calculations and bigstep reasoning\<close>

text \<open>The Idea is to append @{text this} to @{text calculation},
  without rule composition.\<close>

notepad
begin
  txt \<open>A vacuous proof:\<close>
  have A sorry
  moreover
  have B sorry
  moreover
  have C sorry
  ultimately
  have A and B and C .
next
  txt \<open>Slightly more content (trivial bigstep reasoning):\<close>
  have A sorry
  moreover
  have B sorry
  moreover
  have C sorry
  ultimately
  have "A \<and> B \<and> C" by blast
next
  txt \<open>More ambitious bigstep reasoning involving structured results:\<close>
  have "A \<or> B \<or> C" sorry
  moreover
  { assume A have R sorry }
  moreover
  { assume B have R sorry }
  moreover
  { assume C have R sorry }
  ultimately
  have R by blast  -- \<open>``big-bang integration'' of proof blocks (occasionally fragile)\<close>
end

section \<open>Induction\<close>

subsection \<open>Induction as Natural Deduction\<close>

text \<open>In principle, induction is just a special case of Natural
  Deduction (see also \secref{sec:natural-deduction-synopsis}).  For
  example:\<close>

thm nat.induct
print_statement nat.induct

notepad
begin
  fix n :: nat
  have "P n"
  proof (rule nat.induct)  -- \<open>fragile rule application!\<close>
    show "P 0" sorry
  next
    fix n :: nat
    assume "P n"
    show "P (Suc n)" sorry
  qed
end

text \<open>
  In practice, much more proof infrastructure is required.

  The proof method @{method induct} provides:
  \begin{itemize}

  \item implicit rule selection and robust instantiation

  \item context elements via symbolic case names

  \item support for rule-structured induction statements, with local
    parameters, premises, etc.

  \end{itemize}
\<close>

notepad
begin
  fix n :: nat
  have "P n"
  proof (induct n)
    case 0
    show ?case sorry
  next
    case (Suc n)
    from Suc.hyps show ?case sorry
  qed
end

subsubsection \<open>Example\<close>

text \<open>
  The subsequent example combines the following proof patterns:
  \begin{itemize}

  \item outermost induction (over the datatype structure of natural
  numbers), to decompose the proof problem in top-down manner

  \item calculational reasoning (\secref{sec:calculations-synopsis})
  to compose the result in each case

  \item solving local claims within the calculation by simplification

  \end{itemize}
\<close>

lemma
  fixes n :: nat
  shows "(\<Sum>i=0..n. i) = n * (n + 1) div 2"
proof (induct n)
  case 0
  have "(\<Sum>i=0..0. i) = (0::nat)" by simp
  also have "\<dots> = 0 * (0 + 1) div 2" by simp
  finally show ?case .
next
  case (Suc n)
  have "(\<Sum>i=0..Suc n. i) = (\<Sum>i=0..n. i) + (n + 1)" by simp
  also have "\<dots> = n * (n + 1) div 2 + (n + 1)" by (simp add: Suc.hyps)
  also have "\<dots> = (n * (n + 1) + 2 * (n + 1)) div 2" by simp
  also have "\<dots> = (Suc n * (Suc n + 1)) div 2" by simp
  finally show ?case .
qed

text \<open>This demonstrates how induction proofs can be done without
  having to consider the raw Natural Deduction structure.\<close>

subsection \<open>Induction with local parameters and premises\<close>

text \<open>Idea: Pure rule statements are passed through the induction
  rule.  This achieves convenient proof patterns, thanks to some
  internal trickery in the @{method induct} method.

  Important: Using compact HOL formulae with @{text "\<forall>/\<longrightarrow>"} is a
  well-known anti-pattern! It would produce useless formal noise.
\<close>

notepad
begin
  fix n :: nat
  fix P :: "nat \<Rightarrow> bool"
  fix Q :: "'a \<Rightarrow> nat \<Rightarrow> bool"

  have "P n"
  proof (induct n)
    case 0
    show "P 0" sorry
  next
    case (Suc n)
    from \<open>P n\<close> show "P (Suc n)" sorry
  qed

  have "A n \<Longrightarrow> P n"
  proof (induct n)
    case 0
    from \<open>A 0\<close> show "P 0" sorry
  next
    case (Suc n)
    from \<open>A n \<Longrightarrow> P n\<close>
      and \<open>A (Suc n)\<close> show "P (Suc n)" sorry
  qed

  have "\<And>x. Q x n"
  proof (induct n)
    case 0
    show "Q x 0" sorry
  next
    case (Suc n)
    from \<open>\<And>x. Q x n\<close> show "Q x (Suc n)" sorry
    txt \<open>Local quantification admits arbitrary instances:\<close>
    note \<open>Q a n\<close> and \<open>Q b n\<close>
  qed
end

subsection \<open>Implicit induction context\<close>

text \<open>The @{method induct} method can isolate local parameters and
  premises directly from the given statement.  This is convenient in
  practical applications, but requires some understanding of what is
  going on internally (as explained above).\<close>

notepad
begin
  fix n :: nat
  fix Q :: "'a \<Rightarrow> nat \<Rightarrow> bool"

  fix x :: 'a
  assume "A x n"
  then have "Q x n"
  proof (induct n arbitrary: x)
    case 0
    from \<open>A x 0\<close> show "Q x 0" sorry
  next
    case (Suc n)
    from \<open>\<And>x. A x n \<Longrightarrow> Q x n\<close>  -- \<open>arbitrary instances can be produced here\<close>
      and \<open>A x (Suc n)\<close> show "Q x (Suc n)" sorry
  qed
end

subsection \<open>Advanced induction with term definitions\<close>

text \<open>Induction over subexpressions of a certain shape are delicate
  to formalize.  The Isar @{method induct} method provides
  infrastructure for this.

  Idea: sub-expressions of the problem are turned into a defined
  induction variable; often accompanied with fixing of auxiliary
  parameters in the original expression.\<close>

notepad
begin
  fix a :: "'a \<Rightarrow> nat"
  fix A :: "nat \<Rightarrow> bool"

  assume "A (a x)"
  then have "P (a x)"
  proof (induct "a x" arbitrary: x)
    case 0
    note prem = \<open>A (a x)\<close>
      and defn = \<open>0 = a x\<close>
    show "P (a x)" sorry
  next
    case (Suc n)
    note hyp = \<open>\<And>x. n = a x \<Longrightarrow> A (a x) \<Longrightarrow> P (a x)\<close>
      and prem = \<open>A (a x)\<close>
      and defn = \<open>Suc n = a x\<close>
    show "P (a x)" sorry
  qed
end

section \<open>Natural Deduction \label{sec:natural-deduction-synopsis}\<close>

subsection \<open>Rule statements\<close>

text \<open>
  Isabelle/Pure ``theorems'' are always natural deduction rules,
  which sometimes happen to consist of a conclusion only.

  The framework connectives @{text "\<And>"} and @{text "\<Longrightarrow>"} indicate the
  rule structure declaratively.  For example:\<close>

thm conjI
thm impI
thm nat.induct

text \<open>
  The object-logic is embedded into the Pure framework via an implicit
  derivability judgment @{term "Trueprop :: bool \<Rightarrow> prop"}.

  Thus any HOL formulae appears atomic to the Pure framework, while
  the rule structure outlines the corresponding proof pattern.

  This can be made explicit as follows:
\<close>

notepad
begin
  write Trueprop  ("Tr")

  thm conjI
  thm impI
  thm nat.induct
end

text \<open>
  Isar provides first-class notation for rule statements as follows.
\<close>

print_statement conjI
print_statement impI
print_statement nat.induct

subsubsection \<open>Examples\<close>

text \<open>
  Introductions and eliminations of some standard connectives of
  the object-logic can be written as rule statements as follows.  (The
  proof ``@{command "by"}~@{method blast}'' serves as sanity check.)
\<close>

lemma "(P \<Longrightarrow> False) \<Longrightarrow> \<not> P" by blast
lemma "\<not> P \<Longrightarrow> P \<Longrightarrow> Q" by blast

lemma "P \<Longrightarrow> Q \<Longrightarrow> P \<and> Q" by blast
lemma "P \<and> Q \<Longrightarrow> (P \<Longrightarrow> Q \<Longrightarrow> R) \<Longrightarrow> R" by blast

lemma "P \<Longrightarrow> P \<or> Q" by blast
lemma "Q \<Longrightarrow> P \<or> Q" by blast
lemma "P \<or> Q \<Longrightarrow> (P \<Longrightarrow> R) \<Longrightarrow> (Q \<Longrightarrow> R) \<Longrightarrow> R" by blast

lemma "(\<And>x. P x) \<Longrightarrow> (\<forall>x. P x)" by blast
lemma "(\<forall>x. P x) \<Longrightarrow> P x" by blast

lemma "P x \<Longrightarrow> (\<exists>x. P x)" by blast
lemma "(\<exists>x. P x) \<Longrightarrow> (\<And>x. P x \<Longrightarrow> R) \<Longrightarrow> R" by blast

lemma "x \<in> A \<Longrightarrow> x \<in> B \<Longrightarrow> x \<in> A \<inter> B" by blast
lemma "x \<in> A \<inter> B \<Longrightarrow> (x \<in> A \<Longrightarrow> x \<in> B \<Longrightarrow> R) \<Longrightarrow> R" by blast

lemma "x \<in> A \<Longrightarrow> x \<in> A \<union> B" by blast
lemma "x \<in> B \<Longrightarrow> x \<in> A \<union> B" by blast
lemma "x \<in> A \<union> B \<Longrightarrow> (x \<in> A \<Longrightarrow> R) \<Longrightarrow> (x \<in> B \<Longrightarrow> R) \<Longrightarrow> R" by blast

subsection \<open>Isar context elements\<close>

text \<open>We derive some results out of the blue, using Isar context
  elements and some explicit blocks.  This illustrates their meaning
  wrt.\ Pure connectives, without goal states getting in the way.\<close>

notepad
begin
  {
    fix x
    have "B x" sorry
  }
  have "\<And>x. B x" by fact

next

  {
    assume A
    have B sorry
  }
  have "A \<Longrightarrow> B" by fact

next

  {
    def x \<equiv> t
    have "B x" sorry
  }
  have "B t" by fact

next

  {
    obtain x :: 'a where "B x" sorry
    have C sorry
  }
  have C by fact

end

subsection \<open>Pure rule composition\<close>

text \<open>
  The Pure framework provides means for:

  \begin{itemize}

    \item backward-chaining of rules by @{inference resolution}

    \item closing of branches by @{inference assumption}

  \end{itemize}

  Both principles involve higher-order unification of @{text \<lambda>}-terms
  modulo @{text "\<alpha>\<beta>\<eta>"}-equivalence (cf.\ Huet and Miller).\<close>

notepad
begin
  assume a: A and b: B
  thm conjI
  thm conjI [of A B]  -- "instantiation"
  thm conjI [of A B, OF a b]  -- "instantiation and composition"
  thm conjI [OF a b]  -- "composition via unification (trivial)"
  thm conjI [OF \<open>A\<close> \<open>B\<close>]

  thm conjI [OF disjI1]
end

text \<open>Note: Low-level rule composition is tedious and leads to
  unreadable~/ unmaintainable expressions in the text.\<close>

subsection \<open>Structured backward reasoning\<close>

text \<open>Idea: Canonical proof decomposition via @{command fix}~/
  @{command assume}~/ @{command show}, where the body produces a
  natural deduction rule to refine some goal.\<close>

notepad
begin
  fix A B :: "'a \<Rightarrow> bool"

  have "\<And>x. A x \<Longrightarrow> B x"
  proof -
    fix x
    assume "A x"
    show "B x" sorry
  qed

  have "\<And>x. A x \<Longrightarrow> B x"
  proof -
    {
      fix x
      assume "A x"
      show "B x" sorry
    } -- "implicit block structure made explicit"
    note \<open>\<And>x. A x \<Longrightarrow> B x\<close>
      -- "side exit for the resulting rule"
  qed
end

subsection \<open>Structured rule application\<close>

text \<open>
  Idea: Previous facts and new claims are composed with a rule from
  the context (or background library).
\<close>

notepad
begin
  assume r1: "A \<Longrightarrow> B \<Longrightarrow> C"  -- \<open>simple rule (Horn clause)\<close>

  have A sorry  -- "prefix of facts via outer sub-proof"
  then have C
  proof (rule r1)
    show B sorry  -- "remaining rule premises via inner sub-proof"
  qed

  have C
  proof (rule r1)
    show A sorry
    show B sorry
  qed

  have A and B sorry
  then have C
  proof (rule r1)
  qed

  have A and B sorry
  then have C by (rule r1)

next

  assume r2: "A \<Longrightarrow> (\<And>x. B1 x \<Longrightarrow> B2 x) \<Longrightarrow> C"  -- \<open>nested rule\<close>

  have A sorry
  then have C
  proof (rule r2)
    fix x
    assume "B1 x"
    show "B2 x" sorry
  qed

  txt \<open>The compound rule premise @{prop "\<And>x. B1 x \<Longrightarrow> B2 x"} is better
    addressed via @{command fix}~/ @{command assume}~/ @{command show}
    in the nested proof body.\<close>
end

subsection \<open>Example: predicate logic\<close>

text \<open>
  Using the above principles, standard introduction and elimination proofs
  of predicate logic connectives of HOL work as follows.
\<close>

notepad
begin
  have "A \<longrightarrow> B" and A sorry
  then have B ..

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

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

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

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

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

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

  have False sorry
  then have A ..

  have True ..

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

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

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

  have "\<forall>x. P x" sorry
  then have "P a" ..

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

  have "\<exists>x. P x" sorry
  then have C
  proof
    fix a
    assume "P a"
    show C sorry
  qed

  txt \<open>Less awkward version using @{command obtain}:\<close>
  have "\<exists>x. P x" sorry
  then obtain a where "P a" ..
end

text \<open>Further variations to illustrate Isar sub-proofs involving
  @{command show}:\<close>

notepad
begin
  have "A \<and> B"
  proof  -- \<open>two strictly isolated subproofs\<close>
    show A sorry
  next
    show B sorry
  qed

  have "A \<and> B"
  proof  -- \<open>one simultaneous sub-proof\<close>
    show A and B sorry
  qed

  have "A \<and> B"
  proof  -- \<open>two subproofs in the same context\<close>
    show A sorry
    show B sorry
  qed

  have "A \<and> B"
  proof  -- \<open>swapped order\<close>
    show B sorry
    show A sorry
  qed

  have "A \<and> B"
  proof  -- \<open>sequential subproofs\<close>
    show A sorry
    show B using \<open>A\<close> sorry
  qed
end

subsubsection \<open>Example: set-theoretic operators\<close>

text \<open>There is nothing special about logical connectives (@{text
  "\<and>"}, @{text "\<or>"}, @{text "\<forall>"}, @{text "\<exists>"} etc.).  Operators from
  set-theory or lattice-theory work analogously.  It is only a matter
  of rule declarations in the library; rules can be also specified
  explicitly.
\<close>

notepad
begin
  have "x \<in> A" and "x \<in> B" sorry
  then have "x \<in> A \<inter> B" ..

  have "x \<in> A" sorry
  then have "x \<in> A \<union> B" ..

  have "x \<in> B" sorry
  then have "x \<in> A \<union> B" ..

  have "x \<in> A \<union> B" sorry
  then have C
  proof
    assume "x \<in> A"
    then show C sorry
  next
    assume "x \<in> B"
    then show C sorry
  qed

next
  have "x \<in> \<Inter>A"
  proof
    fix a
    assume "a \<in> A"
    show "x \<in> a" sorry
  qed

  have "x \<in> \<Inter>A" sorry
  then have "x \<in> a"
  proof
    show "a \<in> A" sorry
  qed

  have "a \<in> A" and "x \<in> a" sorry
  then have "x \<in> \<Union>A" ..

  have "x \<in> \<Union>A" sorry
  then obtain a where "a \<in> A" and "x \<in> a" ..
end

section \<open>Generalized elimination and cases\<close>

subsection \<open>General elimination rules\<close>

text \<open>
  The general format of elimination rules is illustrated by the
  following typical representatives:
\<close>

thm exE     -- \<open>local parameter\<close>
thm conjE   -- \<open>local premises\<close>
thm disjE   -- \<open>split into cases\<close>

text \<open>
  Combining these characteristics leads to the following general scheme
  for elimination rules with cases:

  \begin{itemize}

  \item prefix of assumptions (or ``major premises'')

  \item one or more cases that enable to establish the main conclusion
    in an augmented context

  \end{itemize}
\<close>

notepad
begin
  assume r:
    "A1 \<Longrightarrow> A2 \<Longrightarrow>  (* assumptions *)
      (\<And>x y. B1 x y \<Longrightarrow> C1 x y \<Longrightarrow> R) \<Longrightarrow>  (* case 1 *)
      (\<And>x y. B2 x y \<Longrightarrow> C2 x y \<Longrightarrow> R) \<Longrightarrow>  (* case 2 *)
      R  (* main conclusion *)"

  have A1 and A2 sorry
  then have R
  proof (rule r)
    fix x y
    assume "B1 x y" and "C1 x y"
    show ?thesis sorry
  next
    fix x y
    assume "B2 x y" and "C2 x y"
    show ?thesis sorry
  qed
end

text \<open>Here @{text "?thesis"} is used to refer to the unchanged goal
  statement.\<close>

subsection \<open>Rules with cases\<close>

text \<open>
  Applying an elimination rule to some goal, leaves that unchanged
  but allows to augment the context in the sub-proof of each case.

  Isar provides some infrastructure to support this:

  \begin{itemize}

  \item native language elements to state eliminations

  \item symbolic case names

  \item method @{method cases} to recover this structure in a
  sub-proof

  \end{itemize}
\<close>

print_statement exE
print_statement conjE
print_statement disjE

lemma
  assumes A1 and A2  -- \<open>assumptions\<close>
  obtains
    (case1)  x y where "B1 x y" and "C1 x y"
  | (case2)  x y where "B2 x y" and "C2 x y"
  sorry

subsubsection \<open>Example\<close>

lemma tertium_non_datur:
  obtains
    (T)  A
  | (F)  "\<not> A"
  by blast

notepad
begin
  fix x y :: 'a
  have C
  proof (cases "x = y" rule: tertium_non_datur)
    case T
    from \<open>x = y\<close> show ?thesis sorry
  next
    case F
    from \<open>x \<noteq> y\<close> show ?thesis sorry
  qed
end

subsubsection \<open>Example\<close>

text \<open>
  Isabelle/HOL specification mechanisms (datatype, inductive, etc.)
  provide suitable derived cases rules.
\<close>

datatype foo = Foo | Bar foo

notepad
begin
  fix x :: foo
  have C
  proof (cases x)
    case Foo
    from \<open>x = Foo\<close> show ?thesis sorry
  next
    case (Bar a)
    from \<open>x = Bar a\<close> show ?thesis sorry
  qed
end

subsection \<open>Obtaining local contexts\<close>

text \<open>A single ``case'' branch may be inlined into Isar proof text
  via @{command obtain}.  This proves @{prop "(\<And>x. B x \<Longrightarrow> thesis) \<Longrightarrow>
  thesis"} on the spot, and augments the context afterwards.\<close>

notepad
begin
  fix B :: "'a \<Rightarrow> bool"

  obtain x where "B x" sorry
  note \<open>B x\<close>

  txt \<open>Conclusions from this context may not mention @{term x} again!\<close>
  {
    obtain x where "B x" sorry
    from \<open>B x\<close> have C sorry
  }
  note \<open>C\<close>
end

end


section \<open>Records \label{sec:records}\<close>

(*<*)
theory Records imports Main begin
(*>*)

text \<open>
  \index{records|(}%
  Records are familiar from programming languages.  A record of $n$
  fields is essentially an $n$-tuple, but the record's components have
  names, which can make expressions easier to read and reduces the
  risk of confusing one field for another.

  A record of Isabelle/HOL covers a collection of fields, with select
  and update operations.  Each field has a specified type, which may
  be polymorphic.  The field names are part of the record type, and
  the order of the fields is significant --- as it is in Pascal but
  not in Standard ML.  If two different record types have field names
  in common, then the ambiguity is resolved in the usual way, by
  qualified names.

  Record types can also be defined by extending other record types.
  Extensible records make use of the reserved pseudo-field \cdx{more},
  which is present in every record type.  Generic record operations
  work on all possible extensions of a given type scheme; polymorphism
  takes care of structural sub-typing behind the scenes.  There are
  also explicit coercion functions between fixed record types.
\<close>

subsection \<open>Record Basics\<close>

text \<open>
  Record types are not primitive in Isabelle and have a delicate
  internal representation \<^cite>\<open>"NaraschewskiW-TPHOLs98"\<close>, based on
  nested copies of the primitive product type.  A \commdx{record}
  declaration introduces a new record type scheme by specifying its
  fields, which are packaged internally to hold up the perception of
  the record as a distinguished entity.  Here is a simple example:
\<close>

record point =
  Xcoord :: int
  Ycoord :: int

text \<open>\noindent
  Records of type \<^typ>\<open>point\<close> have two fields named \<^const>\<open>Xcoord\<close>
  and \<^const>\<open>Ycoord\<close>, both of type~\<^typ>\<open>int\<close>.  We now define a
  constant of type \<^typ>\<open>point\<close>:
\<close>

definition pt1 :: point where
"pt1 \<equiv> (| Xcoord = 999, Ycoord = 23 |)"

text \<open>\noindent
  We see above the ASCII notation for record brackets.  You can also
  use the symbolic brackets \<open>\<lparr>\<close> and \<open>\<rparr>\<close>.  Record type
  expressions can be also written directly with individual fields.
  The type name above is merely an abbreviation.
\<close>

definition pt2 :: "\<lparr>Xcoord :: int, Ycoord :: int\<rparr>" where
"pt2 \<equiv> \<lparr>Xcoord = -45, Ycoord = 97\<rparr>"

text \<open>
  For each field, there is a \emph{selector}\index{selector!record}
  function of the same name.  For example, if \<open>p\<close> has type \<^typ>\<open>point\<close> then \<open>Xcoord p\<close> denotes the value of the \<open>Xcoord\<close> field of~\<open>p\<close>.  Expressions involving field selection
  of explicit records are simplified automatically:
\<close>

lemma "Xcoord \<lparr>Xcoord = a, Ycoord = b\<rparr> = a"
  by simp

text \<open>
  The \emph{update}\index{update!record} operation is functional.  For
  example, \<^term>\<open>p\<lparr>Xcoord := 0\<rparr>\<close> is a record whose \<^const>\<open>Xcoord\<close>
  value is zero and whose \<^const>\<open>Ycoord\<close> value is copied from~\<open>p\<close>.  Updates of explicit records are also simplified automatically:
\<close>

lemma "\<lparr>Xcoord = a, Ycoord = b\<rparr>\<lparr>Xcoord := 0\<rparr> =
         \<lparr>Xcoord = 0, Ycoord = b\<rparr>"
  by simp

text \<open>
  \begin{warn}
  Field names are declared as constants and can no longer be used as
  variables.  It would be unwise, for example, to call the fields of
  type \<^typ>\<open>point\<close> simply \<open>x\<close> and~\<open>y\<close>.
  \end{warn}
\<close>

subsection \<open>Extensible Records and Generic Operations\<close>

text \<open>
  \index{records!extensible|(}%

  Now, let us define coloured points (type \<open>cpoint\<close>) to be
  points extended with a field \<open>col\<close> of type \<open>colour\<close>:
\<close>

datatype colour = Red | Green | Blue

record cpoint = point +
  col :: colour

text \<open>\noindent
  The fields of this new type are \<^const>\<open>Xcoord\<close>, \<open>Ycoord\<close> and
  \<open>col\<close>, in that order.
\<close>

definition cpt1 :: cpoint where
"cpt1 \<equiv> \<lparr>Xcoord = 999, Ycoord = 23, col = Green\<rparr>"

text \<open>
  We can define generic operations that work on arbitrary
  instances of a record scheme, e.g.\ covering \<^typ>\<open>point\<close>, \<^typ>\<open>cpoint\<close>, and any further extensions.  Every record structure has an
  implicit pseudo-field, \cdx{more}, that keeps the extension as an
  explicit value.  Its type is declared as completely
  polymorphic:~\<^typ>\<open>'a\<close>.  When a fixed record value is expressed
  using just its standard fields, the value of \<open>more\<close> is
  implicitly set to \<open>()\<close>, the empty tuple, which has type
  \<^typ>\<open>unit\<close>.  Within the record brackets, you can refer to the
  \<open>more\<close> field by writing ``\<open>\<dots>\<close>'' (three dots):
\<close>

lemma "Xcoord \<lparr>Xcoord = a, Ycoord = b, \<dots> = p\<rparr> = a"
  by simp

text \<open>
  This lemma applies to any record whose first two fields are \<open>Xcoord\<close> and~\<^const>\<open>Ycoord\<close>.  Note that \<open>\<lparr>Xcoord = a, Ycoord
  = b, \<dots> = ()\<rparr>\<close> is exactly the same as \<open>\<lparr>Xcoord = a, Ycoord
  = b\<rparr>\<close>.  Selectors and updates are always polymorphic wrt.\ the
  \<open>more\<close> part of a record scheme, its value is just ignored (for
  select) or copied (for update).

  The \<open>more\<close> pseudo-field may be manipulated directly as well,
  but the identifier needs to be qualified:
\<close>

lemma "point.more cpt1 = \<lparr>col = Green\<rparr>"
  by (simp add: cpt1_def)

text \<open>\noindent
  We see that the colour part attached to this \<^typ>\<open>point\<close> is a
  rudimentary record in its own right, namely \<open>\<lparr>col =
  Green\<rparr>\<close>.  In order to select or update \<open>col\<close>, this fragment
  needs to be put back into the context of the parent type scheme, say
  as \<open>more\<close> part of another \<^typ>\<open>point\<close>.

  To define generic operations, we need to know a bit more about
  records.  Our definition of \<^typ>\<open>point\<close> above has generated two
  type abbreviations:

  \medskip
  \begin{tabular}{l}
  \<^typ>\<open>point\<close>~\<open>=\<close>~\<open>\<lparr>Xcoord :: int, Ycoord :: int\<rparr>\<close> \\
  \<^typ>\<open>'a point_scheme\<close>~\<open>=\<close>~\<open>\<lparr>Xcoord :: int, Ycoord :: int, \<dots> :: 'a\<rparr>\<close> \\
  \end{tabular}
  \medskip

\noindent
  Type \<^typ>\<open>point\<close> is for fixed records having exactly the two fields
  \<^const>\<open>Xcoord\<close> and~\<open>Ycoord\<close>, while the polymorphic type \<^typ>\<open>'a point_scheme\<close> comprises all possible extensions to those two
  fields.  Note that \<^typ>\<open>unit point_scheme\<close> coincides with \<^typ>\<open>point\<close>, and \<^typ>\<open>\<lparr>col :: colour\<rparr> point_scheme\<close> with \<^typ>\<open>cpoint\<close>.

  In the following example we define two operations --- methods, if we
  regard records as objects --- to get and set any point's \<open>Xcoord\<close> field.
\<close>

definition getX :: "'a point_scheme \<Rightarrow> int" where
"getX r \<equiv> Xcoord r"
definition setX :: "'a point_scheme \<Rightarrow> int \<Rightarrow> 'a point_scheme" where
"setX r a \<equiv> r\<lparr>Xcoord := a\<rparr>"

text \<open>
  Here is a generic method that modifies a point, incrementing its
  \<^const>\<open>Xcoord\<close> field.  The \<open>Ycoord\<close> and \<open>more\<close> fields
  are copied across.  It works for any record type scheme derived from
  \<^typ>\<open>point\<close> (including \<^typ>\<open>cpoint\<close> etc.):
\<close>

definition incX :: "'a point_scheme \<Rightarrow> 'a point_scheme" where
"incX r \<equiv>
  \<lparr>Xcoord = Xcoord r + 1, Ycoord = Ycoord r, \<dots> = point.more r\<rparr>"

text \<open>
  Generic theorems can be proved about generic methods.  This trivial
  lemma relates \<^const>\<open>incX\<close> to \<open>getX\<close> and \<open>setX\<close>:
\<close>

lemma "incX r = setX r (getX r + 1)"
  by (simp add: getX_def setX_def incX_def)

text \<open>
  \begin{warn}
  If you use the symbolic record brackets \<open>\<lparr>\<close> and \<open>\<rparr>\<close>,
  then you must also use the symbolic ellipsis, ``\<open>\<dots>\<close>'', rather
  than three consecutive periods, ``\<open>...\<close>''.  Mixing the ASCII
  and symbolic versions causes a syntax error.  (The two versions are
  more distinct on screen than they are on paper.)
  \end{warn}%
  \index{records!extensible|)}
\<close>

subsection \<open>Record Equality\<close>

text \<open>
  Two records are equal\index{equality!of records} if all pairs of
  corresponding fields are equal.  Concrete record equalities are
  simplified automatically:
\<close>

lemma "(\<lparr>Xcoord = a, Ycoord = b\<rparr> = \<lparr>Xcoord = a', Ycoord = b'\<rparr>) =
    (a = a' \<and> b = b')"
  by simp

text \<open>
  The following equality is similar, but generic, in that \<open>r\<close>
  can be any instance of \<^typ>\<open>'a point_scheme\<close>:
\<close>

lemma "r\<lparr>Xcoord := a, Ycoord := b\<rparr> = r\<lparr>Ycoord := b, Xcoord := a\<rparr>"
  by simp

text \<open>\noindent
  We see above the syntax for iterated updates.  We could equivalently
  have written the left-hand side as \<open>r\<lparr>Xcoord := a\<rparr>\<lparr>Ycoord :=
  b\<rparr>\<close>.

  Record equality is \emph{extensional}:
  \index{extensionality!for records} a record is determined entirely
  by the values of its fields.
\<close>

lemma "r = \<lparr>Xcoord = Xcoord r, Ycoord = Ycoord r\<rparr>"
  by simp

text \<open>\noindent
  The generic version of this equality includes the pseudo-field
  \<open>more\<close>:
\<close>

lemma "r = \<lparr>Xcoord = Xcoord r, Ycoord = Ycoord r, \<dots> = point.more r\<rparr>"
  by simp

text \<open>
  The simplifier can prove many record equalities
  automatically, but general equality reasoning can be tricky.
  Consider proving this obvious fact:
\<close>

lemma "r\<lparr>Xcoord := a\<rparr> = r\<lparr>Xcoord := a'\<rparr> \<Longrightarrow> a = a'"
  apply simp?
  oops

text \<open>\noindent
  Here the simplifier can do nothing, since general record equality is
  not eliminated automatically.  One way to proceed is by an explicit
  forward step that applies the selector \<^const>\<open>Xcoord\<close> to both sides
  of the assumed record equality:
\<close>

lemma "r\<lparr>Xcoord := a\<rparr> = r\<lparr>Xcoord := a'\<rparr> \<Longrightarrow> a = a'"
  apply (drule_tac f = Xcoord in arg_cong)
  txt \<open>@{subgoals [display, indent = 0, margin = 65]}
    Now, \<open>simp\<close> will reduce the assumption to the desired
    conclusion.\<close>
  apply simp
  done

text \<open>
  The \<open>cases\<close> method is preferable to such a forward proof.  We
  state the desired lemma again:
\<close>

lemma "r\<lparr>Xcoord := a\<rparr> = r\<lparr>Xcoord := a'\<rparr> \<Longrightarrow> a = a'"

  txt \<open>The \methdx{cases} method adds an equality to replace the
  named record term by an explicit record expression, listing all
  fields.  It even includes the pseudo-field \<open>more\<close>, since the
  record equality stated here is generic for all extensions.\<close>

  apply (cases r)

  txt \<open>@{subgoals [display, indent = 0, margin = 65]} Again, \<open>simp\<close> finishes the proof.  Because \<open>r\<close> is now represented as
  an explicit record construction, the updates can be applied and the
  record equality can be replaced by equality of the corresponding
  fields (due to injectivity).\<close>

  apply simp
  done

text \<open>
  The generic cases method does not admit references to locally bound
  parameters of a goal.  In longer proof scripts one might have to
  fall back on the primitive \<open>rule_tac\<close> used together with the
  internal field representation rules of records.  The above use of
  \<open>(cases r)\<close> would become \<open>(rule_tac r = r in
  point.cases_scheme)\<close>.
\<close>

subsection \<open>Extending and Truncating Records\<close>

text \<open>
  Each record declaration introduces a number of derived operations to
  refer collectively to a record's fields and to convert between fixed
  record types.  They can, for instance, convert between types \<^typ>\<open>point\<close> and \<^typ>\<open>cpoint\<close>.  We can add a colour to a point or convert
  a \<^typ>\<open>cpoint\<close> to a \<^typ>\<open>point\<close> by forgetting its colour.

  \begin{itemize}

  \item Function \cdx{make} takes as arguments all of the record's
  fields (including those inherited from ancestors).  It returns the
  corresponding record.

  \item Function \cdx{fields} takes the record's very own fields and
  returns a record fragment consisting of just those fields.  This may
  be filled into the \<open>more\<close> part of the parent record scheme.

  \item Function \cdx{extend} takes two arguments: a record to be
  extended and a record containing the new fields.

  \item Function \cdx{truncate} takes a record (possibly an extension
  of the original record type) and returns a fixed record, removing
  any additional fields.

  \end{itemize}
  These functions provide useful abbreviations for standard
  record expressions involving constructors and selectors.  The
  definitions, which are \emph{not} unfolded by default, are made
  available by the collective name of \<open>defs\<close> (\<open>point.defs\<close>, \<open>cpoint.defs\<close>, etc.).
  For example, here are the versions of those functions generated for
  record \<^typ>\<open>point\<close>.  We omit \<open>point.fields\<close>, which happens to
  be the same as \<open>point.make\<close>.

  @{thm [display, indent = 0, margin = 65] point.make_def [no_vars]
  point.extend_def [no_vars] point.truncate_def [no_vars]}
  Contrast those with the corresponding functions for record \<^typ>\<open>cpoint\<close>.  Observe \<open>cpoint.fields\<close> in particular.
  @{thm [display, indent = 0, margin = 65] cpoint.make_def [no_vars]
  cpoint.fields_def [no_vars] cpoint.extend_def [no_vars]
  cpoint.truncate_def [no_vars]}

  To demonstrate these functions, we declare a new coloured point by
  extending an ordinary point.  Function \<open>point.extend\<close> augments
  \<open>pt1\<close> with a colour value, which is converted into an
  appropriate record fragment by \<open>cpoint.fields\<close>.
\<close>

definition cpt2 :: cpoint where
"cpt2 \<equiv> point.extend pt1 (cpoint.fields Green)"

text \<open>
  The coloured points \<^const>\<open>cpt1\<close> and \<open>cpt2\<close> are equal.  The
  proof is trivial, by unfolding all the definitions.  We deliberately
  omit the definition of~\<open>pt1\<close> in order to reveal the underlying
  comparison on type \<^typ>\<open>point\<close>.
\<close>

lemma "cpt1 = cpt2"
  apply (simp add: cpt1_def cpt2_def point.defs cpoint.defs)
  txt \<open>@{subgoals [display, indent = 0, margin = 65]}\<close>
  apply (simp add: pt1_def)
  done

text \<open>
  In the example below, a coloured point is truncated to leave a
  point.  We use the \<open>truncate\<close> function of the target record.
\<close>

lemma "point.truncate cpt2 = pt1"
  by (simp add: pt1_def cpt2_def point.defs)

text \<open>
  \begin{exercise}
  Extend record \<^typ>\<open>cpoint\<close> to have a further field, \<open>intensity\<close>, of type~\<^typ>\<open>nat\<close>.  Experiment with generic operations
  (using polymorphic selectors and updates) and explicit coercions
  (using \<open>extend\<close>, \<open>truncate\<close> etc.) among the three record
  types.
  \end{exercise}

  \begin{exercise}
  (For Java programmers.)
  Model a small class hierarchy using records.
  \end{exercise}
  \index{records|)}
\<close>

(*<*)
end
(*>*)


theory prop_16
imports Main
        "../../TestTheories/Listi"
        "../../TestTheories/Naturals"
        "$HIPSTER_HOME/IsaHipster"

begin

(*hipster last app rev*)
lemma lemma_a [thy_expl]: "app x2 NL.Nil = x2"
by (hipster_induct_schemes last.simps app.simps rev.simps)

lemma lemma_aa [thy_expl]: "app (app x1 y1) z1 = app x1 (app y1 z1)"
by (hipster_induct_schemes last.simps app.simps rev.simps)

lemma lemma_ab [thy_expl]: "app (rev x13) (rev y13) = rev (app y13 x13)"
by (hipster_induct_schemes last.simps app.simps rev.simps)

lemma lemma_ac [thy_expl]: "rev (rev x12) = x12"
by (hipster_induct_schemes last.simps app.simps rev.simps)

lemma unknown [thy_expl]: "last (app x x) = last x"
oops

(*hipster_cond notNil last app rev head*)
lemma lemma_ad [thy_expl]: "head (app x1 x1) = head x1"
by (hipster_induct_schemes notNil.simps last.simps app.simps rev.simps head.simps)

lemma lemma_ae [thy_expl]: "notNil (app x2 x2) = notNil x2"
by (hipster_induct_schemes notNil.simps last.simps app.simps rev.simps head.simps)

lemma lemma_af [thy_expl]: "notNil y3 \<Longrightarrow> last (NL.Cons x3 y3) = last y3"
by (hipster_induct_schemes notNil.simps last.simps app.simps rev.simps head.simps)

lemma lemma_ag [thy_expl]: "notNil x3 \<Longrightarrow> head (app x3 y3) = head x3"
by (hipster_induct_schemes notNil.simps last.simps app.simps rev.simps head.simps)

lemma lemma_ah [thy_expl]: "notNil x3 \<Longrightarrow> notNil (app x3 y3) = True"
by (hipster_induct_schemes notNil.simps last.simps app.simps rev.simps head.simps)

lemma lemma_ai [thy_expl]: "notNil y2 \<Longrightarrow> notNil (app x2 y2) = True"
by (hipster_induct_schemes notNil.simps last.simps app.simps rev.simps head.simps)

lemma lemma_aj [thy_expl]: "notNil x17 \<Longrightarrow> head (rev x17) = last x17"
by (hipster_induct_schemes notNil.simps last.simps app.simps rev.simps head.simps)

lemma lemma_ak [thy_expl]: "notNil x17 \<Longrightarrow> notNil (rev x17) = True"
by (hipster_induct_schemes notNil.simps last.simps app.simps rev.simps head.simps)

lemma lemma_al [thy_expl]: "last (app x17 x17) = last x17"
by (hipster_induct_schemes notNil.simps last.simps app.simps rev.simps head.simps)

theorem firstLast: "ts \<noteq> Nil \<Longrightarrow> head ts = last (rev ts)"
by (hipster_induct_schemes last.simps head.simps rev.simps notNil.simps)

end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_propositional_AndIdempotent
  imports "../../Test_Base"
begin

datatype ('a, 'b) pair = pair2 "'a" "'b"

datatype 'a list = nil2 | cons2 "'a" "'a list"

datatype Form = x "Form" "Form" | Not "Form" | Var "int"

fun y :: "'a list => 'a list => 'a list" where
  "y (nil2) y2 = y2"
| "y (cons2 z2 xs) y2 = cons2 z2 (y xs y2)"

fun or2 :: "bool list => bool" where
  "or2 (nil2) = False"
| "or2 (cons2 y2 xs) = (y2 | (or2 xs))"

fun models7 :: "int => ((int, bool) pair) list =>
                ((int, bool) pair) list" where
  "models7 z (nil2) = nil2"
| "models7 z (cons2 z2 xs) =
     (if (z ~= (case z2 of pair2 x2 y22 => x2)) then
        cons2 z2 (models7 z xs)
        else
        models7 z xs)"

fun models6 :: "int => ((int, bool) pair) list => bool list" where
  "models6 z (nil2) = nil2"
| "models6 z (cons2 (pair2 y22 True) x2) = models6 z x2"
| "models6 z (cons2 (pair2 y22 False) x2) =
     cons2 (z = y22) (models6 z x2)"

fun models5 :: "int => ((int, bool) pair) list =>
                ((int, bool) pair) list" where
  "models5 z (nil2) = nil2"
| "models5 z (cons2 z2 xs) =
     (if (z ~= (case z2 of pair2 x2 y22 => x2)) then
        cons2 z2 (models5 z xs)
        else
        models5 z xs)"

fun models4 :: "int => ((int, bool) pair) list => bool list" where
  "models4 z (nil2) = nil2"
| "models4 z (cons2 (pair2 y22 True) x2) =
     cons2 (z = y22) (models4 z x2)"
| "models4 z (cons2 (pair2 y22 False) x2) = models4 z x2"

function models :: "(((int, bool) pair) list) list => Form =>
                    (((int, bool) pair) list) list => (((int, bool) pair) list) list"
  and
  models2 :: "Form => (((int, bool) pair) list) list =>
                     (((int, bool) pair) list) list"
  and
  models3 :: "Form => ((int, bool) pair) list =>
                     (((int, bool) pair) list) list" where
  "models z q (nil2) = models2 q z"
| "models z q (cons2 z2 x2) = cons2 z2 (models z q x2)"
| "models2 q (nil2) = nil2"
| "models2 q (cons2 y2 z2) = models z2 q (models3 q y2)"
| "models3 (x p q) y2 = models2 q (models3 p y2)"
| "models3 (Not (x r q2)) y2 =
     y (models3 (Not r) y2) (models3 (x r (Not q2)) y2)"
| "models3 (Not (Not p2)) y2 = models3 p2 y2"
| "models3 (Not (Var x2)) y2 =
     (if (~ (or2 (models4 x2 y2))) then
        cons2 (cons2 (pair2 x2 False) (models5 x2 y2)) (nil2)
        else
        nil2)"
| "models3 (Var x3) y2 =
     (if (~ (or2 (models6 x3 y2))) then
        cons2 (cons2 (pair2 x3 True) (models7 x3 y2)) (nil2)
        else
        nil2)"
  by pat_completeness auto

fun valid :: "Form => bool" where
  "valid z =
   (case models3 (Not z) (nil2) of
      nil2 => True
      | cons2 y2 z2 => False)"

theorem property0 :
  "((valid (x p p)) = (valid p))"
  oops

end


(*  Title:       Real Euclidean space and Tarski's axioms
    Author:      Tim Makarios <tjm1983 at gmail.com>, 2012
    Maintainer:  Tim Makarios <tjm1983 at gmail.com>
*)

header "Real Euclidean space and Tarski's axioms"

theory Euclid_Tarski
imports Tarski
begin

subsection "Real Euclidean space satisfies the first five axioms"

abbreviation
  real_euclid_C :: "[real^('n::finite), real^('n), real^('n), real^('n)] \<Rightarrow> bool"
  ("_ _ \<congruent>\<^sub>\<real> _ _" [99,99,99,99] 50) where
    "real_euclid_C \<equiv> norm_metric.smC"

definition real_euclid_B :: "[real^('n::finite), real^('n), real^('n)] \<Rightarrow> bool"
  ("B\<^sub>\<real> _ _ _" [99,99,99] 50) where
    "B\<^sub>\<real> a b c \<equiv> \<exists>l. 0 \<le> l \<and> l \<le> 1 \<and> b - a = l *\<^sub>R (c - a)"

interpretation real_euclid: tarski_first5 real_euclid_C real_euclid_B
proof
  txt {* By virtue of being a semimetric space,
    real Euclidean space is already known to satisfy the first three axioms. *}
  { fix q a b c
    have "\<exists>x. B\<^sub>\<real> q a x \<and> a x \<congruent>\<^sub>\<real> b c"
    proof cases
      assume "q = a"
      let ?x = "a + c - b"
      have "B\<^sub>\<real> q a ?x"
      proof -
        let ?l = "0 :: real"
        note real_euclid_B_def [of q a ?x]
        moreover
          have "?l \<ge> 0" and "?l \<le> 1" by auto
        moreover
          from `q = a` have "a - q = 0" by simp
          hence "a - q = ?l *\<^sub>R (?x - q)" by simp
        ultimately show ?thesis by auto
      qed
      moreover
        have "a - ?x = b - c" by simp
        hence "a ?x \<congruent>\<^sub>\<real> b c" by (simp add: field_simps)
      ultimately show ?thesis by blast
    next
      assume "q \<noteq> a"
      hence "norm_dist q a > 0" by simp
      let ?k = "norm_dist b c / norm_dist q a"
      let ?x = "a + ?k *\<^sub>R (a - q)"
      have "B\<^sub>\<real> q a ?x"
      proof -
        let ?l = "1 / (1 + ?k)"
        have "?l > 0" by (simp add: add_pos_nonneg)
        note real_euclid_B_def [of q a ?x]
        moreover
          have "?l \<ge> 0" and "?l \<le> 1" by (auto simp add: add_pos_nonneg)
        moreover
          from scaleR_left_distrib [of 1 ?k "a - q"]
            have "(1 + ?k) *\<^sub>R (a - q) = ?x - q" by simp
          hence "?l *\<^sub>R ((1 + ?k) *\<^sub>R (a - q)) = ?l *\<^sub>R (?x - q)" by simp
          with `?l > 0` and scaleR_right_diff_distrib [of ?l ?x q]
            have "a - q = ?l *\<^sub>R (?x - q)" by simp
        ultimately show "B\<^sub>\<real> q a ?x" by blast
      qed
      moreover
        have "a ?x \<congruent>\<^sub>\<real> b c"
        proof -
          from norm_scaleR [of ?k "a - q"] have
            "norm_dist a ?x = \<bar>?k\<bar> * norm (a - q)" by simp
          also have
            "\<dots> = ?k * norm (a - q)" by simp
          also from norm_metric.symm [of q a] have
            "\<dots> = ?k * norm_dist q a" by simp
          finally have
            "norm_dist a ?x = norm_dist b c / norm_dist q a * norm_dist q a" .
          with `norm_dist q a > 0` show "a ?x \<congruent>\<^sub>\<real> b c" by auto
        qed
      ultimately show ?thesis by blast
    qed }
  thus "\<forall>q a b c. \<exists>x. B\<^sub>\<real> q a x \<and> a x \<congruent>\<^sub>\<real> b c" by auto
  { fix a b c d a' b' c' d'
    assume "a \<noteq> b" and
      "B\<^sub>\<real> a b c" and
      "B\<^sub>\<real> a' b' c'" and
      "a b \<congruent>\<^sub>\<real> a' b'" and
      "b c \<congruent>\<^sub>\<real> b' c'" and
      "a d \<congruent>\<^sub>\<real> a' d'" and
      "b d \<congruent>\<^sub>\<real> b' d'"
    have "c d \<congruent>\<^sub>\<real> c' d'"
    proof -
      { fix m
        fix p q r :: "real^('n::finite)"
        assume "0 \<le> m" and
          "m \<le> 1" and
          "p \<noteq> q" and
          "q - p = m *\<^sub>R (r - p)"
        from `p \<noteq> q` and `q - p = m *\<^sub>R (r - p)` have "m \<noteq> 0"
        proof -
          { assume "m = 0"
            with `q - p = m *\<^sub>R (r - p)` have "q - p = 0" by simp
            with `p \<noteq> q` have False by simp }
          thus ?thesis ..
        qed
        with `m \<ge> 0` have "m > 0" by simp
        from `q - p = m *\<^sub>R (r - p)` and
            scaleR_right_diff_distrib [of m r p]
          have "q - p = m *\<^sub>R r - m *\<^sub>R p" by simp
        hence "q - p - q + p - m *\<^sub>R r =
            m *\<^sub>R r - m *\<^sub>R p - q + p - m *\<^sub>R r"
          by simp
        with scaleR_left_diff_distrib [of 1 m p] and
            scaleR_left_diff_distrib [of 1 m q]
          have "(1 - m) *\<^sub>R p - (1 - m) *\<^sub>R q = m *\<^sub>R q - m *\<^sub>R r" by auto
        with scaleR_right_diff_distrib [of "1 - m" p q] and
            scaleR_right_diff_distrib [of m q r]
          have "(1 - m) *\<^sub>R (p - q) = m *\<^sub>R (q - r)" by simp
        with norm_scaleR [of "1 - m" "p - q"] and norm_scaleR [of m "q - r"]
          have "\<bar>1 - m\<bar> * norm (p - q) = \<bar>m\<bar> * norm (q - r)" by simp
        with `m > 0` and `m \<le> 1`
          have "norm (q - r) = (1 - m) / m * norm (p - q)" by simp
        moreover from `p \<noteq> q` have "norm (p - q) \<noteq> 0" by simp
        ultimately
          have "norm (q - r) / norm (p - q) = (1 - m) / m" by simp
        with `m \<noteq> 0` have
          "norm_dist q r / norm_dist p q = (1 - m) / m" and "m \<noteq> 0" by auto }
      note linelemma = this
      from real_euclid_B_def [of a b c] and `B\<^sub>\<real> a b c`
        obtain l where "0 \<le> l" and "l \<le> 1" and  "b - a = l *\<^sub>R (c - a)" by auto
      from real_euclid_B_def [of a' b' c'] and `B\<^sub>\<real> a' b' c'`
        obtain l' where"0 \<le> l'" and "l' \<le> 1" and  "b' - a' = l' *\<^sub>R (c' - a')" by auto
      from `a \<noteq> b` and `a b \<congruent>\<^sub>\<real> a' b'` have "a' \<noteq> b'" by auto
      from linelemma [of l a b c] and
          `l \<ge> 0` and
          `l \<le> 1` and
          `a \<noteq> b` and
          `b - a = l *\<^sub>R (c - a)`
        have "l \<noteq> 0" and "(1 - l) / l = norm_dist b c / norm_dist a b" by auto
      from `(1 - l) / l = norm_dist b c / norm_dist a b` and
          `a b \<congruent>\<^sub>\<real> a' b'` and
          `b c \<congruent>\<^sub>\<real> b' c'`
        have "(1 - l) / l = norm_dist b' c' / norm_dist a' b'" by simp
      with linelemma [of l' a' b' c'] and
          `l' \<ge> 0` and
          `l' \<le> 1` and
          `a' \<noteq> b'` and
          `b' - a' = l' *\<^sub>R (c' - a')`
        have "l' \<noteq> 0" and "(1 - l) / l = (1 - l') / l'" by auto
      from `(1 - l) / l = (1 - l') / l'`
        have "(1 - l) / l * l * l' = (1 - l') / l' * l * l'" by simp
      with `l \<noteq> 0` and `l' \<noteq> 0` have "(1 - l) * l' = (1 - l') * l" by simp
      with left_diff_distrib [of 1 l l'] and left_diff_distrib [of 1 l' l]
        have "l = l'" by simp
      { fix m
        fix p q r s :: "real^('n::finite)"
        assume "m \<noteq> 0" and
          "q - p = m *\<^sub>R (r - p)"
        with scaleR_scaleR have "r - p = (1/m) *\<^sub>R (q - p)" by simp
        with cosine_rule [of r s p]
          have "(norm_dist r s)\<^sup>2 = (norm_dist r p)\<^sup>2 + (norm_dist p s)\<^sup>2 +
              2 * (((1/m) *\<^sub>R (q - p)) \<bullet> (p - s))"
            by simp
        also from inner_scaleR_left [of "1/m" "q - p" "p - s"]
          have "\<dots> =
              (norm_dist r p)\<^sup>2 + (norm_dist p s)\<^sup>2 + 2/m * ((q - p) \<bullet> (p - s))"
            by simp
        also from `m \<noteq> 0` and cosine_rule [of q s p]
          have "\<dots> = (norm_dist r p)\<^sup>2 + (norm_dist p s)\<^sup>2 +
              1/m * ((norm_dist q s)\<^sup>2 - (norm_dist q p)\<^sup>2 - (norm_dist p s)\<^sup>2)"
            by simp
        finally have "(norm_dist r s)\<^sup>2 = (norm_dist r p)\<^sup>2 + (norm_dist p s)\<^sup>2 +
          1/m * ((norm_dist q s)\<^sup>2 - (norm_dist q p)\<^sup>2 - (norm_dist p s)\<^sup>2)" .
        moreover
        { from norm_dist_dot [of r p] and `r - p = (1/m) *\<^sub>R (q - p)`
            have "(norm_dist r p)\<^sup>2 = ((1/m) *\<^sub>R (q - p)) \<bullet> ((1/m) *\<^sub>R (q - p))"
              by simp
          also from inner_scaleR_left [of "1/m" "q - p"] and
              inner_scaleR_right [of _ "1/m" "q - p"]
            have "\<dots> = 1/m\<^sup>2 * ((q - p) \<bullet> (q - p))"
              by (simp add: power2_eq_square)
          also from norm_dist_dot [of q p] have "\<dots> = 1/m\<^sup>2 * (norm_dist q p)\<^sup>2"
            by simp
          finally have "(norm_dist r p)\<^sup>2 = 1/m\<^sup>2 * (norm_dist q p)\<^sup>2" . }
        ultimately have
          "(norm_dist r s)\<^sup>2 = 1/m\<^sup>2 * (norm_dist q p)\<^sup>2 + (norm_dist p s)\<^sup>2 +
            1/m * ((norm_dist q s)\<^sup>2 - (norm_dist q p)\<^sup>2 - (norm_dist p s)\<^sup>2)"
          by simp
        with norm_metric.symm [of q p]
          have "(norm_dist r s)\<^sup>2 = 1/m\<^sup>2 * (norm_dist p q)\<^sup>2 + (norm_dist p s)\<^sup>2 +
              1/m * ((norm_dist q s)\<^sup>2 - (norm_dist p q)\<^sup>2 - (norm_dist p s)\<^sup>2)"
            by simp }
      note fiveseglemma = this
      from fiveseglemma [of l b a c d] and `l \<noteq> 0` and `b - a = l *\<^sub>R (c - a)`
        have "(norm_dist c d)\<^sup>2 = 1/l\<^sup>2 * (norm_dist a b)\<^sup>2 + (norm_dist a d)\<^sup>2 +
            1/l * ((norm_dist b d)\<^sup>2 - (norm_dist a b)\<^sup>2 - (norm_dist a d)\<^sup>2)"
          by simp
      also from `l = l'` and
          `a b \<congruent>\<^sub>\<real> a' b'` and
          `a d \<congruent>\<^sub>\<real> a' d'` and
          `b d \<congruent>\<^sub>\<real> b' d'`
        have "\<dots> = 1/l'\<^sup>2 * (norm_dist a' b')\<^sup>2 + (norm_dist a' d')\<^sup>2 +
            1/l' * ((norm_dist b' d')\<^sup>2 - (norm_dist a' b')\<^sup>2 - (norm_dist a' d')\<^sup>2)"
          by simp
      also from fiveseglemma [of l' b' a' c' d'] and
          `l' \<noteq> 0` and
          `b' - a' = l' *\<^sub>R (c' - a')`
        have "\<dots> = (norm_dist c' d')\<^sup>2" by simp
      finally have "(norm_dist c d)\<^sup>2 = (norm_dist c' d')\<^sup>2" .
      hence "sqrt ((norm_dist c d)\<^sup>2) = sqrt ((norm_dist c' d')\<^sup>2)" by simp
      with real_sqrt_abs show "c d \<congruent>\<^sub>\<real> c' d'" by simp
    qed }
  thus "\<forall>a b c d a' b' c' d'.
          a \<noteq> b \<and> B\<^sub>\<real> a b c \<and> B\<^sub>\<real> a' b' c' \<and>
          a b \<congruent>\<^sub>\<real> a' b' \<and> b c \<congruent>\<^sub>\<real> b' c' \<and> a d \<congruent>\<^sub>\<real> a' d' \<and> b d \<congruent>\<^sub>\<real> b' d' \<longrightarrow>
            c d \<congruent>\<^sub>\<real> c' d'"
    by blast
qed

subsection "Real Euclidean space also satisfies axioms 6, 7, and 11"

lemma rearrange_real_euclid_B:
  fixes w y z :: "real^('n)" and h
  shows "y - w = h *\<^sub>R (z - w) \<longleftrightarrow> y = h *\<^sub>R z + (1 - h) *\<^sub>R w"
proof
  assume "y - w = h *\<^sub>R (z - w)"
  hence "y - w + w = h *\<^sub>R (z - w) + w" by simp
  hence "y = h *\<^sub>R (z - w) + w" by simp
  with scaleR_right_diff_distrib [of h z w]
    have "y = h *\<^sub>R z + w - h *\<^sub>R w" by simp
  with scaleR_left_diff_distrib [of 1 h w]
    show "y = h *\<^sub>R z + (1 - h) *\<^sub>R w" by simp
next
  assume "y = h *\<^sub>R z + (1 - h) *\<^sub>R w"
  with scaleR_left_diff_distrib [of 1 h w]
    have "y = h *\<^sub>R z + w - h *\<^sub>R w" by simp
  with scaleR_right_diff_distrib [of h z w]
    have "y = h *\<^sub>R (z - w) + w" by simp
  hence "y - w + w = h *\<^sub>R (z - w) + w" by simp
  thus "y - w = h *\<^sub>R (z - w)" by simp
qed

interpretation real_euclid: tarski_absolute_space real_euclid_C real_euclid_B
proof
  { fix a b
    assume "B\<^sub>\<real> a b a"
    with real_euclid_B_def [of a b a]
      obtain l where "b - a = l *\<^sub>R (a - a)" by auto
    hence "a = b" by simp }
  thus "\<forall>a b. B\<^sub>\<real> a b a \<longrightarrow> a = b" by auto
  { fix a b c p q
    assume "B\<^sub>\<real> a p c" and "B\<^sub>\<real> b q c"
    from real_euclid_B_def [of a p c] and `B\<^sub>\<real> a p c`
      obtain i where "i \<ge> 0" and "i \<le> 1" and "p - a = i *\<^sub>R (c - a)" by auto
    have "\<exists>x. B\<^sub>\<real> p x b \<and> B\<^sub>\<real> q x a"
    proof cases
      assume "i = 0"
      with `p - a = i *\<^sub>R (c - a)` have "p = a" by simp
      hence "p - a = 0 *\<^sub>R (b - p)" by simp
      moreover have "(0::real) \<ge> 0" and "(0::real) \<le> 1" by auto
      moreover note real_euclid_B_def [of p a b]
      ultimately have "B\<^sub>\<real> p a b" by auto
      moreover
      { have "a - q = 1 *\<^sub>R (a - q)" by simp
        moreover have "(1::real) \<ge> 0" and "(1::real) \<le> 1" by auto
        moreover note real_euclid_B_def [of q a a]
        ultimately have "B\<^sub>\<real> q a a" by blast }
      ultimately have "B\<^sub>\<real> p a b \<and> B\<^sub>\<real> q a a" by simp
      thus "\<exists>x. B\<^sub>\<real> p x b \<and> B\<^sub>\<real> q x a" by auto
    next
      assume "i \<noteq> 0"
      from real_euclid_B_def [of b q c] and `B\<^sub>\<real> b q c`
        obtain j where "j \<ge> 0" and "j \<le> 1" and "q - b = j *\<^sub>R (c - b)" by auto
      from `i \<ge> 0` and `i \<le> 1`
        have "1 - i \<ge> 0" and "1 - i \<le> 1" by auto
      from `j \<ge> 0` and `1 - i \<ge> 0`
        have "j * (1 - i) \<ge> 0" by auto
      with `i \<ge> 0` and `i \<noteq> 0` have "i + j * (1 - i) > 0" by simp
      hence "i + j * (1 - i) \<noteq> 0" by simp
      let ?l = "j * (1 - i) / (i + j * (1 - i))"
      from diff_divide_distrib [of "i + j * (1 - i)" "j * (1 - i)" "i + j * (1 - i)"] and
          `i + j * (1 - i) \<noteq> 0`
        have "1 - ?l = i / (i + j * (1 - i))" by simp
      let ?k = "i * (1 - j) / (j + i * (1 - j))"
      from right_diff_distrib [of i 1 j] and
          right_diff_distrib [of j 1 i] and
          mult.commute [of i j] and
          add.commute [of i j]
        have "j + i * (1 - j) = i + j * (1 - i)" by simp
      with `i + j * (1 - i) \<noteq> 0` have "j + i * (1 - j) \<noteq> 0" by simp
      with diff_divide_distrib [of "j + i * (1 - j)" "i * (1 - j)" "j + i * (1 - j)"]
        have "1 - ?k = j / (j + i * (1 - j))" by simp
      with `1 - ?l = i / (i + j * (1 - i))` and
          `j + i * (1 - j) = i + j * (1 - i)` and
          times_divide_eq_left [of _ "i + j * (1 - i)"] and
          mult.commute [of i j]
        have "(1 - ?l) * j = (1 - ?k) * i" by simp
      moreover
      { from `1 - ?k = j / (j + i * (1 - j))` and
            `j + i * (1 - j) = i + j * (1 - i)`
          have "?l = (1 - ?k) * (1 - i)" by simp }
      moreover
      { from `1 - ?l = i / (i + j * (1 - i))` and
            `j + i * (1 - j) = i + j * (1 - i)`
          have "(1 - ?l) * (1 - j) = ?k" by simp }
      ultimately
        have "?l *\<^sub>R a + ((1 - ?l) * j) *\<^sub>R c + ((1 - ?l) * (1 - j)) *\<^sub>R b =
            ?k *\<^sub>R b + ((1 - ?k) * i) *\<^sub>R c + ((1 - ?k) * (1 - i)) *\<^sub>R a"
          by simp
      with scaleR_scaleR
        have "?l *\<^sub>R a + (1 - ?l) *\<^sub>R j *\<^sub>R c + (1 - ?l) *\<^sub>R (1 - j) *\<^sub>R b =
            ?k *\<^sub>R b + (1 - ?k) *\<^sub>R i *\<^sub>R c + (1 - ?k) *\<^sub>R (1 - i) *\<^sub>R a"
          by simp
      with scaleR_right_distrib [of "(1 - ?l)" "j *\<^sub>R c" "(1 - j) *\<^sub>R b"] and
          scaleR_right_distrib [of "(1 - ?k)" "i *\<^sub>R c" "(1 - i) *\<^sub>R a"] and
          add.assoc [of "?l *\<^sub>R a" "(1 - ?l) *\<^sub>R j *\<^sub>R c" "(1 - ?l) *\<^sub>R (1 - j) *\<^sub>R b"] and
          add.assoc [of "?k *\<^sub>R b" "(1 - ?k) *\<^sub>R i *\<^sub>R c" "(1 - ?k) *\<^sub>R (1 - i) *\<^sub>R a"]
        have "?l *\<^sub>R a + (1 - ?l) *\<^sub>R (j *\<^sub>R c + (1 - j) *\<^sub>R b) =
            ?k *\<^sub>R b + (1 - ?k) *\<^sub>R (i *\<^sub>R c + (1 - i) *\<^sub>R a)"
          by arith
      from `?l *\<^sub>R a + (1 - ?l) *\<^sub>R (j *\<^sub>R c + (1 - j) *\<^sub>R b) =
            ?k *\<^sub>R b + (1 - ?k) *\<^sub>R (i *\<^sub>R c + (1 - i) *\<^sub>R a)` and
          `p - a = i *\<^sub>R (c - a)` and
          `q - b = j *\<^sub>R (c - b)` and
          rearrange_real_euclid_B [of p a i c] and
          rearrange_real_euclid_B [of q b j c]
        have "?l *\<^sub>R a + (1 - ?l) *\<^sub>R q = ?k *\<^sub>R b + (1 - ?k) *\<^sub>R p" by simp
      let ?x = "?l *\<^sub>R a + (1 - ?l) *\<^sub>R q"
      from rearrange_real_euclid_B [of ?x q ?l a]
        have "?x - q = ?l *\<^sub>R (a - q)" by simp
      from `?x = ?k *\<^sub>R b + (1 - ?k) *\<^sub>R p` and
          rearrange_real_euclid_B [of ?x p ?k b]
        have "?x - p = ?k *\<^sub>R (b - p)" by simp
      from `i + j * (1 - i) > 0` and
          `j * (1 - i) \<ge> 0` and
          zero_le_divide_iff [of "j * (1 - i)" "i + j * (1 - i)"]
        have "?l \<ge> 0" by simp
      from `i + j * (1 - i) > 0` and
          `i \<ge> 0` and
          zero_le_divide_iff [of i "i + j * (1 - i)"] and
          `1 - ?l = i / (i + j * (1 - i))`
        have "1 - ?l \<ge> 0" by simp
      hence "?l \<le> 1" by simp
      with `?l \<ge> 0` and
          `?x - q = ?l *\<^sub>R (a - q)` and
          real_euclid_B_def [of q ?x a]
        have "B\<^sub>\<real> q ?x a" by auto
      from `j \<le> 1` have "1 - j \<ge> 0" by simp
      with `1 - ?l \<ge> 0` and
          `(1 - ?l) * (1 - j) = ?k` and
          zero_le_mult_iff [of "1 - ?l" "1 - j"]
        have "?k \<ge> 0" by simp
      from `j \<ge> 0` have "1 - j \<le> 1" by simp
      from `?l \<ge> 0` have "1 - ?l \<le> 1" by simp
      with `1 - j \<le> 1` and
          `1 - j \<ge> 0` and
          mult_mono [of "1 - ?l" 1 "1 - j" 1] and
          `(1 - ?l) * (1 - j) = ?k`
        have "?k \<le> 1" by simp
      with `?k \<ge> 0` and
          `?x - p = ?k *\<^sub>R (b - p)` and
          real_euclid_B_def [of p ?x b]
        have "B\<^sub>\<real> p ?x b" by auto
      with `B\<^sub>\<real> q ?x a` show ?thesis by auto
    qed }
  thus "\<forall>a b c p q. B\<^sub>\<real> a p c \<and> B\<^sub>\<real> b q c \<longrightarrow> (\<exists>x. B\<^sub>\<real> p x b \<and> B\<^sub>\<real> q x a)" by auto
  { fix X Y
    assume "\<exists>a. \<forall>x y. x \<in> X \<and> y \<in> Y \<longrightarrow> B\<^sub>\<real> a x y"
    then obtain a where "\<forall>x y. x \<in> X \<and> y \<in> Y \<longrightarrow> B\<^sub>\<real> a x y" by auto
    have "\<exists>b. \<forall>x y. x \<in> X \<and> y \<in> Y \<longrightarrow> B\<^sub>\<real> x b y"
    proof cases
      assume "X \<subseteq> {a} \<or> Y = {}"
      let ?b = a
      { fix x y
        assume "x \<in> X" and "y \<in> Y"
        with `X \<subseteq> {a} \<or> Y = {}` have "x = a" by auto
        from `\<forall>x y. x \<in> X \<and> y \<in> Y \<longrightarrow> B\<^sub>\<real> a x y` and `x \<in> X` and `y \<in> Y`
          have "B\<^sub>\<real> a x y" by simp
        with `x = a` have "B\<^sub>\<real> x ?b y" by simp }
      hence "\<forall>x y. x \<in> X \<and> y \<in> Y \<longrightarrow> B\<^sub>\<real> x ?b y" by simp
      thus ?thesis by auto
    next
      assume "\<not>(X \<subseteq> {a} \<or> Y = {})"
      hence "X - {a} \<noteq> {}" and "Y \<noteq> {}" by auto
      from `X - {a} \<noteq> {}` obtain c where "c \<in> X" and "c \<noteq> a" by auto
      from `c \<noteq> a` have "c - a \<noteq> 0" by simp
      { fix y
        assume "y \<in> Y"
        with `\<forall>x y. x \<in> X \<and> y \<in> Y \<longrightarrow> B\<^sub>\<real> a x y` and `c \<in> X`
          have "B\<^sub>\<real> a c y" by simp
        with real_euclid_B_def [of a c y]
          obtain l where "l \<ge> 0" and "l \<le> 1" and "c - a = l *\<^sub>R (y - a)" by auto
        from `c - a = l *\<^sub>R (y - a)` and `c - a \<noteq> 0` have "l \<noteq> 0" by simp
        with `l \<ge> 0` have "l > 0" by simp
        with `c - a = l *\<^sub>R (y - a)` have "y - a = (1/l) *\<^sub>R (c - a)" by simp
        from `l > 0` and `l \<le> 1` have "1/l \<ge> 1" by simp
        with `y - a = (1/l) *\<^sub>R (c - a)`
          have "\<exists>j\<ge>1. y - a = j *\<^sub>R (c - a)" by auto }
      note ylemma = this
      from `Y \<noteq> {}` obtain d where "d \<in> Y" by auto
      with ylemma [of d]
        obtain "jd" where "jd \<ge> 1" and "d - a = jd *\<^sub>R (c - a)" by auto
      { fix x
        assume "x \<in> X"
        with `\<forall>x y. x \<in> X \<and> y \<in> Y \<longrightarrow> B\<^sub>\<real> a x y` and `d \<in> Y`
          have "B\<^sub>\<real> a x d" by simp
        with real_euclid_B_def [of a x d]
          obtain l where "l \<ge> 0" and "x - a = l *\<^sub>R (d - a)" by auto
        from `x - a = l *\<^sub>R (d - a)` and
            `d - a = jd *\<^sub>R (c - a)` and
            scaleR_scaleR
          have "x - a = (l * jd) *\<^sub>R (c - a)" by simp
        hence "\<exists>i. x - a = i *\<^sub>R (c - a)" by auto }
      note xlemma = this
      let ?S = "{j. j \<ge> 1 \<and> (\<exists>y\<in>Y. y - a = j *\<^sub>R (c - a))}"
      from `d \<in> Y` and `jd \<ge> 1` and `d - a = jd *\<^sub>R (c - a)`
        have "?S \<noteq> {}" by auto
      let ?k = "Inf ?S"
      let ?b = "?k *\<^sub>R c + (1 - ?k) *\<^sub>R a"
      from rearrange_real_euclid_B [of ?b a ?k c]
        have "?b - a = ?k *\<^sub>R (c - a)" by simp
      { fix x y
        assume "x \<in> X" and "y \<in> Y"
        from xlemma [of x] and `x \<in> X`
          obtain i where "x - a = i *\<^sub>R (c - a)" by auto
        from ylemma [of y] and `y \<in> Y`
          obtain j where "j \<ge> 1" and "y - a = j *\<^sub>R (c - a)" by auto
        with `y \<in> Y` have "j \<in> ?S" by auto
        then have "?k \<le> j" by (auto intro: cInf_lower)
        { fix h
          assume "h \<in> ?S"
          hence "h \<ge> 1" by simp
          from `h \<in> ?S`
            obtain z where "z \<in> Y" and "z - a = h *\<^sub>R (c - a)" by auto
          from `\<forall>x y. x \<in> X \<and> y \<in> Y \<longrightarrow> B\<^sub>\<real> a x y` and `x \<in> X` and `z \<in> Y`
            have "B\<^sub>\<real> a x z" by simp
          with real_euclid_B_def [of a x z]
            obtain l where "l \<le> 1" and "x - a = l *\<^sub>R (z - a)" by auto
          with `z - a = h *\<^sub>R (c - a)` and scaleR_scaleR
            have "x - a = (l * h) *\<^sub>R (c - a)" by simp
          with `x - a = i *\<^sub>R (c - a)`
            have "i *\<^sub>R (c - a) = (l * h) *\<^sub>R (c - a)" by auto
          with scaleR_cancel_right and `c - a \<noteq> 0` have "i = l * h" by blast
          with `l \<le> 1` and `h \<ge> 1` have "i \<le> h" by simp }
        with `?S \<noteq> {}` and cInf_greatest [of ?S] have "i \<le> ?k" by simp
        have "y - x = (y - a) - (x - a)" by simp
        with `y - a = j *\<^sub>R (c - a)` and `x - a = i *\<^sub>R (c - a)`
          have "y - x = j *\<^sub>R (c - a) - i *\<^sub>R (c - a)" by simp
        with scaleR_left_diff_distrib [of j i "c - a"]
          have "y - x = (j - i) *\<^sub>R (c - a)" by simp
        have "?b - x = (?b - a) - (x - a)" by simp
        with `?b - a = ?k *\<^sub>R (c - a)` and `x - a = i *\<^sub>R (c - a)`
          have "?b - x = ?k *\<^sub>R (c - a) - i *\<^sub>R (c - a)" by simp
        with scaleR_left_diff_distrib [of ?k i "c - a"]
          have "?b - x = (?k - i) *\<^sub>R (c - a)" by simp
        have "B\<^sub>\<real> x ?b y"
        proof cases
          assume "i = j"
          with `i \<le> ?k` and `?k \<le> j` have "?k = i" by simp
          with `?b - x = (?k - i) *\<^sub>R (c - a)` have "?b - x = 0" by simp
          hence "?b - x = 0 *\<^sub>R (y - x)" by simp
          with real_euclid_B_def [of x ?b y] show "B\<^sub>\<real> x ?b y" by auto
        next
          assume "i \<noteq> j"
          with `i \<le> ?k` and `?k \<le> j` have "j - i > 0" by simp
          with `y - x = (j - i) *\<^sub>R (c - a)` and scaleR_scaleR
            have "c - a = (1 / (j - i)) *\<^sub>R (y - x)" by simp
          with `?b - x = (?k - i) *\<^sub>R (c - a)` and scaleR_scaleR
            have "?b - x = ((?k - i) / (j - i)) *\<^sub>R (y - x)" by simp
          let ?l = "(?k - i) / (j - i)"
          from `?k \<le> j` have "?k - i \<le> j - i" by simp
          with `j - i > 0` have "?l \<le> 1" by simp
          from `i \<le> ?k` and `j - i > 0` and pos_le_divide_eq [of "j - i" 0 "?k - i"]
            have "?l \<ge> 0" by simp
          with real_euclid_B_def [of x ?b y] and
              `?l \<le> 1` and
              `?b - x = ?l *\<^sub>R (y - x)`
            show "B\<^sub>\<real> x ?b y" by auto
        qed }
      thus "\<exists>b. \<forall>x y. x \<in> X \<and> y \<in> Y \<longrightarrow> B\<^sub>\<real> x b y" by auto
    qed }
  thus "\<forall>X Y. (\<exists>a. \<forall>x y. x \<in> X \<and> y \<in> Y \<longrightarrow> B\<^sub>\<real> a x y) \<longrightarrow>
          (\<exists>b. \<forall>x y. x \<in> X \<and> y \<in> Y \<longrightarrow> B\<^sub>\<real> x b y)"
    by auto
qed

subsection "Real Euclidean space satisfies the Euclidean axiom"

lemma rearrange_real_euclid_B_2:
  fixes a b c :: "real^('n::finite)"
  assumes "l \<noteq> 0"
  shows "b - a = l *\<^sub>R (c - a) \<longleftrightarrow> c = (1/l) *\<^sub>R b + (1 - 1/l) *\<^sub>R a"
proof
  from scaleR_right_diff_distrib [of "1/l" b a]
    have "(1/l) *\<^sub>R (b - a) = c - a \<longleftrightarrow> (1/l) *\<^sub>R b - (1/l) *\<^sub>R a + a = c" by auto
  also with scaleR_left_diff_distrib [of 1 "1/l" a]
    have "\<dots> \<longleftrightarrow> c = (1/l) *\<^sub>R b + (1 - 1/l) *\<^sub>R a" by auto
  finally have eq:
    "(1/l) *\<^sub>R (b - a) = c - a \<longleftrightarrow> c = (1/l) *\<^sub>R b + (1 - 1/l) *\<^sub>R a" .
  { assume "b - a = l *\<^sub>R (c - a)"
    with `l \<noteq> 0` have "(1/l) *\<^sub>R (b - a) = c - a" by simp
    with eq show "c = (1/l) *\<^sub>R b + (1 - 1/l) *\<^sub>R a" .. }
  { assume "c = (1/l) *\<^sub>R b + (1 - 1/l) *\<^sub>R a"
    with eq have "(1/l) *\<^sub>R (b - a) = c - a" ..
    hence "l *\<^sub>R (1/l) *\<^sub>R (b - a) = l *\<^sub>R (c - a)" by simp
    with `l \<noteq> 0` show "b - a = l *\<^sub>R (c - a)" by simp }
qed

interpretation real_euclid: tarski_space real_euclid_C real_euclid_B
proof
  { fix a b c d t
    assume "B\<^sub>\<real> a d t" and "B\<^sub>\<real> b d c" and "a \<noteq> d"
    from real_euclid_B_def [of a d t] and `B\<^sub>\<real> a d t`
      obtain j where "j \<ge> 0" and "j \<le> 1" and "d - a = j *\<^sub>R (t - a)" by auto
    from `d - a = j *\<^sub>R (t - a)` and `a \<noteq> d` have "j \<noteq> 0" by auto
    with `d - a = j *\<^sub>R (t - a)` and rearrange_real_euclid_B_2
      have "t = (1/j) *\<^sub>R d + (1 - 1/j) *\<^sub>R a" by auto
    let ?x = "(1/j) *\<^sub>R b + (1 - 1/j) *\<^sub>R a"
    let ?y = "(1/j) *\<^sub>R c + (1 - 1/j) *\<^sub>R a"
    from `j \<noteq> 0` and rearrange_real_euclid_B_2 have
      "b - a = j *\<^sub>R (?x - a)" and "c - a = j *\<^sub>R (?y - a)" by auto
    with real_euclid_B_def and `j \<ge> 0` and `j \<le> 1` have
      "B\<^sub>\<real> a b ?x" and "B\<^sub>\<real> a c ?y" by auto
    from real_euclid_B_def and `B\<^sub>\<real> b d c` obtain k where
      "k \<ge> 0" and "k \<le> 1" and "d - b = k *\<^sub>R (c - b)" by blast
    from `t = (1/j) *\<^sub>R d + (1 - 1/j) *\<^sub>R a` have
      "t - ?x = (1/j) *\<^sub>R d - (1/j) *\<^sub>R b" by simp
    also from scaleR_right_diff_distrib [of "1/j" d b] have
      "\<dots> = (1/j) *\<^sub>R (d - b)" by simp
    also from `d - b = k *\<^sub>R (c - b)` have
      "\<dots> = k *\<^sub>R (1/j) *\<^sub>R (c - b)" by simp
    also from scaleR_right_diff_distrib [of "1/j" c b] have
      "\<dots> = k *\<^sub>R (?y - ?x)" by simp
    finally have "t - ?x = k *\<^sub>R (?y - ?x)" .
    with real_euclid_B_def and `k \<ge> 0` and `k \<le> 1` have "B\<^sub>\<real> ?x t ?y" by blast
    with `B\<^sub>\<real> a b ?x` and `B\<^sub>\<real> a c ?y` have
      "\<exists>x y. B\<^sub>\<real> a b x \<and> B\<^sub>\<real> a c y \<and> B\<^sub>\<real> x t y" by auto }
  thus "\<forall>a b c d t. B\<^sub>\<real> a d t \<and> B\<^sub>\<real> b d c \<and> a \<noteq> d \<longrightarrow>
            (\<exists>x y. B\<^sub>\<real> a b x \<and> B\<^sub>\<real> a c y \<and> B\<^sub>\<real> x t y)"
    by auto
qed

subsection "The real Euclidean plane"

lemma Col_dep2:
  "real_euclid.Col a b c \<longleftrightarrow> dep2 (b - a) (c - a)"
proof -
  from real_euclid.Col_def have
    "real_euclid.Col a b c \<longleftrightarrow> B\<^sub>\<real> a b c \<or> B\<^sub>\<real> b c a \<or> B\<^sub>\<real> c a b" by auto
  moreover from dep2_def have
    "dep2 (b - a) (c - a) \<longleftrightarrow> (\<exists>w r s. b - a = r *\<^sub>R w \<and> c - a = s *\<^sub>R w)"
    by auto
  moreover
  { assume "B\<^sub>\<real> a b c \<or> B\<^sub>\<real> b c a \<or> B\<^sub>\<real> c a b"
    moreover
    { assume "B\<^sub>\<real> a b c"
      with real_euclid_B_def obtain l where "b - a = l *\<^sub>R (c - a)" by blast
      moreover have "c - a = 1 *\<^sub>R (c - a)" by simp
      ultimately have "\<exists>w r s. b - a = r *\<^sub>R w \<and> c - a = s *\<^sub>R w" by blast }
    moreover
    { assume "B\<^sub>\<real> b c a"
      with real_euclid_B_def obtain l where "c - b = l *\<^sub>R (a - b)" by blast
      moreover have "c - a = (c - b) - (a - b)" by simp
      ultimately have "c - a = l *\<^sub>R (a - b) - (a - b)" by simp
      with scaleR_left_diff_distrib [of l 1 "a - b"] have
        "c - a = (l - 1) *\<^sub>R (a - b)" by simp
      moreover from scaleR_minus_left [of 1 "a - b"] have
        "b - a = (-1) *\<^sub>R (a - b)" by simp
      ultimately have "\<exists>w r s. b - a = r *\<^sub>R w \<and> c - a = s *\<^sub>R w" by blast }
    moreover
    { assume "B\<^sub>\<real> c a b"
      with real_euclid_B_def obtain l where "a - c = l *\<^sub>R (b - c)" by blast
      moreover have "c - a = -(a - c)" by simp
      ultimately have "c - a = -(l *\<^sub>R (b - c))" by simp
      with scaleR_minus_left have "c - a = (-l) *\<^sub>R (b - c)" by simp
      moreover have "b - a = (b - c) + (c - a)" by simp
      ultimately have "b - a = 1 *\<^sub>R (b - c) + (-l) *\<^sub>R (b - c)" by simp
      with scaleR_left_distrib [of 1 "-l" "b - c"] have
        "b - a = (1 + (-l)) *\<^sub>R (b - c)" by simp
      with `c - a = (-l) *\<^sub>R (b - c)` have
        "\<exists>w r s. b - a = r *\<^sub>R w \<and> c - a = s *\<^sub>R w" by blast }
    ultimately have "\<exists>w r s. b - a = r *\<^sub>R w \<and> c - a = s *\<^sub>R w" by auto }
  moreover
  { assume "\<exists>w r s. b - a = r *\<^sub>R w \<and> c - a = s *\<^sub>R w"
    then obtain w r s where "b - a = r *\<^sub>R w" and "c - a = s *\<^sub>R w" by auto
    have "B\<^sub>\<real> a b c \<or> B\<^sub>\<real> b c a \<or> B\<^sub>\<real> c a b"
    proof cases
      assume "s = 0"
      with `c - a = s *\<^sub>R w` have "a = c" by simp
      with real_euclid.th3_1 have "B\<^sub>\<real> b c a" by simp
      thus ?thesis by simp
    next
      assume "s \<noteq> 0"
      with `c - a = s *\<^sub>R w` have "w = (1/s) *\<^sub>R (c - a)" by simp
      with `b - a = r *\<^sub>R w` have "b - a = (r/s) *\<^sub>R (c - a)" by simp
      have "r/s < 0 \<or> (r/s \<ge> 0 \<and> r/s \<le> 1) \<or> r/s > 1" by arith
      moreover
      { assume "r/s \<ge> 0 \<and> r/s \<le> 1"
        with real_euclid_B_def and `b - a = (r/s) *\<^sub>R (c - a)` have "B\<^sub>\<real> a b c"
          by auto
        hence ?thesis by simp }
      moreover
      { assume "r/s > 1"
        with `b - a = (r/s) *\<^sub>R (c - a)` have "c - a = (s/r) *\<^sub>R (b - a)" by auto
        from `r/s > 1` and le_imp_inverse_le [of 1 "r/s"] have
          "s/r \<le> 1" by simp
        from `r/s > 1` and inverse_positive_iff_positive [of "r/s"] have
          "s/r \<ge> 0" by simp
        with real_euclid_B_def
          and `c - a = (s/r) *\<^sub>R (b - a)`
          and `s/r \<le> 1`
        have "B\<^sub>\<real> a c b" by auto
        with real_euclid.th3_2 have "B\<^sub>\<real> b c a" by auto
        hence ?thesis by simp }
      moreover
      { assume "r/s < 0"
        have "b - c = (b - a) + (a - c)" by simp
        with `b - a = (r/s) *\<^sub>R (c - a)` have
          "b - c = (r/s) *\<^sub>R (c - a) + (a - c)" by simp
        have "c - a = -(a - c)" by simp
        with scaleR_minus_right [of "r/s" "a - c"] have
          "(r/s) *\<^sub>R (c - a) = -((r/s) *\<^sub>R (a - c))" by arith
        with `b - c = (r/s) *\<^sub>R (c - a) + (a - c)` have
          "b - c = -(r/s) *\<^sub>R (a - c) + (a - c)" by simp
        with scaleR_left_distrib [of "-(r/s)" 1 "a - c"] have
          "b - c = (-(r/s) + 1) *\<^sub>R (a - c)" by simp
        moreover from `r/s < 0` have "-(r/s) + 1 > 1" by simp
        ultimately have "a - c = (1 / (-(r/s) + 1)) *\<^sub>R (b - c)" by auto
        let ?l = "1 / (-(r/s) + 1)"
        from `-(r/s) + 1 > 1` and le_imp_inverse_le [of 1 "-(r/s) + 1"] have
          "?l \<le> 1" by simp
        from `-(r/s) + 1 > 1`
          and inverse_positive_iff_positive [of "-(r/s) + 1"]
        have
          "?l \<ge> 0" by simp
        with real_euclid_B_def and `?l \<le> 1` and `a - c = ?l *\<^sub>R (b - c)` have
          "B\<^sub>\<real> c a b" by blast
        hence ?thesis by simp }
      ultimately show ?thesis by auto
    qed }
  ultimately show ?thesis by blast
qed

lemma non_Col_example:
  "\<not>(real_euclid.Col 0 (vector [1/2,0] :: real^2) (vector [0,1/2]))"
  (is "\<not> (real_euclid.Col ?a ?b ?c)")
proof -
  { assume "dep2 (?b - ?a) (?c - ?a)"
    with dep2_def [of "?b - ?a" "?c - ?a"] obtain w r s where
      "?b - ?a = r *\<^sub>R w" and "?c - ?a = s *\<^sub>R w" by auto
    have "?b$1 = 1/2" by simp
    with `?b - ?a = r *\<^sub>R w` have "r * (w$1) = 1/2" by simp
    hence "w$1 \<noteq> 0" by auto
    have "?c$1 = 0" by simp
    with `?c - ?a = s *\<^sub>R w` have "s * (w$1) = 0" by simp
    with `w$1 \<noteq> 0` have "s = 0" by simp
    have "?c$2 = 1/2" by simp
    with `?c - ?a = s *\<^sub>R w` have "s * (w$2) = 1/2" by simp
    with `s = 0` have False by simp }
  hence "\<not>(dep2 (?b - ?a) (?c - ?a))" by auto
  with Col_dep2 show "\<not>(real_euclid.Col ?a ?b ?c)" by blast
qed

interpretation real_euclid:
  tarski "real_euclid_C::([real^2, real^2, real^2, real^2] \<Rightarrow> bool)" real_euclid_B
proof
  { let ?a = "0 :: real^2"
    let ?b = "vector [1/2, 0] :: real^2"
    let ?c = "vector [0, 1/2] :: real^2"
    from non_Col_example and real_euclid.Col_def have
      "\<not> B\<^sub>\<real> ?a ?b ?c \<and> \<not> B\<^sub>\<real> ?b ?c ?a \<and> \<not> B\<^sub>\<real> ?c ?a ?b" by auto }
  thus "\<exists>a b c :: real^2. \<not> B\<^sub>\<real> a b c \<and> \<not> B\<^sub>\<real> b c a \<and> \<not> B\<^sub>\<real> c a b"
    by auto
  { fix p q a b c :: "real^2"
    assume "p \<noteq> q" and "a p \<congruent>\<^sub>\<real>  a q" and "b p \<congruent>\<^sub>\<real> b q" and "c p \<congruent>\<^sub>\<real> c q"
    let ?m = "(1/2) *\<^sub>R (p + q)"
    from scaleR_right_distrib [of "1/2" p q] and
      scaleR_right_diff_distrib [of "1/2" q p] and
      scaleR_left_diff_distrib [of "1/2" 1 p]
    have "?m - p = (1/2) *\<^sub>R (q - p)" by simp
    with `p \<noteq> q` have "?m - p \<noteq> 0" by simp
    from scaleR_right_distrib [of "1/2" p q] and
      scaleR_right_diff_distrib [of "1/2" p q] and
      scaleR_left_diff_distrib [of "1/2" 1 q]
    have "?m - q = (1/2) *\<^sub>R (p - q)" by simp
    with `?m - p = (1/2) *\<^sub>R (q - p)`
      and scaleR_minus_right [of "1/2" "q - p"]
    have "?m - q = -(?m - p)" by simp
    with norm_minus_cancel [of "?m - p"] have
      "(norm (?m - q))\<^sup>2 = (norm (?m - p))\<^sup>2" by (simp only: norm_minus_cancel)
    { fix d
      assume "d p \<congruent>\<^sub>\<real> d q"
      hence "(norm (d - p))\<^sup>2 = (norm (d - q))\<^sup>2" by simp
      have "(d - ?m) \<bullet> (?m - p) = 0"
      proof -
        have "d + (-q) = d - q" by simp
        have "d + (-p) = d - p" by simp
        with dot_norm [of "d - ?m" "?m - p"] have
          "(d - ?m) \<bullet> (?m - p) =
          ((norm (d - p))\<^sup>2 - (norm (d - ?m))\<^sup>2 - (norm(?m - p))\<^sup>2) / 2"
          by simp
        also from `(norm (d - p))\<^sup>2 = (norm (d - q))\<^sup>2`
          and `(norm (?m - q))\<^sup>2 = (norm (?m - p))\<^sup>2`
        have
          "\<dots> = ((norm (d - q))\<^sup>2 - (norm (d - ?m))\<^sup>2 - (norm(?m - q))\<^sup>2) / 2"
          by simp
        also from dot_norm [of "d - ?m" "?m - q"]
          and `d + (-q) = d - q`
        have
          "\<dots> = (d - ?m) \<bullet> (?m - q)" by simp
        also from inner_minus_right [of "d - ?m" "?m - p"]
          and `?m - q = -(?m - p)`
        have
          "\<dots> = -((d - ?m) \<bullet> (?m - p))" by (simp only: inner_minus_left)
        finally have "(d - ?m) \<bullet> (?m - p) = -((d - ?m) \<bullet> (?m - p))" .
        thus "(d - ?m) \<bullet> (?m - p) = 0" by arith
      qed }
    note m_lemma = this
    with `a p \<congruent>\<^sub>\<real> a q` have "(a - ?m) \<bullet> (?m - p) = 0" by simp
    { fix d
      assume "d p \<congruent>\<^sub>\<real> d q"
      with m_lemma have "(d - ?m) \<bullet> (?m - p) = 0" by simp
      with dot_left_diff_distrib [of "d - ?m" "a - ?m" "?m - p"]
        and `(a - ?m) \<bullet> (?m - p) = 0`
      have "(d - a) \<bullet> (?m - p) = 0" by (simp add: inner_diff_left inner_diff_right) }
    with `b p \<congruent>\<^sub>\<real> b q` and `c p \<congruent>\<^sub>\<real> c q` have
      "(b - a) \<bullet> (?m - p) = 0" and "(c - a) \<bullet> (?m - p) = 0" by simp+
    with real2_orthogonal_dep2 and `?m - p \<noteq> 0` have "dep2 (b - a) (c - a)"
      by blast
    with Col_dep2 have "real_euclid.Col a b c" by auto
    with real_euclid.Col_def have "B\<^sub>\<real> a b c \<or> B\<^sub>\<real> b c a \<or> B\<^sub>\<real> c a b" by auto }
  thus "\<forall>p q a b c :: real^2.
          p \<noteq> q \<and> a p \<congruent>\<^sub>\<real> a q \<and> b p \<congruent>\<^sub>\<real> b q \<and> c p \<congruent>\<^sub>\<real> c q \<longrightarrow>
            B\<^sub>\<real> a b c \<or> B\<^sub>\<real> b c a \<or> B\<^sub>\<real> c a b"
    by blast
qed

subsection {* Special cases of theorems of Tarski's geometry *}

lemma real_euclid_B_disjunction:
  assumes "l \<ge> 0" and "b - a = l *\<^sub>R (c - a)"
  shows "B\<^sub>\<real> a b c \<or> B\<^sub>\<real> a c b"
proof cases
  assume "l \<le> 1"
  with `l \<ge> 0` and `b - a = l *\<^sub>R (c - a)`
  have "B\<^sub>\<real> a b c" by (unfold real_euclid_B_def) (simp add: exI [of _ l])
  thus "B\<^sub>\<real> a b c \<or> B\<^sub>\<real> a c b" ..
next
  assume "\<not> (l \<le> 1)"
  hence "1/l \<le> 1" by simp

  from `l \<ge> 0` have "1/l \<ge> 0" by simp

  from `b - a = l *\<^sub>R (c - a)`
  have "(1/l) *\<^sub>R (b - a) = (1/l) *\<^sub>R (l *\<^sub>R (c - a))" by simp
  with `\<not> (l \<le> 1)` have "c - a = (1/l) *\<^sub>R (b - a)" by simp
  with `1/l \<ge> 0` and `1/l \<le> 1`
  have "B\<^sub>\<real> a c b" by (unfold real_euclid_B_def) (simp add: exI [of _ "1/l"])
  thus "B\<^sub>\<real> a b c \<or> B\<^sub>\<real> a c b" ..
qed

text {* The following are true in Tarski's geometry,
  but to prove this would require much more development of it,
  so only the Euclidean case is proven here. *}

theorem real_euclid_th5_1:
  assumes "a \<noteq> b" and "B\<^sub>\<real> a b c" and "B\<^sub>\<real> a b d"
  shows "B\<^sub>\<real> a c d \<or> B\<^sub>\<real> a d c"
proof -
  from `B\<^sub>\<real> a b c` and `B\<^sub>\<real> a b d`
  obtain l and m where "l \<ge> 0" and "b - a = l *\<^sub>R (c - a)"
    and "m \<ge> 0" and "b - a = m *\<^sub>R (d - a)"
    by (unfold real_euclid_B_def) auto
  from `b - a = m *\<^sub>R (d - a)` and `a \<noteq> b` have "m \<noteq> 0" by auto

  from `l \<ge> 0` and `m \<ge> 0` have "l/m \<ge> 0" by (simp add: zero_le_divide_iff)

  from `b - a = l *\<^sub>R (c - a)` and `b - a = m *\<^sub>R (d - a)`
  have "m *\<^sub>R (d - a) = l *\<^sub>R (c - a)" by simp
  hence "(1/m) *\<^sub>R (m *\<^sub>R (d - a)) = (1/m) *\<^sub>R (l *\<^sub>R (c - a))" by simp
  with `m \<noteq> 0` have "d - a = (l/m) *\<^sub>R (c - a)" by simp
  with `l/m \<ge> 0` and real_euclid_B_disjunction
  show "B\<^sub>\<real> a c d \<or> B\<^sub>\<real> a d c" by auto
qed

theorem real_euclid_th5_3:
  assumes "B\<^sub>\<real> a b d" and "B\<^sub>\<real> a c d"
  shows "B\<^sub>\<real> a b c \<or> B\<^sub>\<real> a c b"
proof -
  from `B\<^sub>\<real> a b d` and `B\<^sub>\<real> a c d`
  obtain l and m where "l \<ge> 0" and "b - a = l *\<^sub>R (d - a)"
    and "m \<ge> 0" and "c - a = m *\<^sub>R (d - a)"
    by (unfold real_euclid_B_def) auto

  show "B\<^sub>\<real> a b c \<or> B\<^sub>\<real> a c b"
  proof cases
    assume "l = 0"
    with `b - a = l *\<^sub>R (d - a)` have "b - a = l *\<^sub>R (c - a)" by simp
    with `l = 0`
    have "B\<^sub>\<real> a b c" by (unfold real_euclid_B_def) (simp add: exI [of _ l])
    thus "B\<^sub>\<real> a b c \<or> B\<^sub>\<real> a c b" ..
  next
    assume "l \<noteq> 0"

    from `l \<ge> 0` and `m \<ge> 0` have "m/l \<ge> 0" by (simp add: zero_le_divide_iff)

    from `b - a = l *\<^sub>R (d - a)`
    have "(1/l) *\<^sub>R (b - a) = (1/l) *\<^sub>R (l *\<^sub>R (d - a))" by simp
    with `l \<noteq> 0` have "d - a = (1/l) *\<^sub>R (b - a)" by simp
    with `c - a = m *\<^sub>R (d - a)` have "c - a = (m/l) *\<^sub>R (b - a)" by simp
    with `m/l \<ge> 0` and real_euclid_B_disjunction
    show "B\<^sub>\<real> a b c \<or> B\<^sub>\<real> a c b" by auto
  qed
qed

end


(* Title:  Sum_Util.thy
   Author: Minamide Yasuhiko, Akama Hitoshi
*)

theory Sum_Util
  imports HOL.Sum_Type HOL.List
begin

primrec fold_sum :: "('a \<Rightarrow> 'c) \<Rightarrow> ('b \<Rightarrow> 'c) \<Rightarrow> ('a + 'b \<Rightarrow> 'c)" where
  "fold_sum f g (Inl x) = f x" |
  "fold_sum f g (Inr y) = g y"

fun inl_list :: "'a \<Rightarrow> ('a + 'b) list" where
  "inl_list x = [Inl x]"

fun inr_list :: "'b \<Rightarrow> ('a + 'b) list" where
  "inr_list y = [Inr y]"

lemma ext_sum:
  assumes "\<And>l. f (Inl l) = g (Inl l)"
  assumes "\<And>r. f (Inr r) = g (Inr r)"
  shows "f = g"
proof
  fix x
  show "f x = g x" using assms by (cases x, simp_all)
qed

lemma ext_prod:
  assumes "\<And>x y. f (x, y) = g (x, y)"
  shows "f = g"
proof
  fix x
  show "f x = g x" using assms by (cases x, simp)
qed

lemma map_sum_comp: "map_sum (f1 o f2) (g1 o g2) = map_sum f1 g1 \<circ> map_sum f2 g2"
  by (rule ext_sum, simp_all)

lemma fold_sum_comp: "fold_sum (f1 o g1) (f2 o g2) = fold_sum f1 f2 o map_sum g1 g2"
  by (rule ext_sum, simp_all)

lemma map_sum_eq_fold_sum: "map_sum f g = fold_sum (Inl o f) (Inr o g)"
  by (rule ext_sum, simp_all)

primrec retain_right :: "('a + 'b) \<Rightarrow> 'b list" where
  "retain_right (Inl l) = []" |
  "retain_right (Inr r) = [r]"

primrec retain_left :: "('a + 'b) \<Rightarrow> 'a list" where
  "retain_left (Inl l) = [l]" |
  "retain_left (Inr r) = []"

section \<open>Induction rules for "('a + 'b) list"\<close>

(* an induct rule for variable and alphabet list *)
(* [consumes n] to skip first n assumptions at induct phase *)
lemma xa_induct [consumes 0, case_names Nil Var Alpha]:
  "P [] \<Longrightarrow> (\<And>x xs. P xs \<Longrightarrow> P (Inl x#xs))
        \<Longrightarrow> (\<And>a xs. P xs \<Longrightarrow> P (Inr a#xs))
        \<Longrightarrow> P xs"
proof (induct xs)
  case Nil then show ?case by simp
next
  case (Cons a xs) then show ?case by (cases a) simp_all
qed

lemma xa_rev_induct [consumes 0, case_names Nil Var Alpha]:
  "P [] \<Longrightarrow> (\<And>x xs. P xs \<Longrightarrow> P (xs @ [Inl x]))
        \<Longrightarrow> (\<And>a xs. P xs \<Longrightarrow> P (xs @ [Inr a]))
        \<Longrightarrow> P xs"
proof (induct xs rule: rev_induct)
  case Nil then show ?case by simp
next
  case (snoc a xs) then show ?case by (cases a) simp_all
qed

subsection \<open>new induct rule\<close>

lemma find_last:
  assumes "\<not> P a"
  shows "find P (xs @ [a]) = find P xs"
  using assms by (induct xs, simp_all)

lemma find_var_None_then_all_alpha:
  assumes "find isl xs = None"
  shows "\<exists>u. xs = map Inr u"
using assms proof (induct xs rule: xa_induct)
  case Nil
  then show ?case by simp
next
  case (Var x xs)
  then show ?case by simp
next
  case (Alpha a xs)
  then obtain u where u: "xs = map Inr u" by auto
  then show ?case proof -
    have "Inr a # xs = map Inr (a # u)" using u by simp
    then show ?thesis by (rule exI)
  qed
qed

lemma find_split:
  assumes "List.find P lis \<noteq> None"
  shows "\<exists>l x r. ((l @ x # r = lis) \<and> find P r = None \<and> P x)"
using assms proof (induct lis rule: rev_induct)
  case Nil
  then show ?case by simp
next
  case (snoc a as)
  then show ?case proof (cases "P a")
    case True
    then have "as @ a # [] = as @ [a] \<and> find P [] = None \<and> P a" by simp
    then show ?thesis by blast
  next
    case False
    then have "find P as \<noteq> None"
      using False find_last snoc.prems by fastforce
    then obtain l x r where "l @ x # r = as \<and> find P r = None \<and> P x" using snoc by blast
    then have "l @ x # (r @ [a]) = as @ [a] \<and> find P (r @ [a]) = None \<and> P x" by (simp add: False find_last)
    then show ?thesis by blast
  qed
qed

lemma xw_induct [case_names Word VarWord]:
  assumes word: "(\<And>w. P (map Inr w))"
  assumes var_word: "(\<And>x w u. P u \<Longrightarrow> P (u @ Inl x # map Inr w))"
  shows "P u"
proof (induct u rule: length_induct)
  case IH: (1 xs)
  then show ?case proof (cases "List.find isl xs")
    case None
    then obtain v where "xs = map Inr v" using find_var_None_then_all_alpha by auto
    then show ?thesis by (simp add: word[of "v"])
  next
    case (Some a)
    then have "find isl xs \<noteq> None" by simp
    then obtain l x r where hoge: "(xs = l @ x # r) \<and> find isl r = None \<and> isl x"
      using find_split[where P="isl", where lis="xs"] by blast
    obtain v where v: "r = map Inr v" using find_var_None_then_all_alpha hoge by blast
    obtain x' where x': "x = Inl x'"
      using hoge unfolding isl_def by blast
    have "P (l @ Inl x' # map Inr v)" proof (rule var_word)
      show "P l" by (rule IH[rule_format], simp add: hoge)
    qed
    then show ?thesis by (simp add: v x' hoge)
  qed
qed

hide_fact (open) find_last find_var_None_then_all_alpha find_split

end