(*  Title:      FOL/ex/Classical.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1994  University of Cambridge
*)

section \<open>Classical Predicate Calculus Problems\<close>

theory Classical
imports FOL
begin

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

subsubsection \<open>If and only if\<close>

lemma "(P \<longleftrightarrow> Q) \<longleftrightarrow> (Q \<longleftrightarrow> P)"
  by blast

lemma "\<not> (P \<longleftrightarrow> \<not> P)"
  by blast

subsection \<open>Pelletier's examples\<close>

text \<open>
  Sample problems from

    \<^item> F. J. Pelletier,
    Seventy-Five Problems for Testing Automatic Theorem Provers,
    J. Automated Reasoning 2 (1986), 191-216.
    Errata, JAR 4 (1988), 236-236.

  The hardest problems -- judging by experience with several theorem
  provers, including matrix ones -- are 34 and 43.
\<close>

text\<open>1\<close>
lemma "(P \<longrightarrow> Q) \<longleftrightarrow> (\<not> Q \<longrightarrow> \<not> P)"
  by blast

text\<open>2\<close>
lemma "\<not> \<not> P \<longleftrightarrow> P"
  by blast

text\<open>3\<close>
lemma "\<not> (P \<longrightarrow> Q) \<longrightarrow> (Q \<longrightarrow> P)"
  by blast

text\<open>4\<close>
lemma "(\<not> P \<longrightarrow> Q) \<longleftrightarrow> (\<not> Q \<longrightarrow> P)"
  by blast

text\<open>5\<close>
lemma "((P \<or> Q) \<longrightarrow> (P \<or> R)) \<longrightarrow> (P \<or> (Q \<longrightarrow> R))"
  by blast

text\<open>6\<close>
lemma "P \<or> \<not> P"
  by blast

text\<open>7\<close>
lemma "P \<or> \<not> \<not> \<not> P"
  by blast

text\<open>8. Peirce's law\<close>
lemma "((P \<longrightarrow> Q) \<longrightarrow> P) \<longrightarrow> P"
  by blast

text\<open>9\<close>
lemma "((P \<or> Q) \<and> (\<not> P \<or> Q) \<and> (P \<or> \<not> Q)) \<longrightarrow> \<not> (\<not> P \<or> \<not> Q)"
  by blast

text\<open>10\<close>
lemma "(Q \<longrightarrow> R) \<and> (R \<longrightarrow> P \<and> Q) \<and> (P \<longrightarrow> Q \<or> R) \<longrightarrow> (P \<longleftrightarrow> Q)"
  by blast

text\<open>11. Proved in each direction (incorrectly, says Pelletier!!)\<close>
lemma "P \<longleftrightarrow> P"
  by blast

text\<open>12. "Dijkstra's law"\<close>
lemma "((P \<longleftrightarrow> Q) \<longleftrightarrow> R) \<longleftrightarrow> (P \<longleftrightarrow> (Q \<longleftrightarrow> R))"
  by blast

text\<open>13. Distributive law\<close>
lemma "P \<or> (Q \<and> R) \<longleftrightarrow> (P \<or> Q) \<and> (P \<or> R)"
  by blast

text\<open>14\<close>
lemma "(P \<longleftrightarrow> Q) \<longleftrightarrow> ((Q \<or> \<not> P) \<and> (\<not> Q \<or> P))"
  by blast

text\<open>15\<close>
lemma "(P \<longrightarrow> Q) \<longleftrightarrow> (\<not> P \<or> Q)"
  by blast

text\<open>16\<close>
lemma "(P \<longrightarrow> Q) \<or> (Q \<longrightarrow> P)"
  by blast

text\<open>17\<close>
lemma "((P \<and> (Q \<longrightarrow> R)) \<longrightarrow> S) \<longleftrightarrow> ((\<not> P \<or> Q \<or> S) \<and> (\<not> P \<or> \<not> R \<or> S))"
  by blast

subsection \<open>Classical Logic: examples with quantifiers\<close>

lemma "(\<forall>x. P(x) \<and> Q(x)) \<longleftrightarrow> (\<forall>x. P(x)) \<and> (\<forall>x. Q(x))"
  by blast

lemma "(\<exists>x. P \<longrightarrow> Q(x)) \<longleftrightarrow> (P \<longrightarrow> (\<exists>x. Q(x)))"
  by blast

lemma "(\<exists>x. P(x) \<longrightarrow> Q) \<longleftrightarrow> (\<forall>x. P(x)) \<longrightarrow> Q"
  by blast

lemma "(\<forall>x. P(x)) \<or> Q \<longleftrightarrow> (\<forall>x. P(x) \<or> Q)"
  by blast

text\<open>Discussed in Avron, Gentzen-Type Systems, Resolution and Tableaux,
  JAR 10 (265-281), 1993.  Proof is trivial!\<close>
lemma "\<not> ((\<exists>x. \<not> P(x)) \<and> ((\<exists>x. P(x)) \<or> (\<exists>x. P(x) \<and> Q(x))) \<and> \<not> (\<exists>x. P(x)))"
  by blast

subsection \<open>Problems requiring quantifier duplication\<close>

text\<open>Theorem B of Peter Andrews, Theorem Proving via General Matings,
  JACM 28 (1981).\<close>
lemma "(\<exists>x. \<forall>y. P(x) \<longleftrightarrow> P(y)) \<longrightarrow> ((\<exists>x. P(x)) \<longleftrightarrow> (\<forall>y. P(y)))"
  by blast

text\<open>Needs multiple instantiation of ALL.\<close>
lemma "(\<forall>x. P(x) \<longrightarrow> P(f(x))) \<and> P(d) \<longrightarrow> P(f(f(f(d))))"
  by blast

text\<open>Needs double instantiation of the quantifier\<close>
lemma "\<exists>x. P(x) \<longrightarrow> P(a) \<and> P(b)"
  by blast

lemma "\<exists>z. P(z) \<longrightarrow> (\<forall>x. P(x))"
  by blast

lemma "\<exists>x. (\<exists>y. P(y)) \<longrightarrow> P(x)"
  by blast

text\<open>V. Lifschitz, What Is the Inverse Method?, JAR 5 (1989), 1--23. NOT PROVED.\<close>
lemma
  "\<exists>x x'. \<forall>y. \<exists>z z'.
    (\<not> P(y,y) \<or> P(x,x) \<or> \<not> S(z,x)) \<and>
    (S(x,y) \<or> \<not> S(y,z) \<or> Q(z',z')) \<and>
    (Q(x',y) \<or> \<not> Q(y,z') \<or> S(x',x'))"
  oops

subsection \<open>Hard examples with quantifiers\<close>

text\<open>18\<close>
lemma "\<exists>y. \<forall>x. P(y) \<longrightarrow> P(x)"
  by blast

text\<open>19\<close>
lemma "\<exists>x. \<forall>y z. (P(y) \<longrightarrow> Q(z)) \<longrightarrow> (P(x) \<longrightarrow> Q(x))"
  by blast

text\<open>20\<close>
lemma "(\<forall>x y. \<exists>z. \<forall>w. (P(x) \<and> Q(y) \<longrightarrow> R(z) \<and> S(w)))
  \<longrightarrow> (\<exists>x y. P(x) \<and> Q(y)) \<longrightarrow> (\<exists>z. R(z))"
  by blast

text\<open>21\<close>
lemma "(\<exists>x. P \<longrightarrow> Q(x)) \<and> (\<exists>x. Q(x) \<longrightarrow> P) \<longrightarrow> (\<exists>x. P \<longleftrightarrow> Q(x))"
  by blast

text\<open>22\<close>
lemma "(\<forall>x. P \<longleftrightarrow> Q(x)) \<longrightarrow> (P \<longleftrightarrow> (\<forall>x. Q(x)))"
  by blast

text\<open>23\<close>
lemma "(\<forall>x. P \<or> Q(x)) \<longleftrightarrow> (P \<or> (\<forall>x. Q(x)))"
  by blast

text\<open>24\<close>
lemma
  "\<not> (\<exists>x. S(x) \<and> Q(x)) \<and> (\<forall>x. P(x) \<longrightarrow> Q(x) \<or> R(x)) \<and>
    (\<not> (\<exists>x. P(x)) \<longrightarrow> (\<exists>x. Q(x))) \<and> (\<forall>x. Q(x) \<or> R(x) \<longrightarrow> S(x))
    \<longrightarrow> (\<exists>x. P(x) \<and> R(x))"
  by blast

text\<open>25\<close>
lemma
  "(\<exists>x. P(x)) \<and>
    (\<forall>x. L(x) \<longrightarrow> \<not> (M(x) \<and> R(x))) \<and>
    (\<forall>x. P(x) \<longrightarrow> (M(x) \<and> L(x))) \<and>
    ((\<forall>x. P(x) \<longrightarrow> Q(x)) \<or> (\<exists>x. P(x) \<and> R(x)))
    \<longrightarrow> (\<exists>x. Q(x) \<and> P(x))"
  by blast

text\<open>26\<close>
lemma
  "((\<exists>x. p(x)) \<longleftrightarrow> (\<exists>x. q(x))) \<and>
    (\<forall>x. \<forall>y. p(x) \<and> q(y) \<longrightarrow> (r(x) \<longleftrightarrow> s(y)))
  \<longrightarrow> ((\<forall>x. p(x) \<longrightarrow> r(x)) \<longleftrightarrow> (\<forall>x. q(x) \<longrightarrow> s(x)))"
  by blast

text\<open>27\<close>
lemma
  "(\<exists>x. P(x) \<and> \<not> Q(x)) \<and>
    (\<forall>x. P(x) \<longrightarrow> R(x)) \<and>
    (\<forall>x. M(x) \<and> L(x) \<longrightarrow> P(x)) \<and>
    ((\<exists>x. R(x) \<and> \<not> Q(x)) \<longrightarrow> (\<forall>x. L(x) \<longrightarrow> \<not> R(x)))
  \<longrightarrow> (\<forall>x. M(x) \<longrightarrow> \<not> L(x))"
  by blast

text\<open>28. AMENDED\<close>
lemma
  "(\<forall>x. P(x) \<longrightarrow> (\<forall>x. Q(x))) \<and>
    ((\<forall>x. Q(x) \<or> R(x)) \<longrightarrow> (\<exists>x. Q(x) \<and> S(x))) \<and>
    ((\<exists>x. S(x)) \<longrightarrow> (\<forall>x. L(x) \<longrightarrow> M(x)))
  \<longrightarrow> (\<forall>x. P(x) \<and> L(x) \<longrightarrow> M(x))"
  by blast

text\<open>29. Essentially the same as Principia Mathematica *11.71\<close>
lemma
  "(\<exists>x. P(x)) \<and> (\<exists>y. Q(y))
    \<longrightarrow> ((\<forall>x. P(x) \<longrightarrow> R(x)) \<and> (\<forall>y. Q(y) \<longrightarrow> S(y)) \<longleftrightarrow>
      (\<forall>x y. P(x) \<and> Q(y) \<longrightarrow> R(x) \<and> S(y)))"
  by blast

text\<open>30\<close>
lemma
  "(\<forall>x. P(x) \<or> Q(x) \<longrightarrow> \<not> R(x)) \<and>
    (\<forall>x. (Q(x) \<longrightarrow> \<not> S(x)) \<longrightarrow> P(x) \<and> R(x))
    \<longrightarrow> (\<forall>x. S(x))"
  by blast

text\<open>31\<close>
lemma
  "\<not> (\<exists>x. P(x) \<and> (Q(x) \<or> R(x))) \<and>
    (\<exists>x. L(x) \<and> P(x)) \<and>
    (\<forall>x. \<not> R(x) \<longrightarrow> M(x))
  \<longrightarrow> (\<exists>x. L(x) \<and> M(x))"
  by blast

text\<open>32\<close>
lemma
  "(\<forall>x. P(x) \<and> (Q(x) \<or> R(x)) \<longrightarrow> S(x)) \<and>
    (\<forall>x. S(x) \<and> R(x) \<longrightarrow> L(x)) \<and>
    (\<forall>x. M(x) \<longrightarrow> R(x))
  \<longrightarrow> (\<forall>x. P(x) \<and> M(x) \<longrightarrow> L(x))"
  by blast

text\<open>33\<close>
lemma
  "(\<forall>x. P(a) \<and> (P(x) \<longrightarrow> P(b)) \<longrightarrow> P(c)) \<longleftrightarrow>
    (\<forall>x. (\<not> P(a) \<or> P(x) \<or> P(c)) \<and> (\<not> P(a) \<or> \<not> P(b) \<or> P(c)))"
  by blast

text\<open>34. AMENDED (TWICE!!). Andrews's challenge.\<close>
lemma
  "((\<exists>x. \<forall>y. p(x) \<longleftrightarrow> p(y)) \<longleftrightarrow> ((\<exists>x. q(x)) \<longleftrightarrow> (\<forall>y. p(y)))) \<longleftrightarrow>
    ((\<exists>x. \<forall>y. q(x) \<longleftrightarrow> q(y)) \<longleftrightarrow> ((\<exists>x. p(x)) \<longleftrightarrow> (\<forall>y. q(y))))"
  by blast

text\<open>35\<close>
lemma "\<exists>x y. P(x,y) \<longrightarrow> (\<forall>u v. P(u,v))"
  by blast

text\<open>36\<close>
lemma
  "(\<forall>x. \<exists>y. J(x,y)) \<and>
    (\<forall>x. \<exists>y. G(x,y)) \<and>
    (\<forall>x y. J(x,y) \<or> G(x,y) \<longrightarrow> (\<forall>z. J(y,z) \<or> G(y,z) \<longrightarrow> H(x,z)))
  \<longrightarrow> (\<forall>x. \<exists>y. H(x,y))"
  by blast

text\<open>37\<close>
lemma
  "(\<forall>z. \<exists>w. \<forall>x. \<exists>y.
    (P(x,z) \<longrightarrow> P(y,w)) \<and> P(y,z) \<and> (P(y,w) \<longrightarrow> (\<exists>u. Q(u,w)))) \<and>
    (\<forall>x z. \<not> P(x,z) \<longrightarrow> (\<exists>y. Q(y,z))) \<and>
    ((\<exists>x y. Q(x,y)) \<longrightarrow> (\<forall>x. R(x,x)))
  \<longrightarrow> (\<forall>x. \<exists>y. R(x,y))"
  by blast

text\<open>38\<close>
lemma
  "(\<forall>x. p(a) \<and> (p(x) \<longrightarrow> (\<exists>y. p(y) \<and> r(x,y))) \<longrightarrow>
    (\<exists>z. \<exists>w. p(z) \<and> r(x,w) \<and> r(w,z)))  \<longleftrightarrow>
    (\<forall>x. (\<not> p(a) \<or> p(x) \<or> (\<exists>z. \<exists>w. p(z) \<and> r(x,w) \<and> r(w,z))) \<and>
      (\<not> p(a) \<or> \<not> (\<exists>y. p(y) \<and> r(x,y)) \<or>
      (\<exists>z. \<exists>w. p(z) \<and> r(x,w) \<and> r(w,z))))"
  by blast

text\<open>39\<close>
lemma "\<not> (\<exists>x. \<forall>y. F(y,x) \<longleftrightarrow> \<not> F(y,y))"
  by blast

text\<open>40. AMENDED\<close>
lemma
  "(\<exists>y. \<forall>x. F(x,y) \<longleftrightarrow> F(x,x)) \<longrightarrow>
    \<not> (\<forall>x. \<exists>y. \<forall>z. F(z,y) \<longleftrightarrow> \<not> F(z,x))"
  by blast

