(*  Title:      HOL/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 MainRLT begin

subsection\<open>Traditional Classical Reasoner\<close>

text\<open>The machine "griffon" mentioned below is a 2.5GHz Power Mac G5.\<close>

text\<open>Taken from \<open>FOL/Classical.thy\<close>. When porting examples from
first-order logic, beware of the precedence of \<open>=\<close> versus \<open>\<leftrightarrow>\<close>.\<close>

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

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

lemma "(P=Q) = (Q = (P::bool))"
by blast

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

text\<open>Sample problems from
  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>

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

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

text\<open>2\<close>
lemma "(\<not> \<not> P) =  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)  =  (\<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=Q)"
by blast

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

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

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

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

text\<open>15\<close>
lemma "(P \<longrightarrow> Q) = (\<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)  =  ((\<not>P \<or> Q \<or> S) \<and> (\<not>P \<or> \<not>R \<or> S))"
by blast

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

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

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

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

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

text\<open>From Wishnu Prasetya\<close>
lemma "(\<forall>x. Q(x) \<longrightarrow> R(x)) \<and> \<not>R(a) \<and> (\<forall>x. \<not>R(x) \<and> \<not>Q(x) \<longrightarrow> P(b) \<or> Q(b))
    \<longrightarrow> P(b) \<or> R(b)"
by blast

subsubsection\<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) = P(y)) \<longrightarrow> ((\<exists>x. P(x)) = (\<forall>y. P(y)))"
by blast

text\<open>Needs multiple instantiation of the quantifier.\<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

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

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

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

text\<open>Problem 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>Problem 21\<close>
lemma "(\<exists>x. P\<longrightarrow>Q(x)) \<and> (\<exists>x. Q(x)\<longrightarrow>P) \<longrightarrow> (\<exists>x. P=Q(x))"
by blast

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

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

text\<open>Problem 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>Problem 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>Problem 26\<close>
lemma "((\<exists>x. p(x)) = (\<exists>x. q(x))) \<and>
      (\<forall>x. \<forall>y. p(x) \<and> q(y) \<longrightarrow> (r(x) = s(y)))
  \<longrightarrow> ((\<forall>x. p(x)\<longrightarrow>r(x)) = (\<forall>x. q(x)\<longrightarrow>s(x)))"
by blast

text\<open>Problem 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>Problem 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>Problem 29.  Essentially the same as Principia Mathematica *11.71\<close>
lemma "(\<exists>x. F(x)) \<and> (\<exists>y. G(y))
    \<longrightarrow> ( ((\<forall>x. F(x)\<longrightarrow>H(x)) \<and> (\<forall>y. G(y)\<longrightarrow>J(y)))  =
          (\<forall>x y. F(x) \<and> G(y) \<longrightarrow> H(x) \<and> J(y)))"
by blast

text\<open>Problem 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>Problem 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>Problem 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>Problem 33\<close>
lemma "(\<forall>x. P(a) \<and> (P(x)\<longrightarrow>P(b))\<longrightarrow>P(c))  =
     (\<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>Problem 34  AMENDED (TWICE!!)\<close>
text\<open>Andrews's challenge\<close>
lemma "((\<exists>x. \<forall>y. p(x) = p(y))  =
               ((\<exists>x. q(x)) = (\<forall>y. p(y))))   =
              ((\<exists>x. \<forall>y. q(x) = q(y))  =
               ((\<exists>x. p(x)) = (\<forall>y. q(y))))"
by blast

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

