(*  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 Main 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 --> Q | R) --> (P-->Q) | (P-->R)"
by blast

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

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

lemma "~ (P = (~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-->Q)  =  (~Q --> ~P)"
by blast

text\<open>2\<close>
lemma "(~ ~ P) =  P"
by blast

text\<open>3\<close>
lemma "~(P-->Q) --> (Q-->P)"
by blast

text\<open>4\<close>
lemma "(~P-->Q)  =  (~Q --> P)"
by blast

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

text\<open>6\<close>
lemma "P | ~ P"
by blast

text\<open>7\<close>
lemma "P | ~ ~ ~ P"
by blast

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

text\<open>9\<close>
lemma "((P|Q) & (~P|Q) & (P| ~Q)) --> ~ (~P | ~Q)"
by blast

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

text\<open>14\<close>
lemma "(P = Q) = ((Q | ~P) & (~Q|P))"
by blast

text\<open>15\<close>
lemma "(P --> Q) = (~P | Q)"
by blast

text\<open>16\<close>
lemma "(P-->Q) | (Q-->P)"
by blast

text\<open>17\<close>
lemma "((P & (Q-->R))-->S)  =  ((~P | Q | S) & (~P | ~R | S))"
by blast

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

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

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

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

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

text\<open>From Wishnu Prasetya\<close>
lemma "(\<forall>s. q(s) --> r(s)) & ~r(s) & (\<forall>s. ~r(s) & ~q(s) --> p(t) | q(t))
    --> p(t) | r(t)"
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)) --> ((\<exists>x. P(x)) = (\<forall>y. P(y)))"
by blast

text\<open>Needs multiple instantiation of the quantifier.\<close>
lemma "(\<forall>x. P(x)-->P(f(x)))  &  P(d)-->P(f(f(f(d))))"
by blast

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

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

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

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

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

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

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

text\<open>Problem 21\<close>
lemma "(\<exists>x. P-->Q(x)) & (\<exists>x. Q(x)-->P) --> (\<exists>x. P=Q(x))"
by blast

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

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

text\<open>Problem 24\<close>
lemma "~(\<exists>x. S(x)&Q(x)) & (\<forall>x. P(x) --> Q(x)|R(x)) &
     (~(\<exists>x. P(x)) --> (\<exists>x. Q(x))) & (\<forall>x. Q(x)|R(x) --> S(x))
    --> (\<exists>x. P(x)&R(x))"
by blast

text\<open>Problem 25\<close>
lemma "(\<exists>x. P(x)) &
        (\<forall>x. L(x) --> ~ (M(x) & R(x))) &
        (\<forall>x. P(x) --> (M(x) & L(x))) &
        ((\<forall>x. P(x)-->Q(x)) | (\<exists>x. P(x)&R(x)))
    --> (\<exists>x. Q(x)&P(x))"
by blast

text\<open>Problem 26\<close>
lemma "((\<exists>x. p(x)) = (\<exists>x. q(x))) &
      (\<forall>x. \<forall>y. p(x) & q(y) --> (r(x) = s(y)))
  --> ((\<forall>x. p(x)-->r(x)) = (\<forall>x. q(x)-->s(x)))"
by blast

text\<open>Problem 27\<close>
lemma "(\<exists>x. P(x) & ~Q(x)) &
              (\<forall>x. P(x) --> R(x)) &
              (\<forall>x. M(x) & L(x) --> P(x)) &
              ((\<exists>x. R(x) & ~ Q(x)) --> (\<forall>x. L(x) --> ~ R(x)))
          --> (\<forall>x. M(x) --> ~L(x))"
by blast

text\<open>Problem 28.  AMENDED\<close>
lemma "(\<forall>x. P(x) --> (\<forall>x. Q(x))) &
        ((\<forall>x. Q(x)|R(x)) --> (\<exists>x. Q(x)&S(x))) &
        ((\<exists>x. S(x)) --> (\<forall>x. L(x) --> M(x)))
    --> (\<forall>x. P(x) & L(x) --> M(x))"
by blast

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

text\<open>Problem 30\<close>
lemma "(\<forall>x. P(x) | Q(x) --> ~ R(x)) &
        (\<forall>x. (Q(x) --> ~ S(x)) --> P(x) & R(x))
    --> (\<forall>x. S(x))"
by blast

text\<open>Problem 31\<close>
lemma "~(\<exists>x. P(x) & (Q(x) | R(x))) &
        (\<exists>x. L(x) & P(x)) &
        (\<forall>x. ~ R(x) --> M(x))
    --> (\<exists>x. L(x) & M(x))"
by blast

text\<open>Problem 32\<close>
lemma "(\<forall>x. P(x) & (Q(x)|R(x))-->S(x)) &
        (\<forall>x. S(x) & R(x) --> L(x)) &
        (\<forall>x. M(x) --> R(x))
    --> (\<forall>x. P(x) & M(x) --> L(x))"
by blast

text\<open>Problem 33\<close>
lemma "(\<forall>x. P(a) & (P(x)-->P(b))-->P(c))  =
     (\<forall>x. (~P(a) | P(x) | P(c)) & (~P(a) | ~P(b) | 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 -->  (\<forall>u v. P u v)"
by blast

text\<open>Problem 36\<close>
lemma "(\<forall>x. \<exists>y. J x y) &
        (\<forall>x. \<exists>y. G x y) &
        (\<forall>x y. J x y | G x y -->
        (\<forall>z. J y z | G y z --> H x z))
    --> (\<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 -->P y w) & P y z & (P y w --> (\<exists>u. Q u w))) &
        (\<forall>x z. ~(P x z) --> (\<exists>y. Q y z)) &
        ((\<exists>x y. Q x y) --> (\<forall>x. R x x))
    --> (\<forall>x. \<exists>y. R x y)"
by blast

text\<open>Problem 38\<close>
lemma "(\<forall>x. p(a) & (p(x) --> (\<exists>y. p(y) & r x y)) -->
           (\<exists>z. \<exists>w. p(z) & r x w & r w z))  =
     (\<forall>x. (~p(a) | p(x) | (\<exists>z. \<exists>w. p(z) & r x w & r w z)) &
           (~p(a) | ~(\<exists>y. p(y) & r x y) |
            (\<exists>z. \<exists>w. p(z) & r x w & r w z)))"
by blast (*beats fast!*)

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

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

text\<open>Problem 41\<close>
lemma "(\<forall>z. \<exists>y. \<forall>x. f x y = (f x z & ~ f x x))
               --> ~ (\<exists>z. \<forall>x. f x z)"
by blast

text\<open>Problem 42\<close>
lemma "~ (\<exists>y. \<forall>x. p x y = (~ (\<exists>z. p x z & 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 = (p z y::bool)))
  --> (\<forall>x. (\<forall>y. q x y = (q y x::bool)))"
by blast

text\<open>Problem 44\<close>
lemma "(\<forall>x. f(x) -->
              (\<exists>y. g(y) & h x y & (\<exists>y. g(y) & ~ h x y)))  &
              (\<exists>x. j(x) & (\<forall>y. g(y) --> h x y))
              --> (\<exists>x. j(x) & ~f(x))"
by blast

text\<open>Problem 45\<close>
lemma "(\<forall>x. f(x) & (\<forall>y. g(y) & h x y --> j x y)
                      --> (\<forall>y. g(y) & h x y --> k(y))) &
     ~ (\<exists>y. l(y) & k(y)) &
     (\<exists>x. f(x) & (\<forall>y. h x y --> l(y))
                & (\<forall>y. g(y) & h x y --> j x y))
      --> (\<exists>x. f(x) & ~ (\<exists>y. g(y) & h x y))"
by blast

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

text\<open>Problem 48\<close>
lemma "(a=b | c=d) & (a=c | b=d) --> a=d | 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 | z=y) & P(a) & P(b) & (~a=b)
                --> (\<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 | (\<forall>y. P x y)) --> (\<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 & y=w)) -->
     (\<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 & y=w)) -->
     (\<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) & lives(butler) & lives(charles) &
   (killed agatha agatha | killed butler agatha | killed charles agatha) &
   (\<forall>x y. killed x y --> hates x y & ~richer x y) &
   (\<forall>x. hates agatha x --> ~hates charles x) &
   (hates agatha agatha & hates agatha charles) &
   (\<forall>x. lives(x) & ~richer x agatha --> hates butler x) &
   (\<forall>x. hates agatha x --> hates butler x) &
   (\<forall>x. ~hates x agatha | ~hates x butler | ~hates x charles) -->
    killed ?who agatha"
by fast

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

text\<open>Problem 57\<close>
lemma "P (f a b) (f b c) & P (f b c) (f a c) &
     (\<forall>x y z. P x y & P y z --> P x z)    -->   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)) --> (\<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) = (~P(f(x)))) --> (\<exists>x. P(x) & ~P(f(x)))"
by blast

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

text\<open>Problem 62 as corrected in JAR 18 (1997), page 135\<close>
lemma "(\<forall>x. p a & (p x --> p(f x)) --> p(f(f x)))  =
      (\<forall>x. (~ p a | p x | p(f(f x))) &
              (~ p a | ~ p(f x) | 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) & ~G(x) --> (\<exists>y. H(x,y) & J(y))) &
       (\<exists>x. K(x) & F(x) & (\<forall>y. H(x,y) --> K(y))) &
       (\<forall>x. K(x) --> ~G(x))  -->  (\<exists>x. K(x) & 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) & ~G(x) --> (\<exists>y. H(x,y) & J(y))) &
       (\<exists>x. K(x) & F(x) & (\<forall>y. H(x,y) --> K(y)))  &
       (\<forall>x. K(x) --> ~G(x))   -->   (\<exists>x. K(x) --> ~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) & industrious(x) --> healthy(x)) &
      ~ (\<exists>x. grocer(x) & healthy(x)) &
      (\<forall>x. industrious(x) & grocer(x) --> honest(x)) &
      (\<forall>x. cyclist(x) --> industrious(x)) &
      (\<forall>x. ~healthy(x) & cyclist(x) --> ~honest(x))
      --> (\<forall>x. grocer(x) --> ~cyclist(x))"
by blast

lemma "(\<forall>x y. R(x,y) | R(y,x)) &
       (\<forall>x y. S(x,y) & S(y,x) --> x=y) &
       (\<forall>x y. R(x,y) --> S(x,y))    -->   (\<forall>x y. S(x,y) --> R(x,y))"
by blast

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