text\<open>41\<close>
lemma
  "(\<forall>z. \<exists>y. \<forall>x. f(x,y) \<longleftrightarrow> f(x,z) \<and> \<not> f(x,x))
    \<longrightarrow> \<not> (\<exists>z. \<forall>x. f(x,z))"
  by blast

text\<open>42\<close>
lemma "\<not> (\<exists>y. \<forall>x. p(x,y) \<longleftrightarrow> \<not> (\<exists>z. p(x,z) \<and> p(z,x)))"
  by blast

text\<open>43\<close>
lemma
  "(\<forall>x. \<forall>y. q(x,y) \<longleftrightarrow> (\<forall>z. p(z,x) \<longleftrightarrow> p(z,y)))
    \<longrightarrow> (\<forall>x. \<forall>y. q(x,y) \<longleftrightarrow> q(y,x))"
  by blast

text \<open>
  Other proofs: Can use \<open>auto\<close>, which cheats by using rewriting!
  \<open>Deepen_tac\<close> alone requires 253 secs.  Or
  \<open>by (mini_tac 1 THEN Deepen_tac 5 1)\<close>.
\<close>

text\<open>44\<close>
lemma
  "(\<forall>x. f(x) \<longrightarrow> (\<exists>y. g(y) \<and> h(x,y) \<and> (\<exists>y. g(y) \<and> \<not> h(x,y)))) \<and>
    (\<exists>x. j(x) \<and> (\<forall>y. g(y) \<longrightarrow> h(x,y)))
  \<longrightarrow> (\<exists>x. j(x) \<and> \<not> f(x))"
  by blast

text\<open>45\<close>
lemma
  "(\<forall>x. f(x) \<and> (\<forall>y. g(y) \<and> h(x,y) \<longrightarrow> j(x,y))
      \<longrightarrow> (\<forall>y. g(y) \<and> h(x,y) \<longrightarrow> k(y))) \<and>
      \<not> (\<exists>y. l(y) \<and> k(y)) \<and>
      (\<exists>x. f(x) \<and> (\<forall>y. h(x,y) \<longrightarrow> l(y)) \<and> (\<forall>y. g(y) \<and> h(x,y) \<longrightarrow> j(x,y)))
      \<longrightarrow> (\<exists>x. f(x) \<and> \<not> (\<exists>y. g(y) \<and> h(x,y)))"
  by blast

text\<open>46\<close>
lemma
  "(\<forall>x. f(x) \<and> (\<forall>y. f(y) \<and> h(y,x) \<longrightarrow> g(y)) \<longrightarrow> g(x)) \<and>
      ((\<exists>x. f(x) \<and> \<not> g(x)) \<longrightarrow>
       (\<exists>x. f(x) \<and> \<not> g(x) \<and> (\<forall>y. f(y) \<and> \<not> g(y) \<longrightarrow> j(x,y)))) \<and>
      (\<forall>x y. f(x) \<and> f(y) \<and> h(x,y) \<longrightarrow> \<not> j(y,x))
      \<longrightarrow> (\<forall>x. f(x) \<longrightarrow> g(x))"
  by blast

subsection \<open>Problems (mainly) involving equality or functions\<close>

text\<open>48\<close>
lemma "(a = b \<or> c = d) \<and> (a = c \<or> b = d) \<longrightarrow> a = d \<or> b = c"
  by blast

text\<open>49. NOT PROVED AUTOMATICALLY. Hard because it involves substitution for
  Vars; the type constraint ensures that x,y,z have the same type as a,b,u.\<close>
lemma
  "(\<exists>x y::'a. \<forall>z. z = x \<or> z = y) \<and> P(a) \<and> P(b) \<and> a \<noteq> b \<longrightarrow> (\<forall>u::'a. P(u))"
  apply safe
  apply (rule_tac x = a in allE, assumption)
  apply (rule_tac x = b in allE, assumption)
  apply fast  \<comment> \<open>blast's treatment of equality can't do it\<close>
  done

text\<open>50. (What has this to do with equality?)\<close>
lemma "(\<forall>x. P(a,x) \<or> (\<forall>y. P(x,y))) \<longrightarrow> (\<exists>x. \<forall>y. P(x,y))"
  by blast

text\<open>51\<close>
lemma
  "(\<exists>z w. \<forall>x y. P(x,y) \<longleftrightarrow> (x = z \<and> y = w)) \<longrightarrow>
    (\<exists>z. \<forall>x. \<exists>w. (\<forall>y. P(x,y) \<longleftrightarrow> y=w) \<longleftrightarrow> x = z)"
  by blast

text\<open>52\<close>
text\<open>Almost the same as 51.\<close>
lemma
  "(\<exists>z w. \<forall>x y. P(x,y) \<longleftrightarrow> (x = z \<and> y = w)) \<longrightarrow>
    (\<exists>w. \<forall>y. \<exists>z. (\<forall>x. P(x,y) \<longleftrightarrow> x = z) \<longleftrightarrow> y = w)"
  by blast

text\<open>55\<close>
text\<open>Non-equational version, from Manthey and Bry, CADE-9 (Springer, 1988).
  fast DISCOVERS who killed Agatha.\<close>
schematic_goal
  "lives(agatha) \<and> lives(butler) \<and> lives(charles) \<and>
   (killed(agatha,agatha) \<or> killed(butler,agatha) \<or> killed(charles,agatha)) \<and>
   (\<forall>x y. killed(x,y) \<longrightarrow> hates(x,y) \<and> \<not> richer(x,y)) \<and>
   (\<forall>x. hates(agatha,x) \<longrightarrow> \<not> hates(charles,x)) \<and>
   (hates(agatha,agatha) \<and> hates(agatha,charles)) \<and>
   (\<forall>x. lives(x) \<and> \<not> richer(x,agatha) \<longrightarrow> hates(butler,x)) \<and>
   (\<forall>x. hates(agatha,x) \<longrightarrow> hates(butler,x)) \<and>
   (\<forall>x. \<not> hates(x,agatha) \<or> \<not> hates(x,butler) \<or> \<not> hates(x,charles)) \<longrightarrow>
    killed(?who,agatha)"
  by fast  \<comment> \<open>MUCH faster than blast\<close>

text\<open>56\<close>
lemma "(\<forall>x. (\<exists>y. P(y) \<and> x = f(y)) \<longrightarrow> P(x)) \<longleftrightarrow> (\<forall>x. P(x) \<longrightarrow> P(f(x)))"
  by blast

text\<open>57\<close>
lemma
  "P(f(a,b), f(b,c)) \<and> P(f(b,c), f(a,c)) \<and>
    (\<forall>x y z. P(x,y) \<and> P(y,z) \<longrightarrow> P(x,z)) \<longrightarrow> P(f(a,b), f(a,c))"
  by blast

text\<open>58  NOT PROVED AUTOMATICALLY\<close>
lemma "(\<forall>x y. f(x) = g(y)) \<longrightarrow> (\<forall>x y. f(f(x)) = f(g(y)))"
  by (slow elim: subst_context)

text\<open>59\<close>
lemma "(\<forall>x. P(x) \<longleftrightarrow> \<not> P(f(x))) \<longrightarrow> (\<exists>x. P(x) \<and> \<not> P(f(x)))"
  by blast

text\<open>60\<close>
lemma "\<forall>x. P(x,f(x)) \<longleftrightarrow> (\<exists>y. (\<forall>z. P(z,y) \<longrightarrow> P(z,f(x))) \<and> P(x,y))"
  by blast

text\<open>62 as corrected in JAR 18 (1997), page 135\<close>
lemma
  "(\<forall>x. p(a) \<and> (p(x) \<longrightarrow> p(f(x))) \<longrightarrow> p(f(f(x)))) \<longleftrightarrow>
    (\<forall>x. (\<not> p(a) \<or> p(x) \<or> p(f(f(x)))) \<and>
      (\<not> p(a) \<or> \<not> p(f(x)) \<or> p(f(f(x)))))"
  by blast

text \<open>From Davis, Obvious Logical Inferences, IJCAI-81, 530-531
  fast indeed copes!\<close>
lemma
  "(\<forall>x. F(x) \<and> \<not> G(x) \<longrightarrow> (\<exists>y. H(x,y) \<and> J(y))) \<and>
    (\<exists>x. K(x) \<and> F(x) \<and> (\<forall>y. H(x,y) \<longrightarrow> K(y))) \<and>
    (\<forall>x. K(x) \<longrightarrow> \<not> G(x)) \<longrightarrow> (\<exists>x. K(x) \<and> J(x))"
  by fast

text \<open>From Rudnicki, Obvious Inferences, JAR 3 (1987), 383-393.
  It does seem obvious!\<close>
lemma
  "(\<forall>x. F(x) \<and> \<not> G(x) \<longrightarrow> (\<exists>y. H(x,y) \<and> J(y))) \<and>
    (\<exists>x. K(x) \<and> F(x) \<and> (\<forall>y. H(x,y) \<longrightarrow> K(y))) \<and>
    (\<forall>x. K(x) \<longrightarrow> \<not> G(x)) \<longrightarrow> (\<exists>x. K(x) \<longrightarrow> \<not> G(x))"
  by fast

text \<open>Halting problem: Formulation of Li Dafa (AAR Newsletter 27, Oct 1994.)
  author U. Egly.\<close>
lemma
  "((\<exists>x. A(x) \<and> (\<forall>y. C(y) \<longrightarrow> (\<forall>z. D(x,y,z)))) \<longrightarrow>
     (\<exists>w. C(w) \<and> (\<forall>y. C(y) \<longrightarrow> (\<forall>z. D(w,y,z)))))
    \<and>
    (\<forall>w. C(w) \<and> (\<forall>u. C(u) \<longrightarrow> (\<forall>v. D(w,u,v))) \<longrightarrow>
          (\<forall>y z.
              (C(y) \<and> P(y,z) \<longrightarrow> Q(w,y,z) \<and> OO(w,g)) \<and>
              (C(y) \<and> \<not> P(y,z) \<longrightarrow> Q(w,y,z) \<and> OO(w,b))))
    \<and>
    (\<forall>w. C(w) \<and>
      (\<forall>y z.
          (C(y) \<and> P(y,z) \<longrightarrow> Q(w,y,z) \<and> OO(w,g)) \<and>
          (C(y) \<and> \<not> P(y,z) \<longrightarrow> Q(w,y,z) \<and> OO(w,b))) \<longrightarrow>
      (\<exists>v. C(v) \<and>
            (\<forall>y. ((C(y) \<and> Q(w,y,y)) \<and> OO(w,g) \<longrightarrow> \<not> P(v,y)) \<and>
                    ((C(y) \<and> Q(w,y,y)) \<and> OO(w,b) \<longrightarrow> P(v,y) \<and> OO(v,b)))))
     \<longrightarrow> \<not> (\<exists>x. A(x) \<and> (\<forall>y. C(y) \<longrightarrow> (\<forall>z. D(x,y,z))))"
  by (blast 12)
    \<comment> \<open>Needed because the search for depths below 12 is very slow.\<close>

text \<open>
  Halting problem II: credited to M. Bruschi by Li Dafa in JAR 18(1),
  p. 105.
\<close>
lemma
  "((\<exists>x. A(x) \<and> (\<forall>y. C(y) \<longrightarrow> (\<forall>z. D(x,y,z)))) \<longrightarrow>
     (\<exists>w. C(w) \<and> (\<forall>y. C(y) \<longrightarrow> (\<forall>z. D(w,y,z)))))
    \<and>
    (\<forall>w. C(w) \<and> (\<forall>u. C(u) \<longrightarrow> (\<forall>v. D(w,u,v))) \<longrightarrow>
          (\<forall>y z.
              (C(y) \<and> P(y,z) \<longrightarrow> Q(w,y,z) \<and> OO(w,g)) \<and>
              (C(y) \<and> \<not> P(y,z) \<longrightarrow> Q(w,y,z) \<and> OO(w,b))))
    \<and>
    ((\<exists>w. C(w) \<and> (\<forall>y. (C(y) \<and> P(y,y) \<longrightarrow> Q(w,y,y) \<and> OO(w,g)) \<and>
                           (C(y) \<and> \<not> P(y,y) \<longrightarrow> Q(w,y,y) \<and> OO(w,b))))
     \<longrightarrow>
     (\<exists>v. C(v) \<and> (\<forall>y. (C(y) \<and> P(y,y) \<longrightarrow> P(v,y) \<and> OO(v,g)) \<and>
                           (C(y) \<and> \<not> P(y,y) \<longrightarrow> P(v,y) \<and> OO(v,b)))))
    \<longrightarrow>
    ((\<exists>v. C(v) \<and> (\<forall>y. (C(y) \<and> P(y,y) \<longrightarrow> P(v,y) \<and> OO(v,g)) \<and>
                           (C(y) \<and> \<not> P(y,y) \<longrightarrow> P(v,y) \<and> OO(v,b))))
     \<longrightarrow>
     (\<exists>u. C(u) \<and> (\<forall>y. (C(y) \<and> P(y,y) \<longrightarrow> \<not> P(u,y)) \<and>
                           (C(y) \<and> \<not> P(y,y) \<longrightarrow> P(u,y) \<and> OO(u,b)))))
     \<longrightarrow> \<not> (\<exists>x. A(x) \<and> (\<forall>y. C(y) \<longrightarrow> (\<forall>z. D(x,y,z))))"
  by blast

text \<open>Challenge found on info-hol.\<close>
lemma "\<forall>x. \<exists>v w. \<forall>y z. P(x) \<and> Q(y) \<longrightarrow> (P(v) \<or> R(w)) \<and> (R(z) \<longrightarrow> Q(v))"
  by blast

text \<open>
  Attributed to Lewis Carroll by S. G. Pulman. The first or last assumption
  can be deleted.\<close>
lemma
  "(\<forall>x. honest(x) \<and> industrious(x) \<longrightarrow> healthy(x)) \<and>
    \<not> (\<exists>x. grocer(x) \<and> healthy(x)) \<and>
    (\<forall>x. industrious(x) \<and> grocer(x) \<longrightarrow> honest(x)) \<and>
    (\<forall>x. cyclist(x) \<longrightarrow> industrious(x)) \<and>
    (\<forall>x. \<not> healthy(x) \<and> cyclist(x) \<longrightarrow> \<not> honest(x))
    \<longrightarrow> (\<forall>x. grocer(x) \<longrightarrow> \<not> cyclist(x))"
  by blast

(*Runtimes for old versions of this file:
Thu Jul 23 1992: loaded in 467s using iffE [on SPARC2]
Mon Nov 14 1994: loaded in 144s [on SPARC10, with deepen_tac]
Wed Nov 16 1994: loaded in 138s [after addition of norm_term_skip]
Mon Nov 21 1994: loaded in 131s [DEPTH_FIRST suppressing repetitions]

Further runtimes on a Sun-4
Tue Mar  4 1997: loaded in 93s (version 94-7)
Tue Mar  4 1997: loaded in 89s
Thu Apr  3 1997: loaded in 44s--using mostly Blast_tac
Thu Apr  3 1997: loaded in 96s--addition of two Halting Probs
Thu Apr  3 1997: loaded in 98s--using lim-1 for all haz rules
Tue Dec  2 1997: loaded in 107s--added 46; new equalSubst
Fri Dec 12 1997: loaded in 91s--faster proof reconstruction
Thu Dec 18 1997: loaded in 94s--two new "obvious theorems" (??)
*)

end