text\<open>Problem 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>Problem 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>Problem 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))  =
     (\<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 (*beats fast!*)

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

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

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

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

text\<open>Problem 43!!\<close>
lemma "(\<forall>x::'a. \<forall>y::'a. q x y = (\<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>Problem 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>Problem 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

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

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

text\<open>Problem 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> (\<not>a=b)
                \<longrightarrow> (\<forall>u::'a. P(u))"
by metis

text\<open>Problem 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>Problem 51\<close>
lemma "(\<exists>z w. \<forall>x y. P x y = (x=z \<and> y=w)) \<longrightarrow>
     (\<exists>z. \<forall>x. \<exists>w. (\<forall>y. P x y = (y=w)) = (x=z))"
by blast

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

text\<open>Problem 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

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

text\<open>Problem 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>Problem 58  NOT PROVED AUTOMATICALLY\<close>
lemma "(\<forall>x y. f(x)=g(y)) \<longrightarrow> (\<forall>x y. f(f(x))=f(g(y)))"
by (fast intro: arg_cong [of concl: f])

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

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

text\<open>Problem 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)))  =
      (\<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>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

lemma "(\<forall>x y. R(x,y) \<or> R(y,x)) \<and>
       (\<forall>x y. S(x,y) \<and> S(y,x) \<longrightarrow> x=y) \<and>
       (\<forall>x y. R(x,y) \<longrightarrow> S(x,y))    \<longrightarrow>   (\<forall>x y. S(x,y) \<longrightarrow> R(x,y))"
by blast

subsection\<open>Model Elimination Prover\<close>

text\<open>Trying out meson with arguments\<close>
lemma "x < y \<and> y < z \<longrightarrow> \<not> (z < (x::nat))"
by (meson order_less_irrefl order_less_trans)

text\<open>The "small example" from Bezem, Hendriks and de Nivelle,
Automatic Proof Construction in Type Theory Using Resolution,
JAR 29: 3-4 (2002), pages 253-275\<close>
lemma "(\<forall>x y z. R(x,y) \<and> R(y,z) \<longrightarrow> R(x,z)) \<and>
       (\<forall>x. \<exists>y. R(x,y)) \<longrightarrow>
       \<not> (\<forall>x. P x = (\<forall>y. R(x,y) \<longrightarrow> \<not> P y))"
by (tactic\<open>Meson.safe_best_meson_tac \<^context> 1\<close>)
    \<comment> \<open>In contrast, \<open>meson\<close> is SLOW: 7.6s on griffon\<close>

subsubsection\<open>Pelletier's examples\<close>
text\<open>1\<close>
lemma "(P \<longrightarrow> Q)  =  (\<not>Q \<longrightarrow> \<not>P)"
by blast

text\<open>2\<close>
lemma "(\<not> \<not> P) =  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)  =  (\<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=Q)"
by blast

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

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

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

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

text\<open>15\<close>
lemma "(P \<longrightarrow> Q) = (\<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)  =  ((\<not>P \<or> Q \<or> S) \<and> (\<not>P \<or> \<not>R \<or> S))"
by blast

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

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

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

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

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

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 EXISTS\<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

text\<open>From a paper by Claire Quigley\<close>
lemma "\<exists>y. ((P c \<and> Q y) \<or> (\<exists>z. \<not> Q z)) \<or> (\<exists>x. \<not> P x \<and> Q d)"
by fast

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

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

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

text\<open>Problem 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>Problem 21\<close>
lemma "(\<exists>x. P \<longrightarrow> Q x) \<and> (\<exists>x. Q x \<longrightarrow> P) \<longrightarrow> (\<exists>x. P=Q x)"
by blast

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

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

text\<open>Problem 24\<close>  (*The first goal clause is useless*)
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>Problem 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>Problem 26; has 24 Horn clauses\<close>
lemma "((\<exists>x. p x) = (\<exists>x. q x)) \<and>
      (\<forall>x. \<forall>y. p x \<and> q y \<longrightarrow> (r x = s y))
  \<longrightarrow> ((\<forall>x. p x \<longrightarrow> r x) = (\<forall>x. q x \<longrightarrow> s x))"
by blast

text\<open>Problem 27; has 13 Horn clauses\<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>Problem 28.  AMENDED; has 14 Horn clauses\<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>Problem 29.  Essentially the same as Principia Mathematica *11.71.
      62 Horn clauses\<close>
lemma "(\<exists>x. F x) \<and> (\<exists>y. G y)
    \<longrightarrow> ( ((\<forall>x. F x \<longrightarrow> H x) \<and> (\<forall>y. G y \<longrightarrow> J y))  =
          (\<forall>x y. F x \<and> G y \<longrightarrow> H x \<and> J y))"
by blast

text\<open>Problem 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>Problem 31; has 10 Horn clauses; first negative clauses is useless\<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>Problem 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>Problem 33; has 55 Horn clauses\<close>
lemma "(\<forall>x. P a \<and> (P x \<longrightarrow> P b)\<longrightarrow>P c)  =
      (\<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>Problem 34: Andrews's challenge has 924 Horn clauses\<close>
lemma "((\<exists>x. \<forall>y. p x = p y)  = ((\<exists>x. q x) = (\<forall>y. p y)))     =
      ((\<exists>x. \<forall>y. q x = q y)  = ((\<exists>x. p x) = (\<forall>y. q y)))"
by blast

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

text\<open>Problem 36; has 15 Horn clauses\<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>Problem 37; has 10 Horn clauses\<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 \<comment> \<open>causes unification tracing messages\<close>

text\<open>Problem 38\<close>  text\<open>Quite hard: 422 Horn clauses!!\<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))  =
      (\<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>Problem 39\<close>
lemma "\<not> (\<exists>x. \<forall>y. F y x = (\<not>F y y))"
by blast

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

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

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

text\<open>Problem 43  NOW PROVED AUTOMATICALLY!!\<close>
lemma "(\<forall>x. \<forall>y. q x y = (\<forall>z. p z x = (p z y::bool)))
      \<longrightarrow> (\<forall>x. (\<forall>y. q x y = (q y x::bool)))"
by blast

text\<open>Problem 44: 13 Horn clauses; 7-step proof\<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>Problem 45; has 27 Horn clauses; 54-step proof\<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>Problem 46; has 26 Horn clauses; 21-step proof\<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

text\<open>Problem 47.  Schubert's Steamroller.
      26 clauses; 63 Horn clauses.
      87094 inferences so far.  Searching to depth 36\<close>
lemma "(\<forall>x. wolf x \<longrightarrow> animal x) \<and> (\<exists>x. wolf x) \<and>
       (\<forall>x. fox x \<longrightarrow> animal x) \<and> (\<exists>x. fox x) \<and>
       (\<forall>x. bird x \<longrightarrow> animal x) \<and> (\<exists>x. bird x) \<and>
       (\<forall>x. caterpillar x \<longrightarrow> animal x) \<and> (\<exists>x. caterpillar x) \<and>
       (\<forall>x. snail x \<longrightarrow> animal x) \<and> (\<exists>x. snail x) \<and>
       (\<forall>x. grain x \<longrightarrow> plant x) \<and> (\<exists>x. grain x) \<and>
       (\<forall>x. animal x \<longrightarrow>
             ((\<forall>y. plant y \<longrightarrow> eats x y)  \<or>
              (\<forall>y. animal y \<and> smaller_than y x \<and>
                    (\<exists>z. plant z \<and> eats y z) \<longrightarrow> eats x y))) \<and>
       (\<forall>x y. bird y \<and> (snail x \<or> caterpillar x) \<longrightarrow> smaller_than x y) \<and>
       (\<forall>x y. bird x \<and> fox y \<longrightarrow> smaller_than x y) \<and>
       (\<forall>x y. fox x \<and> wolf y \<longrightarrow> smaller_than x y) \<and>
       (\<forall>x y. wolf x \<and> (fox y \<or> grain y) \<longrightarrow> \<not>eats x y) \<and>
       (\<forall>x y. bird x \<and> caterpillar y \<longrightarrow> eats x y) \<and>
       (\<forall>x y. bird x \<and> snail y \<longrightarrow> \<not>eats x y) \<and>
       (\<forall>x. (caterpillar x \<or> snail x) \<longrightarrow> (\<exists>y. plant y \<and> eats x y))
       \<longrightarrow> (\<exists>x y. animal x \<and> animal y \<and> (\<exists>z. grain z \<and> eats y z \<and> eats x y))"
by (tactic\<open>Meson.safe_best_meson_tac \<^context> 1\<close>)
    \<comment> \<open>Nearly twice as fast as \<open>meson\<close>,
        which performs iterative deepening rather than best-first search\<close>

text\<open>The Los problem. Circulated by John Harrison\<close>
lemma "(\<forall>x y z. P x y \<and> P y z \<longrightarrow> P x z) \<and>
       (\<forall>x y z. Q x y \<and> Q y z \<longrightarrow> Q x z) \<and>
       (\<forall>x y. P x y \<longrightarrow> P y x) \<and>
       (\<forall>x y. P x y \<or> Q x y)
       \<longrightarrow> (\<forall>x y. P x y) \<or> (\<forall>x y. Q x y)"
by meson

text\<open>A similar example, suggested by Johannes Schumann and
 credited to Pelletier\<close>
lemma "(\<forall>x y z. P x y \<longrightarrow> P y z \<longrightarrow> P x z) \<longrightarrow>
       (\<forall>x y z. Q x y \<longrightarrow> Q y z \<longrightarrow> Q x z) \<longrightarrow>
       (\<forall>x y. Q x y \<longrightarrow> Q y x) \<longrightarrow>  (\<forall>x y. P x y \<or> Q x y) \<longrightarrow>
       (\<forall>x y. P x y) \<or> (\<forall>x y. Q x y)"
by meson

text\<open>Problem 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>Problem 54: NOT PROVED\<close>
lemma "(\<forall>y::'a. \<exists>z. \<forall>x. F x z = (x=y)) \<longrightarrow>
      \<not> (\<exists>w. \<forall>x. F x w = (\<forall>u. F x u \<longrightarrow> (\<exists>y. F y u \<and> \<not> (\<exists>z. F z u \<and> F z y))))"
oops

text\<open>Problem 55\<close>

text\<open>Non-equational version, from Manthey and Bry, CADE-9 (Springer, 1988).
  \<open>meson\<close> cannot report who killed Agatha.\<close>
lemma "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>
       (\<exists>x. killed x agatha)"
by meson

text\<open>Problem 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>Problem 58: Challenge found on info-hol\<close>
lemma "\<forall>P Q R 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>Problem 59\<close>
lemma "(\<forall>x. P x = (\<not>P(f x))) \<longrightarrow> (\<exists>x. P x \<and> \<not>P(f x))"
by blast

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

text\<open>Problem 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)))  =
       (\<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>Charles Morgan's problems\<close>
context
  fixes T i n
  assumes a: "\<forall>x y. T(i x(i y x))"
    and b: "\<forall>x y z. T(i (i x (i y z)) (i (i x y) (i x z)))"
    and c: "\<forall>x y. T(i (i (n x) (n y)) (i y x))"
    and c': "\<forall>x y. T(i (i y x) (i (n x) (n y)))"
    and d: "\<forall>x y. T(i x y) \<and> T x \<longrightarrow> T y"
begin

lemma "\<forall>x. T(i x x)"
  using a b d by blast

lemma "\<forall>x. T(i x (n(n x)))" \<comment> \<open>Problem 66\<close>
  using a b c d by metis

lemma "\<forall>x. T(i (n(n x)) x)" \<comment> \<open>Problem 67\<close>
  using a b c d by meson \<comment> \<open>4.9s on griffon. 51061 inferences, depth 21\<close>

lemma "\<forall>x. T(i x (n(n x)))" \<comment> \<open>Problem 68: not proved.  Listed as satisfiable in TPTP (LCL078-1)\<close>
  using a b c' d oops

end

text\<open>Problem 71, as found in TPTP (SYN007+1.005)\<close>
lemma "p1 = (p2 = (p3 = (p4 = (p5 = (p1 = (p2 = (p3 = (p4 = p5))))))))"
  by blast

end


(*  Title:      HOL/Hoare/Hoare_Logic.thy
    Author:     Leonor Prensa Nieto & Tobias Nipkow
    Copyright   1998 TUM

Sugared semantic embedding of Hoare logic.
Strictly speaking a shallow embedding (as implemented by Norbert Galm
following Mike Gordon) would suffice. Maybe the datatype com comes in useful
later.
*)

theory Hoare_Logic
imports Main
begin

type_synonym 'a bexp = "'a set"
type_synonym 'a assn = "'a set"

datatype 'a com =
  Basic "'a \<Rightarrow> 'a"
| Seq "'a com" "'a com"               ("(_;/ _)"      [61,60] 60)
| Cond "'a bexp" "'a com" "'a com"    ("(1IF _/ THEN _ / ELSE _/ FI)"  [0,0,0] 61)
| While "'a bexp" "'a assn" "'a com"  ("(1WHILE _/ INV {_} //DO _ /OD)"  [0,0,0] 61)

abbreviation annskip ("SKIP") where "SKIP == Basic id"

type_synonym 'a sem = "'a => 'a => bool"

inductive Sem :: "'a com \<Rightarrow> 'a sem"
where
  "Sem (Basic f) s (f s)"
| "Sem c1 s s'' \<Longrightarrow> Sem c2 s'' s' \<Longrightarrow> Sem (c1;c2) s s'"
| "s \<in> b \<Longrightarrow> Sem c1 s s' \<Longrightarrow> Sem (IF b THEN c1 ELSE c2 FI) s s'"
| "s \<notin> b \<Longrightarrow> Sem c2 s s' \<Longrightarrow> Sem (IF b THEN c1 ELSE c2 FI) s s'"
| "s \<notin> b \<Longrightarrow> Sem (While b x c) s s"
| "s \<in> b \<Longrightarrow> Sem c s s'' \<Longrightarrow> Sem (While b x c) s'' s' \<Longrightarrow>
   Sem (While b x c) s s'"

inductive_cases [elim!]:
  "Sem (Basic f) s s'" "Sem (c1;c2) s s'"
  "Sem (IF b THEN c1 ELSE c2 FI) s s'"

definition Valid :: "'a bexp \<Rightarrow> 'a com \<Rightarrow> 'a bexp \<Rightarrow> bool"
  where "Valid p c q \<longleftrightarrow> (\<forall>s s'. Sem c s s' \<longrightarrow> s \<in> p \<longrightarrow> s' \<in> q)"

syntax
  "_assign" :: "idt => 'b => 'a com"  ("(2_ :=/ _)" [70, 65] 61)

syntax
 "_hoare_vars" :: "[idts, 'a assn,'a com,'a assn] => bool"
                 ("VARS _// {_} // _ // {_}" [0,0,55,0] 50)
syntax ("" output)
 "_hoare"      :: "['a assn,'a com,'a assn] => bool"
                 ("{_} // _ // {_}" [0,55,0] 50)

ML_file \<open>hoare_syntax.ML\<close>
parse_translation \<open>[(\<^syntax_const>\<open>_hoare_vars\<close>, K Hoare_Syntax.hoare_vars_tr)]\<close>
print_translation \<open>[(\<^const_syntax>\<open>Valid\<close>, K (Hoare_Syntax.spec_tr' \<^syntax_const>\<open>_hoare\<close>))]\<close>

lemma SkipRule: "p \<subseteq> q \<Longrightarrow> Valid p (Basic id) q"
by (auto simp:Valid_def)

lemma BasicRule: "p \<subseteq> {s. f s \<in> q} \<Longrightarrow> Valid p (Basic f) q"
by (auto simp:Valid_def)

lemma SeqRule: "Valid P c1 Q \<Longrightarrow> Valid Q c2 R \<Longrightarrow> Valid P (c1;c2) R"
by (auto simp:Valid_def)

lemma CondRule:
 "p \<subseteq> {s. (s \<in> b \<longrightarrow> s \<in> w) \<and> (s \<notin> b \<longrightarrow> s \<in> w')}
  \<Longrightarrow> Valid w c1 q \<Longrightarrow> Valid w' c2 q \<Longrightarrow> Valid p (Cond b c1 c2) q"
by (auto simp:Valid_def)

lemma While_aux:
  assumes "Sem (WHILE b INV {i} DO c OD) s s'"
  shows "\<forall>s s'. Sem c s s' \<longrightarrow> s \<in> I \<and> s \<in> b \<longrightarrow> s' \<in> I \<Longrightarrow>
    s \<in> I \<Longrightarrow> s' \<in> I \<and> s' \<notin> b"
  using assms
  by (induct "WHILE b INV {i} DO c OD" s s') auto

lemma WhileRule:
 "p \<subseteq> i \<Longrightarrow> Valid (i \<inter> b) c i \<Longrightarrow> i \<inter> (-b) \<subseteq> q \<Longrightarrow> Valid p (While b i c) q"
apply (clarsimp simp:Valid_def)
apply(drule While_aux)
  apply assumption
 apply blast
apply blast
done

lemma Compl_Collect: "-(Collect b) = {x. ~(b x)}"
  by blast

lemmas AbortRule = SkipRule  \<comment> \<open>dummy version\<close>
ML_file \<open>hoare_tac.ML\<close>

method_setup vcg = \<open>
  Scan.succeed (fn ctxt => SIMPLE_METHOD' (Hoare.hoare_tac ctxt (K all_tac)))\<close>
  "verification condition generator"

method_setup vcg_simp = \<open>
  Scan.succeed (fn ctxt =>
    SIMPLE_METHOD' (Hoare.hoare_tac ctxt (asm_full_simp_tac ctxt)))\<close>
  "verification condition generator plus simplification"

end


(* Property from Productive Use of Failure in Inductive Proof,
   Andrew Ireland and Alan Bundy, JAR 1996.
   This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_prop_26
  imports "../../Test_Base"
begin

datatype Nat = Z | S "Nat"

fun half :: "Nat => Nat" where
  "half (Z) = Z"
| "half (S (Z)) = Z"
| "half (S (S z)) = S (half z)"

fun t2 :: "Nat => Nat => Nat" where
  "t2 (Z) y = y"
| "t2 (S z) y = S (t2 z y)"

theorem property0 :
  "((half (t2 x y)) = (half (t2 y x)))"
  oops

end


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

datatype Bin = One | ZeroAnd "Bin" | OneAnd "Bin"

fun s :: "Bin => Bin" where
"s (One) = ZeroAnd One"
| "s (ZeroAnd xs) = OneAnd xs"
| "s (OneAnd ys) = ZeroAnd (s ys)"

fun plus :: "Bin => Bin => Bin" where
"plus (One) y = s y"
| "plus (ZeroAnd z) (One) = s (ZeroAnd z)"
| "plus (ZeroAnd z) (ZeroAnd ys) = ZeroAnd (plus z ys)"
| "plus (ZeroAnd z) (OneAnd xs) = OneAnd (plus z xs)"
| "plus (OneAnd x2) (One) = s (OneAnd x2)"
| "plus (OneAnd x2) (ZeroAnd zs) = OneAnd (plus x2 zs)"
| "plus (OneAnd x2) (OneAnd ys2) = ZeroAnd (s (plus x2 ys2))"

fun times :: "Bin => Bin => Bin" where
"times (One) y = y"
| "times (ZeroAnd xs1) y = ZeroAnd (times xs1 y)"
| "times (OneAnd xs12) y = plus (ZeroAnd (times xs12 y)) y"

theorem property0 :
  "((times x (times y z)) = (times (times x y) z))"
  oops

end


theory prop_61
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin
  datatype 'a list = Nil2 | Cons2 "'a" "'a list"
  datatype Nat = Z | S "Nat"
  fun last :: "Nat list => Nat" where
  "last (Nil2) = Z"
  | "last (Cons2 y (Nil2)) = y"
  | "last (Cons2 y (Cons2 x2 x3)) = last (Cons2 x2 x3)"
  fun lastOfTwo :: "Nat list => Nat list => Nat" where
  "lastOfTwo x (Nil2) = last x"
  | "lastOfTwo x (Cons2 z x2) = last (Cons2 z x2)"
  fun append :: "Nat list => Nat list => Nat list" where
  "append (Nil2) y = y"
  | "append (Cons2 z xs) y = Cons2 z (append xs y)"
  (*hipster last lastOfTwo append *)

(*hipster lastOfTwo*)(*
lemma lemma_a [thy_expl]: "last x2 = lastOfTwo x2 x2"
by (hipster_induct_schemes lastOfTwo.simps)
(*hipster append last*)

lemma lemma_aa [thy_expl]: "append x2 Nil2 = x2"
by (hipster_induct_schemes append.simps last.simps)

lemma lemma_ab [thy_expl]: "append (append x2 y2) z2 = append x2 (append y2 z2)"
by (hipster_induct_schemes append.simps last.simps)

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

(*hipster lastOfTwo last append*)

  theorem x0 :
    "(last (append xs ys)) = (lastOfTwo xs ys)"
    by (hipster_induct_schemes last.simps append.simps lastOfTwo.simps list.exhaust Nat.exhaust)

end


theory Functions_Functions
imports "$HETS_LIB/Isabelle/MainHC"
uses "$HETS_LIB/Isabelle/prelude"
begin

ML "Header.initialize
    [\"o_def\", \"id_def\", \"o_assoc\", \"id_neut\", \"inj\",
     \"surj\"]"

consts
X__o__X :: "('b => 'c partial) * ('a => 'b partial) => 'a => 'c partial"
X_id :: "'a => 'a partial" ("id''/'(_')" [3] 999)

axioms
o_def [rule_format] :
"ALL f.
 ALL g.
 X__o__X (f, g) =
 (% x. case g x of
       None => noneOp |
       Some Xc0 => f Xc0)"

id_def [rule_format] : "X_id = makePartial o (% x. x)"

theorem o_assoc :
"ALL f.
 ALL g.
 ALL h. X__o__X (f, X__o__X (g, h)) = X__o__X (X__o__X (f, g), h)"
apply (auto simp only: o_def)
(* (%x. option_case None f (option_case None g (h x))) = (%x. case h x of None => None | Some x => option_case None f (g x))*)
apply (rule ext)
apply (case_tac "h x")
apply (simp_all add:noneOp_def)
done

theorem id_neut : "ALL f'. X__o__X (f', X_id) = f'"
apply (auto simp only: o_def id_def)
apply (rule ext)
apply (case_tac "f' x")
apply (simp_all add: noneOp_def makePartial_def)
done

theorem inj  :
"ALL f'.
 X__o__X (f', f') = X_id -->
 (ALL x. ALL y. f' x =s= f' y --> x = y)"
apply (auto)
apply (subgoal_tac "option_case None fâ (fâ y) = Some y")
apply (drule_tac x = "x" in fun_cong)
apply (case_tac "fâ x")
apply (drule_tac[3] x = "y" in fun_cong)
apply (unfold strongEqualOp_def)
apply (simp)
apply (case_tac "fâ y")
apply (auto)
apply (unfold o_def id_def)
apply (unfold makePartial_def)
apply (simp)
apply (unfold noneOp_def)
apply (simp)
done

theorem surj  :
"ALL f'.
 X__o__X (f', f') = X_id --> (ALL x. EX y. f' y = makePartial x)"
apply (auto)
apply (subgoal_tac "option_case None fâ (fâ y) = Some y")
apply (drule_tac x = "x" in fun_cong)
apply (case_tac "f' x")
apply (drule_tac[3] x = "y" in fun_cong)
apply (unfold strongEqualOp_def)
apply (simp)
apply (case_tac "f' y")
apply (auto)
apply (unfold o_def id_def)
apply (unfold makePartial_def)
apply (simp)
apply (unfold noneOp_def)
apply (simp)
done

end


theory sort_NStoogeSortIsSort
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin

datatype 'a list = Nil2 | Cons2 "'a" "'a list"

datatype ('a, 'b) Pair2 = Pair "'a" "'b"

datatype Nat = Z | S "Nat"

fun third :: "Nat => Nat" where
"third (Z) = Z"
| "third (S (Z)) = Z"
| "third (S (S (Z))) = Z"
| "third (S (S (S n))) = S (third n)"

fun take :: "Nat => 'a list => 'a list" where
"take (Z) y = Nil2"
| "take (S z) (Nil2) = Nil2"
| "take (S z) (Cons2 x2 x3) = Cons2 x2 (take z x3)"

fun sort2 :: "int => int => int list" where
"sort2 x y =
   (if x <= y then Cons2 x (Cons2 y (Nil2)) else
      Cons2 y (Cons2 x (Nil2)))"

fun length :: "'t list => Nat" where
"length (Nil2) = Z"
| "length (Cons2 y xs) = S (length xs)"

fun insert2 :: "int => int list => int list" where
"insert2 x (Nil2) = Cons2 x (Nil2)"
| "insert2 x (Cons2 z xs) =
     (if x <= z then Cons2 x (Cons2 z xs) else Cons2 z (insert2 x xs))"

fun isort :: "int list => int list" where
"isort (Nil2) = Nil2"
| "isort (Cons2 y xs) = insert2 y (isort xs)"

fun drop :: "Nat => 'a list => 'a list" where
"drop (Z) y = y"
| "drop (S z) (Nil2) = Nil2"
| "drop (S z) (Cons2 x2 x3) = drop z x3"

fun splitAt :: "Nat => 'a list =>
              (('a list), ('a list)) Pair2" where
"splitAt x y = Pair (take x y) (drop x y)"

fun append :: "'a list => 'a list => 'a list" where
"append (Nil2) y = y"
| "append (Cons2 z xs) y = Cons2 z (append xs y)"

fun reverse :: "'t list => 't list" where
"reverse (Nil2) = Nil2"
| "reverse (Cons2 y xs) = append (reverse xs) (Cons2 y (Nil2))"

function nstooge1sort2 :: "int list => int list"
         and nstoogesort :: "int list => int list"
         and nstooge1sort1 :: "int list => int list" where
"nstooge1sort2 x =
   case splitAt (third (length x)) (reverse x) of
     | Pair ys zs =>
         case splitAt (third (length x)) (reverse x) of
           | Pair xs zs2 => append (nstoogesort zs) (reverse xs)
         end
   end"
| "nstoogesort (Nil2) = Nil2"
| "nstoogesort (Cons2 y (Nil2)) = Cons2 y (Nil2)"
| "nstoogesort (Cons2 y (Cons2 y2 (Nil2))) = sort2 y y2"
| "nstoogesort (Cons2 y (Cons2 y2 (Cons2 x3 x4))) =
     nstooge1sort2
       (nstooge1sort1 (nstooge1sort2 (Cons2 y (Cons2 y2 (Cons2 x3 x4)))))"
| "nstooge1sort1 x =
     case splitAt (third (length x)) x of
       | Pair ys zs =>
           case splitAt (third (length x)) x of
             | Pair xs zs2 => append ys (nstoogesort zs2)
           end
     end"
by pat_completeness auto

(*hipster third
          take
          sort2
          length
          insert2
          isort
          drop
          splitAt
          append
          reverse
          nstooge1sort2
          nstoogesort
          nstooge1sort1 *)

theorem x0 :
  "!! (x :: int list) . (nstoogesort x) = (isort x)"
  by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)

end


theory HL_PlayAround
imports
  Main
  "../../HL_State"
begin

fun accfact:: "nat \<Rightarrow> nat \<Rightarrow> nat" where
af1:  "accfact 0 a = a" |
af2: "accfact (Suc n) a = accfact n (a * Suc n)"

lemma accfact_mult: "accfact n (a * b) = b * accfact n a"
  apply (induction n arbitrary: a b)
   apply (simp)
  apply (simp only: af2)
  by (simp add: semiring_normalization_rules(19))

lemma accfact_aux: "accfact (Suc n) x = (Suc n) * accfact n x"
  apply (induction n)
   apply simp
  using Int_State_Monad.af2 accfact_mult by presburger

fun monfact:: "nat \<Rightarrow> (nat, unit) state" where
mf1: "monfact 0 = skip" |
mf2: "monfact (Suc n) = do { y \<leftarrow> get; y \<leftarrow> return (y * (Suc n)); put y; monfact n }"

lemma monfact_mult: "snd (run_state (monfact n) (a * b)) = b * snd (run_state (monfact n) a)"
  apply (induction n arbitrary: a b)
  apply (simp add: skip_def)
  apply (simp add: return_def put_def get_def)
  by (metis mult.assoc mult.commute mult_Suc)

lemma monfact_shift: "snd (run_state (monfact (Suc n)) x) = snd (run_state (monfact n) ((Suc n) * x))"
  apply (induction n arbitrary: x)
  apply (simp add: get_def put_def return_def)
  apply (simp add: put_def return_def get_def)
  by (simp add: mult.commute)

lemma monfact_aux: "snd (run_state (monfact (Suc n)) x) = (Suc n) * snd (run_state (monfact n) x)"
  apply (induction n arbitrary: x)
   apply (simp add: skip_def return_def get_def put_def)
  by (metis monfact_mult monfact_shift mult.commute)

lemma fact_basic: "snd (run_state (monfact n) (x::nat)) = accfact n (x::nat)"
  apply (induction n)
   apply (simp add: put_def fst_def skip_def)
  using accfact_aux monfact_aux by auto

lemma fact_main: "snd (run_state (do { put (1::nat); monfact n }) (x::nat)) = accfact n (1::nat)"
  by (simp add: fact_basic put_def)

fun fibacc :: "nat \<Rightarrow> nat => nat \<Rightarrow> nat" where
fa1: "fibacc 0 a b = a"|
fa2: "fibacc (Suc 0) a b = b"|
fa3: "fibacc (Suc (Suc n)) a b = fibacc (Suc n) b (a+b)"

definition fib_wrap:: "nat \<Rightarrow> nat" where
  "fib_wrap n \<equiv> fibacc n 1 1"

fun monfibacc :: "nat \<Rightarrow> nat => (nat, unit) state" where
m1:  "monfibacc 0 a = skip"|
m3:  "monfibacc (Suc n) a  = do{b \<leftarrow> get; put (a + b); monfibacc n b}"

definition monfib_wrap where
  "monfib_wrap n \<equiv> (monfibacc n 1)"

value \<open>fibacc 9 1 1 = 55\<close>
value \<open>snd (run_state (monfibacc 9 0) (1::nat)) = 55\<close>
value \<open>fib_wrap 9 = 55\<close>
value \<open>snd (run_state (monfib_wrap 9) (1::nat))\<close>
value \<open>snd (run_state (monfib_wrap 2) (1::nat))\<close>
value \<open>snd (run_state (monfib_wrap (Suc 0)) (snd (run_state (monfib_wrap 0) 1)))\<close>
value \<open>snd (run_state (monfib_wrap (Suc (Suc 0))) 1)\<close>

lemma fib_base[simp]: "snd (run_state (monfib_wrap 0) (Suc 0)) = fib_wrap 0"
  by (simp add: fib_wrap_def monfib_wrap_def put_def skip_def)

lemma fib_basic: "snd (run_state (monfib_wrap n) 1) = fib_wrap n"
  apply (induction n)
   apply (simp)
  sorry

end


theory prop_04
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin
  datatype 'a list = Nil2 | Cons2 "'a" "'a list"
  datatype Nat = Z | S "Nat"
  fun length :: "'a list => Nat" where
  "length (Nil2) = Z"
  | "length (Cons2 y xs) = S (length xs)"
  fun double :: "Nat => Nat" where
  "double (Z) = Z"
  | "double (S y) = S (S (double y))"
  fun append :: "'a list => 'a list => 'a list" where
  "append (Nil2) y = y"
  | "append (Cons2 z xs) y = Cons2 z (append xs y)"
  (*hipster length double append *)

hipster double

lemma lemma_a [thy_expl]: "append x2 Nil2 = x2"
by (hipster_induct_schemes length.simps append.simps)

lemma lemma_aa [thy_expl]: "append (append x2 y2) z2 = append x2 (append y2 z2)"
by (hipster_induct_schemes length.simps append.simps)

(*hipster double length append*)
lemma unknown []: "length (append x y) = length (append y x)"
oops

lemma unknown []: "length (append x x) = double (length x)"
oops

(*
Trivial proof: append (Cons2 x Nil2) y = Cons2 x y
Trivial proof: length (Cons2 x Nil2) = S Z
Trivial proof: S (S Z) = double (S Z)
Trivial proof: append (Cons2 x Nil2) (append y z) = Cons2 x (append y z)
Trivial proof: append (Cons2 x Nil2) (Cons2 y z) = Cons2 x (Cons2 y z)
Trivial proof: append (Cons2 x Nil2) (append y y) = Cons2 x (append y y)
Trivial proof: append (Cons2 x Nil2) (Cons2 x y) = Cons2 x (Cons2 x y)
Trivial proof: append (Cons2 x Nil2) (Cons2 y Nil2) = Cons2 x (Cons2 y Nil2)
Trivial proof: append (Cons2 x Nil2) (Cons2 x Nil2) = Cons2 x (Cons2 x Nil2)

Trivial proof: length (Cons2 x y) = length (Cons2 z y)
*)
(*
lemma ax: "length (append (Cons2 ya xs) y) = S (length (append xs y))"
by (metis length.simps(2) append.simps(2))
*)
lemma ax2[thy_expl]: "length (append y (Cons2 ya xs)) = S (length (append y xs))"
by(hipster_induct_schemes)

  theorem x0 :
    "(length (append x x)) = (double (length x))"
    by (hipster_induct_schemes append.simps double.simps length.simps list.exhaust Nat.exhaust)

    by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)
end


theory Pedersen imports
  Abstract_Commitment
  "HOL-Number_Theory.Cong"
  CryptHOL.CryptHOL
  Cyclic_Group_Ext
  Discrete_log
  GCD
begin

locale pedersen_base =
  fixes \<G> :: "'grp cyclic_group" (structure)
   assumes finite_group: "finite (carrier \<G>)"
  and order_gt_0: "order \<G> > 0"
begin

type_synonym 'grp' ck = "'grp'"
type_synonym 'grp' vk = "'grp'"
type_synonym plain = "nat"
type_synonym 'grp' commit = "'grp'"
type_synonym opening = "nat"

definition key_gen :: "('grp ck \<times> 'grp vk) spmf"
where
  "key_gen = do {
    x :: nat \<leftarrow> sample_uniform (order \<G>);
    let h = \<^bold>g (^) x;
    return_spmf (h, h)
  }"

definition commit :: "'grp ck \<Rightarrow> plain \<Rightarrow> ('grp commit \<times> opening) spmf"
where
  "commit pub_key m = do {
    d :: nat \<leftarrow> sample_uniform (order \<G>);
    let c = ((\<^bold>g (^) d) \<otimes> (pub_key (^) m));
    return_spmf (c,d)
  }"

definition verify :: "'grp vk \<Rightarrow> plain \<Rightarrow> 'grp commit \<Rightarrow> opening \<Rightarrow> bool spmf"
where
  "verify v_key m c d = do {
    let c' = (\<^bold>g (^) d \<otimes>  v_key (^) m);
    return_spmf (c = c')
  }"

definition valid_msg :: "plain \<Rightarrow> bool"
  where "valid_msg msg \<equiv> msg \<in> {..<order \<G>}"

definition \_cond :: "'grp commit \<Rightarrow> plain \<Rightarrow> opening \<Rightarrow> plain \<Rightarrow> opening \<Rightarrow> bool"
  where "\_cond c m d m' d' = (m > m' \<and> \<not> [m = m'] (mod order \<G>) \<and> (gcd (m - m') (order \<G>) = 1))"

definition dis_log_\ :: "('grp ck, plain, 'grp commit, opening) bind_adv \<Rightarrow> 'grp ck \<Rightarrow> nat spmf"
where "dis_log_\ \ h = do {
  (c, m, d, m', d') \<leftarrow> \ h;
  _ :: unit \<leftarrow> assert_spmf (m > m' \<and> \<not> [m = m'] (mod order \<G>) \<and> (gcd (m - m') (order \<G>) = 1));
  _ :: unit \<leftarrow> assert_spmf (c = \<^bold>g (^) d \<otimes> h (^) m \<and> c = \<^bold>g (^) d' \<otimes> h (^) m');
  return_spmf  (nat ((int d' - int d) * (fst (bezw (m - m') (order \<G>))) mod order \<G>))}"

sublocale abstract_commitment: abstract_commitment key_gen commit verify valid_msg \_cond .
sublocale discrete_log: dis_log .

end

locale pedersen = pedersen_base + cyclic_group \<G> +
 assumes finite_group: "finite (carrier \<G>)"
begin

lemma inverse: assumes "gcd (nat (int m - int m')) (order \<G>) = 1" and m_ge_m': "m > m'"
  shows "[(int m - int m') * (fst (bezw (nat (int m - int m')) (order \<G>))) = 1] (mod order \<G>)"
proof-
  have 1: "int m - int m' = int (m - m')" using m_ge_m' by simp
  have 2: "fst (bezw  (nat (int m - int m')) (order \<G>)) * int (m - m') + snd (bezw (nat (int m - int m')) (order \<G>)) * int (order \<G>) = 1"
    using bezw_aux assms int_minus by presburger
  hence 3: "(fst (bezw  (nat (int m - int m')) (order \<G>)) * int (m - m') + snd (bezw (nat (int m - int m')) (order \<G>)) * int (order \<G>)) mod (order \<G>) = 1 mod (order \<G>)"
    by (simp add: zmod_int)
  hence 4: "(fst (bezw (nat (int m - int m')) (order \<G>)) * int  (m - m')) mod (order \<G>) = 1 mod (order \<G>)"
    by simp
  hence 5:  "[(fst (bezw (nat (int m - int m')) (order \<G>))) *(int m - int m')  = 1] (mod order \<G>)"
    using 1 2 3 cong_int_def by auto
  then show ?thesis by(simp add: mult.commute)
qed

lemma mod_one_cancel: assumes "[int y * z * x = y' * x] (mod order \<G>)" and "[z * x = 1] (mod order \<G>)"
  shows "[int y = y' * x] (mod order \<G>)"
    using assms by (metis ab_semigroup_mult_class.mult_ac(1) cong_refl_int cong_scalar2_int cong_sym_int cong_trans_int mult.left_neutral semiring_normalization_rules(7))

lemma dis_log_break:
  fixes d d' m m' :: nat
  assumes c: "c = \<^bold>g (^) d \<otimes> (\<^bold>g (^) y) (^) m"
    and c': "c = \<^bold>g (^) d' \<otimes> (\<^bold>g (^) y) (^) m'"
    and y_less_order: "y < order \<G>"
    and gcd: "gcd (m - m') (order \<G>) = 1"
    and m_ge_m': "m > m'"
    and mm': "\<not> [m = m'] (mod order \<G>)"
  shows "y = nat ((int d' - int d) * (fst (bezw (m - m') (order \<G>))) mod order \<G>)"
proof -
  have "\<^bold>g (^) (d + y * m) = \<^bold>g (^) (d' + y * m')" using c c' by (simp add: nat_pow_mult nat_pow_pow)
  hence "[d + y * m = d' + y * m'] (mod order \<G>)" by(simp add: pow_generator_eq_iff_cong finite_group)
  hence "[int d + int y * int m = int d' + int y * int m'] (mod order \<G>)"
    by(simp add: transfer_int_nat_cong[symmetric])
  from cong_diff_int[OF this cong_refl_int, of "int d + int y * int m'"]
  have "[int y * int (m - m') = int d' - int d] (mod order \<G>)" using m_ge_m'
    by(simp add: int_distrib of_nat_diff)
  hence "[int y * int (m - m') * (fst (bezw (m - m') (order \<G>))) = (int d' - int d) * (fst (bezw (m - m') (order \<G>)))] (mod order \<G>)"
    by (simp add: cong_scalar_int)
  also have "int y * int (m - m') * (fst (bezw (m - m') (order \<G>))) = int y * (int (m - m') * (fst (bezw (m - m') (order \<G>))))"
    by simp
  also have "\<dots> = int y * (1 - snd (bezw (m - m') (order \<G>)) * order \<G>)"
    using bezw_aux[of "m - m'" "order \<G>"] gcd by(simp add: mult_ac)
  also have "[\<dots> = int y] (mod order \<G>)"
    by(simp add: right_diff_distrib cong_iff_lin_int)
  finally (cong_trans_int[OF cong_sym_eq_int[THEN iffD2]])
  have "[int y = (int d' - int d) * (fst (bezw (m - m') (order \<G>)))] (mod order \<G>)" by(simp add: cong_sym_eq_int)
  hence "int y mod order \<G> = (int d' - int d) * (fst (bezw (m - m') (order \<G>))) mod order \<G>"
    using cong_int_def by blast
  hence "y mod order \<G> = (int d' - int d) * (fst (bezw (m - m') (order \<G>))) mod order \<G>"
    by (simp add: zmod_int)
  then show ?thesis using y_less_order by simp
qed

lemma set_spmf_samp_uni [simp]: "set_spmf (sample_uniform (order \<G>)) = {x. x < order \<G>}"
  by(auto simp add: sample_uniform_def)

lemma correct:
  shows "spmf (abstract_commitment.correct_game m) True  = 1"
  using finite_group order_gt_0_iff_finite
  apply(simp add: abstract_commitment.correct_game_def Let_def commit_def verify_def)
    by(simp add: key_gen_def Let_def bind_spmf_const cong: bind_spmf_cong_simp)

theorem abstract_correct:
  shows "abstract_commitment.correct m"
  unfolding abstract_commitment.correct_def using correct by simp

lemma perfect_hiding:
  shows "spmf (abstract_commitment.hiding_game \) True = 1/2"
  including monad_normalisation
proof -
  obtain \1 \2 where [simp]: "\ = (\1, \2)" by(cases \)
  note [simp] =  finite_group order_gt_0_iff_finite
  have "abstract_commitment.hiding_game (\1, \2) = TRY do {
    (ck,vk) \<leftarrow> key_gen;
    ((m0, m1), \<sigma>) \<leftarrow> \1 vk;
    _ :: unit \<leftarrow> assert_spmf (valid_msg m0 \<and> valid_msg m1);
    b \<leftarrow> coin_spmf;
    (c,d) \<leftarrow> commit ck (if b then m0 else m1);
    b' \<leftarrow> \2 c \<sigma>;
    return_spmf (b' = b)} ELSE coin_spmf"
      by(simp add: abstract_commitment.hiding_game_def)
  also have "... = TRY do {
    x :: nat \<leftarrow> sample_uniform (order \<G>);
    let h = \<^bold>g (^) x;
    ((m0, m1), \<sigma>) \<leftarrow> \1 h;
    _ :: unit \<leftarrow> assert_spmf (valid_msg m0 \<and> valid_msg m1);
     b \<leftarrow> coin_spmf;
    d :: nat \<leftarrow> sample_uniform (order \<G>);
    let c = ((\<^bold>g (^) d) \<otimes> (h (^) (if b then m0 else m1)));
    b' \<leftarrow> \2 c \<sigma>;
    return_spmf (b' = b)} ELSE coin_spmf"
      by(simp add: commit_def key_gen_def Let_def)
  also have "... = TRY do {
    x :: nat \<leftarrow> sample_uniform (order \<G>);
    let h = (\<^bold>g (^) x);
    ((m0, m1), \<sigma>) \<leftarrow> \1 h;
    _ :: unit \<leftarrow> assert_spmf (valid_msg m0 \<and> valid_msg m1);
    b \<leftarrow> coin_spmf;
    z \<leftarrow> map_spmf (\<lambda>z.  \<^bold>g (^) z \<otimes> (h (^) (if b then m0 else m1))) (sample_uniform (order \<G>));
    guess :: bool \<leftarrow> \2 z \<sigma>;
    return_spmf(guess = b)} ELSE coin_spmf"
      by(simp add: bind_map_spmf o_def)
  also have "... = TRY do {
    x :: nat \<leftarrow> sample_uniform (order \<G>);
    let h = (\<^bold>g (^) x);
    ((m0, m1), \<sigma>) \<leftarrow> \1 h;
    _ :: unit \<leftarrow> assert_spmf (valid_msg m0 \<and> valid_msg m1);
    b \<leftarrow> coin_spmf;
    z \<leftarrow> map_spmf (\<lambda>z.  \<^bold>g (^) z) (sample_uniform (order \<G>));
    guess :: bool \<leftarrow> \2 z \<sigma>;
    return_spmf(guess = b)} ELSE coin_spmf"
      by(clarsimp simp add: Let_def sample_uniform_one_time_pad)
  also have "... = TRY do {
    x :: nat \<leftarrow> sample_uniform (order \<G>);
    let h = (\<^bold>g (^) x);
    ((m0, m1), \<sigma>) \<leftarrow> \1 h;
    _ :: unit \<leftarrow> assert_spmf (valid_msg m0 \<and> valid_msg m1);
    z \<leftarrow> map_spmf (\<lambda>z.  \<^bold>g (^) z)  (sample_uniform (order \<G>));
    guess :: bool \<leftarrow> \2 z \<sigma>;
    map_spmf(op = guess) coin_spmf} ELSE coin_spmf"
      by(simp add: map_spmf_conv_bind_spmf)
  also have "... = coin_spmf"
     by(auto simp add: map_eq_const_coin_spmf try_bind_spmf_lossless2' map_eq_const_coin_spmf Let_def split_def bind_spmf_const try_bind_spmf_lossless2' scale_bind_spmf weight_spmf_le_1 scale_scale_spmf)
  ultimately show ?thesis by(simp add: spmf_of_set)
qed

theorem abstract_perfect_hiding:
  shows "abstract_commitment.perfect_hiding \"
  using perfect_hiding abstract_commitment.perfect_hiding_def by blast

lemma bind_game_eq_dis_log:
  shows "abstract_commitment.bind_game \ = discrete_log.dis_log (dis_log_\ \)"
proof-
  have "abstract_commitment.bind_game \ = TRY do {
    (ck,vk) \<leftarrow> key_gen;
    (c, m, d, m', d') \<leftarrow> \ ck;
    _ :: unit \<leftarrow> assert_spmf(m > m' \<and> \<not> [m = m'] (mod order \<G>) \<and> (gcd (m - m') (order \<G>) = 1));
    b \<leftarrow> verify vk m c d;
    b' \<leftarrow> verify vk m' c d';
    _ :: unit \<leftarrow> assert_spmf (b \<and> b');
    return_spmf True} ELSE return_spmf False"
    by(simp add: abstract_commitment.bind_game_def \_cond_def)
  also have "... = TRY do {
    x :: nat \<leftarrow> sample_uniform (Coset.order \<G>);
    (c, m, d, m', d') \<leftarrow> \ (\<^bold>g (^) x);
    _ :: unit \<leftarrow> assert_spmf (m > m' \<and> \<not> [m = m'] (mod order \<G>) \<and> (gcd (m - m') (order \<G>) = 1));
    _ :: unit \<leftarrow> assert_spmf (c = \<^bold>g (^) d \<otimes>  (\<^bold>g (^) x) (^) m \<and> c = \<^bold>g (^) d' \<otimes> (\<^bold>g (^) x) (^) m');
    return_spmf True} ELSE return_spmf False"
      by(simp add: verify_def key_gen_def Let_def)
  also have "... = TRY do {
    x :: nat \<leftarrow> sample_uniform (order \<G>);
    (c, m, d, m', d') \<leftarrow> \ (\<^bold>g (^) x);
    _ :: unit \<leftarrow> assert_spmf (m > m' \<and> \<not> [m = m'] (mod order \<G>) \<and> (gcd (m - m') (order \<G>) = 1));
    _ :: unit \<leftarrow> assert_spmf (c = \<^bold>g (^) d \<otimes>  (\<^bold>g (^) x) (^) m \<and> c = \<^bold>g (^) d' \<otimes> (\<^bold>g (^) x) (^) m');
    return_spmf (x = nat ((int d' - int d) * (fst (bezw (m - m') (order \<G>))) mod order \<G>))} ELSE return_spmf False"
    apply(intro try_spmf_cong)
    apply(intro bind_spmf_cong[OF refl]; clarsimp?)+
    apply(rule dis_log_break)
    by auto
  ultimately show ?thesis by(simp add: discrete_log.dis_log_def dis_log_\_def Let_def split_def cong: bind_spmf_cong_simp)
qed

theorem pedersen_bind: "abstract_commitment.bind_advantage \ = discrete_log.advantage (dis_log_\ \)"
  using bind_game_eq_dis_log unfolding abstract_commitment.bind_advantage_def discrete_log.advantage_def
  by simp

end

locale pedersen_asymp =
  fixes \<G> :: "nat \<Rightarrow> 'grp cyclic_group"
  assumes pedersen: "\<And>\<eta>. pedersen (\<G> \<eta>)"
begin

sublocale pedersen "\<G> \<eta>" for \<eta> by(simp add: pedersen)

theorem pedersen_correct:
 shows "abstract_commitment.correct n m"
  using abstract_correct by simp

theorem pedersen_perfect_hiding:
  assumes lossless_\: "abstract_commitment.lossless (\ n)"
  shows "abstract_commitment.perfect_hiding n (\ n)"
    by (simp add: lossless_\ abstract_perfect_hiding)

theorem pedersen_binding:
  shows "abstract_commitment.bind_advantage n (\ n) = discrete_log.advantage n (dis_log_\ n (\ n))"
  using pedersen_bind by(simp)

theorem "negligible (\<lambda> n. abstract_commitment.bind_advantage n (\ n)) \<longleftrightarrow> negligible (\<lambda> n. discrete_log.advantage n (dis_log_\ n (\ n)))"
  by(simp add: pedersen_binding)

end

end


(*  Title:       Verification components with MKA and non-deterministic functions
    Author:      Jonathan Julián Huerta y Munive, 2019
    Maintainer:  Jonathan Julián Huerta y Munive <jjhuertaymunive1@sheffield.ac.uk>
*)

section \<open> Verification components with MKA and non-deterministic functions\<close>

text \<open> We show that non-deterministic endofunctions form an antidomain Kleene algebra
(hence a modal Kleene algebra). We use MKA's forward box operator to derive rules for weakest
liberal preconditions (wlps) of hybrid programs. Finally, we derive our three methods
for verifying correctness specifications for the continuous dynamics of HS. \<close>

theory HS_VC_MKA_ndfun
  imports
    "../HS_ODEs"
    "Transformer_Semantics.Kleisli_Quantale"
    "KAD.Modal_Kleene_Algebra"

begin

subsection \<open> Modal Kleene algebra preparation \<close>

context antidomain_kleene_algebra
begin

lemma fbox_frame: "d p \<cdot> x \<le> x \<cdot> d p \<Longrightarrow> d q \<le> |x] t \<Longrightarrow> d p \<cdot> d q \<le> |x] (d p \<cdot> d t)"
  using dual.mult_isol_var fbox_add1 fbox_demodalisation3 fbox_simp by auto

lemma fbox_export1: "ad p + |x] q = |d p \<cdot> x] q"
  using a_d_add_closure addual.ars_r_def fbox_def fbox_mult by auto

lemma plus_inv: "i \<le> |x] i \<Longrightarrow> j \<le> |x] j \<Longrightarrow> (i + j) \<le> |x] (i + j)"
  by (metis ads_d_def dka.dsr5 fbox_simp fbox_subdist join.sup_mono order_trans)

lemma mult_inv: "d i \<le> |x] d i \<Longrightarrow> d j \<le> |x] d j \<Longrightarrow> (d i \<cdot> d j) \<le> |x] (d i \<cdot> d j)"
  using fbox_demodalisation3 fbox_frame fbox_simp by auto

lemma fbox_stari: "d p \<le> d i \<Longrightarrow> d i \<le> |x] i \<Longrightarrow> d i \<le> d q \<Longrightarrow> d p \<le> |x\<^sup>\<star>] q"
  by (meson dual_order.trans fbox_iso fbox_star_induct_var)

declare fbox_mult [simp]

definition cond :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a" ("if _ then _ else _ fi" [64,64,64] 63)
  where "if p then x else y fi = d p \<cdot> x + ad p \<cdot> y"

lemma fbox_cond_var [simp]: "|if p then x else y fi] q = (ad p + |x] q) \<cdot> (d p + |y] q)"
  using cond_def a_closure' ads_d_def ans_d_def fbox_add2 fbox_export1 by auto

definition loopi :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" ("loop _ inv _ " [64,64] 63)
  where "loop x inv i = x\<^sup>\<star>"

lemma fbox_loopi: "d p \<le> d i \<Longrightarrow> d i \<le> |x] i \<Longrightarrow> d i \<le> d q \<Longrightarrow> d p \<le> |loop x inv i] q"
  unfolding loopi_def using fbox_stari by blast

end

subsection \<open> Non-deterministic functions \<close>

text\<open> Our semantics now corresponds to nondeterministic functions @{typ "'a nd_fun"}. Below we prove
some auxiliary lemmas for them and show that they form an antidomain kleene algebra. The proof just
extends the results on the Transformer\_Semantics.Kleisli\_Quantale theory.\<close>

notation Abs_nd_fun ("_\<^sup>\<bullet>" [101] 100)
     and Rep_nd_fun ("_\<^sub>\<bullet>" [101] 100)
     and fbox ("wp")

declare Abs_nd_fun_inverse [simp]

lemma nd_fun_ext: "(\<And>x. (f\<^sub>\<bullet>) x = (g\<^sub>\<bullet>) x) \<Longrightarrow> f = g"
  apply(subgoal_tac "Rep_nd_fun f = Rep_nd_fun g")
  using Rep_nd_fun_inject
   apply blast
  by(rule ext, simp)

lemma nd_fun_eq_iff: "(f = g) = (\<forall>x. (f\<^sub>\<bullet>) x = (g\<^sub>\<bullet>) x)"
  by (auto simp: nd_fun_ext)

instantiation nd_fun :: (type) antidomain_kleene_algebra
begin

definition "ad f = (\<lambda>x. if ((f\<^sub>\<bullet>) x = {}) then {x} else {})\<^sup>\<bullet>"

definition "0 = \<zeta>\<^sup>\<bullet>"

definition "star_nd_fun f = qstar f" for f::"'a nd_fun"

definition "f + g = ((f\<^sub>\<bullet>) \<squnion> (g\<^sub>\<bullet>))\<^sup>\<bullet>"

named_theorems nd_fun_aka "antidomain kleene algebra properties for nondeterministic functions."

lemma nd_fun_plus_assoc[nd_fun_aka]: "x + y + z = x + (y + z)"
  and nd_fun_plus_comm[nd_fun_aka]: "x + y = y + x"
  and nd_fun_plus_idem[nd_fun_aka]: "x + x = x" for x::"'a nd_fun"
  unfolding plus_nd_fun_def by (simp add: ksup_assoc, simp_all add: ksup_comm)

lemma nd_fun_distr[nd_fun_aka]: "(x + y) \<cdot> z = x \<cdot> z + y \<cdot> z"
  and nd_fun_distl[nd_fun_aka]: "x \<cdot> (y + z) = x \<cdot> y + x \<cdot> z" for x::"'a nd_fun"
  unfolding plus_nd_fun_def times_nd_fun_def by (simp_all add: kcomp_distr kcomp_distl)

lemma nd_fun_plus_zerol[nd_fun_aka]: "0 + x = x"
  and nd_fun_mult_zerol[nd_fun_aka]: "0 \<cdot> x = 0"
  and nd_fun_mult_zeror[nd_fun_aka]: "x \<cdot> 0 = 0" for x::"'a nd_fun"
  unfolding plus_nd_fun_def zero_nd_fun_def times_nd_fun_def by auto

lemma nd_fun_leq[nd_fun_aka]: "(x \<le> y) = (x + y = y)"
  and nd_fun_less[nd_fun_aka]: "(x < y) = (x + y = y \<and> x \<noteq> y)"
  and nd_fun_leq_add[nd_fun_aka]: "z \<cdot> x \<le> z \<cdot> (x + y)" for x::"'a nd_fun"
  unfolding less_eq_nd_fun_def less_nd_fun_def plus_nd_fun_def times_nd_fun_def sup_fun_def
  by (unfold nd_fun_eq_iff le_fun_def, auto simp: kcomp_def)

lemma nd_fun_ad_zero[nd_fun_aka]: "ad x \<cdot> x = 0"
  and nd_fun_ad[nd_fun_aka]: "ad (x \<cdot> y) + ad (x \<cdot> ad (ad y)) = ad (x \<cdot> ad (ad y))"
  and nd_fun_ad_one[nd_fun_aka]: "ad (ad x) + ad x = 1" for x::"'a nd_fun"
  unfolding antidomain_op_nd_fun_def times_nd_fun_def plus_nd_fun_def zero_nd_fun_def
  by (auto simp: nd_fun_eq_iff kcomp_def one_nd_fun_def)

lemma nd_star_one[nd_fun_aka]: "1 + x \<cdot> x\<^sup>\<star> \<le> x\<^sup>\<star>"
  and nd_star_unfoldl[nd_fun_aka]: "z + x \<cdot> y \<le> y \<Longrightarrow> x\<^sup>\<star> \<cdot> z \<le> y"
  and nd_star_unfoldr[nd_fun_aka]: "z + y \<cdot> x \<le> y \<Longrightarrow> z \<cdot> x\<^sup>\<star> \<le> y" for x::"'a nd_fun"
  unfolding plus_nd_fun_def star_nd_fun_def
    apply(simp_all add: fun_star_inductl sup_nd_fun.rep_eq fun_star_inductr)
  by (metis order_refl sup_nd_fun.rep_eq uwqlka.conway.dagger_unfoldl_eq)

instance
  apply intro_classes
  using nd_fun_aka by simp_all

end

subsection \<open> Store and weakest preconditions \<close>

text\<open> Now that we know that nondeterministic functions form an Antidomain Kleene Algebra, we give
 a lifting operation from predicates to @{typ "'a nd_fun"} and use it to compute weakest liberal
preconditions.\<close>

\<comment> \<open>We start by deleting some notation and introducing some new.\<close>

type_synonym 'a pred = "'a \<Rightarrow> bool"

no_notation Archimedean_Field.ceiling ("\<lceil>_\<rceil>")
        and Relation.relcomp (infixl ";" 75)
        and Range_Semiring.antirange_semiring_class.ars_r ("r")
        and antidomain_semiringl.ads_d ("d")

abbreviation p2ndf :: "'a pred \<Rightarrow> 'a nd_fun" ("(1\<lceil>_\<rceil>)")
  where "\<lceil>Q\<rceil> \<equiv> (\<lambda> x::'a. {s::'a. s = x \<and> Q s})\<^sup>\<bullet>"

lemma p2ndf_simps[simp]:
  "\<lceil>P\<rceil> \<le> \<lceil>Q\<rceil> = (\<forall>s. P s \<longrightarrow> Q s)"
  "(\<lceil>P\<rceil> = \<lceil>Q\<rceil>) = (\<forall>s. P s = Q s)"
  "(\<lceil>P\<rceil> \<cdot> \<lceil>Q\<rceil>) = \<lceil>\<lambda> s. P s \<and> Q s\<rceil>"
  "(\<lceil>P\<rceil> + \<lceil>Q\<rceil>) = \<lceil>\<lambda> s. P s \<or> Q s\<rceil>"
  "ad \<lceil>P\<rceil> = \<lceil>\<lambda>s. \<not> P s\<rceil>"
  "d \<lceil>P\<rceil> = \<lceil>P\<rceil>" "\<lceil>P\<rceil> \<le> \<eta>\<^sup>\<bullet>"
  unfolding less_eq_nd_fun_def times_nd_fun_def plus_nd_fun_def ads_d_def
  by (auto simp: nd_fun_eq_iff kcomp_def le_fun_def antidomain_op_nd_fun_def)

lemma wp_nd_fun: "wp F \<lceil>P\<rceil> = \<lceil>\<lambda>s. \<forall>s'. s' \<in> ((F\<^sub>\<bullet>) s) \<longrightarrow> P s'\<rceil>"
  apply(simp add: fbox_def antidomain_op_nd_fun_def)
  by(rule nd_fun_ext, auto simp: Rep_comp_hom kcomp_prop)

definition vec_upd :: "('a^'b) \<Rightarrow> 'b \<Rightarrow> 'a \<Rightarrow> 'a^'b"
  where "vec_upd s i a = (\<chi> j. ((($) s)(i := a)) j)"

definition assign :: "'b \<Rightarrow> ('a^'b \<Rightarrow> 'a) \<Rightarrow> ('a^'b) nd_fun" ("(2_ ::= _)" [70, 65] 61)
  where "(x ::= e) = (\<lambda>s. {vec_upd s x (e s)})\<^sup>\<bullet>"

abbreviation seq_comp :: "'a nd_fun \<Rightarrow> 'a nd_fun \<Rightarrow> 'a nd_fun" (infixl ";" 75)
  where "f ; g \<equiv> f \<cdot> g"

lemma wp_assign[simp]: "wp (x ::= e) \<lceil>Q\<rceil> = \<lceil>\<lambda>s. Q (\<chi> j. ((($) s)(x := (e s))) j)\<rceil>"
  unfolding wp_nd_fun nd_fun_eq_iff vec_upd_def assign_def by auto

abbreviation skip :: "'a nd_fun"
  where "skip \<equiv> 1"

abbreviation cond_sugar :: "'a pred \<Rightarrow> 'a nd_fun \<Rightarrow> 'a nd_fun \<Rightarrow> 'a nd_fun" ("IF _ THEN _ ELSE _" [64,64] 63)
  where "IF P THEN X ELSE Y \<equiv> cond \<lceil>P\<rceil> X Y"

abbreviation loopi_sugar :: "'a nd_fun \<Rightarrow> 'a pred \<Rightarrow> 'a nd_fun" ("LOOP _ INV _ " [64,64] 63)
  where "LOOP R INV I \<equiv> loopi R \<lceil>I\<rceil>"

lemma wp_loopI: "\<lceil>P\<rceil> \<le> \<lceil>I\<rceil> \<Longrightarrow> \<lceil>I\<rceil> \<le> \<lceil>Q\<rceil> \<Longrightarrow> \<lceil>I\<rceil> \<le> wp R \<lceil>I\<rceil> \<Longrightarrow> \<lceil>P\<rceil> \<le> wp (LOOP R INV I) \<lceil>Q\<rceil>"
  using fbox_loopi[of "\<lceil>P\<rceil>"] by auto

subsection \<open> Verification of hybrid programs \<close>

text  \<open>Verification by providing evolution\<close>

definition g_evol :: "(('a::ord) \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> 'b pred \<Rightarrow> 'a set \<Rightarrow> 'b nd_fun" ("EVOL")
  where "EVOL \<phi> G T = (\<lambda>s. g_orbit (\<lambda>t. \<phi> t s) G T)\<^sup>\<bullet>"

lemma wp_g_dyn[simp]:
  fixes \<phi> :: "('a::preorder) \<Rightarrow> 'b \<Rightarrow> 'b"
  shows "wp (EVOL \<phi> G T) \<lceil>Q\<rceil> = \<lceil>\<lambda>s. \<forall>t\<in>T. (\<forall>\<tau>\<in>down T t. G (\<phi> \<tau> s)) \<longrightarrow> Q (\<phi> t s)\<rceil>"
  unfolding wp_nd_fun g_evol_def g_orbit_eq by (auto simp: fun_eq_iff)

text \<open>Verification by providing solutions\<close>

definition g_ode ::"(('a::banach)\<Rightarrow>'a) \<Rightarrow> 'a pred \<Rightarrow> real set \<Rightarrow> 'a set \<Rightarrow>
  real \<Rightarrow> 'a nd_fun" ("(1x\<acute>= _ & _ on _ _ @ _)")
  where "(x\<acute>= f & G on T S @ t\<^sub>0) \<equiv> (\<lambda> s. g_orbital f G T S t\<^sub>0 s)\<^sup>\<bullet>"

lemma wp_g_orbital: "wp (x\<acute>= f & G on T S @ t\<^sub>0) \<lceil>Q\<rceil>=
  \<lceil>\<lambda> s. \<forall>X\<in>ivp_sols (\<lambda>t. f) T S t\<^sub>0 s. \<forall>t\<in>T. (\<forall>\<tau>\<in>down T t. G (X \<tau>)) \<longrightarrow> Q (X t)\<rceil>"
  unfolding g_orbital_eq(1) wp_nd_fun g_ode_def by (auto simp: fun_eq_iff)

context local_flow
begin

lemma wp_g_ode: "wp (x\<acute>= f & G on T S @ 0) \<lceil>Q\<rceil> =
  \<lceil>\<lambda> s. s \<in> S \<longrightarrow> (\<forall>t\<in>T. (\<forall>\<tau>\<in>down T t. G (\<phi> \<tau> s)) \<longrightarrow> Q (\<phi> t s))\<rceil>"
  unfolding wp_g_orbital
  apply(clarsimp, safe)
    apply(erule_tac x="\<lambda>t. \<phi> t s" in ballE)
  using in_ivp_sols
     apply(force, force, force simp: init_time ivp_sols_def)
  apply(subgoal_tac "\<forall>\<tau>\<in>down T t. X \<tau> = \<phi> \<tau> s", simp_all, clarsimp)
  apply(subst eq_solution, simp_all add: ivp_sols_def)
  using init_time by auto

lemma fbox_g_ode_ivl: "t \<ge> 0 \<Longrightarrow> t \<in> T \<Longrightarrow> wp (x\<acute>=f & G on {0..t} S @ 0) \<lceil>Q\<rceil> =
  \<lceil>\<lambda>s. s \<in> S \<longrightarrow> (\<forall>t\<in>{0..t}. (\<forall>\<tau>\<in>{0..t}. G (\<phi> \<tau> s)) \<longrightarrow> Q (\<phi> t s))\<rceil>"
  unfolding wp_g_orbital
  apply(clarsimp, safe)
    apply(erule_tac x="\<lambda>t. \<phi> t s" in ballE, force)
  using in_ivp_sols_ivl
    apply(force simp: closed_segment_eq_real_ivl)
  using in_ivp_sols_ivl
   apply(force simp: ivp_sols_def)
  apply(subgoal_tac "\<forall>t\<in>{0..t}. (\<forall>\<tau>\<in>{0..t}. X \<tau> = \<phi> \<tau> s)", simp, clarsimp)
  apply(subst eq_solution_ivl, simp_all add: ivp_sols_def)
     apply(rule has_vderiv_on_subset, force, force simp: closed_segment_eq_real_ivl)
    apply(force simp: closed_segment_eq_real_ivl)
  using interval_time init_time
   apply (meson is_interval_1 order_trans)
  using init_time by force

lemma wp_orbit: "wp (\<gamma>\<^sup>\<phi>\<^sup>\<bullet>) \<lceil>Q\<rceil> = \<lceil>\<lambda> s. s \<in> S \<longrightarrow> (\<forall> t \<in> T. Q (\<phi> t s))\<rceil>"
  unfolding orbit_def wp_g_ode g_ode_def[symmetric] by auto

end

text \<open> Verification with differential invariants \<close>

definition g_ode_inv :: "(('a::banach)\<Rightarrow>'a) \<Rightarrow> 'a pred \<Rightarrow> real set \<Rightarrow> 'a set \<Rightarrow>
  real \<Rightarrow> 'a pred \<Rightarrow> 'a nd_fun" ("(1x\<acute>=_ & _ on _ _ @ _ DINV _ )")
  where "(x\<acute>= f & G on T S @ t\<^sub>0 DINV I) = (x\<acute>= f & G on T S @ t\<^sub>0)"

lemma wp_g_orbital_guard:
  assumes "H = (\<lambda>s. G s \<and> Q s)"
  shows "wp (x\<acute>= f & G on T S @ t\<^sub>0) \<lceil>Q\<rceil> = wp (x\<acute>= f & G on T S @ t\<^sub>0) \<lceil>H\<rceil>"
  unfolding wp_g_orbital using assms by auto

lemma wp_g_orbital_inv:
  assumes "\<lceil>P\<rceil> \<le> \<lceil>I\<rceil>" and "\<lceil>I\<rceil> \<le> wp (x\<acute>= f & G on T S @ t\<^sub>0) \<lceil>I\<rceil>" and "\<lceil>I\<rceil> \<le> \<lceil>Q\<rceil>"
  shows "\<lceil>P\<rceil> \<le> wp (x\<acute>= f & G on T S @ t\<^sub>0) \<lceil>Q\<rceil>"
  using assms(1)
  apply(rule order.trans)
  using assms(2)
  apply(rule order.trans)
  apply(rule fbox_iso)
  using assms(3) by auto

lemma wp_diff_inv[simp]: "(\<lceil>I\<rceil> \<le> wp (x\<acute>= f & G on T S @ t\<^sub>0) \<lceil>I\<rceil>) = diff_invariant I f T S t\<^sub>0 G"
  unfolding diff_invariant_eq wp_g_orbital by(auto simp: fun_eq_iff)

lemma diff_inv_guard_ignore:
  assumes "\<lceil>I\<rceil> \<le> wp (x\<acute>= f & (\<lambda>s. True) on T S @ t\<^sub>0) \<lceil>I\<rceil>"
  shows "\<lceil>I\<rceil> \<le> wp (x\<acute>= f & G on T S @ t\<^sub>0) \<lceil>I\<rceil>"
  using assms unfolding wp_diff_inv diff_invariant_eq by auto

context local_flow
begin

lemma wp_diff_inv_eq: "diff_invariant I f T S 0 (\<lambda>s. True) =
  (\<lceil>\<lambda>s. s \<in> S \<longrightarrow> I s\<rceil> = wp (x\<acute>= f & (\<lambda>s. True) on T S @ 0) \<lceil>\<lambda>s. s \<in> S \<longrightarrow> I s\<rceil>)"
  unfolding wp_diff_inv[symmetric] wp_g_orbital
  using init_time
  apply(clarsimp simp: ivp_sols_def)
  apply(safe, force, force)
  apply(subst ivp(2)[symmetric], simp)
  apply(erule_tac x="\<lambda>t. \<phi> t s" in allE)
  using in_domain has_vderiv_on_domain ivp(2) init_time by auto

lemma diff_inv_eq_inv_set:
  "diff_invariant I f T S 0 (\<lambda>s. True) = (\<forall>s. I s \<longrightarrow> \<gamma>\<^sup>\<phi> s \<subseteq> {s. I s})"
  unfolding diff_inv_eq_inv_set orbit_def by auto

end

lemma wp_g_odei: "\<lceil>P\<rceil> \<le> \<lceil>I\<rceil> \<Longrightarrow> \<lceil>I\<rceil> \<le> wp (x\<acute>= f & G on T S @ t\<^sub>0) \<lceil>I\<rceil> \<Longrightarrow> \<lceil>\<lambda>s. I s \<and> G s\<rceil> \<le> \<lceil>Q\<rceil> \<Longrightarrow>
  \<lceil>P\<rceil> \<le> wp (x\<acute>= f & G on T S @ t\<^sub>0 DINV I) \<lceil>Q\<rceil>"
  unfolding g_ode_inv_def
  apply(rule_tac b="wp (x\<acute>= f & G on T S @ t\<^sub>0) \<lceil>I\<rceil>" in order.trans)
   apply(rule_tac I="I" in wp_g_orbital_inv, simp_all)
  apply(subst wp_g_orbital_guard, simp)
  by (rule fbox_iso, simp)

subsection \<open> Derivation of the rules of dL \<close>

text\<open> We derive domain specific rules of differential dynamic logic (dL). First we present a
generalised version, then we show the rules as instances of the general ones.\<close>

lemma diff_solve_axiom:
  fixes c::"'a::{heine_borel, banach}"
  assumes "0 \<in> T" and "is_interval T" "open T"
  shows "wp (x\<acute>=(\<lambda>s. c) & G on T UNIV @ 0) \<lceil>Q\<rceil> =
  \<lceil>\<lambda> s. \<forall>t\<in>T. (\<P> (\<lambda> t. s + t *\<^sub>R c) (down T t) \<subseteq> {s. G s}) \<longrightarrow> Q (s + t *\<^sub>R c)\<rceil>"
  apply(subst local_flow.wp_g_ode[where f="\<lambda>s. c" and \<phi>="(\<lambda> t s. s + t *\<^sub>R c)"])
  using line_is_local_flow[OF assms] by auto

lemma diff_solve_rule:
  assumes "local_flow f T UNIV \<phi>"
    and "\<forall>s. P s \<longrightarrow> (\<forall> t\<in>T. (\<P> (\<lambda>t. \<phi> t s) (down T t) \<subseteq> {s. G s}) \<longrightarrow> Q (\<phi> t s))"
  shows "\<lceil>P\<rceil> \<le> wp (x\<acute>= f & G on T UNIV @ 0) \<lceil>Q\<rceil>"
  using assms by(subst local_flow.wp_g_ode, auto)

lemma diff_weak_axiom:
  "wp (x\<acute>= f & G on T S @ t\<^sub>0) \<lceil>Q\<rceil> = wp (x\<acute>= f & G on T S @ t\<^sub>0) \<lceil>\<lambda> s. G s \<longrightarrow> Q s\<rceil>"
  unfolding wp_g_orbital image_def by force

lemma diff_weak_rule: "\<lceil>G\<rceil> \<le> \<lceil>Q\<rceil> \<Longrightarrow> \<lceil>P\<rceil> \<le> wp (x\<acute>= f & G on T S @ t\<^sub>0) \<lceil>Q\<rceil>"
  by (subst wp_g_orbital) (auto simp: g_ode_def)

lemma wp_g_orbit_IdD:
  assumes "wp (x\<acute>= f & G on T S @ t\<^sub>0) \<lceil>C\<rceil> = \<eta>\<^sup>\<bullet>"
    and "\<forall>\<tau>\<in>(down T t). x \<tau> \<in> g_orbital f G T S t\<^sub>0 s"
  shows "\<forall>\<tau>\<in>(down T t). C (x \<tau>)"
proof
  fix \<tau> assume "\<tau> \<in> (down T t)"
  hence "x \<tau> \<in> g_orbital f G T S t\<^sub>0 s"
    using assms(2) by blast
  also have "\<forall>y. y \<in> (g_orbital f G T S t\<^sub>0 s) \<longrightarrow> C y"
    using assms(1) unfolding wp_nd_fun g_ode_def
    by (subst (asm) nd_fun_eq_iff) auto
  ultimately show "C (x \<tau>)"
    by blast
qed

lemma diff_cut_axiom:
  assumes Thyp: "is_interval T" "t\<^sub>0 \<in> T"
    and "wp (x\<acute>= f & G on T S @ t\<^sub>0) \<lceil>C\<rceil> = \<eta>\<^sup>\<bullet>"
  shows "wp (x\<acute>= f & G on T S @ t\<^sub>0) \<lceil>Q\<rceil> = wp (x\<acute>= f & (\<lambda>s. G s \<and> C s) on T S @ t\<^sub>0) \<lceil>Q\<rceil>"
proof(rule_tac f="\<lambda> x. wp x \<lceil>Q\<rceil>" in HOL.arg_cong, rule nd_fun_ext, rule subset_antisym)
  fix s show "((x\<acute>= f & G on T S @ t\<^sub>0)\<^sub>\<bullet>) s \<subseteq> ((x\<acute>= f & (\<lambda>s. G s \<and> C s) on T S @ t\<^sub>0)\<^sub>\<bullet>) s"
  proof(clarsimp simp: g_ode_def)
    fix s' assume "s' \<in> g_orbital f G T S t\<^sub>0 s"
    then obtain \<tau>::real and X where x_ivp: "X \<in> ivp_sols (\<lambda>t. f) T S t\<^sub>0 s"
      and "X \<tau> = s'" and "\<tau> \<in> T" and guard_x:"(\<P> X (down T \<tau>) \<subseteq> {s. G s})"
      using g_orbitalD[of s' "f" G T S t\<^sub>0 s] by blast
    have "\<forall>t\<in>(down T \<tau>). \<P> X (down T t) \<subseteq> {s. G s}"
      using guard_x by (force simp: image_def)
    also have "\<forall>t\<in>(down T \<tau>). t \<in> T"
      using \<open>\<tau> \<in> T\<close> Thyp by auto
    ultimately have "\<forall>t\<in>(down T \<tau>). X t \<in> g_orbital f G T S t\<^sub>0 s"
      using g_orbitalI[OF x_ivp] by (metis (mono_tags, lifting))
    hence "\<forall>t\<in>(down T \<tau>). C (X t)"
      using wp_g_orbit_IdD[OF assms(3)] by blast
    thus "s' \<in> g_orbital f (\<lambda>s. G s \<and> C s) T S t\<^sub>0 s"
      using g_orbitalI[OF x_ivp \<open>\<tau> \<in> T\<close>] guard_x \<open>X \<tau> = s'\<close> by fastforce
  qed
next
  fix s show "((x\<acute>= f & \<lambda>s. G s \<and> C s on T S @ t\<^sub>0)\<^sub>\<bullet>) s \<subseteq> ((x\<acute>= f & G on T S @ t\<^sub>0)\<^sub>\<bullet>) s"
    by (auto simp: g_orbital_eq g_ode_def)
qed

lemma diff_cut_rule:
  assumes Thyp: "is_interval T" "t\<^sub>0 \<in> T"
    and wp_C: "\<lceil>P\<rceil> \<le> wp (x\<acute>= f & G on T S @ t\<^sub>0) \<lceil>C\<rceil>"
    and wp_Q: "\<lceil>P\<rceil> \<le> wp (x\<acute>= f & (\<lambda>s. G s \<and> C s) on T S @ t\<^sub>0) \<lceil>Q\<rceil>"
  shows "\<lceil>P\<rceil> \<le> wp (x\<acute>= f & G on T S @ t\<^sub>0) \<lceil>Q\<rceil>"
proof(simp add: wp_nd_fun g_orbital_eq g_ode_def, clarsimp)
  fix t::real and X::"real \<Rightarrow> 'a" and s assume "P s" and "t \<in> T"
    and x_ivp:"X \<in> ivp_sols (\<lambda>t. f) T S t\<^sub>0 s"
    and guard_x:"\<forall>x. x \<in> T \<and> x \<le> t \<longrightarrow> G (X x)"
  have "\<forall>t\<in>(down T t). X t \<in> g_orbital f G T S t\<^sub>0 s"
    using g_orbitalI[OF x_ivp] guard_x by auto
  hence "\<forall>t\<in>(down T t). C (X t)"
    using wp_C \<open>P s\<close> by (subst (asm) wp_nd_fun, auto simp: g_ode_def)
  hence "X t \<in> g_orbital f (\<lambda>s. G s \<and> C s) T S t\<^sub>0 s"
    using guard_x \<open>t \<in> T\<close> by (auto intro!: g_orbitalI x_ivp)
  thus "Q (X t)"
    using \<open>P s\<close> wp_Q by (subst (asm) wp_nd_fun) (auto simp: g_ode_def)
qed

text \<open>The rules of dL\<close>

abbreviation g_global_ode ::"(('a::banach)\<Rightarrow>'a) \<Rightarrow> 'a pred \<Rightarrow> 'a nd_fun" ("(1x\<acute>=_ & _)")
  where "(x\<acute>= f & G) \<equiv> (x\<acute>= f & G on UNIV UNIV @ 0)"

abbreviation g_global_ode_inv :: "(('a::banach)\<Rightarrow>'a) \<Rightarrow> 'a pred \<Rightarrow> 'a pred \<Rightarrow> 'a nd_fun"
  ("(1x\<acute>=_ & _ DINV _)") where "(x\<acute>= f & G DINV I) \<equiv> (x\<acute>= f & G on UNIV UNIV @ 0 DINV I)"

lemma DS:
  fixes c::"'a::{heine_borel, banach}"
  shows "wp (x\<acute>=(\<lambda>s. c) & G) \<lceil>Q\<rceil> = \<lceil>\<lambda>x. \<forall>t. (\<forall>\<tau>\<le>t. G (x + \<tau> *\<^sub>R c)) \<longrightarrow> Q (x + t *\<^sub>R c)\<rceil>"
  by (subst diff_solve_axiom[of UNIV]) (auto simp: fun_eq_iff)

lemma solve:
  assumes "local_flow f UNIV UNIV \<phi>"
    and "\<forall>s. P s \<longrightarrow> (\<forall>t. (\<forall>\<tau>\<le>t. G (\<phi> \<tau> s)) \<longrightarrow> Q (\<phi> t s))"
  shows "\<lceil>P\<rceil> \<le> wp (x\<acute>= f & G) \<lceil>Q\<rceil>"
  apply(rule diff_solve_rule[OF assms(1)])
  using assms(2) by simp

lemma DW: "wp (x\<acute>= f & G) \<lceil>Q\<rceil> = wp (x\<acute>= f & G) \<lceil>\<lambda>s. G s \<longrightarrow> Q s\<rceil>"
  by (rule diff_weak_axiom)

lemma DC:
  assumes "wp (x\<acute>= f & G) \<lceil>C\<rceil> = \<eta>\<^sup>\<bullet>"
  shows "wp (x\<acute>= f & G) \<lceil>Q\<rceil> = wp (x\<acute>= f & (\<lambda>s. G s \<and> C s)) \<lceil>Q\<rceil>"
  apply (rule diff_cut_axiom)
  using assms by auto

lemma dC:
  assumes "\<lceil>P\<rceil> \<le> wp (x\<acute>= f & G) \<lceil>C\<rceil>"
    and "\<lceil>P\<rceil> \<le> wp (x\<acute>= f & (\<lambda>s. G s \<and> C s)) \<lceil>Q\<rceil>"
  shows "\<lceil>P\<rceil> \<le> wp (x\<acute>= f & G) \<lceil>Q\<rceil>"
  apply(rule diff_cut_rule)
  using assms by auto

end