text\<open>Trying out meson with arguments\<close>
lemma "x < y & y < z --> ~ (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) & R(y,z) --> R(x,z)) &
       (\<forall>x. \<exists>y. R(x,y)) -->
       ~ (\<forall>x. P x = (\<forall>y. R(x,y) --> ~ 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 --> Q)  =  (~Q --> ~P)"
by blast

text\<open>2\<close>
lemma "(~ ~ P) =  P"
by blast

text\<open>3\<close>
lemma "~(P-->Q) --> (Q-->P)"
by blast

text\<open>4\<close>
lemma "(~P-->Q)  =  (~Q --> P)"
by blast

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

text\<open>6\<close>
lemma "P | ~ P"
by blast

text\<open>7\<close>
lemma "P | ~ ~ ~ P"
by blast

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

text\<open>9\<close>
lemma "((P|Q) & (~P|Q) & (P| ~Q)) --> ~ (~P | ~Q)"
by blast

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

text\<open>14\<close>
lemma "(P = Q) = ((Q | ~P) & (~Q|P))"
by blast

text\<open>15\<close>
lemma "(P --> Q) = (~P | Q)"
by blast

text\<open>16\<close>
lemma "(P-->Q) | (Q-->P)"
by blast

text\<open>17\<close>
lemma "((P & (Q-->R))-->S)  =  ((~P | Q | S) & (~P | ~R | S))"
by blast

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

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

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

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

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

lemma "(\<forall>x. P x --> P(f x))  &  P d --> P(f(f(f d)))"
by blast

text\<open>Needs double instantiation of EXISTS\<close>
lemma "\<exists>x. P x --> P a & P b"
by blast

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

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

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

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

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

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

text\<open>Problem 21\<close>
lemma "(\<exists>x. P --> Q x) & (\<exists>x. Q x --> P) --> (\<exists>x. P=Q x)"
by blast

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

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

text\<open>Problem 24\<close>  (*The first goal clause is useless*)
lemma "~(\<exists>x. S x & Q x) & (\<forall>x. P x --> Q x | R x) &
      (~(\<exists>x. P x) --> (\<exists>x. Q x)) & (\<forall>x. Q x | R x --> S x)
    --> (\<exists>x. P x & R x)"
by blast

text\<open>Problem 25\<close>
lemma "(\<exists>x. P x) &
      (\<forall>x. L x --> ~ (M x & R x)) &
      (\<forall>x. P x --> (M x & L x)) &
      ((\<forall>x. P x --> Q x) | (\<exists>x. P x & R x))
    --> (\<exists>x. Q x & P x)"
by blast

text\<open>Problem 26; has 24 Horn clauses\<close>
lemma "((\<exists>x. p x) = (\<exists>x. q x)) &
      (\<forall>x. \<forall>y. p x & q y --> (r x = s y))
  --> ((\<forall>x. p x --> r x) = (\<forall>x. q x --> s x))"
by blast

text\<open>Problem 27; has 13 Horn clauses\<close>
lemma "(\<exists>x. P x & ~Q x) &
      (\<forall>x. P x --> R x) &
      (\<forall>x. M x & L x --> P x) &
      ((\<exists>x. R x & ~ Q x) --> (\<forall>x. L x --> ~ R x))
      --> (\<forall>x. M x --> ~L x)"
by blast

text\<open>Problem 28.  AMENDED; has 14 Horn clauses\<close>
lemma "(\<forall>x. P x --> (\<forall>x. Q x)) &
      ((\<forall>x. Q x | R x) --> (\<exists>x. Q x & S x)) &
      ((\<exists>x. S x) --> (\<forall>x. L x --> M x))
    --> (\<forall>x. P x & L x --> 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) & (\<exists>y. G y)
    --> ( ((\<forall>x. F x --> H x) & (\<forall>y. G y --> J y))  =
          (\<forall>x y. F x & G y --> H x & J y))"
by blast

text\<open>Problem 30\<close>
lemma "(\<forall>x. P x | Q x --> ~ R x) & (\<forall>x. (Q x --> ~ S x) --> P x & R x)
       --> (\<forall>x. S x)"
by blast

text\<open>Problem 31; has 10 Horn clauses; first negative clauses is useless\<close>
lemma "~(\<exists>x. P x & (Q x | R x)) &
      (\<exists>x. L x & P x) &
      (\<forall>x. ~ R x --> M x)
    --> (\<exists>x. L x & M x)"
by blast

text\<open>Problem 32\<close>
lemma "(\<forall>x. P x & (Q x | R x)-->S x) &
      (\<forall>x. S x & R x --> L x) &
      (\<forall>x. M x --> R x)
    --> (\<forall>x. P x & M x --> L x)"
by blast

text\<open>Problem 33; has 55 Horn clauses\<close>
lemma "(\<forall>x. P a & (P x --> P b)-->P c)  =
      (\<forall>x. (~P a | P x | P c) & (~P a | ~P b | 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 -->  (\<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) & (\<forall>x. \<exists>y. G x y) &
       (\<forall>x y. J x y | G x y --> (\<forall>z. J y z | G y z --> H x z))
       --> (\<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 --> P y w) & P y z & (P y w --> (\<exists>u. Q u w))) &
      (\<forall>x z. ~P x z --> (\<exists>y. Q y z)) &
      ((\<exists>x y. Q x y) --> (\<forall>x. R x x))
    --> (\<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 & (p x --> (\<exists>y. p y & r x y)) -->
           (\<exists>z. \<exists>w. p z & r x w & r w z))  =
      (\<forall>x. (~p a | p x | (\<exists>z. \<exists>w. p z & r x w & r w z)) &
            (~p a | ~(\<exists>y. p y & r x y) |
             (\<exists>z. \<exists>w. p z & r x w & r w z)))"
by blast

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

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

text\<open>Problem 41\<close>
lemma "(\<forall>z. (\<exists>y. (\<forall>x. f x y = (f x z & ~ f x x))))
      --> ~ (\<exists>z. \<forall>x. f x z)"
by blast

text\<open>Problem 42\<close>
lemma "~ (\<exists>y. \<forall>x. p x y = (~ (\<exists>z. p x z & 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)))
      --> (\<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 --> (\<exists>y. g y & h x y & (\<exists>y. g y & ~ h x y)))  &
       (\<exists>x. j x & (\<forall>y. g y --> h x y))
       --> (\<exists>x. j x & ~f x)"
by blast

text\<open>Problem 45; has 27 Horn clauses; 54-step proof\<close>
lemma "(\<forall>x. f x & (\<forall>y. g y & h x y --> j x y)
            --> (\<forall>y. g y & h x y --> k y)) &
      ~ (\<exists>y. l y & k y) &
      (\<exists>x. f x & (\<forall>y. h x y --> l y)
                & (\<forall>y. g y & h x y --> j x y))
      --> (\<exists>x. f x & ~ (\<exists>y. g y & h x y))"
by blast

text\<open>Problem 46; has 26 Horn clauses; 21-step proof\<close>
lemma "(\<forall>x. f x & (\<forall>y. f y & h y x --> g y) --> g x) &
       ((\<exists>x. f x & ~g x) -->
       (\<exists>x. f x & ~g x & (\<forall>y. f y & ~g y --> j x y))) &
       (\<forall>x y. f x & f y & h x y --> ~j y x)
       --> (\<forall>x. f x --> 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) & (\<exists>x. wolf x) &
       (\<forall>x. fox x \<longrightarrow> animal x) & (\<exists>x. fox x) &
       (\<forall>x. bird x \<longrightarrow> animal x) & (\<exists>x. bird x) &
       (\<forall>x. caterpillar x \<longrightarrow> animal x) & (\<exists>x. caterpillar x) &
       (\<forall>x. snail x \<longrightarrow> animal x) & (\<exists>x. snail x) &
       (\<forall>x. grain x \<longrightarrow> plant x) & (\<exists>x. grain x) &
       (\<forall>x. animal x \<longrightarrow>
             ((\<forall>y. plant y \<longrightarrow> eats x y)  \<or>
              (\<forall>y. animal y & smaller_than y x &
                    (\<exists>z. plant z & eats y z) \<longrightarrow> eats x y))) &
       (\<forall>x y. bird y & (snail x \<or> caterpillar x) \<longrightarrow> smaller_than x y) &
       (\<forall>x y. bird x & fox y \<longrightarrow> smaller_than x y) &
       (\<forall>x y. fox x & wolf y \<longrightarrow> smaller_than x y) &
       (\<forall>x y. wolf x & (fox y \<or> grain y) \<longrightarrow> ~eats x y) &
       (\<forall>x y. bird x & caterpillar y \<longrightarrow> eats x y) &
       (\<forall>x y. bird x & snail y \<longrightarrow> ~eats x y) &
       (\<forall>x. (caterpillar x \<or> snail x) \<longrightarrow> (\<exists>y. plant y & eats x y))
       \<longrightarrow> (\<exists>x y. animal x & animal y & (\<exists>z. grain z & eats y z & 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 & P y z --> P x z) &
       (\<forall>x y z. Q x y & Q y z --> Q x z) &
       (\<forall>x y. P x y --> P y x) &
       (\<forall>x y. P x y | Q x y)
       --> (\<forall>x y. P x y) | (\<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 --> P y z --> P x z) -->
       (\<forall>x y z. Q x y --> Q y z --> Q x z) -->
       (\<forall>x y. Q x y --> Q y x) -->  (\<forall>x y. P x y | Q x y) -->
       (\<forall>x y. P x y) | (\<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 | (\<forall>y. P x y)) --> (\<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)) -->
      ~ (\<exists>w. \<forall>x. F x w = (\<forall>u. F x u --> (\<exists>y. F y u & ~ (\<exists>z. F z u & 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 & lives butler & lives charles &
       (killed agatha agatha | killed butler agatha | killed charles agatha) &
       (\<forall>x y. killed x y --> hates x y & ~richer x y) &
       (\<forall>x. hates agatha x --> ~hates charles x) &
       (hates agatha agatha & hates agatha charles) &
       (\<forall>x. lives x & ~richer x agatha --> hates butler x) &
       (\<forall>x. hates agatha x --> hates butler x) &
       (\<forall>x. ~hates x agatha | ~hates x butler | ~hates x charles) -->
       (\<exists>x. killed x agatha)"
by meson

text\<open>Problem 57\<close>
lemma "P (f a b) (f b c) & P (f b c) (f a c) &
      (\<forall>x y z. P x y & P y z --> P x z)    -->   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 & Q y --> (P v | R w) & (R z --> Q v)"
by blast

text\<open>Problem 59\<close>
lemma "(\<forall>x. P x = (~P(f x))) --> (\<exists>x. P x & ~P(f x))"
by blast

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

text\<open>Problem 62 as corrected in JAR 18 (1997), page 135\<close>
lemma "(\<forall>x. p a & (p x --> p(f x)) --> p(f(f x)))  =
       (\<forall>x. (~ p a | p x | p(f(f x))) &
            (~ p a | ~ p(f x) | p(f(f x))))"
by blast

text\<open>* Charles Morgan's problems *\<close>

lemma
  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) & T x --> T y"
 shows True
proof -
  from a b d have "\<forall>x. T(i x x)" by blast
  from a b c d have "\<forall>x. T(i x (n(n x)))" \<comment>\<open>Problem 66\<close>
    by metis
  from a b c d have "\<forall>x. T(i (n(n x)) x)" \<comment>\<open>Problem 67\<close>
    by meson
      \<comment>\<open>4.9s on griffon. 51061 inferences, depth 21\<close>
  from a b c' d have "\<forall>x. T(i x (n(n x)))"
      \<comment>\<open>Problem 68: not proved.  Listed as satisfiable in TPTP (LCL078-1)\<close>
oops

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


theory MinWeightBasis
  imports NREST.NREST "../../Refine_Foreach"
    "List-Index.List_Index" Matroids.Matroid
begin

abbreviation "sorted_wrt_w w == sorted_wrt (\<lambda>e1 e2. w e1 \<le> w e2)"

locale minWeightBasis = matroid carrier indep for carrier::"'a set" and indep  +
  fixes w :: "'a \<Rightarrow> 'b::{linorder, ordered_comm_monoid_add}"
begin

section \<open>minWeightBasis algorithm\<close>

subsection \<open>Proof that it computes an minimum Basis\<close>

definition minBasis where "minBasis B \<equiv> basis B \<and> (\<forall>B'. basis B' \<longrightarrow> sum w B \<le> sum w B')"

subsubsection \<open>preparation\<close>

fun in_sort_edge where
   "in_sort_edge x [] = [x]"
 | "in_sort_edge x (y#ys) = (if w x \<le> w y then x#y#ys else y# in_sort_edge x ys)"

lemma in_sort_edge: "sorted_wrt (\<lambda>e1 e2. w e1 \<le> w e2) L \<Longrightarrow> sorted_wrt (\<lambda>e1 e2. w e1 \<le> w e2) (in_sort_edge x L)"
  apply(induct L ) by auto

lemma in_sort_edge_distinct: "x \<notin> set L \<Longrightarrow> distinct L \<Longrightarrow> distinct (in_sort_edge x L)"
apply(induct L) by auto

lemma finite_sorted_edge_distinct:
  assumes "finite S"
  obtains L where "distinct L" "sorted_wrt (\<lambda>e1 e2. w e1 \<le> w e2) L" "S = set L"
proof -
  {
    have "\<exists>L.  distinct L \<and> sorted_wrt (\<lambda>e1 e2. w e1 \<le> w e2) L \<and> S = set L"
      using assms
      apply(induct S)
       apply(clarsimp)
      apply(clarsimp)
      subgoal for x L apply(rule exI[where x="in_sort_edge x L"])
        by (auto simp: in_sort_edge in_sort_edge_distinct)
    done
  }
  with that show ?thesis by blast
qed

abbreviation "wsorted == sorted_wrt_w w"

lemma sum_list_map_cons: "sum_list (map w (y # ys)) = w y + sum_list (map w ys)" by auto

lemma exists_greater:
  assumes  len: "length F = length F'"
      and sum: "sum_list (map w F) > sum_list (map w F')"
    shows "\<exists>i<length F. w (F ! i) > w (F' ! i)"
using len sum
proof (induct rule: list_induct2)
  case (Cons x xs y ys)
  show ?case
  proof(cases "w y < w x")
    case True
    then show ?thesis by auto
  next
    case False
    from False Cons(3) have "sum_list (map w ys) < sum_list (map w xs)"
      apply(simp add: sum_list_map_cons)
      by (meson add_mono leD le_less_linear)
    from Cons(2)[OF this] show ?thesis by auto
  qed
qed simp

lemma wsorted_Cons: "wsorted (x#xs) = (wsorted xs & (ALL y:set xs. w x <= w y))"
  by (induct xs arbitrary: x) auto

lemma wsorted_nth_mono: assumes "wsorted L" "i\<le>j" "j<length L"
  shows "w (L!i) \<le> w (L!j)"
  using assms apply (induct L arbitrary: i j rule: list.induct) by (auto simp: nth_Cons' wsorted_Cons)

(**
  limi T g is the set T restricted
     to elements only with weight
    strictly smaller than g.
*)
definition "limi T g == {e. e\<in>T \<and> w e < g}"

lemma limi_subset: "limi T g \<subseteq> T" unfolding limi_def by auto

lemma limi_mono: "A \<subseteq> B \<Longrightarrow> limi A g \<subseteq> limi B g"
unfolding limi_def by auto

(*
  let F be a set of elements
  limi F g is the set F restricted to elements with weight smaller than g
  let E be a set of elements we want to exclude

  no_smallest_element_skipped E F says,
     that going greedyly over (carrier-E), every every element,
     that did not render the akkumulated set dependent, was added to the set F.
*)
definition "no_smallest_element_skipped E F = (\<forall>e\<in>carrier - E. \<forall>g>w e. indep (insert e (limi F g)) \<longrightarrow> (e \<in> limi F g))"

lemma no_smallest_element_skipped_empty[simp]: "no_smallest_element_skipped carrier {}"
  by(auto simp: no_smallest_element_skipped_def)

lemma greedy_approach_leads_to_minBasis: assumes "indep F"
  and "\<forall>e\<in>carrier - F. \<not> indep (insert e F)"
  and "no_smallest_element_skipped {} F"
  shows "minBasis F"
proof (rule ccontr)
  \<comment> \<open>from our assumptions we have that F is a basis\<close>
  from assms have bF: "basis F" using indep_not_basis by blast
  \<comment> \<open>towards a contradiction, assume F is not a minimum Basis\<close>
  assume notmin: "\<not> minBasis F"
  \<comment> \<open>then we can get a smaller Basis B\<close>
  from bF notmin[unfolded minBasis_def] obtain B where bB: "basis B" and sum: "sum w B < sum w F"
    by force
  \<comment> \<open>lets us obtain two sorted lists for the bases F and B\<close>
  from bF basis_finite finite_sorted_edge_distinct
    obtain FL where dF[simp]: "distinct FL" and wF[simp]: "wsorted FL" and sF[simp]: "F = set FL"
    by blast
  from bB basis_finite finite_sorted_edge_distinct
    obtain BL where dB[simp]: "distinct BL" and wB[simp]: "wsorted BL" and sB[simp]: "B = set BL"
      by blast
  \<comment> \<open>as basis F has more total weight than basis B ...\<close>
  from sum have suml: "sum_list (map w BL) < sum_list (map w FL)"
    by(simp add: sum.distinct_set_conv_list[symmetric])
  from bB bF have "card B = card F"
    using basis_card by blast
  then have l: "length FL = length BL"
    by (simp add: distinct_card)
  \<comment> \<open>... there exists an index i such that the ith element of the BL is strictly smaller
      than the ith element of FL \<close>
  from exists_greater[OF (*_ _ _ _*) l suml] obtain i where i: "i<length FL" and gr: "w (BL ! i) < w (FL ! i)"
    by auto
  let ?FL_restricted = "limi (set FL) (w (FL ! i))"

  \<comment> \<open>now let us look at the two independent sets X and Y:
        let X and Y be the set if we take the first i-1 elements of BL
         and the first i elements of FL respectively.
      We want to use the augment property of Matroids in order to show that we must have skipped
      and optimal element, which then contradicts our assumption. \<close>
  let ?X = "take i FL"
  have X_size: "card (set ?X) = i" using i
    by (simp add: distinct_card)
  have X_indep: "indep (set ?X)" using bF
    using indep_iff_subset_basis set_take_subset by force

  let ?Y = "take (Suc i) BL"
  have Y_size: "card (set ?Y) = Suc i" using i l
    by (simp add: distinct_card)
  have Y_indep: "indep (set ?Y)" using bB
    using indep_iff_subset_basis set_take_subset by force

  have "card (set ?X) < card (set ?Y)" using X_size Y_size by simp

  \<comment> \<open>X and Y are independent and X is smaller than Y, thus we can augment X with some element x\<close>
  with Y_indep X_indep
    obtain x where x: "x\<in>set (take (Suc i) BL) - set ?X" and indepX: "indep (insert x (set ?X))"
      using augment by auto

  \<comment> \<open>we know many things about x now, i.e. x weights strictly less than the ith element of FL ...\<close>
  have "x\<in>carrier"  using indepX indep_subset_carrier by blast
  from x have xs: "x\<in>set (take (Suc i) BL)" and xnX: "x \<notin> set ?X" by auto
  from xs have "w x \<le> w (BL ! i)" using wB
    by (metis List.length_take Lists_Thms.nth_take Suc_leI Suc_le_mono dB distinct_Ex1 distinct_take i local.l min_Suc_gt(2) wsorted_nth_mono)
      (* FIXME *)
  then have k: "w x < w (FL ! i)" using gr by auto

  \<comment> \<open>... and that adding x to X gives us an independent set\<close>
  have "?FL_restricted \<subseteq> set ?X"
    unfolding  limi_def apply auto
    by (smt dF i index_nth_id leD leI linorder_linear mem_Collect_eq set_conv_nth set_take_if_index wF wsorted_nth_mono) (* FIXME *)
  have z': "insert x ?FL_restricted \<subseteq> insert x (set ?X)"
    using xnX \<open>?FL_restricted \<subseteq> set (take i FL)\<close> by auto
  from indep_subset[OF indepX z'] have add_x_stay_indep: "indep (insert x ?FL_restricted)" .

  \<comment> \<open>... finally this means that we must have taken the element during our greedy algorithm\<close>
  from \<open>no_smallest_element_skipped {} F\<close> \<open>x\<in>carrier\<close> \<open>w x < w (FL ! i)\<close> add_x_stay_indep
    have "x \<in> ?FL_restricted"  by (auto dest: no_smallest_element_skippedD)
  with \<open>?FL_restricted \<subseteq> set ?X\<close> have "x \<in> set ?X"  by auto

  \<comment> \<open>... but we actually didn't. This finishes our proof by contradiction.\<close>
  with xnX show "False" by auto
qed

lemma assumes createsCycle: "\<not> indep (insert e F)"
       and    I: "no_smallest_element_skipped (E\<union>{e}) F"
       and    sorted: "(\<forall>x\<in>F.\<forall>y\<in>(E\<union>{e}). w x \<le> w y)"
     shows I_preservation1': "no_smallest_element_skipped E F"
  unfolding no_smallest_element_skipped_def
proof (clarsimp)
  fix x g
  assume x: "x \<in> carrier"  "x \<notin> E"  "w x < g"
  assume f: "indep (insert x (limi F g))"
  show "(x \<in> limi F g)"
  proof (cases "x=e")
    case True
    from True have "limi F g = F"
      unfolding limi_def using \<open>w x < g\<close> sorted by fastforce
    with createsCycle f True have "False" by auto
    then show ?thesis by simp
  next
    case False
    show ?thesis
    apply(rule I[THEN no_smallest_element_skippedD, OF _ \<open>w x < g\<close>])
    using x f False
    by (auto simp add: )
  qed
qed

lemma I_preservation2:
    assumes "e \<in> E" "\<forall>e\<in>carrier - E - F. \<not> indep (insert e F)"
    shows  "(\<forall>x\<in>carrier - (E - {e}) - insert e F. \<not> indep (insert x (insert e F)))"
using assms  by (smt Diff_insert Diff_insert2 indep_subset insert_Diff insert_commute subset_insertI)

lemma I_preservation3':
  assumes I: "no_smallest_element_skipped (E\<union>{e}) F"
  shows "no_smallest_element_skipped E (insert e F)"
  unfolding no_smallest_element_skipped_def
proof (clarsimp)
  fix x g
  assume xc: "x \<in> carrier"
  assume x: "x \<notin> E"
  assume wx: "w x < g"
  assume f: "indep (insert x (limi (insert e F) g))"
  show "(x \<in> limi (insert e F) g)"
  proof(cases "x=e")
    case True
    then show ?thesis unfolding limi_def
      using wx by blast
  next
    case False
    have ind: "indep (insert x (limi F g))" apply(rule indep_subset[OF f]) using limi_mono by blast
    have "indep (insert x (limi F g)) \<Longrightarrow> x \<in> limi F g"
      apply(rule I[THEN no_smallest_element_skippedD]) using False xc wx x by auto
    with ind show ?thesis using limi_mono by blast
  qed
qed

definition I_minWeightBasis_fine where
  "I_minWeightBasis_fine == \<lambda>(T,E). indep T
                \<and> T \<subseteq> carrier
                 \<and> E \<subseteq> carrier  \<and> T \<inter> E = {}
                 \<and> (\<forall>x\<in>T.\<forall>y\<in>E. w x \<le> w y)
                \<and> (\<forall>e\<in>carrier-E-T. ~indep (insert e T))
                 \<and> no_smallest_element_skipped E T"

lemma I_minWeightBasis_fineD:
  assumes
   "I_minWeightBasis_fine (T,E)"
 shows"indep T" "\<And>e. e\<in>carrier-E-T \<Longrightarrow> ~indep (insert e T)"
    "E \<subseteq> carrier" "\<And>x y. x\<in>T \<Longrightarrow> y\<in>E \<Longrightarrow> w x \<le> w y" "T \<inter> E = {}" "T \<subseteq> carrier"
    "no_smallest_element_skipped E T"
  using assms by(auto simp: no_smallest_element_skipped_def I_minWeightBasis_fine_def)

lemma I_minWeightBasis_fineI:
  assumes "indep T" "\<And>e. e\<in>carrier-E-T \<Longrightarrow> ~indep (insert e T)"
    "E \<subseteq> carrier" "\<And>x y. x\<in>T \<Longrightarrow> y\<in>E \<Longrightarrow> w x \<le> w y" "T \<inter> E = {}" "T \<subseteq> carrier"
    "no_smallest_element_skipped E T"
  shows "I_minWeightBasis_fine (T,E)"
  using assms by(auto simp: no_smallest_element_skipped_def I_minWeightBasis_fine_def)

lemma I_minWeightBasis_fineG: "I_minWeightBasis_fine (T,E) \<Longrightarrow> no_smallest_element_skipped E T" by(auto simp: no_smallest_element_skipped_def I_minWeightBasis_fine_def)

lemma I_minWeightBasis_sorted: "I_minWeightBasis_fine (T,E) \<Longrightarrow> (\<forall>x\<in>T.\<forall>y\<in>E. w x \<le> w y)" by(auto simp: no_smallest_element_skipped_def I_minWeightBasis_fine_def)

end

locale minWeightBasis_time = minWeightBasis +
  fixes sorted_carrier_time :: nat
    and  empty_basis_time indep_test_time insert_time :: nat
begin
subsection \<open>Refinement to an algorithm using sorted lists\<close>

  definition (in -) "obtain_sorted_carrier_aux sct c w \<equiv> SPECT (emb (\<lambda>L. sorted_wrt_w w L \<and> distinct L \<and> set L = c) sct)"

  abbreviation "obtain_sorted_carrier \<equiv> obtain_sorted_carrier_aux sorted_carrier_time carrier w"

section \<open>minWeightBasis algorithm with nfoldi\<close>

abbreviation "empty_basis \<equiv> {}"

definition (in -) minWeightBasis3_aux where
  "minWeightBasis3_aux osc_t c we ebt itt it ind eb \<equiv> do {
        l \<leftarrow> obtain_sorted_carrier_aux osc_t c we ;
        ASSERT (set l = c);
        s \<leftarrow> SPECT [eb\<mapsto>ebt];
        T \<leftarrow> nfoldli l (\<lambda>_. True)
        (\<lambda>e T. do {
            ASSERT (e\<notin>T \<and> ind T \<and> e\<in>c \<and> T\<subseteq>c);
            b \<leftarrow> SPECT [ind (insert e T) \<mapsto> itt];
            if b then
              SPECT [(insert e T)\<mapsto>it]
            else
              RETURNT T
        }) s;
        RETURNT T
      }"

abbreviation "minWeightBasis3 \<equiv> minWeightBasis3_aux sorted_carrier_time carrier w empty_basis_time
                                     indep_test_time insert_time indep empty_basis"

lemma I_minWeightBasis_fine_empty: "I_minWeightBasis_fine ({}, carrier)"
  by (auto simp: I_minWeightBasis_fine_def)

lemma I_minWeightBasis_fine_final: "I_minWeightBasis_fine (T, {}) \<Longrightarrow> minBasis T"
  by(auto simp: greedy_approach_leads_to_minBasis I_minWeightBasis_fine_def)

lemma preservation_else: "set x = carrier \<Longrightarrow>
    x = l1 @ xa # l2 \<Longrightarrow> I_minWeightBasis_fine (\<sigma>, set (xa # l2))
     \<Longrightarrow> indep \<sigma>   \<Longrightarrow> \<not> indep (insert xa \<sigma>) \<Longrightarrow> I_minWeightBasis_fine (\<sigma>, set l2)"
  apply(rule I_minWeightBasis_fineI)
  subgoal by simp
  subgoal by (auto simp: DiffD2 I_minWeightBasis_fine_def)
  subgoal by auto
  subgoal by(auto simp: I_minWeightBasis_fine_def)
  subgoal by(auto simp: I_minWeightBasis_fine_def)
  subgoal by(auto simp: I_minWeightBasis_fine_def)
  subgoal apply (rule I_preservation1')
    by(auto intro!:  simp: I_minWeightBasis_fine_def)
  done

lemma I_preservation2':
  assumes "e \<in> E" "\<forall>e\<in>carrier - E - F. \<not> indep (insert e F)"
    and "x\<in>carrier - (E - {e}) - insert e F"
    shows  "\<not> indep (insert x (insert e F))"
  using assms I_preservation2 by auto

lemma preservation_if: "wsorted x \<Longrightarrow> distinct x \<Longrightarrow> set x = carrier \<Longrightarrow>
    x = l1 @ xa # l2 \<Longrightarrow> I_minWeightBasis_fine (\<sigma>, set (xa # l2)) \<Longrightarrow> True \<Longrightarrow> xa \<notin> \<sigma>
   \<Longrightarrow> xa \<in> carrier \<Longrightarrow> indep (insert xa \<sigma>) \<Longrightarrow> I_minWeightBasis_fine (insert xa \<sigma>, set l2)"
  apply(rule I_minWeightBasis_fineI)
  subgoal by simp
  subgoal unfolding I_minWeightBasis_fine_def apply(rule I_preservation2'[where E="set (xa # l2)"])
    by simp_all
  subgoal by auto
  subgoal by (metis insert_iff list.set(2) I_minWeightBasis_sorted sorted_wrt_append wsorted_Cons)
  subgoal by(auto simp: I_minWeightBasis_fine_def)
  subgoal by(auto simp: I_minWeightBasis_fine_def)
  subgoal apply (rule I_preservation3')
    by(auto intro!:  simp: I_minWeightBasis_fine_def)
  done

definition "minBasis_time = sorted_carrier_time +  empty_basis_time
             +  card carrier * (indep_test_time + insert_time)"

lemma le_Id: "M \<le> M' \<Longrightarrow> M \<le> \<Down> Id M'"
  by auto

theorem minWeightBasis3_refine: "minWeightBasis3 \<le> \<Down> Id (SPECT (emb minBasis minBasis_time))"
  unfolding minWeightBasis3_aux_def obtain_sorted_carrier_aux_def
  unfolding nfoldliIE_def[where E="indep_test_time + insert_time" and I="\<lambda>l1 l2 s. I_minWeightBasis_fine (s,set l2)", symmetric]
  apply(rule le_Id)
  apply(rule T_specifies_I)
  unfolding nfoldliIE'_def[symmetric]
  apply(vcg' \<open>-\<close> rules: nfoldliIE'_rule  )
  unfolding Some_le_emb'_conv
       apply (safe)
  oops

lemmas f = nfoldliIE_rule[where  t="card carrier * (indep_test_time + insert_time)" and
                    P="\<lambda>T. I_minWeightBasis_fine (T, {})", THEN T_specifies_rev, THEN T_conseq4]
theorem minWeightBasis3_refine: "minWeightBasis3 \<le> \<Down> Id (SPECT (emb minBasis minBasis_time))"
  unfolding minWeightBasis3_aux_def obtain_sorted_carrier_aux_def
  unfolding nfoldliIE_def[where E="indep_test_time + insert_time" and I="\<lambda>l1 l2 s. I_minWeightBasis_fine (s,set l2)", symmetric]
  apply(rule le_Id)
    apply(rule T_specifies_I)
  apply(vcg' \<open>-\<close> rules: f )

  subgoal by (auto simp: I_minWeightBasis_fine_empty)
  subgoal (* loop body *)
    apply(rule T_specifies_I)
    apply(vcg' \<open>-\<close> rules: f )
      apply(simp_all add: Some_le_emb'_conv )

    subgoal apply(rule preservation_if) by (auto dest!: I_minWeightBasis_fineD(5))
    subgoal apply(rule preservation_else) by (auto dest!: I_minWeightBasis_fineD(1))

    (* asserts *)
    subgoal by (auto      simp: I_minWeightBasis_fine_def)
    done
  subgoal by simp
  subgoal by simp

  subgoal by (auto  simp:  distinct_card Some_le_emb'_conv )
  subgoal by (auto  simp: I_minWeightBasis_fine_final minBasis_time_def vcg_simp_rules)
  subgoal by auto
  done

end

end


theory Original
  imports Defs
begin

section \<open>Defs and preleminaries/auxillary lemmas\<close>
subsection \<open>local defs\<close>
text \<open>since the definition of the language (lang dfa) uses states and not only words, we also need to argue about
states, which we therefore track by extending our word definition.\<close>
inductive word_rec_states :: "state list \<Rightarrow> state \<Rightarrow> DFA \<Rightarrow> word \<Rightarrow> bool" where
empty:  "q \<in> (Q dfa) \<Longrightarrow> word_rec_states [] q dfa ''''" |
step: "\<lbrakk>word_rec_states qs q' dfa w ;c \<in> (\<Sigma> dfa); p \<in> (Q dfa); (\<delta> dfa) q' c = p\<rbrakk> \<Longrightarrow>  word_rec_states (qs@[q']) p dfa (w@[c])" |
back_step: "\<lbrakk>word_rec_states qs q' dfa w ;c \<in> (\<Sigma> dfa); p \<in> (Q dfa); (\<delta> dfa) p c = hd (qs@[q'])\<rbrakk> \<Longrightarrow>  word_rec_states (p#qs) q' dfa (c#w)"

fun repeat :: "'a list \<Rightarrow> nat \<Rightarrow> 'a list" where
  0: "repeat v 0 = []" |
  i: "repeat v i = repeat v (i-1) @ v"

subsection \<open>auxiliary lemmas\<close>
lemma wordl_eq_statesl: "word_rec_states qs p dfa w \<Longrightarrow> length qs = length w"
proof (induction rule: word_rec_states.induct)
  case (empty q dfa)
  then show ?case by simp
next
  case (step qs q' dfa w c p)
  then show ?case by simp
next
  case (back_step qs q' dfa w c p)
  then show ?case by simp
qed

text \<open>show that word implies word_rec_states and vice versa\<close>
lemma word_imp_rec:  "word q p dfa w \<Longrightarrow> \<exists>qs. word_rec_states (qs) p dfa w \<and> hd (qs@[p]) = q"
proof (induction rule: word.induct)
  case (empty q dfa)
  then show ?case using word_rec_states.empty by fastforce
next
  case (step q q' dfa w c p)
  then show ?case using word_rec_states.step using hd_append2 by blast
next
  case (back_step q q' dfa w c p)
  then show ?case using word_rec_states.back_step
    by (metis hd_append2 list.distinct(1) list.sel(1))
qed

lemma rec_imp_word:  "word_rec_states (qs) p dfa w \<Longrightarrow>word (hd (qs@[p])) p dfa w"
proof (induction rule: word_rec_states.induct)
  case (empty q dfa)
  then show ?case using word.empty by simp
next
  case (step qs q' dfa w c p)
  then show ?case using word.step
    by (metis hd_append2 snoc_eq_iff_butlast)
next
  case (back_step qs q' dfa w c p)
  then show ?case by (simp add: word.back_step)
qed

text \<open>show that all states referred to in the state list (qs) and final state (p) of word_rec_states
are indeed states of the dfa (\<in> (Q dfa))\<close>
lemma state_of_Q: "\<lbrakk>word_rec_states qs p dfa w\<rbrakk> \<Longrightarrow> \<forall>q \<in> (set qs) \<union> {p} . q \<in> (Q dfa)"
proof (induction rule: word_rec_states.induct)
  case (empty q dfa)
  then show ?case by simp
next
  case (step qs q' dfa w c p)
  then show ?case
    by (metis Un_iff empty_set list.simps(15) set_append singletonD)
next
  case (back_step qs q' dfa w c p)
  then show ?case by simp
qed

lemma hd_drop: "i < length l \<Longrightarrow> hd (drop i l) = nth l i"
proof (induction l)
  case Nil
  then show ?case by simp
next
  case (Cons a l)
  then show ?case using hd_drop_conv_nth by blast
qed

text \<open>aux lemma for the next one\<close>
lemma not_distinct: "\<lbrakk>finite M; (set l) \<subseteq> M ; length l > card M\<rbrakk> \<Longrightarrow> \<not> distinct l"
proof
  assume 0: "finite M"
  assume 1: "(set l) \<subseteq> M"
  assume 2: "length l > card M"
  assume 3: "distinct l"
  have "card M \<ge> card (set l)" using "0" "1" card_mono by blast
  also have "card (set l) = length l" using distinct_card using "3" by blast
  also have "length l > card M" using 2 by blast
  then show "False" using calculation leD by blast
qed

text \<open>for the purpose of showing that if qs is longer than the cardianlity of Q, there must be two equal states in qs\<close>
corollary i_j: "\<lbrakk>finite M; (set l) \<subseteq> M ; length l > card M\<rbrakk> \<Longrightarrow> \<exists>i j. i\<ge>0 \<and> i<j \<and> j<length l \<and> l ! i = l!j"
  by (metis distinct_conv_nth not_distinct not_less_iff_gr_or_eq zero_le)

text \<open>show that sub paths in a path/word are still valid paths in the dfa\<close>
lemma take_word_rec_states: "\<lbrakk>word_rec_states sts s dfa w; i\<le>length w\<rbrakk> \<Longrightarrow> word_rec_states (take i (sts@[s])) ((sts@[s]) ! i) dfa (take i w)"
proof (induction arbitrary: i rule: word_rec_states.induct)
  case (empty q dfa)
  then show ?case using word_rec_states.empty by auto
next
  case (step qs q' dfa w c p)
  then show ?case
  proof (cases "i>length w")
    let ?qs = "((qs @ [q']) @ [p])"
    case True
    then show ?thesis
      by (metis (no_types, lifting) Suc_leI antisym butlast_snoc le_imp_less_Suc length_append_singleton nth_append_length step.hyps(1) step.hyps(2) step.hyps(3) step.hyps(4) step.prems take_all_iff take_butlast word_rec_states.step wordl_eq_statesl)
  next
    case False
    then show ?thesis
      by (metis (no_types, lifting) butlast_snoc length_append_singleton less_Suc_eq_le not_less_eq nth_append step.IH step.hyps(1) step.prems take_butlast wordl_eq_statesl)
  qed
next
  case (back_step qs q' dfa w c p)
  then show ?case
  proof (cases "i<1")
    case True
    then show ?thesis by (simp add: back_step.hyps(3) word_rec_states.empty)
  next
    case False
    have take: "take i ((p # qs) @ [q']) = [p] @ take (i-1) (qs@[q'])"
      by (metis Cons_eq_appendI False add_diff_inverse_nat append_Nil plus_1_eq_Suc take_Suc_Cons)
    have bang:"((p # qs) @ [q']) ! i = (qs@[q']) ! (i-1)" using False by auto
    have c:"take i (c # w) = c#(take (i-1) w)" by (metis False less_one take_Cons')
    have i: "(i-1)\<le>length w" using back_step.prems by auto
    then have w_im1: "word_rec_states (take (i-1) (qs @ [q'])) ((qs @ [q']) ! (i-1)) dfa (take (i-1) w)"
      using take bang c back_step.IH by blast
    let ?qstake =  "(take (i-1) (qs @ [q']))"
    let ?qsi = "((qs @ [q']) ! (i-1))"
    let ?wtake = "(take (i-1) w)"
    have "hd ((take (i - 1) (qs @ [q'])) @ [(qs @ [q']) ! (i - 1)]) = hd (qs @ [q'])"
      by (metis append_Nil hd_append2 hd_conv_nth hd_take list.sel(1) neq0_conv snoc_eq_iff_butlast take_eq_Nil2)
    then have "\<delta> dfa p c = hd ((take (i - 1) (qs @ [q'])) @ [(qs @ [q']) ! (i - 1)])"
      using back_step.hyps(4) by presburger
    then have "word_rec_states (p#?qstake) ?qsi dfa (c#?wtake)"
      using back_step.hyps(2) back_step.hyps(3) w_im1 word_rec_states.back_step by blast
    then show ?thesis
      by (metis Cons_eq_appendI append_Nil bang c take)
 qed
qed

lemma drop_word_rec_states: "\<lbrakk>word_rec_states sts s dfa w; i\<le>length w\<rbrakk> \<Longrightarrow> word_rec_states (butlast (drop i (sts@[s]))) (last (sts@[s])) dfa (drop i w)"
proof (induction arbitrary: i rule: word_rec_states.induct)
  case (empty q dfa)
  then show ?case by (simp add: word_rec_states.empty)
next
  case (step qs q' dfa w c p)
  then show ?case
  proof (cases "i\<le>length w")
    case True
    have "word_rec_states (butlast (drop i ((qs @ [q']) @ [p]))) (last ((qs @ [q']) @ [p])) dfa (drop i (w @ [c]))
    = word_rec_states (drop i (qs) @ [q']) p dfa (drop i (w) @ [c])"
      by (metis (no_types, lifting) True butlast_snoc diff_is_0_eq' drop0 drop_append drop_butlast last_snoc step.hyps(1) wordl_eq_statesl)
    also have "word_rec_states (drop i (qs) @ [q']) p dfa (drop i (w) @ [c])"
      using word_rec_states.step
      by (metis True butlast_snoc drop_butlast last_snoc step.IH step.hyps(2) step.hyps(3) step.hyps(4))
    then show ?thesis using calculation by blast
  next
    case False
    have "i>length w" using False step.prems by auto
    then show ?thesis
      using not_less_eq step.hyps(1) step.hyps(3) step.prems word_rec_states.empty wordl_eq_statesl by fastforce
 qed
next
  case (back_step qs q' dfa w c p)
  then show ?case
  proof (cases "i>1")
    show ?thesis
      by (metis Cons_eq_appendI back_step.hyps(1) back_step.hyps(2) back_step.hyps(3) back_step.hyps(4) back_step.prems butlast_snoc diff_diff_left diff_is_0_eq drop_Cons' last_snoc length_Cons local.back_step(5) plus_1_eq_Suc word_rec_states.back_step)
  next
    case False
    then show ?thesis
      by (metis Cons_eq_appendI One_nat_def back_step.hyps(1) back_step.hyps(2) back_step.hyps(3) back_step.hyps(4) butlast_snoc diff_Suc_1 drop0 drop_Cons' last_snoc less_one not_less_iff_gr_or_eq word_rec_states.back_step)
  qed
qed

text \<open>show append property of paths/subwords\<close>
lemma append_word_rec_states: "\<lbrakk>word_rec_states qs q dfa w; word_rec_states (q#ps) p dfa w'\<rbrakk> \<Longrightarrow> (word_rec_states (qs@(q#ps)) p dfa (w@w'))"
proof (induction arbitrary: ps p w' rule: word_rec_states.induct)
  case (empty q dfa)
  then show ?case by simp
next
  case (step qs q dfa w c p')
  have rule: "word_rec_states (q # p' # ps) p dfa (c#w') \<Longrightarrow> word_rec_states (qs @ q # p' # ps) p dfa (w @ c#w')"
    using step.IH by simp
  have "q \<in> Q dfa" using state_of_Q step.hyps(1) by auto
  have " \<delta> dfa q c = hd (p' # ps)" by (simp add: step.hyps(4))
  then have "word_rec_states (q # (p' # ps)) p dfa (c#w')"
    by (simp add: \<open>q \<in> Q dfa\<close> step.hyps(2) word_rec_states.back_step step.prems)
  then show ?case using rule by simp
next
  case (back_step qs q' dfa w c p')
  then show ?case
    by (metis (no_types, lifting) append_Cons append_is_Nil_conv hd_append2 list.sel(1) self_append_conv2 word_rec_states.back_step)
qed

text \<open>extend append property to allquantor in the case that the path starts with the same state it
ended with, to at some point show that uv^iw is a valid word for all i.\<close>
lemma loop_states: "\<lbrakk>length qs > 0;word_rec_states qs q dfa w; hd qs = q; i \<ge> 0\<rbrakk> \<Longrightarrow> word_rec_states (repeat qs i) q dfa (repeat w i)"
proof (induction i)
  case 0
  then show ?case using state_of_Q word_rec_states.empty by simp
next
  case (Suc i)
  have wrs_repeat: "word_rec_states (repeat qs i) q dfa (repeat w i)"
    using Suc.IH Suc.prems by blast
  from \<open>hd qs = q\<close> obtain qs' where qs':"qs= (q#qs')"
    by (metis Cons_nth_drop_Suc Suc.prems(1) drop0 hd_conv_nth length_greater_0_conv)
  then have wrs_qs': "word_rec_states (q#qs') q dfa w" using Suc.prems(2) by blast
  have eq: "word_rec_states (repeat qs (Suc i)) q dfa (repeat w (Suc i)) =
       word_rec_states  ((repeat qs i)@(q#qs')) q dfa ((repeat w i)@w)" using qs' by simp
  have "word_rec_states  ((repeat qs i)@(q#qs')) q dfa ((repeat w i)@w)"
    using append_word_rec_states wrs_qs' wrs_repeat by simp
  then show ?case using eq by blast
qed

text \<open>repeat for prepending instead of appending\<close>
lemma repeat_rev: "i>0 \<Longrightarrow>repeat v i = v @ repeat v (i-1)"
proof (induction i)
  case 0
  then show ?case by simp
next
  case (Suc i)
  then show ?case
    by (metis append.assoc append.right_neutral append_self_conv2 bot_nat_0.not_eq_extremum diff_Suc_1 nat.discI repeat.elims)
qed

section \<open>pumping lemma\<close>
text \<open>pumping lemma based on
https://teaching.model.in.tum.de/2022ss/theo/handout.pdf theorem 3.32 pumping lemma for regular
langauges\<close>
theorem pumping_lemma:
  assumes  "Q_\<Sigma>_finite (dfa::DFA)"
      and "\<delta>_total_on_Q_\<Sigma> dfa"
      and "q\<^sub>0_in_Q dfa"
      and "F_sub_Q dfa"
    shows "\<exists>n::nat>0. \<forall>z \<in> (lang dfa). length z \<ge> n \<longrightarrow> (
        \<exists> u v w. z = u@v@w \<and>
        v \<noteq> '''' \<and>
        length (u@v) \<le> n \<and>
        (\<forall>i::nat. (u@(repeat v i)@w) \<in> (lang dfa))
)"
proof -
  text \<open> pick n such that n = cardinality of Q and therefore first show that card Q > 0\<close>
  from assms(3) have "card (Q dfa) > 0"
    using Q_\<Sigma>_finite_def assms(1) card_gt_0_iff q\<^sub>0_in_Q_def by auto
  then obtain n where n: "card (Q dfa) = n \<and> n > 0" by blast
  text \<open>show the implication with our picked n for arbitrary but fixed z \<close>
  have z: "(\<forall>z. z\<in>lang dfa \<and> n \<le> length z \<longrightarrow> (\<exists>u v w. z = u @ v @ w \<and> v \<noteq> [] \<and> length (u @ v) \<le> n \<and> (\<forall>i. u @ repeat v i @ w \<in> lang dfa)))"
  proof (intro allI)
    fix z
    show "z\<in>lang dfa \<and> n \<le> length z \<longrightarrow> (\<exists>u v w. z = u @ v @ w \<and> v \<noteq> [] \<and> length (u @ v) \<le> n \<and> (\<forall>i. u @ repeat v i @ w \<in> lang dfa))"
    proof (cases "z\<in>lang dfa \<and> n \<le> length z")
      case True
      text \<open>proof that u v w = z exist and fulfill the requirements if the precondition is True\<close>
      then obtain m where m: "length z = m \<and> m\<ge>n" by blast
      have "(\<exists>u v w. z = u @ v @ w \<and> v \<noteq> [] \<and> length (u @ v) \<le> n \<and> (\<forall>i. u @ repeat v i @ w \<in> lang dfa))"
      proof -
        text \<open>reconstruct the state path from z\<close>
        obtain qs q where qs_q: "word_rec_states qs q dfa z \<and> hd (qs@[q]) = q\<^sub>0 dfa \<and> q \<in> F dfa" using word_imp_rec True by fastforce
        let ?qs = "(qs@[q])"
        have qs_q_length: "length ?qs = m+1" using wordl_eq_statesl qs_q m by fastforce
        then have qs_q_l_n: "n\<le>length z" using m by simp
        subsubsection \<open>cut n+1 states in of ?qs to guarantee |uv| \<le> n\<close>
        text \<open>cut off qs@[q] at n+1 for |uv| \<le> n (to get a word with length \<le> n).
        We split into qs'@[q'] and gw, where gw stands for guarantied w, which means these states
        only compute the tail of w and qs'@[q'] could compute u v and the head (front part) of w \<close>
        then obtain qs' q' Wqs'q' where qs'_q'_Wqs'q':"qs'=take n ?qs \<and> q' = ?qs ! n \<and> Wqs'q' = take n z \<and> word_rec_states qs' q' dfa Wqs'q'"
          using qs_q take_word_rec_states by simp
        let ?qs' = "(qs'@[q'])"
        have "length ?qs' = n+1" using qs_q_length m
          by (metis Suc_eq_plus1 add_diff_cancel_right' append_take_drop_id diff_diff_cancel length_append length_append_singleton length_drop qs'_q'_Wqs'q' wordl_eq_statesl)
        then obtain gwqs gwq gw where gwqs_gwq_Wgwqsgwq: "gwqs = butlast (drop n ?qs) \<and> gwq = last ?qs \<and> gw = drop n z \<and>  word_rec_states gwqs gwq dfa gw"
          using drop_word_rec_states qs_q qs_q_l_n by presburger
        then have "Wqs'q'@gw=z" using append_take_drop_id qs'_q'_Wqs'q' by blast
        from qs'_q'_Wqs'q' qs_q_length m have "length ?qs' = n+1" by simp
        then have qs'q'_length: "length ?qs' > card (Q dfa)" using n by simp
        also have qs'q'_sub_Q: "set ?qs' \<subseteq> Q dfa" using qs'_q'_Wqs'q' state_of_Q by auto
        text \<open>Now ?qs' is exactly one longer than the cardinality of Q and we therefore can
        find equal states Pi and Pj to loop over and obtain u and v after wards, such that |uv| \<le> n\<close>
        obtain i j where i_j: "0\<le>i \<and> i<j \<and> j < length ?qs' \<and> ?qs' ! i = ?qs' ! j"
          using i_j assms qs'q'_sub_Q qs'q'_length Q_\<Sigma>_finite_def by metis
        subsubsection \<open>Cut into u v w\<close>
        text \<open> We cut ?qs' accordingly int u v w, where v is a loop that can be used l times, where l\<ge>0 and
          uv^lw \<in> (lang dfa). To make correct use of our append_word_rec_states lemma we therefore
          need to make ?qs'[i] the last state of u and the first of v and ?qs'[j] the last state of v and the first
          of fw where fw is the possible first part of w that could still be in ?qs'\<close>
        then obtain uqs uq u where u:"uqs=take i ?qs' \<and> uq = ?qs' ! i \<and> u = take i Wqs'q' \<and> word_rec_states uqs uq dfa u"
          by (metis length_append_singleton less_Suc_eq_le order_less_trans qs'_q'_Wqs'q' take_word_rec_states wordl_eq_statesl)
        obtain vfwqs vfwq vfw where vfw: "vfwqs= butlast (drop i ?qs') \<and> vfwq = last ?qs' \<and> vfw = drop i Wqs'q' \<and> word_rec_states vfwqs vfwq dfa vfw"
          by (metis (no_types, lifting) drop_word_rec_states length_append_singleton less_Suc_eq_le local.i_j order_less_trans qs'_q'_Wqs'q' wordl_eq_statesl)
        let ?vfwqs = "vfwqs@[vfwq]"
        have "u@vfw@gw=z" by (metis \<open>Wqs'q' @ gw = z\<close> u append.assoc append_take_drop_id vfw)
        let ?j="(j-i)"
        have j:"?j < length ?vfwqs" using last_drop local.i_j vfw by auto
        then obtain vqs vq v where v: "vqs= take ?j ?vfwqs \<and> vq = ?vfwqs ! ?j \<and> v = take ?j vfw \<and> word_rec_states vqs vq dfa v"
          by (metis length_append_singleton less_Suc_eq_le take_word_rec_states vfw wordl_eq_statesl)
        text \<open>as a corollary we can show now the condition v\<noteq>'''' because i and j are not equal,
        and therefore |vqs@[vq]|\<ge>2/|vqs|\<ge>1 and hence v cannot be empty by wordl_eq_statesl\<close>
        then have "v\<noteq>''''"
          by (metis j diff_is_0_eq leD length_append_singleton list.size(3) local.i_j not_less_eq take_eq_Nil vfw wordl_eq_statesl zero_less_diff)
        have hd_eq_last_v: "hd vqs = vq"
        proof -
          have "?vfwqs = drop i ?qs'" using local.i_j vfw by auto
          then have "?vfwqs ! ?j = ?qs' ! j "
            by (metis (full_types) le_add_diff_inverse less_or_eq_imp_le local.i_j nth_drop order_less_trans)
          also have "hd ?vfwqs = ?qs' ! i"
            by (metis \<open>vfwqs @ [vfwq] = drop i (qs' @ [q'])\<close> hd_drop local.i_j order_less_trans)
          then show ?thesis
            by (metis calculation hd_take local.i_j v zero_less_diff)
        qed
        obtain fwqs fwq fw where fw: "fwqs = butlast (drop ?j ?vfwqs) \<and> fwq = last ?vfwqs \<and> fw = drop ?j vfw \<and> word_rec_states fwqs fwq dfa fw"
          by (metis drop_word_rec_states j length_append_singleton less_Suc_eq_le vfw wordl_eq_statesl)
        text \<open>put together the front part and the tail part of w\<close>
        let ?w = "(fw@gw)"
        let ?wqs = "fwqs@gwqs"
        let ?wq = "gwq"
        have w: "word_rec_states ?wqs ?wq dfa ?w"
        proof (cases gwqs)
          case Nil
          then show ?thesis
            by (metis add.right_neutral append.right_neutral drop_eq_Nil fw gwqs_gwq_Wgwqsgwq last_snoc le_add_diff_inverse length_drop list.size(3) nth_append_length qs'_q'_Wqs'q' qs_q vfw wordl_eq_statesl m)
        next
          case (Cons a list)
          then show ?thesis
            by (metis append_butlast_last_id append_word_rec_states drop_eq_Nil fw gwqs_gwq_Wgwqsgwq hd_append2 hd_drop last_snoc le_imp_less_Suc length_append_singleton list.distinct(1) list.sel(1) not_less_eq_eq qs'_q'_Wqs'q' qs_q vfw wordl_eq_statesl m)
        qed
        text \<open>after we cut u v and ?w and its states check that u v and ?w form still z and are
        correct obtained\<close>
        have "u@v@?w=z" by (metis \<open>u @ vfw @ gw = z\<close> append.assoc append_take_drop_id v fw)
        have hd_fwqsfwq: "hd (fwqs@[fwq]) = vq" by (metis append_butlast_last_id drop_eq_Nil fw hd_drop j last_drop linorder_not_le v)
        text \<open>finally for the split we can conclude that |uv|\<le>n\<close>
        have length_uv_n: "length (u@v) \<le> n"
        proof -
          have l_u_vfw: "length (u@vfw) < length ?qs'"
            by (metis append_take_drop_id length_append_singleton lessI qs'_q'_Wqs'q' u vfw wordl_eq_statesl)
          have "length (u@v) < length ?qs'" using v l_u_vfw by auto
          then show ?thesis using \<open>length (qs' @ [q']) = n + 1\<close> by presburger
        qed
        subsubsection \<open>show u@(repeat l v)@w \<in> (lang dfa)\<close>
        text \<open>the next big step is showing u@(repeat l v)@w is valid and in (lang dfa)
        We start by showing v^l is a valid sub-path of the dfa for all l\<close>
        from hd_eq_last_v have v_l: "\<forall>l. l\<ge>0 \<longrightarrow>  word_rec_states (repeat vqs l) vq dfa (repeat v l)"
          by (metis \<open>v \<noteq> []\<close> bot_nat_0.extremum length_greater_0_conv loop_states v wordl_eq_statesl)
        text \<open>next we want to prepend u to v^l
        Therefore  we show that they are appendable because they have the same ending state on u
        and starting state on v\<close>
        have "uq= hd ?vfwqs"
        proof -
          have "?vfwqs = drop i ?qs'" using local.i_j vfw by auto
          then have "hd ?vfwqs = ?qs' ! i"
            by (metis hd_drop local.i_j order_less_trans)
          then show ?thesis using u by argo
        qed
        then have uq_hd_vqs: "uq = hd vqs" by (metis hd_take local.i_j v zero_less_diff)
        text \<open>first the base appendiation for l=1, that we'll use in the l step\<close>
        have base_uv: "word_rec_states (uqs@vqs) vq dfa (u@v)"
        proof -
          obtain vqs' where "vqs=(uq#vqs')"
            using uq_hd_vqs by (metis \<open>v \<noteq> []\<close> list.collapse list.discI rotate1.simps(2) rotate1_is_Nil_conv take_eq_Nil v)
          then have "word_rec_states (uqs @ (uq#vqs')) vq dfa (u @ v)" using append_word_rec_states u v by blast
          then show ?thesis by (simp add: \<open>vqs = uq # vqs'\<close>)
        qed
        text \<open>and now using the base case we can proof u@v^l for all l\<close>
        then have urv: "\<forall>l. l\<ge>0\<longrightarrow>word_rec_states (uqs@(repeat vqs l)) vq dfa (u@(repeat v l))"
        proof (intro allI)
          fix l
          show "l\<ge>0 \<longrightarrow> word_rec_states (uqs@(repeat vqs l)) vq dfa (u@(repeat v l))"
           proof (cases "l\<le>1")
             case True
             then show ?thesis
             proof (cases "l=1")
               case True
               then show ?thesis using base_uv by simp
             next
               case False
               have "l=0" using False True by linarith
               then show ?thesis
                 using hd_eq_last_v u uq_hd_vqs by auto
           qed
           next
             case False
             have "uq= hd ?vfwqs" using \<open>uq = hd (vfwqs @ [vfwq])\<close> by blast
             then have "uq = hd vqs" using uq_hd_vqs by blast
             then obtain vqs' where "vqs=(uq#vqs')"
               by (metis Nil_is_append_conv diff_is_0_eq leD list.collapse local.i_j not_Cons_self2 take_eq_Nil v)
             then have r:"l\<ge>1\<Longrightarrow>repeat vqs l = (uq#vqs')@(repeat vqs (l-1))"
             proof (induction l)
               case 0
               then show ?case by simp
             next
               case (Suc l)
               then show ?case using repeat_rev by blast
             qed
             then show ?thesis
               by (metis False append_Cons append_word_rec_states nat_le_linear u v_l)
           qed
         qed
         text \<open>now append ?w to uv^l
        We start with the base case l=0 and append ?w to u\<close>
        have uw: "word_rec_states (uqs@?wqs) ?wq dfa (u@?w)"
        proof (cases ?wqs)
          case Nil
          then show ?thesis
            by (metis Nil_is_append_conv add.right_neutral append.right_neutral append_self_conv2 butlast_snoc drop_butlast drop_eq_Nil fw gwqs_gwq_Wgwqsgwq hd_eq_last_v hd_fwqsfwq last_snoc le_add_diff_inverse length_drop list.sel(1) list.size(3) nth_append_length qs'_q'_Wqs'q' qs_q u uq_hd_vqs vfw wordl_eq_statesl m)
        next
          case (Cons a list)
          then show ?thesis
            by (metis (no_types, lifting) \<open>word_rec_states (fwqs @ gwqs) gwq dfa (fw @ gw)\<close> append_butlast_last_id append_self_conv2 append_word_rec_states drop_eq_Nil fw gwqs_gwq_Wgwqsgwq hd_append2 hd_drop hd_eq_last_v hd_fwqsfwq last_snoc leD le_imp_less_Suc length_append_singleton list.distinct(1) list.sel(1) qs'_q'_Wqs'q' qs_q u uq_hd_vqs vfw wordl_eq_statesl m)
        qed
        text \<open>then we go in the induction on l\<close>
        have u_repeat_v_l_w: "\<forall>l. l\<ge>0 \<longrightarrow> word_rec_states (uqs@(repeat vqs l)@?wqs) ?wq dfa (u@(repeat v l)@?w)"
        proof (intro allI)
          fix l
          show "l\<ge>0 \<longrightarrow> word_rec_states (uqs@(repeat vqs l)@?wqs) ?wq dfa (u@(repeat v l)@?w)"
          proof (cases"l=0")
            case True
            then show ?thesis by (simp add: uw)
          next
            case False
            let ?l = "(l-1)"
            have "word_rec_states (vqs@?wqs) ?wq dfa (v@?w)"
            proof (cases ?wqs)
              case Nil
              then have "vq = ?wq"
                by (metis Nil_is_append_conv True add.right_neutral append_self_conv2 fw gwqs_gwq_Wgwqsgwq hd_fwqsfwq last_snoc le_add_diff_inverse length_drop list.sel(1) list.size(3) nth_append_length qs'_q'_Wqs'q' qs_q vfw wordl_eq_statesl)
              then show ?thesis
                by (metis append.right_neutral length_0_conv local.Nil v w wordl_eq_statesl)
            next
              case (Cons a list)
              then obtain hdw wqs where "(hdw# wqs) = ?wqs" by simp
              then have "hdw = vq"
                by (metis (no_types, lifting) True append_butlast_last_id append_self_conv2 drop_eq_Nil fw gwqs_gwq_Wgwqsgwq hd_append hd_drop hd_fwqsfwq last_snoc le_imp_less_Suc length_append_singleton list.distinct(1) list.sel(1) not_less_eq_eq qs'_q'_Wqs'q' qs_q vfw wordl_eq_statesl)
              then show ?thesis
                by (metis \<open>hdw # wqs = fwqs @ gwqs\<close> append_word_rec_states v w)
            qed
            text \<open>we divide uvw into a frontpart uv^(l-1) and a backpart vw to bring the multiple
            appendiations into a form where we can apply our append_word_rec_states lemma, because
            we know uv^l holds for arbitrary l and vw also holds.\<close>
            have eq:"?thesis = word_rec_states (uqs@(repeat vqs ?l)@(vqs@?wqs)) ?wq dfa (u@(repeat v ?l)@(v@?w))"
              by (metis False append.assoc bot_nat_0.extremum repeat.elims)
            obtain vqs' where vqs': "vqs=(vq#vqs')" by (metis \<open>v \<noteq> []\<close> hd_eq_last_v length_0_conv list.collapse v wordl_eq_statesl)
            from eq have "?thesis =  word_rec_states (uqs@(repeat vqs ?l)@((vq#vqs')@?wqs)) ?wq dfa (u@(repeat v ?l)@(v@?w))"
              using vqs' by simp
            let ?frontpart = "(uqs@(repeat vqs ?l))"
            let ?frontword= "(u@(repeat v ?l))"
            obtain backpart backword where b: "backpart=vqs'@?wqs \<and> backword=(v@?w)" by simp
            have "word_rec_states (uqs@(repeat vqs ?l)@(vq#vqs'@?wqs)) ?wq dfa (u@(repeat v ?l)@(v@?w))
              = word_rec_states (?frontpart @ (vq#backpart)) ?wq dfa (?frontword@backword)"
              by (simp add: b )
            have uvw: "word_rec_states (?frontpart @ (vq#backpart)) ?wq dfa (?frontword@backword)"
            proof (rule append_word_rec_states)
              show "word_rec_states ?frontpart vq dfa ?frontword" using urv by simp
              show "word_rec_states (vq # backpart) gwq dfa backword"
                using vqs' \<open>word_rec_states (vqs @ fwqs @ gwqs) gwq dfa (v @ fw @ gw)\<close> b by simp
            qed
            then show ?thesis
              using vqs' b eq by auto
          qed
        qed
        text \<open>After we now showed that uv^lw is a valid path in the dfa, we now show that for all l
         uv^lw is also in the langauage of the dfa. Therefore we need to show for all l that the head is
         q0 and the last state is in (F dfa)\<close>
        have u_repeat_v_l_w_lang: "\<forall>l. l\<ge>0 \<longrightarrow> (u@(repeat v l)@?w) \<in> lang dfa"
        proof (intro allI)
          fix l
          text \<open>we know per construction that ?wq is always the last state in uv^lw and therefore
           only need to show that ?wq \<in> (F dfa)\<close>
          have wq_f: "?wq \<in> F dfa" by (simp add: gwqs_gwq_Wgwqsgwq qs_q)
          text \<open>now the head of uv^lw's states must be shown to be q0 for all l\<close>
          show "0 \<le> l \<longrightarrow> u @ repeat v l @ ?w \<in> lang dfa"
          proof (cases "l=0")
            case True
            have "word (hd (uqs@vqs@?wqs@[?wq])) ?wq dfa (u@v@?w)"
            proof -
              have uvw: "word_rec_states (uqs@vqs@?wqs) ?wq dfa (u@v@?w)"
              proof (cases ?wqs)
                case Nil
                then have "word_rec_states (uqs@vqs@?wqs) ?wq dfa (u@v@?w) = word_rec_states (uqs@vqs) ?wq dfa (u@v)" using wordl_eq_statesl
                  by (metis Nil_is_append_conv append.right_neutral fw gwqs_gwq_Wgwqsgwq length_0_conv)
                also have "word_rec_states (uqs@vqs) ?wq dfa (u@v)"
                proof -
                  from Nil have "vq = ?wq"
                    by (metis Nil_is_append_conv add.right_neutral append_self_conv2 fw gwqs_gwq_Wgwqsgwq hd_fwqsfwq last_snoc le_add_diff_inverse length_drop list.sel(1) list.size(3) m nth_append_length qs'_q'_Wqs'q' qs_q vfw wordl_eq_statesl)
                  then show ?thesis using base_uv by blast
                qed
                then show ?thesis using calculation by blast
              next
                case (Cons a list)
                then obtain hdw wqs where "(hdw# wqs) = ?wqs" by simp
                then have "hdw = vq"
                   by (metis append_self_conv2 butlast_snoc drop_butlast drop_eq_Nil fw gwqs_gwq_Wgwqsgwq hd_append hd_drop hd_fwqsfwq last_snoc le_eq_less_or_eq list.distinct(1) list.sel(1) m nth_append qs'_q'_Wqs'q' qs_q vfw wordl_eq_statesl)
                then show ?thesis
                  by (metis \<open>hdw # wqs = fwqs @ gwqs\<close> append.assoc append_word_rec_states base_uv w)
              qed
              then show ?thesis using rec_imp_word  uvw \<open>u @ v @ ?w = z\<close> by force
            qed
            then have "hd (uqs@vqs@?wqs@[?wq]) = q\<^sub>0 dfa" using True
              by (metis Nil_is_append_conv append_self_conv2 diff_is_0_eq hd_append2 hd_conv_nth hd_take leD le_eq_less_or_eq local.i_j n not_Cons_self2 qs'_q'_Wqs'q' qs_q take_eq_Nil2 u uq_hd_vqs v)
            also have "hd (uqs@vqs@?wqs@[?wq]) = hd (uqs@vqs)"
              by (metis Nil_is_append_conv diff_is_0_eq hd_append leD local.i_j not_Cons_self2 take_eq_Nil2 v)
            then have "hd (uqs@vqs) = q\<^sub>0 dfa" using calculation by presburger
            let ?wrs = "word_rec_states (uqs@(repeat vqs l)@?wqs) ?wq dfa (u@(repeat v l)@?w)"
            have ?wrs using u_repeat_v_l_w by simp
            have "?wrs = word_rec_states (uqs@?wqs) ?wq dfa (u@?w)" using u_repeat_v_l_w uw by blast
            have "hd ((uqs@?wqs)@[?wq]) = q\<^sub>0 dfa"
            proof (cases "uqs=[]")
              case True
              then have "vq = q\<^sub>0 dfa"
                using \<open>hd (uqs @ vqs) = q\<^sub>0 dfa\<close>  hd_eq_last_v by auto
              also have "hd (?wqs@[?wq]) = vq"
              proof (cases ?wqs)
                case Nil
                then show ?thesis
                  by (metis Nil_is_append_conv add.right_neutral fw gwqs_gwq_Wgwqsgwq hd_fwqsfwq last_snoc le_add_diff_inverse length_drop list.size(3) m nth_append_length qs'_q'_Wqs'q' qs_q vfw wordl_eq_statesl)
              next
                case (Cons a list)
                then show ?thesis
                proof (cases fwqs)
                  case Nil
                  then show ?thesis
                  proof (cases gwqs)
                    case Nil
                    then show ?thesis
                      using hd_fwqsfwq local.Cons by force
                  next
                    case (Cons a list)
                    then obtain hdgwq gwq' where "(hdgwq#gwq') = gwqs" by simp
                    then have "hdgwq = vq"
                      by (metis add.commute append_butlast_last_id drop_eq_Nil2 fw gwqs_gwq_Wgwqsgwq hd_append hd_drop_conv_nth hd_fwqsfwq last_ConsL last_appendR less_Suc_eq_le list.sel(1) list.simps(3) local.Nil m not_less_eq_eq plus_1_eq_Suc qs'_q'_Wqs'q' qs_q_length vfw)
                    then show ?thesis
                      using \<open>hdgwq # gwq' = gwqs\<close> local.Nil by force
                  qed
                next
                  case (Cons a list)
                  then show ?thesis
                    using hd_fwqsfwq by auto
                qed
              qed
              then show ?thesis  by (simp add: True calculation)
            next
              case False
              then show ?thesis using calculation by fastforce
            qed
            then show ?thesis using rec_imp_word uw wq_f using True by force
          next
            case False
            let ?l = "(l-1)"
            let ?ulvw=  "word_rec_states (uqs@(repeat vqs l)@?wqs) ?wq dfa (u@(repeat v l)@?w)"
            have ulvw: ?ulvw using u_repeat_v_l_w by blast
            then have eq:"?ulvw = word_rec_states (uqs@vqs@(repeat vqs ?l)@?wqs) ?wq dfa (u@v@(repeat v ?l)@?w)"
              by (metis False append.assoc bot_nat_0.extremum le_eq_less_or_eq repeat_rev)
            then have "hd (uqs@(repeat vqs l)@?wqs@[?wq]) = hd (uqs@vqs)"
              by (metis False Nil_is_append_conv bot_nat_0.extremum diff_is_0_eq hd_append leD le_eq_less_or_eq local.i_j not_Cons_self2 repeat_rev take_eq_Nil2 v)
            then have "hd (uqs@(repeat vqs l)@?wqs@[?wq]) = q\<^sub>0 dfa"
              by (metis (no_types, lifting) antisym_conv3 gr_implies_not_zero hd_append hd_conv_nth hd_take n qs'_q'_Wqs'q' qs_q snoc_eq_iff_butlast take_eq_Nil u uq_hd_vqs)
            then show ?thesis using rec_imp_word ulvw wq_f by fastforce
          qed
        qed
        text \<open>Now we simply put everything together\<close>
        then show ?thesis
          using \<open>length (u @ v) \<le> n\<close> \<open>u @ v @ ?w = z\<close> \<open>v \<noteq> []\<close> by blast
      qed
      then show ?thesis
        by blast
    next
      case False
      then show ?thesis by blast
    qed
  qed
  show ?thesis using n z by blast
qed

end


(* Copyright 2021 (C) Mihails Milehins *)

section\<open>Cardinality\<close>
theory CZH_Sets_Cardinality
  imports
    CZH_Sets_Nat
    CZH_Sets_Equipollence
begin

subsection\<open>Background\<close>

text\<open>
The section presents further results about the cardinality of terms of the type
\<^typ>\<open>V\<close>. The emphasis of this work, however, is on the development of a theory of
finite sets internalized in the type \<^typ>\<open>V\<close>.

Many of the results that are presented in this section were carried over
(with amendments) from the theory \<open>Finite\<close> in the main library of Isabelle/HOL.
\<close>

declare One_nat_def[simp del]

subsection\<open>Cardinality of an arbitrary set\<close>

text\<open>Elementary properties.\<close>

lemma vcard_veqpoll: "vcard A = vcard B \<longleftrightarrow> A \<approx>\<^sub>\<circ> B"
  by (metis cardinal_cong cardinal_eqpoll eqpoll_sym eqpoll_trans)

lemma vcard_vlepoll: "vcard A \<le> vcard B \<longleftrightarrow> A \<lesssim>\<^sub>\<circ> B"
proof
  assume "vcard A \<le> vcard B"
  moreover have "vcard A \<approx>\<^sub>\<circ> A" by (rule cardinal_eqpoll)
  moreover have "vcard B \<approx>\<^sub>\<circ> B" by (rule cardinal_eqpoll)
  ultimately show "A \<lesssim>\<^sub>\<circ> B"
    by (meson eqpoll_sym lepoll_trans1 lepoll_trans2 vlepoll_vsubset)
qed (simp add: lepoll_imp_Card_le)

lemma vcard_vempty: "vcard A = 0 \<longleftrightarrow> A = 0"
proof-
  have vcard_A: "vcard A \<approx>\<^sub>\<circ> A" by (simp add: cardinal_eqpoll)
  then show ?thesis using eq0_iff eqpoll_iff_bijections by metis
qed

lemmas vcard_vemptyD = vcard_vempty[THEN iffD1]
  and vcard_vemptyI = vcard_vempty[THEN iffD2]

lemma vcard_neq_vempty: "vcard A \<noteq> 0\<^sub>\<nat> \<longleftrightarrow> A \<noteq> 0\<^sub>\<nat>"
  using vcard_vempty by auto

lemmas vcard_neq_vemptyD = vcard_neq_vempty[THEN iffD1]
  and vcard_neq_vemptyI = vcard_neq_vempty[THEN iffD2]

text\<open>Set operations.\<close>

lemma vcard_mono:
  assumes "A \<subseteq>\<^sub>\<circ> B"
  shows "vcard A \<le> vcard B"
  using assms by (simp add: lepoll_imp_Card_le vlepoll_vsubset)

lemma vcard_vinsert_in[simp]:
  assumes "a \<in>\<^sub>\<circ> A"
  shows "vcard (vinsert a A) = vcard A"
  using assms by (simp add: cardinal_cong insert_absorb)

lemma vcard_vintersection_left: "vcard (A \<inter>\<^sub>\<circ> B) \<le> vcard A"
  by (simp add: vcard_mono)

lemma vcard_vintersection_right: "vcard (A \<inter>\<^sub>\<circ> B) \<le> vcard B"
  by (simp add: vcard_mono)

lemma vcard_vunion:
  assumes "vdisjnt A B"
  shows "vcard (A \<union>\<^sub>\<circ> B) = vcard A \<oplus> vcard B"
  using assms by (rule vcard_disjoint_sup)

lemma vcard_vdiff[simp]: "vcard (A -\<^sub>\<circ> B) \<oplus> vcard (A \<inter>\<^sub>\<circ> B) = vcard A"
proof-
  have ABB: "vdisjnt (A -\<^sub>\<circ> B) (A \<inter>\<^sub>\<circ> B)" by auto
  have "A -\<^sub>\<circ> B \<union>\<^sub>\<circ> A \<inter>\<^sub>\<circ> B = A" by auto
  from vcard_vunion[OF ABB, unfolded this] show ?thesis ..
qed

lemma vcard_vdiff_vsubset:
  assumes "B \<subseteq>\<^sub>\<circ> A"
  shows "vcard (A -\<^sub>\<circ> B) \<oplus> vcard B = vcard A"
  by (metis assms inf.absorb_iff2 vcard_vdiff)

text\<open>Connections.\<close>

lemma (in vsv) vsv_vcard_vdomain: "vcard (\<D>\<^sub>\<circ> r) = vcard r"
  unfolding vcard_veqpoll
proof-
  define f where "f x = \<langle>x, r\<lparr>x\<rparr>\<rangle>" for x
  have "bij_betw f (elts (\<D>\<^sub>\<circ> r)) (elts r)"
    unfolding f_def bij_betw_def
  proof(intro conjI inj_onI subset_antisym subsetI)
    from vlrestriction_vdomain show
      "x \<in>\<^sub>\<circ> r \<Longrightarrow> x \<in> (\<lambda>x. \<langle>x, r\<lparr>x\<rparr>\<rangle>) ` elts (\<D>\<^sub>\<circ> r)"
      for x
      unfolding mem_Collect_eq by blast
  qed (auto simp: image_def)
  then show "\<D>\<^sub>\<circ> r \<approx>\<^sub>\<circ> r" unfolding eqpoll_def by auto
qed

text\<open>Special properties.\<close>

lemma vcard_vunion_vintersection:
  "vcard (A \<union>\<^sub>\<circ> B) \<oplus> vcard (A \<inter>\<^sub>\<circ> B) = vcard A \<oplus> vcard B"
proof-
  have AB_ABB: "A \<union>\<^sub>\<circ> B = B \<union>\<^sub>\<circ> (A -\<^sub>\<circ> B)" by auto
  have ABB: "vdisjnt B (A -\<^sub>\<circ> B)" by auto
  show ?thesis
    unfolding vcard_vunion[OF ABB, folded AB_ABB] cadd_assoc vcard_vdiff
    by (simp add: cadd_commute)
qed

subsection\<open>Finite sets\<close>

abbreviation vfinite :: "V \<Rightarrow> bool"
  where "vfinite A \<equiv> finite (elts A)"

lemma vfinite_def: "vfinite A \<longleftrightarrow> (\<exists>n\<in>\<^sub>\<circ>\<omega>. n \<approx>\<^sub>\<circ> A)"
proof
  assume "finite (elts A)"
  then obtain n :: nat where eltsA: "elts A \<approx> {..<n}"
    by (simp add: eqpoll_iff_card)
  have on: "ord_of_nat n = set (ord_of_nat ` {..<n})"
    by (simp add: ord_of_nat_eq_initial[symmetric])
  from eltsA have "elts A \<approx> elts (ord_of_nat n)"
    unfolding on by (simp add: inj_on_def)
  moreover have "ord_of_nat n \<in>\<^sub>\<circ> \<omega>" by (simp add: \<omega>_def)
  ultimately show "\<exists>n\<in>\<^sub>\<circ>\<omega>. n \<approx>\<^sub>\<circ> A" by (auto intro: eqpoll_sym)
next
  assume "\<exists>n\<in>\<^sub>\<circ>\<omega>. n \<approx>\<^sub>\<circ> A"
  then obtain n where "n \<in>\<^sub>\<circ> \<omega>" and "n \<approx>\<^sub>\<circ> A" by auto
  with eqpoll_finite_iff show "finite (elts A)"
    by (auto intro: finite_Ord_omega)
qed

text\<open>Rules.\<close>

lemmas vfiniteI[intro!] = vfinite_def[THEN iffD2]

lemmas vfiniteD[dest!] = vfinite_def[THEN iffD1]

lemma vfiniteE1[elim!]:
  assumes "vfinite A" and "\<exists>n\<in>\<^sub>\<circ>\<omega>. n \<approx>\<^sub>\<circ> A \<Longrightarrow> P"
  shows P
  using assms by auto

lemma vfiniteE2[elim]:
  assumes "vfinite A"
  obtains n where "n \<in>\<^sub>\<circ> \<omega>" and "n \<approx>\<^sub>\<circ> A"
  using assms by auto

text\<open>Elementary properties.\<close>

lemma veqpoll_omega_vcard[intro, simp]:
  assumes "n \<in>\<^sub>\<circ> \<omega>" and "n \<approx>\<^sub>\<circ> A"
  shows "vcard A = n"
  using
    nat_into_Card[OF assms(1), unfolded Card_def]
    cardinal_cong[OF assms(2)]
  by simp

lemma (in vsv) vfinite_vimage[intro]:
  assumes "vfinite A"
  shows "vfinite (r `\<^sub>\<circ> A)"
proof-
  have rA: "r `\<^sub>\<circ> A = r `\<^sub>\<circ> (\<D>\<^sub>\<circ> r \<inter>\<^sub>\<circ> A)" by fast
  have DrA: "\<D>\<^sub>\<circ> r \<inter>\<^sub>\<circ> A \<subseteq>\<^sub>\<circ> \<D>\<^sub>\<circ> r" by simp
  show ?thesis by (simp add: inf_V_def assms vimage_image[OF DrA, folded rA])
qed

lemmas [intro] = vsv.vfinite_vimage

lemma vfinite_veqpoll_trans:
  assumes "vfinite A" and "A \<approx>\<^sub>\<circ> B"
  shows "vfinite B"
  using assms by (simp add: eqpoll_finite_iff)

lemma vfinite_vlepoll_trans:
  assumes "vfinite A" and "B \<lesssim>\<^sub>\<circ> A"
  shows "vfinite B"
  by (meson assms eqpoll_finite_iff finite_lepoll_infinite lepoll_antisym)

lemma vfinite_vlesspoll_trans:
  assumes "vfinite A" and "B \<prec>\<^sub>\<circ> A"
  shows "vfinite B"
  using assms by (auto simp: vlesspoll_def vfinite_vlepoll_trans)

text\<open>Induction.\<close>

lemma vfinite_induct[consumes 1, case_names vempty vinsert]:
  assumes "vfinite F"
    and "P 0"
    and "\<And>x F. \<lbrakk>vfinite F; x \<notin>\<^sub>\<circ> F; P F\<rbrakk> \<Longrightarrow> P (vinsert x F)"
  shows "P F"
proof-

  from assms(1) obtain n where n: "n \<in>\<^sub>\<circ> \<omega>" and "n \<approx>\<^sub>\<circ> F" by clarsimp
  then obtain f'' where bij: "bij_betw f'' (elts n) (elts F)"
    unfolding eqpoll_def by clarsimp
  define f where "f = (\<lambda>a\<in>\<^sub>\<circ>n. f'' a)"
  interpret v11 f
    unfolding f_def
  proof(intro v11I)
    show "vsv ((\<lambda>a\<in>\<^sub>\<circ>n. f'' a)\<inverse>\<^sub>\<circ>)"
    proof(intro vsvI)
      fix a b c
      assume "\<langle>a, b\<rangle> \<in>\<^sub>\<circ> (\<lambda>a\<in>\<^sub>\<circ>n. f'' a)\<inverse>\<^sub>\<circ>" and "\<langle>a, c\<rangle> \<in>\<^sub>\<circ> (\<lambda>a\<in>\<^sub>\<circ>n. f'' a)\<inverse>\<^sub>\<circ>"
      then have "\<langle>b, a\<rangle> \<in>\<^sub>\<circ> (\<lambda>a\<in>\<^sub>\<circ>n. f'' a)"
        and "\<langle>c, a\<rangle> \<in>\<^sub>\<circ> (\<lambda>a\<in>\<^sub>\<circ>n. f'' a)"
        and "b \<in>\<^sub>\<circ> n"
        and "c \<in>\<^sub>\<circ> n"
        by auto
      moreover then have "f'' b = f'' c" by auto
      ultimately show "b = c" using bij by (metis bij_betw_iff_bijections)
    qed auto
  qed auto
  have dom_f: "\<D>\<^sub>\<circ> f = n" unfolding f_def by clarsimp
  have ran_f: "\<R>\<^sub>\<circ> f = F"
  proof(intro vsubset_antisym vsubsetI)
    fix b assume "b \<in>\<^sub>\<circ> \<R>\<^sub>\<circ> f"
    then obtain a where "a \<in>\<^sub>\<circ> n" and "b = f'' a" unfolding f_def by auto
    then show "b \<in>\<^sub>\<circ> F" by (meson bij bij_betw_iff_bijections)
  next
    fix b assume "b \<in>\<^sub>\<circ> F"
    then obtain a where "a \<in>\<^sub>\<circ> n" and "b = f'' a"
      by (metis bij bij_betw_iff_bijections)
    then show "b \<in>\<^sub>\<circ> \<R>\<^sub>\<circ> f" unfolding f_def by auto
  qed

  define f' where "f' n = f `\<^sub>\<circ> n" for n
  have F_def: "F = f' n"
    unfolding f'_def using dom_f ran_f vimage_vdomain by clarsimp
  have "v11 (\<lambda>a\<in>\<^sub>\<circ>n. f' a)"
  proof(intro vsv.vsv_valneq_v11I, unfold vdomain_VLambda)
    show "vsv (\<lambda>a\<in>\<^sub>\<circ>n. f' a)" by simp
    fix x y assume xD: "x \<in>\<^sub>\<circ> n" and yD: "y \<in>\<^sub>\<circ> n" and xy: "x \<noteq> y"
    from \<open>x \<in>\<^sub>\<circ> n\<close> \<open>y \<in>\<^sub>\<circ> n\<close> \<open>n \<in>\<^sub>\<circ> \<omega>\<close> have xn: "x \<subseteq>\<^sub>\<circ> n" and yn: "y \<subseteq>\<^sub>\<circ> n"
      by (simp_all add: OrdmemD order.strict_implies_order)
    show "(\<lambda>a\<in>\<^sub>\<circ>n. f' a)\<lparr>x\<rparr> \<noteq> (\<lambda>a\<in>\<^sub>\<circ>n. f' a)\<lparr>y\<rparr>"
      unfolding beta[OF xD] beta[OF yD] f'_def
      using xn yn xy
      by (simp add: dom_f v11_vimage_vpsubset_neq)
  qed

  define P' where "P' n' = (if n' \<le> n then P (f' n') else True)" for n'
  from n have "P' n"
  proof(induct rule: omega_induct)
    case 0 then show ?case
      unfolding P'_def f'_def using assms(2) by auto
  next
    case (succ k) show ?case
    proof(cases \<open>succ k \<le> n\<close>)
      case True
      then obtain x where xF: "vinsert x (f' k) = (f' (succ k))"
        by (simp add: f'_def succ_def vsubsetD dom_f vsv_vimage_vinsert)
      from True have "k \<le> n" by auto
      with \<open>P' k\<close> have "P (f' k)" unfolding P'_def by simp
      then have "f' k \<noteq> f' (succ k)"
        by (simp add: True f'_def \<open>k \<le> n\<close> dom_f v11_vimage_vpsubset_neq)
      with xF have "x \<notin>\<^sub>\<circ> f' k" by auto
      have "vfinite (f' k)"
        by (simp add: \<open>k \<in>\<^sub>\<circ> \<omega>\<close> f'_def finite_Ord_omega vfinite_vimage)
      from assms(3)[OF \<open>vfinite (f' k)\<close> \<open>x \<notin>\<^sub>\<circ> f' k\<close> \<open>P (f' k)\<close>] show ?thesis
        unfolding xF P'_def by simp
    qed (unfold P'_def, auto)
  qed

  then show ?thesis unfolding P'_def F_def by simp

qed

text\<open>Set operations.\<close>

lemma vfinite_vempty[simp]: "vfinite (0\<^sub>\<nat>)" by simp

lemma vfinite_vsingleton[simp]: "vfinite (set {x})" by simp

lemma vfinite_vdoubleton[simp]: "vfinite (set {x, y})" by simp

lemma vfinite_vinsert:
  assumes "vfinite F"
  shows "vfinite (vinsert x F)"
  using assms by simp

lemma vfinite_vinsertD:
  assumes "vfinite (vinsert x F)"
  shows "vfinite F"
  using assms by simp

lemma vfinite_vsubset:
  assumes "vfinite B" and "A \<subseteq>\<^sub>\<circ> B"
  shows "vfinite A"
  using assms
  by (induct arbitrary: A rule: vfinite_induct)
    (simp_all add: less_eq_V_def finite_subset)

lemma vfinite_vunion: "vfinite (A \<union>\<^sub>\<circ> B) \<longleftrightarrow> vfinite A \<and> vfinite B"
  by (auto simp: elts_sup_iff)

lemma vfinite_vunionI:
  assumes "vfinite A" and "vfinite B"
  shows "vfinite (A \<union>\<^sub>\<circ> B)"
  using assms by (simp add: elts_sup_iff)

lemma vfinite_vunionD:
  assumes "vfinite (A \<union>\<^sub>\<circ> B)"
  shows "vfinite A" and "vfinite B"
  using assms by (auto simp: elts_sup_iff)

lemma vfinite_vintersectionI:
  assumes "vfinite A" and "vfinite B"
  shows "vfinite (A \<inter>\<^sub>\<circ> B)"
  using assms by (simp add: vfinite_vsubset)

lemma vfinite_VPowI:
  assumes "vfinite A"
  shows "vfinite (VPow A)"
  using assms
proof(induct rule: vfinite_induct)
  case vempty then show ?case by simp
next
  case (vinsert x F)
  then show ?case
    unfolding VPow_vinsert
    using rel_VLambda.vfinite_vimage
    by (intro vfinite_vunionI) metis+
qed

text\<open>Connections.\<close>

lemma vfinite_vcard_vfinite: "vfinite (vcard A) = vfinite A"
  by (simp add: cardinal_eqpoll eqpoll_finite_iff)

lemma vfinite_vcard_omega_iff: "vfinite A \<longleftrightarrow> vcard A \<in>\<^sub>\<circ> \<omega>"
   using vfinite_vcard_vfinite by auto

lemmas vcard_vfinite_omega = vfinite_vcard_omega_iff[THEN iffD2]
  and vfinite_vcard_omega = vfinite_vcard_omega_iff[THEN iffD1]

lemma vfinite_csucc[intro, simp]:
  assumes "vfinite A"
  shows "csucc (vcard A) = succ (vcard A)"
  using assms by (force simp: finite_csucc)

lemmas [intro, simp] = finite_csucc

text\<open>Previous connections.\<close>

lemma vcard_vsingleton[simp]: "vcard (set {a}) = 1\<^sub>\<nat>" by auto

lemma vfinite_vcard_vinsert_nin[simp]:
  assumes "vfinite A" and "a \<notin>\<^sub>\<circ> A"
  shows "vcard (vinsert a A) = csucc (vcard A)"
  using assms by (simp add: ZFC_in_HOL.vinsert_def)

text\<open>\newpage\<close>

end