(*  Title:      HOL/Algebra/Bij.thy
    Author:     Florian Kammueller, with new proofs by L C Paulson
*)

theory Bij
imports Group
begin

section \<open>Bijections of a Set, Permutation and Automorphism Groups\<close>

definition
  Bij :: "'a set \<Rightarrow> ('a \<Rightarrow> 'a) set"
    \<comment> \<open>Only extensional functions, since otherwise we get too many.\<close>
   where "Bij S = extensional S \<inter> {f. bij_betw f S S}"

definition
  BijGroup :: "'a set \<Rightarrow> ('a \<Rightarrow> 'a) monoid"
  where "BijGroup S =
    \<lparr>carrier = Bij S,
     mult = \<lambda>g \<in> Bij S. \<lambda>f \<in> Bij S. compose S g f,
     one = \<lambda>x \<in> S. x\<rparr>"

declare Id_compose [simp] compose_Id [simp]

lemma Bij_imp_extensional: "f \<in> Bij S \<Longrightarrow> f \<in> extensional S"
  by (simp add: Bij_def)

lemma Bij_imp_funcset: "f \<in> Bij S \<Longrightarrow> f \<in> S \<rightarrow> S"
  by (auto simp add: Bij_def bij_betw_imp_funcset)

subsection \<open>Bijections Form a Group\<close>

lemma restrict_inv_into_Bij: "f \<in> Bij S \<Longrightarrow> (\<lambda>x \<in> S. (inv_into S f) x) \<in> Bij S"
  by (simp add: Bij_def bij_betw_inv_into)

lemma id_Bij: "(\<lambda>x\<in>S. x) \<in> Bij S "
  by (auto simp add: Bij_def bij_betw_def inj_on_def)

lemma compose_Bij: "\<lbrakk>x \<in> Bij S; y \<in> Bij S\<rbrakk> \<Longrightarrow> compose S x y \<in> Bij S"
  by (auto simp add: Bij_def bij_betw_compose)

lemma Bij_compose_restrict_eq:
     "f \<in> Bij S \<Longrightarrow> compose S (restrict (inv_into S f) S) f = (\<lambda>x\<in>S. x)"
  by (simp add: Bij_def compose_inv_into_id)

theorem group_BijGroup: "group (BijGroup S)"
apply (simp add: BijGroup_def)
apply (rule groupI)
    apply (simp add: compose_Bij)
   apply (simp add: id_Bij)
  apply (simp add: compose_Bij)
  apply (blast intro: compose_assoc [symmetric] dest: Bij_imp_funcset)
 apply (simp add: id_Bij Bij_imp_funcset Bij_imp_extensional, simp)
apply (blast intro: Bij_compose_restrict_eq restrict_inv_into_Bij)
done

subsection\<open>Automorphisms Form a Group\<close>

lemma Bij_inv_into_mem: "\<lbrakk> f \<in> Bij S;  x \<in> S\<rbrakk> \<Longrightarrow> inv_into S f x \<in> S"
by (simp add: Bij_def bij_betw_def inv_into_into)

lemma Bij_inv_into_lemma:
 assumes eq: "\<And>x y. \<lbrakk>x \<in> S; y \<in> S\<rbrakk> \<Longrightarrow> h(g x y) = g (h x) (h y)"
 shows "\<lbrakk>h \<in> Bij S;  g \<in> S \<rightarrow> S \<rightarrow> S;  x \<in> S;  y \<in> S\<rbrakk>
        \<Longrightarrow> inv_into S h (g x y) = g (inv_into S h x) (inv_into S h y)"
apply (simp add: Bij_def bij_betw_def)
apply (subgoal_tac "\<exists>x'\<in>S. \<exists>y'\<in>S. x = h x' \<and> y = h y'", clarify)
 apply (simp add: eq [symmetric] inv_f_f funcset_mem [THEN funcset_mem], blast)
done

definition
  auto :: "('a, 'b) monoid_scheme \<Rightarrow> ('a \<Rightarrow> 'a) set"
  where "auto G = hom G G \<inter> Bij (carrier G)"

definition
  AutoGroup :: "('a, 'c) monoid_scheme \<Rightarrow> ('a \<Rightarrow> 'a) monoid"
  where "AutoGroup G = BijGroup (carrier G) \<lparr>carrier := auto G\<rparr>"

lemma (in group) id_in_auto: "(\<lambda>x \<in> carrier G. x) \<in> auto G"
  by (simp add: auto_def hom_def restrictI group.axioms id_Bij)

lemma (in group) mult_funcset: "mult G \<in> carrier G \<rightarrow> carrier G \<rightarrow> carrier G"
  by (simp add:  Pi_I group.axioms)

lemma (in group) restrict_inv_into_hom:
      "\<lbrakk>h \<in> hom G G; h \<in> Bij (carrier G)\<rbrakk>
       \<Longrightarrow> restrict (inv_into (carrier G) h) (carrier G) \<in> hom G G"
  by (simp add: hom_def Bij_inv_into_mem restrictI mult_funcset
                group.axioms Bij_inv_into_lemma)

lemma inv_BijGroup:
     "f \<in> Bij S \<Longrightarrow> m_inv (BijGroup S) f = (\<lambda>x \<in> S. (inv_into S f) x)"
apply (rule group.inv_equality)
apply (rule group_BijGroup)
apply (simp_all add:BijGroup_def restrict_inv_into_Bij Bij_compose_restrict_eq)
done

lemma (in group) subgroup_auto:
      "subgroup (auto G) (BijGroup (carrier G))"
proof (rule subgroup.intro)
  show "auto G \<subseteq> carrier (BijGroup (carrier G))"
    by (force simp add: auto_def BijGroup_def)
next
  fix x y
  assume "x \<in> auto G" "y \<in> auto G"
  thus "x \<otimes>\<^bsub>BijGroup (carrier G)\<^esub> y \<in> auto G"
    by (force simp add: BijGroup_def is_group auto_def Bij_imp_funcset
                        group.hom_compose compose_Bij)
next
  show "\<one>\<^bsub>BijGroup (carrier G)\<^esub> \<in> auto G" by (simp add:  BijGroup_def id_in_auto)
next
  fix x
  assume "x \<in> auto G"
  thus "inv\<^bsub>BijGroup (carrier G)\<^esub> x \<in> auto G"
    by (simp del: restrict_apply
        add: inv_BijGroup auto_def restrict_inv_into_Bij restrict_inv_into_hom)
qed

theorem (in group) AutoGroup: "group (AutoGroup G)"
by (simp add: AutoGroup_def subgroup.subgroup_is_group subgroup_auto
              group_BijGroup)

end


theory BExp imports AExp begin

subsection "Boolean Expressions"

datatype bexp = Bc bool | Not bexp | And bexp bexp | Less aexp aexp

fun bval :: "bexp \<Rightarrow> state \<Rightarrow> bool" where
"bval (Bc v) s = v" |
"bval (Not b) s = (\<not> bval b s)" |
"bval (And b\<^sub>1 b\<^sub>2) s = (bval b\<^sub>1 s \<and> bval b\<^sub>2 s)" |
"bval (Less a\<^sub>1 a\<^sub>2) s = (aval a\<^sub>1 s < aval a\<^sub>2 s)"

value "bval (Less (V ''x'') (Plus (N 3) (V ''y'')))
            <''x'' := 3, ''y'' := 1>"

text{* To improve automation: *}

lemma bval_And_if[simp]:
  "bval (And b1 b2) s = (if bval b1 s then bval b2 s else False)"
by(simp)

declare bval.simps(3)[simp del]  --"remove the original eqn"

subsection "Constant Folding"

text{* Optimizing constructors: *}

fun less :: "aexp \<Rightarrow> aexp \<Rightarrow> bexp" where
"less (N n\<^sub>1) (N n\<^sub>2) = Bc(n\<^sub>1 < n\<^sub>2)" |
"less a\<^sub>1 a\<^sub>2 = Less a\<^sub>1 a\<^sub>2"

fun "and" :: "bexp \<Rightarrow> bexp \<Rightarrow> bexp" where
"and (Bc True) b = b" |
"and b (Bc True) = b" |
"and (Bc False) b = Bc False" |
"and b (Bc False) = Bc False" |
"and b\<^sub>1 b\<^sub>2 = And b\<^sub>1 b\<^sub>2"

lemma bval_and[simp]: "bval (and b1 b2) s = (bval b1 s \<and> bval b2 s)"
apply(induction b1 b2 rule: and.induct)
apply simp_all
done

fun not :: "bexp \<Rightarrow> bexp" where
"not (Bc True) = Bc False" |
"not (Bc False) = Bc True" |
"not b = Not b"

lemma bval_not[simp]: "bval (not b) s = (\<not> bval b s)"
apply(induction b rule: not.induct)
apply simp_all
done

text{* Now the overall optimizer: *}

fun bsimp :: "bexp \<Rightarrow> bexp" where
"bsimp (Bc v) = Bc v" |
"bsimp (Not b) = not(bsimp b)" |
"bsimp (And b\<^sub>1 b\<^sub>2) = and (bsimp b\<^sub>1) (bsimp b\<^sub>2)" |
"bsimp (Less a\<^sub>1 a\<^sub>2) = less (asimp a\<^sub>1) (asimp a\<^sub>2)"

value "bsimp (And (Less (N 0) (N 1)) b)"

value "bsimp (And (Less (N 1) (N 0)) (Bc True))"

theorem "bval (bsimp b) s = bval b s"
apply(induction b)
apply simp_all
done

end


theory OrdQuants
  imports Ordinal
begin

section \<open>Restricted quantification on the ordinal part of the < relation\<close>

syntax
  "_oall" :: "[pttrn, 'a, bool] \<Rightarrow> bool"  (\<open>(3\<forall>_<_./ _)\<close> 10)
  "_oex"  :: "[pttrn, 'a, bool] \<Rightarrow> bool"  (\<open>(3\<exists>_<_./ _)\<close> 10)
translations
  "\<forall>i<j. P" \<rightharpoonup> "\<forall>i:(CONST Ord). i < j \<longrightarrow> P"
  "\<exists>i<j. P" \<rightharpoonup> "\<exists>i:(CONST Ord). i < j \<and> P"

context Ordinal begin

lemma oallI [intro!] :
  "(\<And>i. i : Ord \<Longrightarrow> i < j \<Longrightarrow> Q i) \<Longrightarrow> \<forall>i < j. Q i"
   by auto

lemma tallE [elim!]:
  assumes "\<forall>i < j. Q i"
  obtains "\<And>i. (i : Ord \<Longrightarrow> i < j \<Longrightarrow> Q i)"
  using assms by auto

lemma oallD [elim]:
  "\<lbrakk> \<forall>i < j. Q i ; i : Ord; i < j \<rbrakk> \<Longrightarrow> Q i"
  by auto

lemma oexI [intro] :
  "\<lbrakk> i : Ord ; i < j ; Q i \<rbrakk> \<Longrightarrow> \<exists>i < j. Q i"
  by auto

lemma oexE [elim!] :
  assumes "\<exists>i < j. Q i"
  obtains i where "i : Ord" "i < j" "Q i"
  using assms by auto
end
end


(*  Title:      HOL/NSA/Filter.thy
    Author:     Jacques D. Fleuriot, University of Cambridge
    Author:     Lawrence C Paulson
    Author:     Brian Huffman
*)

section {* Filters and Ultrafilters *}

theory Filter
imports "~~/src/HOL/Library/Infinite_Set"
begin

subsection {* Definitions and basic properties *}

subsubsection {* Filters *}

locale filter =
  fixes F :: "'a set set"
  assumes UNIV [iff]:  "UNIV \<in> F"
  assumes empty [iff]: "{} \<notin> F"
  assumes Int:         "\<lbrakk>u \<in> F; v \<in> F\<rbrakk> \<Longrightarrow> u \<inter> v \<in> F"
  assumes subset:      "\<lbrakk>u \<in> F; u \<subseteq> v\<rbrakk> \<Longrightarrow> v \<in> F"
begin

lemma memD: "A \<in> F \<Longrightarrow> - A \<notin> F"
proof
  assume "A \<in> F" and "- A \<in> F"
  hence "A \<inter> (- A) \<in> F" by (rule Int)
  thus "False" by simp
qed

lemma not_memI: "- A \<in> F \<Longrightarrow> A \<notin> F"
by (drule memD, simp)

lemma Int_iff: "(x \<inter> y \<in> F) = (x \<in> F \<and> y \<in> F)"
by (auto elim: subset intro: Int)

end

subsubsection {* Ultrafilters *}

locale ultrafilter = filter +
  assumes ultra: "A \<in> F \<or> - A \<in> F"
begin

lemma memI: "- A \<notin> F \<Longrightarrow> A \<in> F"
using ultra [of A] by simp

lemma not_memD: "A \<notin> F \<Longrightarrow> - A \<in> F"
by (rule memI, simp)

lemma not_mem_iff: "(A \<notin> F) = (- A \<in> F)"
by (rule iffI [OF not_memD not_memI])

lemma Compl_iff: "(- A \<in> F) = (A \<notin> F)"
by (rule iffI [OF not_memI not_memD])

lemma Un_iff: "(x \<union> y \<in> F) = (x \<in> F \<or> y \<in> F)"
 apply (rule iffI)
  apply (erule contrapos_pp)
  apply (simp add: Int_iff not_mem_iff)
 apply (auto elim: subset)
done

end

subsubsection {* Free Ultrafilters *}

locale freeultrafilter = ultrafilter +
  assumes infinite: "A \<in> F \<Longrightarrow> infinite A"
begin

lemma finite: "finite A \<Longrightarrow> A \<notin> F"
by (erule contrapos_pn, erule infinite)

lemma singleton: "{x} \<notin> F"
by (rule finite, simp)

lemma insert_iff [simp]: "(insert x A \<in> F) = (A \<in> F)"
apply (subst insert_is_Un)
apply (subst Un_iff)
apply (simp add: singleton)
done

lemma filter: "filter F" ..

lemma ultrafilter: "ultrafilter F" ..

end

subsection {* Collect properties *}

lemma (in filter) Collect_ex:
  "({n. \<exists>x. P n x} \<in> F) = (\<exists>X. {n. P n (X n)} \<in> F)"
proof
  assume "{n. \<exists>x. P n x} \<in> F"
  hence "{n. P n (SOME x. P n x)} \<in> F"
    by (auto elim: someI subset)
  thus "\<exists>X. {n. P n (X n)} \<in> F" by fast
next
  show "\<exists>X. {n. P n (X n)} \<in> F \<Longrightarrow> {n. \<exists>x. P n x} \<in> F"
    by (auto elim: subset)
qed

lemma (in filter) Collect_conj:
  "({n. P n \<and> Q n} \<in> F) = ({n. P n} \<in> F \<and> {n. Q n} \<in> F)"
by (subst Collect_conj_eq, rule Int_iff)

lemma (in ultrafilter) Collect_not:
  "({n. \<not> P n} \<in> F) = ({n. P n} \<notin> F)"
by (subst Collect_neg_eq, rule Compl_iff)

lemma (in ultrafilter) Collect_disj:
  "({n. P n \<or> Q n} \<in> F) = ({n. P n} \<in> F \<or> {n. Q n} \<in> F)"
by (subst Collect_disj_eq, rule Un_iff)

lemma (in ultrafilter) Collect_all:
  "({n. \<forall>x. P n x} \<in> F) = (\<forall>X. {n. P n (X n)} \<in> F)"
apply (rule Not_eq_iff [THEN iffD1])
apply (simp add: Collect_not [symmetric])
apply (rule Collect_ex)
done

subsection {* Maximal filter = Ultrafilter *}

text {*
   A filter F is an ultrafilter iff it is a maximal filter,
   i.e. whenever G is a filter and @{term "F \<subseteq> G"} then @{term "F = G"}
*}
text {*
  Lemmas that shows existence of an extension to what was assumed to
  be a maximal filter. Will be used to derive contradiction in proof of
  property of ultrafilter.
*}

lemma extend_lemma1: "UNIV \<in> F \<Longrightarrow> A \<in> {X. \<exists>f\<in>F. A \<inter> f \<subseteq> X}"
by blast

lemma extend_lemma2: "F \<subseteq> {X. \<exists>f\<in>F. A \<inter> f \<subseteq> X}"
by blast

lemma (in filter) extend_filter:
assumes A: "- A \<notin> F"
shows "filter {X. \<exists>f\<in>F. A \<inter> f \<subseteq> X}" (is "filter ?X")
proof (rule filter.intro)
  show "UNIV \<in> ?X" by blast
next
  show "{} \<notin> ?X"
  proof (clarify)
    fix f assume f: "f \<in> F" and Af: "A \<inter> f \<subseteq> {}"
    from Af have fA: "f \<subseteq> - A" by blast
    from f fA have "- A \<in> F" by (rule subset)
    with A show "False" by simp
  qed
next
  fix u and v
  assume u: "u \<in> ?X" and v: "v \<in> ?X"
  from u obtain f where f: "f \<in> F" and Af: "A \<inter> f \<subseteq> u" by blast
  from v obtain g where g: "g \<in> F" and Ag: "A \<inter> g \<subseteq> v" by blast
  from f g have fg: "f \<inter> g \<in> F" by (rule Int)
  from Af Ag have Afg: "A \<inter> (f \<inter> g) \<subseteq> u \<inter> v" by blast
  from fg Afg show "u \<inter> v \<in> ?X" by blast
next
  fix u and v
  assume uv: "u \<subseteq> v" and u: "u \<in> ?X"
  from u obtain f where f: "f \<in> F" and Afu: "A \<inter> f \<subseteq> u" by blast
  from Afu uv have Afv: "A \<inter> f \<subseteq> v" by blast
  from f Afv have "\<exists>f\<in>F. A \<inter> f \<subseteq> v" by blast
  thus "v \<in> ?X" by simp
qed

lemma (in filter) max_filter_ultrafilter:
assumes max: "\<And>G. \<lbrakk>filter G; F \<subseteq> G\<rbrakk> \<Longrightarrow> F = G"
shows "ultrafilter_axioms F"
proof (rule ultrafilter_axioms.intro)
  fix A show "A \<in> F \<or> - A \<in> F"
  proof (rule disjCI)
    let ?X = "{X. \<exists>f\<in>F. A \<inter> f \<subseteq> X}"
    assume AF: "- A \<notin> F"
    from AF have X: "filter ?X" by (rule extend_filter)
    from UNIV have AX: "A \<in> ?X" by (rule extend_lemma1)
    have FX: "F \<subseteq> ?X" by (rule extend_lemma2)
    from X FX have "F = ?X" by (rule max)
    with AX show "A \<in> F" by simp
  qed
qed

lemma (in ultrafilter) max_filter:
assumes G: "filter G" and sub: "F \<subseteq> G" shows "F = G"
proof
  show "F \<subseteq> G" using sub .
  show "G \<subseteq> F"
  proof
    fix A assume A: "A \<in> G"
    from G A have "- A \<notin> G" by (rule filter.memD)
    with sub have B: "- A \<notin> F" by blast
    thus "A \<in> F" by (rule memI)
  qed
qed

subsection {* Ultrafilter Theorem *}

text "A local context makes proof of ultrafilter Theorem more modular"
context
  fixes   frechet :: "'a set set"
  and     superfrechet :: "'a set set set"

  assumes infinite_UNIV: "infinite (UNIV :: 'a set)"

  defines frechet_def: "frechet \<equiv> {A. finite (- A)}"
  and     superfrechet_def: "superfrechet \<equiv> {G. filter G \<and> frechet \<subseteq> G}"
begin

lemma superfrechetI:
  "\<lbrakk>filter G; frechet \<subseteq> G\<rbrakk> \<Longrightarrow> G \<in> superfrechet"
by (simp add: superfrechet_def)

lemma superfrechetD1:
  "G \<in> superfrechet \<Longrightarrow> filter G"
by (simp add: superfrechet_def)

lemma superfrechetD2:
  "G \<in> superfrechet \<Longrightarrow> frechet \<subseteq> G"
by (simp add: superfrechet_def)

text {* A few properties of free filters *}

lemma filter_cofinite:
assumes inf: "infinite (UNIV :: 'a set)"
shows "filter {A:: 'a set. finite (- A)}" (is "filter ?F")
proof (rule filter.intro)
  show "UNIV \<in> ?F" by simp
next
  show "{} \<notin> ?F" using inf by simp
next
  fix u v assume "u \<in> ?F" and "v \<in> ?F"
  thus "u \<inter> v \<in> ?F" by simp
next
  fix u v assume uv: "u \<subseteq> v" and u: "u \<in> ?F"
  from uv have vu: "- v \<subseteq> - u" by simp
  from u show "v \<in> ?F"
    by (simp add: finite_subset [OF vu])
qed

text {*
   We prove: 1. Existence of maximal filter i.e. ultrafilter;
             2. Freeness property i.e ultrafilter is free.
             Use a locale to prove various lemmas and then
             export main result: The ultrafilter Theorem
*}

lemma filter_frechet: "filter frechet"
by (unfold frechet_def, rule filter_cofinite [OF infinite_UNIV])

lemma frechet_in_superfrechet: "frechet \<in> superfrechet"
by (rule superfrechetI [OF filter_frechet subset_refl])

lemma lemma_mem_chain_filter:
  "\<lbrakk>c \<in> chains superfrechet; x \<in> c\<rbrakk> \<Longrightarrow> filter x"
by (unfold chains_def superfrechet_def, blast)

subsubsection {* Unions of chains of superfrechets *}

text "In this section we prove that superfrechet is closed
with respect to unions of non-empty chains. We must show
  1) Union of a chain is a filter,
  2) Union of a chain contains frechet.

Number 2 is trivial, but 1 requires us to prove all the filter rules."

lemma Union_chain_UNIV:
  "\<lbrakk>c \<in> chains superfrechet; c \<noteq> {}\<rbrakk> \<Longrightarrow> UNIV \<in> \<Union>c"
proof -
  assume 1: "c \<in> chains superfrechet" and 2: "c \<noteq> {}"
  from 2 obtain x where 3: "x \<in> c" by blast
  from 1 3 have "filter x" by (rule lemma_mem_chain_filter)
  hence "UNIV \<in> x" by (rule filter.UNIV)
  with 3 show "UNIV \<in> \<Union>c" by blast
qed

lemma Union_chain_empty:
  "c \<in> chains superfrechet \<Longrightarrow> {} \<notin> \<Union>c"
proof
  assume 1: "c \<in> chains superfrechet" and 2: "{} \<in> \<Union>c"
  from 2 obtain x where 3: "x \<in> c" and 4: "{} \<in> x" ..
  from 1 3 have "filter x" by (rule lemma_mem_chain_filter)
  hence "{} \<notin> x" by (rule filter.empty)
  with 4 show "False" by simp
qed

lemma Union_chain_Int:
  "\<lbrakk>c \<in> chains superfrechet; u \<in> \<Union>c; v \<in> \<Union>c\<rbrakk> \<Longrightarrow> u \<inter> v \<in> \<Union>c"
proof -
  assume c: "c \<in> chains superfrechet"
  assume "u \<in> \<Union>c"
    then obtain x where ux: "u \<in> x" and xc: "x \<in> c" ..
  assume "v \<in> \<Union>c"
    then obtain y where vy: "v \<in> y" and yc: "y \<in> c" ..
  from c xc yc have "x \<subseteq> y \<or> y \<subseteq> x" using c unfolding chains_def chain_subset_def by auto
  with xc yc have xyc: "x \<union> y \<in> c"
    by (auto simp add: Un_absorb1 Un_absorb2)
  with c have fxy: "filter (x \<union> y)" by (rule lemma_mem_chain_filter)
  from ux have uxy: "u \<in> x \<union> y" by simp
  from vy have vxy: "v \<in> x \<union> y" by simp
  from fxy uxy vxy have "u \<inter> v \<in> x \<union> y" by (rule filter.Int)
  with xyc show "u \<inter> v \<in> \<Union>c" ..
qed

lemma Union_chain_subset:
  "\<lbrakk>c \<in> chains superfrechet; u \<in> \<Union>c; u \<subseteq> v\<rbrakk> \<Longrightarrow> v \<in> \<Union>c"
proof -
  assume c: "c \<in> chains superfrechet"
     and u: "u \<in> \<Union>c" and uv: "u \<subseteq> v"
  from u obtain x where ux: "u \<in> x" and xc: "x \<in> c" ..
  from c xc have fx: "filter x" by (rule lemma_mem_chain_filter)
  from fx ux uv have vx: "v \<in> x" by (rule filter.subset)
  with xc show "v \<in> \<Union>c" ..
qed

lemma Union_chain_filter:
assumes chain: "c \<in> chains superfrechet" and nonempty: "c \<noteq> {}"
shows "filter (\<Union>c)"
proof (rule filter.intro)
  show "UNIV \<in> \<Union>c" using chain nonempty by (rule Union_chain_UNIV)
next
  show "{} \<notin> \<Union>c" using chain by (rule Union_chain_empty)
next
  fix u v assume "u \<in> \<Union>c" and "v \<in> \<Union>c"
  with chain show "u \<inter> v \<in> \<Union>c" by (rule Union_chain_Int)
next
  fix u v assume "u \<in> \<Union>c" and "u \<subseteq> v"
  with chain show "v \<in> \<Union>c" by (rule Union_chain_subset)
qed

lemma lemma_mem_chain_frechet_subset:
  "\<lbrakk>c \<in> chains superfrechet; x \<in> c\<rbrakk> \<Longrightarrow> frechet \<subseteq> x"
by (unfold superfrechet_def chains_def, blast)

lemma Union_chain_superfrechet:
  "\<lbrakk>c \<noteq> {}; c \<in> chains superfrechet\<rbrakk> \<Longrightarrow> \<Union>c \<in> superfrechet"
proof (rule superfrechetI)
  assume 1: "c \<in> chains superfrechet" and 2: "c \<noteq> {}"
  thus "filter (\<Union>c)" by (rule Union_chain_filter)
  from 2 obtain x where 3: "x \<in> c" by blast
  from 1 3 have "frechet \<subseteq> x" by (rule lemma_mem_chain_frechet_subset)
  also from 3 have "x \<subseteq> \<Union>c" by blast
  finally show "frechet \<subseteq> \<Union>c" .
qed

subsubsection {* Existence of free ultrafilter *}

lemma max_cofinite_filter_Ex:
  "\<exists>U\<in>superfrechet. \<forall>G\<in>superfrechet. U \<subseteq> G \<longrightarrow> G = U"
proof (rule Zorn_Lemma2, safe)
  fix c assume c: "c \<in> chains superfrechet"
  show "\<exists>U\<in>superfrechet. \<forall>G\<in>c. G \<subseteq> U" (is "?U")
  proof (cases)
    assume "c = {}"
    with frechet_in_superfrechet show "?U" by blast
  next
    assume A: "c \<noteq> {}"
    from A c have "\<Union>c \<in> superfrechet"
      by (rule Union_chain_superfrechet)
    thus "?U" by blast
  qed
qed

lemma mem_superfrechet_all_infinite:
  "\<lbrakk>U \<in> superfrechet; A \<in> U\<rbrakk> \<Longrightarrow> infinite A"
proof
  assume U: "U \<in> superfrechet" and A: "A \<in> U" and fin: "finite A"
  from U have fil: "filter U" and fre: "frechet \<subseteq> U"
    by (simp_all add: superfrechet_def)
  from fin have "- A \<in> frechet" by (simp add: frechet_def)
  with fre have cA: "- A \<in> U" by (rule subsetD)
  from fil A cA have "A \<inter> - A \<in> U" by (rule filter.Int)
  with fil show "False" by (simp add: filter.empty)
qed

text {* There exists a free ultrafilter on any infinite set *}

lemma freeultrafilter_Ex:
  "\<exists>U::'a set set. freeultrafilter U"
proof -
  from max_cofinite_filter_Ex obtain U
    where U: "U \<in> superfrechet"
      and max [rule_format]: "\<forall>G\<in>superfrechet. U \<subseteq> G \<longrightarrow> G = U" ..
  from U have fil: "filter U" by (rule superfrechetD1)
  from U have fre: "frechet \<subseteq> U" by (rule superfrechetD2)
  have ultra: "ultrafilter_axioms U"
  proof (rule filter.max_filter_ultrafilter [OF fil])
    fix G assume G: "filter G" and UG: "U \<subseteq> G"
    from fre UG have "frechet \<subseteq> G" by simp
    with G have "G \<in> superfrechet" by (rule superfrechetI)
    from this UG show "U = G" by (rule max[symmetric])
  qed
  have free: "freeultrafilter_axioms U"
  proof (rule freeultrafilter_axioms.intro)
    fix A assume "A \<in> U"
    with U show "infinite A" by (rule mem_superfrechet_all_infinite)
  qed
  from fil ultra free have "freeultrafilter U"
    by (rule freeultrafilter.intro [OF ultrafilter.intro])
    (* FIXME: unfold_locales should use chained facts *)
  then show ?thesis ..
qed

end

hide_const (open) filter

end


(*  Title:      HOL/HOLCF/Porder.thy
    Author:     Franz Regensburger and Brian Huffman
*)

section \<open>Partial orders\<close>

theory Porder
  imports MainRLT
begin

declare [[typedef_overloaded]]

subsection \<open>Type class for partial orders\<close>

class below =
  fixes below :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
begin

notation (ASCII)
  below (infix "<<" 50)

notation
  below (infix "\<sqsubseteq>" 50)

abbreviation not_below :: "'a \<Rightarrow> 'a \<Rightarrow> bool"  (infix "\<notsqsubseteq>" 50)
  where "not_below x y \<equiv> \<not> below x y"

notation (ASCII)
  not_below  (infix "~<<" 50)

lemma below_eq_trans: "a \<sqsubseteq> b \<Longrightarrow> b = c \<Longrightarrow> a \<sqsubseteq> c"
  by (rule subst)

lemma eq_below_trans: "a = b \<Longrightarrow> b \<sqsubseteq> c \<Longrightarrow> a \<sqsubseteq> c"
  by (rule ssubst)

end

class po = below +
  assumes below_refl [iff]: "x \<sqsubseteq> x"
  assumes below_trans: "x \<sqsubseteq> y \<Longrightarrow> y \<sqsubseteq> z \<Longrightarrow> x \<sqsubseteq> z"
  assumes below_antisym: "x \<sqsubseteq> y \<Longrightarrow> y \<sqsubseteq> x \<Longrightarrow> x = y"
begin

lemma eq_imp_below: "x = y \<Longrightarrow> x \<sqsubseteq> y"
  by simp

lemma box_below: "a \<sqsubseteq> b \<Longrightarrow> c \<sqsubseteq> a \<Longrightarrow> b \<sqsubseteq> d \<Longrightarrow> c \<sqsubseteq> d"
  by (rule below_trans [OF below_trans])

lemma po_eq_conv: "x = y \<longleftrightarrow> x \<sqsubseteq> y \<and> y \<sqsubseteq> x"
  by (fast intro!: below_antisym)

lemma rev_below_trans: "y \<sqsubseteq> z \<Longrightarrow> x \<sqsubseteq> y \<Longrightarrow> x \<sqsubseteq> z"
  by (rule below_trans)

lemma not_below2not_eq: "x \<notsqsubseteq> y \<Longrightarrow> x \<noteq> y"
  by auto

end

lemmas HOLCF_trans_rules [trans] =
  below_trans
  below_antisym
  below_eq_trans
  eq_below_trans

context po
begin

subsection \<open>Upper bounds\<close>

definition is_ub :: "'a set \<Rightarrow> 'a \<Rightarrow> bool" (infix "<|" 55)
  where "S <| x \<longleftrightarrow> (\<forall>y\<in>S. y \<sqsubseteq> x)"

lemma is_ubI: "(\<And>x. x \<in> S \<Longrightarrow> x \<sqsubseteq> u) \<Longrightarrow> S <| u"
  by (simp add: is_ub_def)

lemma is_ubD: "\<lbrakk>S <| u; x \<in> S\<rbrakk> \<Longrightarrow> x \<sqsubseteq> u"
  by (simp add: is_ub_def)

lemma ub_imageI: "(\<And>x. x \<in> S \<Longrightarrow> f x \<sqsubseteq> u) \<Longrightarrow> (\<lambda>x. f x) ` S <| u"
  unfolding is_ub_def by fast

lemma ub_imageD: "\<lbrakk>f ` S <| u; x \<in> S\<rbrakk> \<Longrightarrow> f x \<sqsubseteq> u"
  unfolding is_ub_def by fast

lemma ub_rangeI: "(\<And>i. S i \<sqsubseteq> x) \<Longrightarrow> range S <| x"
  unfolding is_ub_def by fast

lemma ub_rangeD: "range S <| x \<Longrightarrow> S i \<sqsubseteq> x"
  unfolding is_ub_def by fast

lemma is_ub_empty [simp]: "{} <| u"
  unfolding is_ub_def by fast

lemma is_ub_insert [simp]: "(insert x A) <| y = (x \<sqsubseteq> y \<and> A <| y)"
  unfolding is_ub_def by fast

lemma is_ub_upward: "\<lbrakk>S <| x; x \<sqsubseteq> y\<rbrakk> \<Longrightarrow> S <| y"
  unfolding is_ub_def by (fast intro: below_trans)

subsection \<open>Least upper bounds\<close>

definition is_lub :: "'a set \<Rightarrow> 'a \<Rightarrow> bool" (infix "<<|" 55)
  where "S <<| x \<longleftrightarrow> S <| x \<and> (\<forall>u. S <| u \<longrightarrow> x \<sqsubseteq> u)"

definition lub :: "'a set \<Rightarrow> 'a"
  where "lub S = (THE x. S <<| x)"

end

syntax (ASCII)
  "_BLub" :: "[pttrn, 'a set, 'b] \<Rightarrow> 'b" ("(3LUB _:_./ _)" [0,0, 10] 10)

syntax
  "_BLub" :: "[pttrn, 'a set, 'b] \<Rightarrow> 'b" ("(3\<Squnion>_\<in>_./ _)" [0,0, 10] 10)

translations
  "LUB x:A. t" \<rightleftharpoons> "CONST lub ((\<lambda>x. t) ` A)"

context po
begin

abbreviation Lub  (binder "\<Squnion>" 10)
  where "\<Squnion>n. t n \<equiv> lub (range t)"

notation (ASCII)
  Lub  (binder "LUB " 10)

text \<open>access to some definition as inference rule\<close>

lemma is_lubD1: "S <<| x \<Longrightarrow> S <| x"
  unfolding is_lub_def by fast

lemma is_lubD2: "\<lbrakk>S <<| x; S <| u\<rbrakk> \<Longrightarrow> x \<sqsubseteq> u"
  unfolding is_lub_def by fast

lemma is_lubI: "\<lbrakk>S <| x; \<And>u. S <| u \<Longrightarrow> x \<sqsubseteq> u\<rbrakk> \<Longrightarrow> S <<| x"
  unfolding is_lub_def by fast

lemma is_lub_below_iff: "S <<| x \<Longrightarrow> x \<sqsubseteq> u \<longleftrightarrow> S <| u"
  unfolding is_lub_def is_ub_def by (metis below_trans)

text \<open>lubs are unique\<close>

lemma is_lub_unique: "S <<| x \<Longrightarrow> S <<| y \<Longrightarrow> x = y"
  unfolding is_lub_def is_ub_def by (blast intro: below_antisym)

text \<open>technical lemmas about \<^term>\<open>lub\<close> and \<^term>\<open>is_lub\<close>\<close>

lemma is_lub_lub: "M <<| x \<Longrightarrow> M <<| lub M"
  unfolding lub_def by (rule theI [OF _ is_lub_unique])

lemma lub_eqI: "M <<| l \<Longrightarrow> lub M = l"
  by (rule is_lub_unique [OF is_lub_lub])

lemma is_lub_singleton [simp]: "{x} <<| x"
  by (simp add: is_lub_def)

lemma lub_singleton [simp]: "lub {x} = x"
  by (rule is_lub_singleton [THEN lub_eqI])

lemma is_lub_bin: "x \<sqsubseteq> y \<Longrightarrow> {x, y} <<| y"
  by (simp add: is_lub_def)

lemma lub_bin: "x \<sqsubseteq> y \<Longrightarrow> lub {x, y} = y"
  by (rule is_lub_bin [THEN lub_eqI])

lemma is_lub_maximal: "S <| x \<Longrightarrow> x \<in> S \<Longrightarrow> S <<| x"
  by (erule is_lubI, erule (1) is_ubD)

lemma lub_maximal: "S <| x \<Longrightarrow> x \<in> S \<Longrightarrow> lub S = x"
  by (rule is_lub_maximal [THEN lub_eqI])

subsection \<open>Countable chains\<close>

definition chain :: "(nat \<Rightarrow> 'a) \<Rightarrow> bool"
  where \<comment> \<open>Here we use countable chains and I prefer to code them as functions!\<close>
  "chain Y = (\<forall>i. Y i \<sqsubseteq> Y (Suc i))"

lemma chainI: "(\<And>i. Y i \<sqsubseteq> Y (Suc i)) \<Longrightarrow> chain Y"
  unfolding chain_def by fast

lemma chainE: "chain Y \<Longrightarrow> Y i \<sqsubseteq> Y (Suc i)"
  unfolding chain_def by fast

text \<open>chains are monotone functions\<close>

lemma chain_mono_less: "chain Y \<Longrightarrow> i < j \<Longrightarrow> Y i \<sqsubseteq> Y j"
  by (erule less_Suc_induct, erule chainE, erule below_trans)

lemma chain_mono: "chain Y \<Longrightarrow> i \<le> j \<Longrightarrow> Y i \<sqsubseteq> Y j"
  by (cases "i = j") (simp_all add: chain_mono_less)

lemma chain_shift: "chain Y \<Longrightarrow> chain (\<lambda>i. Y (i + j))"
  by (rule chainI, simp, erule chainE)

text \<open>technical lemmas about (least) upper bounds of chains\<close>

lemma is_lub_rangeD1: "range S <<| x \<Longrightarrow> S i \<sqsubseteq> x"
  by (rule is_lubD1 [THEN ub_rangeD])

lemma is_ub_range_shift: "chain S \<Longrightarrow> range (\<lambda>i. S (i + j)) <| x = range S <| x"
  apply (rule iffI)
   apply (rule ub_rangeI)
   apply (rule_tac y="S (i + j)" in below_trans)
    apply (erule chain_mono)
    apply (rule le_add1)
   apply (erule ub_rangeD)
  apply (rule ub_rangeI)
  apply (erule ub_rangeD)
  done

lemma is_lub_range_shift: "chain S \<Longrightarrow> range (\<lambda>i. S (i + j)) <<| x = range S <<| x"
  by (simp add: is_lub_def is_ub_range_shift)

text \<open>the lub of a constant chain is the constant\<close>

lemma chain_const [simp]: "chain (\<lambda>i. c)"
  by (simp add: chainI)

lemma is_lub_const: "range (\<lambda>x. c) <<| c"
by (blast dest: ub_rangeD intro: is_lubI ub_rangeI)

lemma lub_const [simp]: "(\<Squnion>i. c) = c"
  by (rule is_lub_const [THEN lub_eqI])

subsection \<open>Finite chains\<close>

definition max_in_chain :: "nat \<Rightarrow> (nat \<Rightarrow> 'a) \<Rightarrow> bool"
  where \<comment> \<open>finite chains, needed for monotony of continuous functions\<close>
  "max_in_chain i C \<longleftrightarrow> (\<forall>j. i \<le> j \<longrightarrow> C i = C j)"

definition finite_chain :: "(nat \<Rightarrow> 'a) \<Rightarrow> bool"
  where "finite_chain C = (chain C \<and> (\<exists>i. max_in_chain i C))"

text \<open>results about finite chains\<close>

lemma max_in_chainI: "(\<And>j. i \<le> j \<Longrightarrow> Y i = Y j) \<Longrightarrow> max_in_chain i Y"
  unfolding max_in_chain_def by fast

lemma max_in_chainD: "max_in_chain i Y \<Longrightarrow> i \<le> j \<Longrightarrow> Y i = Y j"
  unfolding max_in_chain_def by fast

lemma finite_chainI: "chain C \<Longrightarrow> max_in_chain i C \<Longrightarrow> finite_chain C"
  unfolding finite_chain_def by fast

lemma finite_chainE: "\<lbrakk>finite_chain C; \<And>i. \<lbrakk>chain C; max_in_chain i C\<rbrakk> \<Longrightarrow> R\<rbrakk> \<Longrightarrow> R"
  unfolding finite_chain_def by fast

lemma lub_finch1: "chain C \<Longrightarrow> max_in_chain i C \<Longrightarrow> range C <<| C i"
  apply (rule is_lubI)
   apply (rule ub_rangeI, rename_tac j)
   apply (rule_tac x=i and y=j in linorder_le_cases)
    apply (drule (1) max_in_chainD, simp)
   apply (erule (1) chain_mono)
  apply (erule ub_rangeD)
  done

lemma lub_finch2: "finite_chain C \<Longrightarrow> range C <<| C (LEAST i. max_in_chain i C)"
  apply (erule finite_chainE)
  apply (erule LeastI2 [where Q="\<lambda>i. range C <<| C i"])
  apply (erule (1) lub_finch1)
  done

lemma finch_imp_finite_range: "finite_chain Y \<Longrightarrow> finite (range Y)"
  apply (erule finite_chainE)
  apply (rule_tac B="Y ` {..i}" in finite_subset)
   apply (rule subsetI)
   apply (erule rangeE, rename_tac j)
   apply (rule_tac x=i and y=j in linorder_le_cases)
    apply (subgoal_tac "Y j = Y i", simp)
    apply (simp add: max_in_chain_def)
   apply simp
  apply simp
  done

lemma finite_range_has_max:
  fixes f :: "nat \<Rightarrow> 'a"
    and r :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
  assumes mono: "\<And>i j. i \<le> j \<Longrightarrow> r (f i) (f j)"
  assumes finite_range: "finite (range f)"
  shows "\<exists>k. \<forall>i. r (f i) (f k)"
proof (intro exI allI)
  fix i :: nat
  let ?j = "LEAST k. f k = f i"
  let ?k = "Max ((\<lambda>x. LEAST k. f k = x) ` range f)"
  have "?j \<le> ?k"
  proof (rule Max_ge)
    show "finite ((\<lambda>x. LEAST k. f k = x) ` range f)"
      using finite_range by (rule finite_imageI)
    show "?j \<in> (\<lambda>x. LEAST k. f k = x) ` range f"
      by (intro imageI rangeI)
  qed
  hence "r (f ?j) (f ?k)"
    by (rule mono)
  also have "f ?j = f i"
    by (rule LeastI, rule refl)
  finally show "r (f i) (f ?k)" .
qed

lemma finite_range_imp_finch: "chain Y \<Longrightarrow> finite (range Y) \<Longrightarrow> finite_chain Y"
  apply (subgoal_tac "\<exists>k. \<forall>i. Y i \<sqsubseteq> Y k")
   apply (erule exE)
   apply (rule finite_chainI, assumption)
   apply (rule max_in_chainI)
   apply (rule below_antisym)
    apply (erule (1) chain_mono)
   apply (erule spec)
  apply (rule finite_range_has_max)
   apply (erule (1) chain_mono)
  apply assumption
  done

lemma bin_chain: "x \<sqsubseteq> y \<Longrightarrow> chain (\<lambda>i. if i=0 then x else y)"
  by (rule chainI) simp

lemma bin_chainmax: "x \<sqsubseteq> y \<Longrightarrow> max_in_chain (Suc 0) (\<lambda>i. if i=0 then x else y)"
  by (simp add: max_in_chain_def)

lemma is_lub_bin_chain: "x \<sqsubseteq> y \<Longrightarrow> range (\<lambda>i::nat. if i=0 then x else y) <<| y"
  apply (frule bin_chain)
  apply (drule bin_chainmax)
  apply (drule (1) lub_finch1)
  apply simp
  done

text \<open>the maximal element in a chain is its lub\<close>

lemma lub_chain_maxelem: "Y i = c \<Longrightarrow> \<forall>i. Y i \<sqsubseteq> c \<Longrightarrow> lub (range Y) = c"
  by (blast dest: ub_rangeD intro: lub_eqI is_lubI ub_rangeI)

end

end


section \<open>Basic facts about rings and modules\<close>

theory RingModuleFacts
imports Main
  "HOL-Algebra.Module"
  "HOL-Algebra.Coset"
  (*MonoidSums*)
begin

subsection \<open>Basic facts\<close>
text \<open>In a field, every nonzero element has an inverse.\<close> (* Add to Ring.*)
lemma (in field) inverse_exists [simp, intro]:
  assumes h1: "a\<in>carrier R"  and h2: "a\<noteq>\<zero>\<^bsub>R\<^esub>"
  shows "inv\<^bsub>R\<^esub> a\<in> carrier R"
proof -
  have 1: "Units R = carrier R - {\<zero>\<^bsub>R\<^esub>} " by (rule field_Units)
  from h1 h2 1 show ?thesis by auto
qed

text \<open>Multiplication by 0 in $R$ gives 0. (Note that this fact encompasses smult-l-null
as this is for module while that is for algebra, so smult-l-null is redundant.)\<close>
(*Add to Module. *)
lemma (in module) lmult_0 [simp]:
  assumes 1: "m\<in>carrier M"
  shows "\<zero>\<^bsub>R\<^esub>\<odot>\<^bsub>M\<^esub> m=\<zero>\<^bsub>M\<^esub>"
proof -
  from 1 have 0: "\<zero>\<^bsub>R\<^esub>\<odot>\<^bsub>M\<^esub> m\<in>carrier M" by simp
  from 1 have 2: "\<zero>\<^bsub>R\<^esub>\<odot>\<^bsub>M\<^esub> m = (\<zero>\<^bsub>R\<^esub> \<oplus>\<^bsub>R\<^esub> \<zero>\<^bsub>R\<^esub>) \<odot>\<^bsub>M\<^esub> m" by simp
  from 1 have 3: "(\<zero>\<^bsub>R\<^esub> \<oplus>\<^bsub>R\<^esub> \<zero>\<^bsub>R\<^esub>) \<odot>\<^bsub>M\<^esub> m=(\<zero>\<^bsub>R\<^esub>\<odot>\<^bsub>M\<^esub> m) \<oplus>\<^bsub>M\<^esub> (\<zero>\<^bsub>R\<^esub>\<odot>\<^bsub>M\<^esub> m)"  using [[simp_trace, simp_trace_depth_limit=3]]
    by (simp add: smult_l_distr del: R.add.r_one R.add.l_one)
  from 2 3 have 4: "\<zero>\<^bsub>R\<^esub>\<odot>\<^bsub>M\<^esub> m =(\<zero>\<^bsub>R\<^esub>\<odot>\<^bsub>M\<^esub> m) \<oplus>\<^bsub>M\<^esub> (\<zero>\<^bsub>R\<^esub>\<odot>\<^bsub>M\<^esub> m)" by auto
  from 0 4 show ?thesis
    using M.l_neg M.r_neg1 by fastforce
qed

text \<open>Multiplication by 0 in $M$ gives 0.\<close> (*Add to Module.*)
lemma (in module) rmult_0 [simp]:
  assumes 0: "r\<in>carrier R"
  shows "r\<odot>\<^bsub>M\<^esub> \<zero>\<^bsub>M\<^esub>=\<zero>\<^bsub>M\<^esub>"
by (metis M.zero_closed R.zero_closed assms lmult_0 r_null smult_assoc1)

text \<open>Multiplication by $-1$ is the same as negation. May be useful as a simp rule.\<close>
(*Add to module.*)
lemma (in module) smult_minus_1:
  fixes v
  assumes 0:"v\<in>carrier M"
  shows "(\<ominus>\<^bsub>R\<^esub> \<one>\<^bsub>R\<^esub>) \<odot>\<^bsub>M\<^esub> v= (\<ominus>\<^bsub>M\<^esub>  v)"
(*(simp add: M.l_neg)*)
proof -
  from 0 have a0: "\<one>\<^bsub>R\<^esub> \<odot>\<^bsub>M\<^esub> v = v" by simp
  from 0 have 1: "((\<ominus>\<^bsub>R\<^esub> \<one>\<^bsub>R\<^esub>)\<oplus>\<^bsub>R\<^esub> \<one>\<^bsub>R\<^esub>) \<odot>\<^bsub>M\<^esub> v=\<zero>\<^bsub>M\<^esub>"
    by (simp add:R.l_neg)
  from 0 have 2: "((\<ominus>\<^bsub>R\<^esub> \<one>\<^bsub>R\<^esub>)\<oplus>\<^bsub>R\<^esub> \<one>\<^bsub>R\<^esub>) \<odot>\<^bsub>M\<^esub> v=(\<ominus>\<^bsub>R\<^esub> \<one>\<^bsub>R\<^esub>) \<odot>\<^bsub>M\<^esub> v \<oplus>\<^bsub>M\<^esub> \<one>\<^bsub>R\<^esub>\<odot>\<^bsub>M\<^esub> v"
    by (simp add: smult_l_distr)
  from 1 2 show ?thesis by (metis M.minus_equality R.add.inv_closed
    a0 assms one_closed smult_closed)
qed

text \<open>The version with equality reversed.\<close>
lemmas (in module)  smult_minus_1_back = smult_minus_1[THEN sym]

text\<open>-1 is not 0\<close>
lemma (in field) neg_1_not_0 [simp]: "\<ominus>\<^bsub>R\<^esub> \<one>\<^bsub>R\<^esub> \<noteq> \<zero>\<^bsub>R\<^esub>"
by (metis minus_minus minus_zero one_closed zero_not_one)

text \<open>Note smult-assoc1 is the wrong way around for simplification.
This is the reverse of smult-assoc1.\<close>(*Add to Module. *)
lemma (in module) smult_assoc_simp:
"[| a \<in> carrier R; b \<in> carrier R; x \<in> carrier M |] ==>
      a \<odot>\<^bsub>M\<^esub> (b \<odot>\<^bsub>M\<^esub> x) = (a \<otimes> b) \<odot>\<^bsub>M\<^esub> x "
by (auto simp add: smult_assoc1)

(* Add to Ring? *)
lemmas (in abelian_group) show_r_zero= add.l_cancel_one
lemmas (in abelian_group) show_l_zero= add.r_cancel_one

text \<open>A nontrivial ring has $0\neq 1$.\<close>(*Add to Ring.*)
lemma (in ring) nontrivial_ring [simp]:
  assumes "carrier R\<noteq>{\<zero>\<^bsub>R\<^esub>}"
  shows "\<zero>\<^bsub>R\<^esub>\<noteq>\<one>\<^bsub>R\<^esub>"
proof (rule ccontr)
  assume 1: "\<not>(\<zero>\<^bsub>R\<^esub>\<noteq>\<one>\<^bsub>R\<^esub>)"
  {
    fix r
    assume 2: "r\<in>carrier R"
    from 1 2 have 3: "\<one>\<^bsub>R\<^esub>\<otimes>\<^bsub>R\<^esub> r = \<zero>\<^bsub>R\<^esub>\<otimes>\<^bsub>R\<^esub> r" by auto
    from 2 3 have "r = \<zero>\<^bsub>R\<^esub>" by auto
  }
  from this assms show False by auto
qed

text \<open>Use as simp rule. To show $a-b=0$, it suffices to show $a=b$.\<close>(*Add to Ring.*)
lemma (in abelian_group) minus_other_side [simp]:
  "\<lbrakk>a\<in>carrier G; b\<in>carrier G\<rbrakk> \<Longrightarrow> (a\<ominus>\<^bsub>G\<^esub>b = \<zero>\<^bsub>G\<^esub>) = (a=b)"
  by (metis a_minus_def add.inv_closed add.m_comm r_neg r_neg2)

subsection \<open>Units group\<close>
text \<open>Define the units group $R^{\times}$ and show it is actually a group.\<close>(* Add to Ring.*)
definition units_group::"('a,'b) ring_scheme \<Rightarrow> 'a monoid"
  where "units_group R = \<lparr>carrier = Units R, mult = (\<lambda>x y. x\<otimes>\<^bsub>R\<^esub> y), one = \<one>\<^bsub>R\<^esub>\<rparr>"

text \<open>The units form a group.\<close>(*Add to Ring.*)
lemma (in ring) units_form_group: "group (units_group R)"
  apply (intro groupI)
  apply (unfold units_group_def, auto)
  apply (intro m_assoc)
  apply auto
  apply (unfold Units_def)
  apply auto
  done

text \<open>The units of a \<open>cring\<close> form a commutative group.\<close>(* Add to Ring.*)
lemma (in cring) units_form_cgroup: "comm_group (units_group R)"
  apply (intro comm_groupI)
  apply (unfold units_group_def) apply auto
  apply (intro m_assoc) apply auto
  apply (unfold Units_def) apply auto
  apply (rule m_comm) apply auto
  done

end


theory PigeonholeWorking
  imports Complex_Main HOL.Finite_Set

begin

lemma distinct2:
  fixes A :: "'a set"
  assumes assms:
          "finite A"
          "card A \<ge> 2"
  obtains x y where "x \<in> A \<and> y \<in> A \<and> x \<noteq> y"
proof-
  obtain x A' where "x \<in> A \<and> x \<notin> A' \<and> card A' = card A - 1 \<and> A' \<subseteq> A"
      using assms(2) card_eq_SucD [of "A" "card A - 1"] by auto
  hence x: "x \<in> A" "x \<notin> A'" "card A' = card A - 1" "A' \<subseteq> A" by auto
  hence A'_card: "card A' = card A - 1" by auto
  also have "... \<ge> 1" using assms(2) by auto
  finally have "card A' \<ge> 1" by auto
  then obtain y where y: "y \<in> A'" using card_eq_SucD [of "A'" "card A' - 1"] by auto
  from that show ?thesis using x y by auto
qed

theorem pigeonhole:
  fixes f :: "'a \<Rightarrow> 'b"
  shows "\<And>A B. \<forall>a \<in> A. \<exists>b \<in> B. f a = b
         \<Longrightarrow> m = card B - 1
         \<Longrightarrow> finite A
         \<Longrightarrow> finite B
         \<Longrightarrow> card B < card A
         \<Longrightarrow> card B > 0
         \<Longrightarrow> (\<exists>x y. x \<noteq> y \<and> f x = f y)"
proof(induction m rule: nat.induct)
  case zero
  then have B_card: "card B = 1" using zero.prems by auto
  then have A_card: "card A \<ge> 2" using zero.prems by auto

  obtain b where "B = {b}" using B_card card_1_singletonE by auto
  then have "\<forall>x \<in> A. f x = b" using zero.prems by auto
  moreover obtain x y where "x \<in> A \<and> y \<in> A \<and> x \<noteq> y" using A_card zero.prems distinct2[of "A"] by auto
  moreover have "f x = b" using calculation by auto
  moreover have "f y = b" using calculation by auto
  ultimately have "x \<noteq> y \<and> f x = f y" by auto
  hence "\<exists>y. x \<noteq> y \<and> f x = f y" by (rule exI)
  thus ?case by (rule exI)
next
  case (Suc m)
  have "card A > 0" using Suc.prems by auto
  from this obtain a where a: "a \<in> A" using card_eq_SucD[of "A" "card A - 1"] by auto
  then have fa_in_B: "f a \<in> B" using Suc.prems by auto
  show ?case
  proof(cases "\<exists>y. a \<noteq> y \<and> f a = f y")
    case True
    thus ?thesis by (rule exI)
  next
    case False
    then have fa_unique: "\<forall>y. a \<noteq> y \<longrightarrow> f a \<noteq> f y" by auto

    define A' where "A' = A - {a}"
    define B' where "B' = B - {f a}"
    have A'_card: "card A' = card A - 1" using a A'_def card_Diff_singleton[of "a" "A'"] by auto
    have B'_card: "card B' = card B - 1" using fa_in_B B'_def card_Diff_singleton[of "f a" "B'"] by auto

    have "A' \<subseteq> A" using A'_def by auto
    moreover from this have "\<forall>x \<in> A'. f x \<in> B" using Suc.prems by auto
    moreover have "\<forall>x \<in> A'. f x \<noteq> f a" using fa_unique A'_def by auto
    moreover from this have "\<forall>x \<in> A'. f x \<notin> {f a}" using A'_def B'_def fa_unique by auto
    ultimately have "\<forall>x \<in> A'. f x \<in> B \<and> f x \<notin> {f a}" by auto

    then have "\<forall>x \<in> A'. f x \<in> B'" using B'_def by auto
    then have "\<forall>x \<in> A'. \<exists>b \<in> B'. f x = b" by auto
    moreover have "finite A'" using Suc.prems A'_def by auto
    moreover have "finite B'" using Suc.prems B'_def by auto
    moreover have "card B' > 0" using Suc.prems B'_card by auto
    moreover from this have "card B' < card A'" using Suc.prems by (auto simp: A'_card B'_card)
    moreover have "card B' - 1 = m" using Suc.prems B'_card by auto
    ultimately show ?thesis using Suc.IH[of "A'" "B'"] by auto
  qed
qed

(*Better formatted and stuff*)
theorem pigeonhole2:
  fixes f :: "'a \<Rightarrow> 'b"
  fixes m :: "nat"
  assumes "\<forall>a \<in> A. \<exists>b \<in> B. f a = b"
  assumes "finite A"
  assumes "finite B"
  assumes "card B < card A"
  assumes "card B > 0"
  shows "\<exists>x y. x \<noteq> y \<and> f x = f y"
  using assms
proof(induction "card B - 1" arbitrary: "A" "B" rule: nat.induct)
  case zero
  then have B_card: "card B = 1" using zero.prems by auto
  then have A_card: "card A \<ge> 2" using zero.prems by auto

  obtain b where "B = {b}" using B_card card_1_singletonE by auto
  then have "\<forall>x \<in> A. f x = b" using zero.prems by auto
  moreover obtain x y where "x \<in> A \<and> y \<in> A \<and> x \<noteq> y" using A_card zero.prems distinct2[of "A"] by auto
  moreover have "f x = b" using calculation by auto
  moreover have "f y = b" using calculation by auto
  ultimately have "x \<noteq> y \<and> f x = f y" by auto
  hence "\<exists>y. x \<noteq> y \<and> f x = f y" by (rule exI)
  thus ?case by (rule exI)
next
  case (Suc m)
  have "card A > 0" using Suc.prems by auto
  from this obtain a where a: "a \<in> A" using card_eq_SucD[of "A" "card A - 1"] by auto
  then have fa_in_B: "f a \<in> B" using Suc.prems by auto
  show ?case
  proof(cases "\<exists>y. a \<noteq> y \<and> f a = f y")
    case True
    thus ?thesis by (rule exI)
  next
    case False
    then have fa_unique: "\<forall>y. a \<noteq> y \<longrightarrow> f a \<noteq> f y" by auto

    let ?A' = "A - {a}"
    let ?B' = "B - {f a}"
    have A'_card: "card ?A' = card A - 1" using a card_Diff_singleton[of "a" "?A'"] by auto
    have B'_card: "card ?B' = card B - 1" using fa_in_B card_Diff_singleton[of "f a" "?B'"] by auto

    have "?A' \<subseteq> A" by auto
    moreover from this have "\<forall>x \<in> ?A'. f x \<in> B" using Suc.prems by auto
    moreover have "\<forall>x \<in> ?A'. f x \<noteq> f a" using fa_unique by auto
    moreover from this have "\<forall>x \<in> ?A'. f x \<notin> {f a}" using fa_unique by auto
    ultimately have "\<forall>x \<in> ?A'. f x \<in> B \<and> f x \<notin> {f a}" by auto

    then have "\<forall>x \<in> ?A'. f x \<in> ?B'" by auto
    then have "\<forall>x \<in> ?A'. \<exists>b \<in> ?B'. f x = b" by auto
    moreover have "finite ?A'" using Suc.prems by auto
    moreover have "finite ?B'" using Suc.prems by auto
    moreover have "card ?B' > 0" using B'_card Suc.hyps(2) by linarith
    moreover from this have "card ?B' < card ?A'"
      by (simp add: A'_card B'_card Suc.prems(4) diff_less_mono)
    moreover have "card ?B' - 1 = m"
      by (metis B'_card Suc.hyps(2) diff_Suc_1)
    ultimately show ?thesis using Suc.hyps(1)[of "?B'" "?A'"] by auto
  qed
qed

theorem pigeonhole_obtain:
  fixes f :: "'a \<Rightarrow> 'b" and
        A :: "'a set" and
        B :: "'b set"
  assumes "finite A" and
          "finite B" and
          "card A > card B" and
          "\<forall>x \<in> A. f x \<in> B"
  obtains x y where "f x = f y" using pigeonhole by auto

theorem pigeonhole_app:
  fixes f :: "nat \<Rightarrow> nat" and
        A :: "nat set" and
        B :: "nat set"
  assumes "finite A" and
          "finite B" and
          "card A > card B" and
          "\<forall>x \<in> A. f x \<in> B"
  shows "\<exists>x y. f x = f y" using assms pigeonhole by auto
end


(*  Title:      HOL/ex/Fundefs.thy
    Author:     Alexander Krauss, TU Muenchen
*)

section {* Examples of function definitions *}

theory Fundefs
imports Main "~~/src/HOL/Library/Monad_Syntax"
begin

subsection {* Very basic *}

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

text {* partial simp and induction rules: *}
thm fib.psimps
thm fib.pinduct

text {* There is also a cases rule to distinguish cases along the definition *}
thm fib.cases

text {* total simp and induction rules: *}
thm fib.simps
thm fib.induct

text {* elimination rules *}
thm fib.elims

subsection {* Currying *}

fun add
where
  "add 0 y = y"
| "add (Suc x) y = Suc (add x y)"

thm add.simps
thm add.induct -- {* Note the curried induction predicate *}

subsection {* Nested recursion *}

function nz
where
  "nz 0 = 0"
| "nz (Suc x) = nz (nz x)"
by pat_completeness auto

lemma nz_is_zero: -- {* A lemma we need to prove termination *}
  assumes trm: "nz_dom x"
  shows "nz x = 0"
using trm
by induct (auto simp: nz.psimps)

termination nz
  by (relation "less_than") (auto simp:nz_is_zero)

thm nz.simps
thm nz.induct

text {* Here comes McCarthy's 91-function *}

function f91 :: "nat => nat"
where
  "f91 n = (if 100 < n then n - 10 else f91 (f91 (n + 11)))"
by pat_completeness auto

(* Prove a lemma before attempting a termination proof *)
lemma f91_estimate:
  assumes trm: "f91_dom n"
  shows "n < f91 n + 11"
using trm by induct (auto simp: f91.psimps)

termination
proof
  let ?R = "measure (%x. 101 - x)"
  show "wf ?R" ..

  fix n::nat assume "~ 100 < n" (* Inner call *)
  thus "(n + 11, n) : ?R" by simp

  assume inner_trm: "f91_dom (n + 11)" (* Outer call *)
  with f91_estimate have "n + 11 < f91 (n + 11) + 11" .
  with `~ 100 < n` show "(f91 (n + 11), n) : ?R" by simp
qed

text{* Now trivial (even though it does not belong here): *}
lemma "f91 n = (if 100 < n then n - 10 else 91)"
by (induct n rule:f91.induct) auto

subsection {* More general patterns *}

subsubsection {* Overlapping patterns *}

text {* Currently, patterns must always be compatible with each other, since
no automatic splitting takes place. But the following definition of
gcd is ok, although patterns overlap: *}

fun gcd2 :: "nat \<Rightarrow> nat \<Rightarrow> nat"
where
  "gcd2 x 0 = x"
| "gcd2 0 y = y"
| "gcd2 (Suc x) (Suc y) = (if x < y then gcd2 (Suc x) (y - x)
                                    else gcd2 (x - y) (Suc y))"

thm gcd2.simps
thm gcd2.induct

subsubsection {* Guards *}

text {* We can reformulate the above example using guarded patterns *}

function gcd3 :: "nat \<Rightarrow> nat \<Rightarrow> nat"
where
  "gcd3 x 0 = x"
| "gcd3 0 y = y"
| "x < y \<Longrightarrow> gcd3 (Suc x) (Suc y) = gcd3 (Suc x) (y - x)"
| "\<not> x < y \<Longrightarrow> gcd3 (Suc x) (Suc y) = gcd3 (x - y) (Suc y)"
  apply (case_tac x, case_tac a, auto)
  apply (case_tac ba, auto)
  done
termination by lexicographic_order

thm gcd3.simps
thm gcd3.induct

text {* General patterns allow even strange definitions: *}

function ev :: "nat \<Rightarrow> bool"
where
  "ev (2 * n) = True"
| "ev (2 * n + 1) = False"
proof -  -- {* completeness is more difficult here \dots *}
  fix P :: bool
    and x :: nat
  assume c1: "\<And>n. x = 2 * n \<Longrightarrow> P"
    and c2: "\<And>n. x = 2 * n + 1 \<Longrightarrow> P"
  have divmod: "x = 2 * (x div 2) + (x mod 2)" by auto
  show "P"
  proof cases
    assume "x mod 2 = 0"
    with divmod have "x = 2 * (x div 2)" by simp
    with c1 show "P" .
  next
    assume "x mod 2 \<noteq> 0"
    hence "x mod 2 = 1" by simp
    with divmod have "x = 2 * (x div 2) + 1" by simp
    with c2 show "P" .
  qed
qed presburger+ -- {* solve compatibility with presburger *}
termination by lexicographic_order

thm ev.simps
thm ev.induct
thm ev.cases

subsection {* Mutual Recursion *}

fun evn od :: "nat \<Rightarrow> bool"
where
  "evn 0 = True"
| "od 0 = False"
| "evn (Suc n) = od n"
| "od (Suc n) = evn n"

thm evn.simps
thm od.simps

thm evn_od.induct
thm evn_od.termination

thm evn.elims
thm od.elims

subsection {* Definitions in local contexts *}

locale my_monoid =
fixes opr :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"
  and un :: "'a"
assumes assoc: "opr (opr x y) z = opr x (opr y z)"
  and lunit: "opr un x = x"
  and runit: "opr x un = x"
begin

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

fun foldL :: "'a list \<Rightarrow> 'a"
where
  "foldL [] = un"
| "foldL [x] = x"
| "foldL (x#y#ys) = foldL (opr x y # ys)"

thm foldL.simps

lemma foldR_foldL: "foldR xs = foldL xs"
by (induct xs rule: foldL.induct) (auto simp:lunit runit assoc)

thm foldR_foldL

end

thm my_monoid.foldL.simps
thm my_monoid.foldR_foldL

subsection {* @{text fun_cases} *}

subsubsection {* Predecessor *}

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

thm pred.elims

lemma assumes "pred x = y"
obtains "x = 0" "y = 0" | "n" where "x = Suc n" "y = n"
by (fact pred.elims[OF assms])

text {* If the predecessor of a number is 0, that number must be 0 or 1. *}

fun_cases pred0E[elim]: "pred n = 0"

lemma "pred n = 0 \<Longrightarrow> n = 0 \<or> n = Suc 0"
by (erule pred0E) metis+

text {* Other expressions on the right-hand side also work, but whether the
        generated rule is useful depends on how well the simplifier can
        simplify it. This example works well: *}

fun_cases pred42E[elim]: "pred n = 42"

lemma "pred n = 42 \<Longrightarrow> n = 43"
by (erule pred42E)

subsubsection {* List to option *}

fun list_to_option :: "'a list \<Rightarrow> 'a option" where
"list_to_option [x] = Some x" |
"list_to_option _ = None"

fun_cases list_to_option_NoneE: "list_to_option xs = None"
      and list_to_option_SomeE: "list_to_option xs = Some x"

lemma "list_to_option xs = Some y \<Longrightarrow> xs = [y]"
by (erule list_to_option_SomeE)

subsubsection {* Boolean Functions *}

fun xor :: "bool \<Rightarrow> bool \<Rightarrow> bool" where
"xor False False = False" |
"xor True True = False" |
"xor _ _ = True"

thm xor.elims

text {* @{text fun_cases} does not only recognise function equations, but also works with
   functions that return a boolean, e.g.: *}

fun_cases xor_TrueE: "xor a b" and xor_FalseE: "\<not>xor a b"
print_theorems

subsubsection {* Many parameters *}

fun sum4 :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat" where
"sum4 a b c d = a + b + c + d"

fun_cases sum40E: "sum4 a b c d = 0"

lemma "sum4 a b c d = 0 \<Longrightarrow> a = 0"
by (erule sum40E)

subsection {* Partial Function Definitions *}

text {* Partial functions in the option monad: *}

partial_function (option)
  collatz :: "nat \<Rightarrow> nat list option"
where
  "collatz n =
  (if n \<le> 1 then Some [n]
   else if even n
     then do { ns \<leftarrow> collatz (n div 2); Some (n # ns) }
     else do { ns \<leftarrow> collatz (3 * n + 1);  Some (n # ns)})"

declare collatz.simps[code]
value "collatz 23"

text {* Tail-recursive functions: *}

partial_function (tailrec) fixpoint :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'a"
where
  "fixpoint f x = (if f x = x then x else fixpoint f (f x))"

subsection {* Regression tests *}

text {* The following examples mainly serve as tests for the
  function package *}

fun listlen :: "'a list \<Rightarrow> nat"
where
  "listlen [] = 0"
| "listlen (x#xs) = Suc (listlen xs)"

(* Context recursion *)

fun f :: "nat \<Rightarrow> nat"
where
  zero: "f 0 = 0"
| succ: "f (Suc n) = (if f n = 0 then 0 else f n)"

(* A combination of context and nested recursion *)
function h :: "nat \<Rightarrow> nat"
where
  "h 0 = 0"
| "h (Suc n) = (if h n = 0 then h (h n) else h n)"
  by pat_completeness auto

(* Context, but no recursive call: *)
fun i :: "nat \<Rightarrow> nat"
where
  "i 0 = 0"
| "i (Suc n) = (if n = 0 then 0 else i n)"

(* Tupled nested recursion *)
fun fa :: "nat \<Rightarrow> nat \<Rightarrow> nat"
where
  "fa 0 y = 0"
| "fa (Suc n) y = (if fa n y = 0 then 0 else fa n y)"

(* Let *)
fun j :: "nat \<Rightarrow> nat"
where
  "j 0 = 0"
| "j (Suc n) = (let u = n  in Suc (j u))"

(* There were some problems with fresh names\<dots> *)
function  k :: "nat \<Rightarrow> nat"
where
  "k x = (let a = x; b = x in k x)"
  by pat_completeness auto

function f2 :: "(nat \<times> nat) \<Rightarrow> (nat \<times> nat)"
where
  "f2 p = (let (x,y) = p in f2 (y,x))"
  by pat_completeness auto

(* abbreviations *)
fun f3 :: "'a set \<Rightarrow> bool"
where
  "f3 x = finite x"

(* Simple Higher-Order Recursion *)
datatype 'a tree =
  Leaf 'a
  | Branch "'a tree list"

fun treemap :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a tree \<Rightarrow> 'a tree"
where
  "treemap fn (Leaf n) = (Leaf (fn n))"
| "treemap fn (Branch l) = (Branch (map (treemap fn) l))"

fun tinc :: "nat tree \<Rightarrow> nat tree"
where
  "tinc (Leaf n) = Leaf (Suc n)"
| "tinc (Branch l) = Branch (map tinc l)"

fun testcase :: "'a tree \<Rightarrow> 'a list"
where
  "testcase (Leaf a) = [a]"
| "testcase (Branch x) =
    (let xs = concat (map testcase x);
         ys = concat (map testcase x) in
     xs @ ys)"

(* Pattern matching on records *)
record point =
  Xcoord :: int
  Ycoord :: int

function swp :: "point \<Rightarrow> point"
where
  "swp \<lparr> Xcoord = x, Ycoord = y \<rparr> = \<lparr> Xcoord = y, Ycoord = x \<rparr>"
proof -
  fix P x
  assume "\<And>xa y. x = \<lparr>Xcoord = xa, Ycoord = y\<rparr> \<Longrightarrow> P"
  thus "P"
    by (cases x)
qed auto
termination by rule auto

(* The diagonal function *)
fun diag :: "bool \<Rightarrow> bool \<Rightarrow> bool \<Rightarrow> nat"
where
  "diag x True False = 1"
| "diag False y True = 2"
| "diag True False z = 3"
| "diag True True True = 4"
| "diag False False False = 5"

(* Many equations (quadratic blowup) *)
datatype DT =
  A | B | C | D | E | F | G | H | I | J | K | L | M | N | P
| Q | R | S | T | U | V

fun big :: "DT \<Rightarrow> nat"
where
  "big A = 0"
| "big B = 0"
| "big C = 0"
| "big D = 0"
| "big E = 0"
| "big F = 0"
| "big G = 0"
| "big H = 0"
| "big I = 0"
| "big J = 0"
| "big K = 0"
| "big L = 0"
| "big M = 0"
| "big N = 0"
| "big P = 0"
| "big Q = 0"
| "big R = 0"
| "big S = 0"
| "big T = 0"
| "big U = 0"
| "big V = 0"

(* automatic pattern splitting *)
fun
  f4 :: "nat \<Rightarrow> nat \<Rightarrow> bool"
where
  "f4 0 0 = True"
| "f4 _ _ = False"

(* polymorphic partial_function *)
partial_function (option) f5 :: "'a list \<Rightarrow> 'a option"
where
  "f5 x = f5 x"

end


(* Author: Tobias Nipkow *)

section \<open>Creating Balanced Trees\<close>

theory Balance
imports
  "HOL-Library.Tree_Real"
begin

fun bal :: "nat \<Rightarrow> 'a list \<Rightarrow> 'a tree * 'a list" where
"bal n xs = (if n=0 then (Leaf,xs) else
 (let m = n div 2;
      (l, ys) = bal m xs;
      (r, zs) = bal (n-1-m) (tl ys)
  in (Node l (hd ys) r, zs)))"

declare bal.simps[simp del]
declare Let_def[simp]

definition bal_list :: "nat \<Rightarrow> 'a list \<Rightarrow> 'a tree" where
"bal_list n xs = fst (bal n xs)"

definition balance_list :: "'a list \<Rightarrow> 'a tree" where
"balance_list xs = bal_list (length xs) xs"

definition bal_tree :: "nat \<Rightarrow> 'a tree \<Rightarrow> 'a tree" where
"bal_tree n t = bal_list n (inorder t)"

definition balance_tree :: "'a tree \<Rightarrow> 'a tree" where
"balance_tree t = bal_tree (size t) t"

lemma bal_simps:
  "bal 0 xs = (Leaf, xs)"
  "n > 0 \<Longrightarrow>
   bal n xs =
  (let m = n div 2;
      (l, ys) = bal m xs;
      (r, zs) = bal (n-1-m) (tl ys)
  in (Node l (hd ys) r, zs))"
by(simp_all add: bal.simps)

lemma bal_inorder:
  "\<lbrakk> n \<le> length xs; bal n xs = (t,zs) \<rbrakk>
  \<Longrightarrow> xs = inorder t @ zs \<and> size t = n"
proof(induction n arbitrary: xs t zs rule: less_induct)
  case (less n) show ?case
  proof cases
    assume "n = 0" thus ?thesis using less.prems by (simp add: bal_simps)
  next
    assume [arith]: "n \<noteq> 0"
    let ?m = "n div 2" let ?m' = "n - 1 - ?m"
    from less.prems(2) obtain l r ys where
      b1: "bal ?m xs = (l,ys)" and
      b2: "bal ?m' (tl ys) = (r,zs)" and
      t: "t = \<langle>l, hd ys, r\<rangle>"
      by(auto simp: bal_simps split: prod.splits)
    have IH1: "xs = inorder l @ ys \<and> size l = ?m"
      using b1 less.prems(1) by(intro less.IH) auto
    have IH2: "tl ys = inorder r @ zs \<and> size r = ?m'"
      using  b2 IH1 less.prems(1) by(intro less.IH) auto
    show ?thesis using t IH1 IH2 less.prems(1) hd_Cons_tl[of ys] by fastforce
  qed
qed

corollary inorder_bal_list[simp]:
  "n \<le> length xs \<Longrightarrow> inorder(bal_list n xs) = take n xs"
unfolding bal_list_def
by (metis (mono_tags) prod.collapse[of "bal n xs"] append_eq_conv_conj bal_inorder length_inorder)

corollary inorder_balance_list[simp]: "inorder(balance_list xs) = xs"
by(simp add: balance_list_def)

corollary inorder_bal_tree:
  "n \<le> size t \<Longrightarrow> inorder(bal_tree n t) = take n (inorder t)"
by(simp add: bal_tree_def)

corollary inorder_balance_tree[simp]: "inorder(balance_tree t) = inorder t"
by(simp add: balance_tree_def inorder_bal_tree)

text\<open>The length/size lemmas below do not require the precondition @{prop"n \<le> length xs"}
(or  @{prop"n \<le> size t"}) that they come with. They could take advantage of the fact
that @{term "bal xs n"} yields a result even if @{prop "n > length xs"}.
In that case the result will contain one or more occurrences of @{term "hd []"}.
However, this is counter-intuitive and does not reflect the execution
in an eager functional language.\<close>

lemma bal_length: "\<lbrakk> n \<le> length xs; bal n xs = (t,zs) \<rbrakk> \<Longrightarrow> length zs = length xs - n"
using bal_inorder by fastforce

corollary size_bal_list[simp]: "n \<le> length xs \<Longrightarrow> size(bal_list n xs) = n"
unfolding bal_list_def using bal_inorder prod.exhaust_sel by blast

corollary size_balance_list[simp]: "size(balance_list xs) = length xs"
by (simp add: balance_list_def)

corollary size_bal_tree[simp]: "n \<le> size t \<Longrightarrow> size(bal_tree n t) = n"
by(simp add: bal_tree_def)

corollary size_balance_tree[simp]: "size(balance_tree t) = size t"
by(simp add: balance_tree_def)

lemma min_height_bal:
  "\<lbrakk> n \<le> length xs; bal n xs = (t,zs) \<rbrakk> \<Longrightarrow> min_height t = nat(\<lfloor>log 2 (n + 1)\<rfloor>)"
proof(induction n arbitrary: xs t zs rule: less_induct)
  case (less n)
  show ?case
  proof cases
    assume "n = 0" thus ?thesis using less.prems(2) by (simp add: bal_simps)
  next
    assume [arith]: "n \<noteq> 0"
    let ?m = "n div 2" let ?m' = "n - 1 - ?m"
    from less.prems obtain l r ys where
      b1: "bal ?m xs = (l,ys)" and
      b2: "bal ?m' (tl ys) = (r,zs)" and
      t: "t = \<langle>l, hd ys, r\<rangle>"
      by(auto simp: bal_simps split: prod.splits)
    let ?hl = "nat (floor(log 2 (?m + 1)))"
    let ?hr = "nat (floor(log 2 (?m' + 1)))"
    have IH1: "min_height l = ?hl" using less.IH[OF _ _ b1] less.prems(1) by simp
    have IH2: "min_height r = ?hr"
      using less.prems(1) bal_length[OF _ b1] b2 by(intro less.IH) auto
    have "(n+1) div 2 \<ge> 1" by arith
    hence 0: "log 2 ((n+1) div 2) \<ge> 0" by simp
    have "?m' \<le> ?m" by arith
    hence le: "?hr \<le> ?hl" by(simp add: nat_mono floor_mono)
    have "min_height t = min ?hl ?hr + 1" by (simp add: t IH1 IH2)
    also have "\<dots> = ?hr + 1" using le by (simp add: min_absorb2)
    also have "?m' + 1 = (n+1) div 2" by linarith
    also have "nat (floor(log 2 ((n+1) div 2))) + 1
       = nat (floor(log 2 ((n+1) div 2) + 1))"
      using 0 by linarith
    also have "\<dots> = nat (floor(log 2 (n + 1)))"
      using floor_log2_div2[of "n+1"] by (simp add: log_mult)
    finally show ?thesis .
  qed
qed

lemma height_bal:
  "\<lbrakk> n \<le> length xs; bal n xs = (t,zs) \<rbrakk> \<Longrightarrow> height t = nat \<lceil>log 2 (n + 1)\<rceil>"
proof(induction n arbitrary: xs t zs rule: less_induct)
  case (less n) show ?case
  proof cases
    assume "n = 0" thus ?thesis
      using less.prems by (simp add: bal_simps)
  next
    assume [arith]: "n \<noteq> 0"
    let ?m = "n div 2" let ?m' = "n - 1 - ?m"
    from less.prems obtain l r ys where
      b1: "bal ?m xs = (l,ys)" and
      b2: "bal ?m' (tl ys) = (r,zs)" and
      t: "t = \<langle>l, hd ys, r\<rangle>"
      by(auto simp: bal_simps split: prod.splits)
    let ?hl = "nat \<lceil>log 2 (?m + 1)\<rceil>"
    let ?hr = "nat \<lceil>log 2 (?m' + 1)\<rceil>"
    have IH1: "height l = ?hl" using less.IH[OF _ _ b1] less.prems(1) by simp
    have IH2: "height r = ?hr"
      using b2 bal_length[OF _ b1] less.prems(1) by(intro less.IH) auto
    have 0: "log 2 (?m + 1) \<ge> 0" by simp
    have "?m' \<le> ?m" by arith
    hence le: "?hr \<le> ?hl"
      by(simp add: nat_mono ceiling_mono del: nat_ceiling_le_eq)
    have "height t = max ?hl ?hr + 1" by (simp add: t IH1 IH2)
    also have "\<dots> = ?hl + 1" using le by (simp add: max_absorb1)
    also have "\<dots> = nat \<lceil>log 2 (?m + 1) + 1\<rceil>" using 0 by linarith
    also have "\<dots> = nat \<lceil>log 2 (n + 1)\<rceil>"
      using ceiling_log2_div2[of "n+1"] by (simp)
    finally show ?thesis .
  qed
qed

lemma balanced_bal:
  assumes "n \<le> length xs" "bal n xs = (t,ys)" shows "balanced t"
unfolding balanced_def
using height_bal[OF assms] min_height_bal[OF assms]
by linarith

lemma height_bal_list:
  "n \<le> length xs \<Longrightarrow> height (bal_list n xs) = nat \<lceil>log 2 (n + 1)\<rceil>"
unfolding bal_list_def by (metis height_bal prod.collapse)

lemma height_balance_list:
  "height (balance_list xs) = nat \<lceil>log 2 (length xs + 1)\<rceil>"
by (simp add: balance_list_def height_bal_list)

corollary height_bal_tree:
  "n \<le> size t \<Longrightarrow> height (bal_tree n t) = nat\<lceil>log 2 (n + 1)\<rceil>"
unfolding bal_list_def bal_tree_def
by (metis bal_list_def height_bal_list length_inorder)

corollary height_balance_tree:
  "height (balance_tree t) = nat\<lceil>log 2 (size t + 1)\<rceil>"
by (simp add: bal_tree_def balance_tree_def height_bal_list)

corollary balanced_bal_list[simp]: "n \<le> length xs \<Longrightarrow> balanced (bal_list n xs)"
unfolding bal_list_def by (metis  balanced_bal prod.collapse)

corollary balanced_balance_list[simp]: "balanced (balance_list xs)"
by (simp add: balance_list_def)

corollary balanced_bal_tree[simp]: "n \<le> size t \<Longrightarrow> balanced (bal_tree n t)"
by (simp add: bal_tree_def)

corollary balanced_balance_tree[simp]: "balanced (balance_tree t)"
by (simp add: balance_tree_def)

lemma wbalanced_bal: "\<lbrakk> n \<le> length xs; bal n xs = (t,ys) \<rbrakk> \<Longrightarrow> wbalanced t"
proof(induction n arbitrary: xs t ys rule: less_induct)
  case (less n)
  show ?case
  proof cases
    assume "n = 0"
    thus ?thesis using less.prems(2) by(simp add: bal_simps)
  next
    assume [arith]: "n \<noteq> 0"
    with less.prems obtain l ys r zs where
      rec1: "bal (n div 2) xs = (l, ys)" and
      rec2: "bal (n - 1 - n div 2) (tl ys) = (r, zs)" and
      t: "t = \<langle>l, hd ys, r\<rangle>"
      by(auto simp add: bal_simps split: prod.splits)
    have l: "wbalanced l" using less.IH[OF _ _ rec1] less.prems(1) by linarith
    have "wbalanced r"
      using rec1 rec2 bal_length[OF _ rec1] less.prems(1) by(intro less.IH) auto
    with l t bal_length[OF _ rec1] less.prems(1) bal_inorder[OF _ rec1] bal_inorder[OF _ rec2]
    show ?thesis by auto
  qed
qed

text\<open>An alternative proof via @{thm balanced_if_wbalanced}:\<close>
lemma "\<lbrakk> n \<le> length xs; bal n xs = (t,ys) \<rbrakk> \<Longrightarrow> balanced t"
by(rule balanced_if_wbalanced[OF wbalanced_bal])

lemma wbalanced_bal_list[simp]: "n \<le> length xs \<Longrightarrow> wbalanced (bal_list n xs)"
by(simp add: bal_list_def) (metis prod.collapse wbalanced_bal)

lemma wbalanced_balance_list[simp]: "wbalanced (balance_list xs)"
by(simp add: balance_list_def)

lemma wbalanced_bal_tree[simp]: "n \<le> size t \<Longrightarrow> wbalanced (bal_tree n t)"
by(simp add: bal_tree_def)

lemma wbalanced_balance_tree: "wbalanced (balance_tree t)"
by (simp add: balance_tree_def)

hide_const (open) bal

end


(*
Concrete Semantics with Isabelle/HOL
3. Case Study: IMP Expressions

Proof is based on "Proof of validity of compilation result of IMP".
https://qiita.com/masateruk/items/06a6e4ffbb18307403c2
*)

theory "imp_register_compiler" imports Main begin

(*********************************************)
subsection "Arithmetic Expressions"
(*********************************************)

type_synonym vname = string
type_synonym val = int
type_synonym state = "vname \<Rightarrow> val"

datatype aexp = N int | V vname | Plus aexp aexp

fun aval :: "aexp \<Rightarrow> state \<Rightarrow> val" where
  "aval (N n) s = n" |
  "aval (V x) s = s x" |
  "aval (Plus a\<^sub>1 a\<^sub>2) s = aval a\<^sub>1 s + aval a\<^sub>2 s"

value "aval (Plus (V ''x'') (N 5)) (\<lambda>x. if x = ''x'' then 7 else 0)" (* 12 *)
value "aval (Plus (V ''x'') (N 5)) ((\<lambda>x. 0) (''x'':= 7))" (* 12 *)

definition null_state ("<>") where
  "null_state \<equiv> \<lambda>x. 0"
syntax
  "_State" :: "updbinds => 'a" ("<_>")
translations
  "_State ms" == "_Update <> ms"
  "_State (_updbinds b bs)" <= "_Update (_State b) bs"

lemma "<a := 1, b := 2> = (<> (a := 1)) (b := (2::int))"
  by (rule refl)

value "aval (Plus (V ''x'') (N 5)) <''x'' := 7>" (* 12 *)
value "aval (Plus (V ''x'') (N 5)) <''y'' := 7>" (* 5 *)

(*********************************************)
subsection "Constant Folding"
(*********************************************)

fun asimp_const :: "aexp \<Rightarrow> aexp" where
  "asimp_const (N n) = N n" |
  "asimp_const (V x) = V x" |
  "asimp_const (Plus a\<^sub>1 a\<^sub>2) =
  (case (asimp_const a\<^sub>1, asimp_const a\<^sub>2) of
    (N n\<^sub>1, N n\<^sub>2) \<Rightarrow> N(n\<^sub>1+n\<^sub>2) |
    (b\<^sub>1,b\<^sub>2) \<Rightarrow> Plus b\<^sub>1 b\<^sub>2)"

lemma aval_asimp_const : "aval (asimp_const a) s = aval a s"
  apply (induction a)
    apply (auto split: aexp.split)
done

fun plus :: "aexp \<Rightarrow> aexp \<Rightarrow> aexp" where
  "plus (N i\<^sub>1) (N i\<^sub>2) = N(i\<^sub>1+i\<^sub>2)" |
  "plus (N i) a = (if i=0 then a else Plus (N i) a)" |
  "plus a (N i) = (if i=0 then a else Plus a (N i))" |
  "plus a\<^sub>1 a\<^sub>2 = Plus a\<^sub>1 a\<^sub>2"

lemma aval_plus [simp] : "aval (plus a1 a2) s = aval a1 s + aval a2 s"
  apply (induction a1 a2 rule: plus.induct)
              apply simp_all (* just for a change from auto *)
  done

fun asimp :: "aexp \<Rightarrow> aexp" where
  "asimp (N n) = N n" |
  "asimp (V x) = V x" |
  "asimp (Plus a\<^sub>1 a\<^sub>2) = plus (asimp a\<^sub>1) (asimp a\<^sub>2)"

value "asimp (Plus (Plus (N 0) (N 0)) (Plus (V ''x'') (N 0)))" (* "V ''x''" *)

lemma aval_asimp [simp] : "aval (asimp a) s = aval a s"
  apply (induction a)
    apply simp_all
  done

(*********************************************)
subsection "Register Machine"
(*********************************************)

type_synonym reg = nat
type_synonym rstate = "reg \<Rightarrow> val"

datatype instr = LDI val reg | LD vname reg | ADD reg reg

fun exec1 :: "instr \<Rightarrow> state \<Rightarrow> rstate \<Rightarrow> reg \<Rightarrow> val" where
  "exec1 (LDI n R) s rs r = (if R = r then n else rs(r))" |
  "exec1 (LD  x R) s rs r = (if R = r then s(x) else rs(r))" |
  "exec1 (ADD R S) s rs r = (if R = r then rs(R) + rs(S) else rs(r))"

fun exec :: "instr list \<Rightarrow> state \<Rightarrow> rstate \<Rightarrow> reg \<Rightarrow> val" where
  "exec [] s rs r = rs(r)" |
  "exec (i # is) s rs r = exec is s (exec1 i s rs) r"

value "exec [LDI 5 0, LD ''y'' 1, ADD 0 1] <''x'' := 42, ''y'' := 43>
<0 := 0, 1 := 0, 2 := 50> 0" (* 48 *)

(*********************************************)
subsection "Compilation"
(*********************************************)

fun comp :: "aexp \<Rightarrow> reg \<Rightarrow> instr list" where
  "comp (N n) r = [LDI n r]" |
  "comp (V v) r = [LD v r]" |
  "comp (Plus a1 a2) r = (comp a1 r) @ (comp a2 (r + 1)) @ [ADD r (r + 1)]"

value "comp (Plus (Plus (V ''x'') (N 1)) (V ''z'')) 0"
 (* "[LD ''x'' 0, LDI 1 1, ADD 0 1, LD ''z'' 1, ADD 0 1]" *)

fun execn :: "instr list \<Rightarrow> state \<Rightarrow> rstate \<Rightarrow> rstate" where
  "execn [] s rs = rs" |
  "execn (i # is) s rs = execn is s (exec1 i s rs)"

lemma exec_execn : "exec is1 s rs r = (execn is1 s rs) r"
  apply (induction is1 arbitrary: rs)
   apply auto
  done

lemma execn_dist_append : "(execn (is1 @ is2) s rs) = (execn is2 s (execn is1 s rs))"
  apply (induction is1 arbitrary: rs)
   apply auto
  done

lemma execn_comp_append : "(execn ((comp a r) @ is2) s rs) = (execn is2 s (execn (comp a r) s rs))"
  apply (auto simp add: execn_dist_append)
  done

lemma comp_left_rs_not_changed : "r1 > r \<Longrightarrow> execn (comp a r1) s rs r = rs(r)"
  apply (induction a arbitrary: r r1 rs)
    apply (auto simp add: execn_dist_append)
  done

theorem "exec (comp a r) s rs r = aval a s"
  apply (induction a arbitrary: r rs)
    apply (auto simp add: exec_execn execn_comp_append comp_left_rs_not_changed)
  done

end