(*  Title:      HOL/Quickcheck_Examples/Quickcheck_Narrowing_Examples.thy
    Author:     Lukas Bulwahn
    Copyright   2011 TU Muenchen
*)

section \<open>Examples for narrowing-based testing\<close>

theory Quickcheck_Narrowing_Examples
imports MainRLT
begin

declare [[quickcheck_timeout = 3600]]

subsection \<open>Minimalistic examples\<close>

lemma
  "x = y"
quickcheck[tester = narrowing, finite_types = false, default_type = int, expect = counterexample]
oops

lemma
  "x = y"
quickcheck[tester = narrowing, finite_types = false, default_type = nat, expect = counterexample]
oops

subsection \<open>Simple examples with existentials\<close>

lemma
  "\<exists> y :: nat. \<forall> x. x = y"
quickcheck[tester = narrowing, finite_types = false, expect = counterexample]
oops
(*
lemma
  "\<exists> y :: int. \<forall> x. x = y"
quickcheck[tester = narrowing, size = 2]
oops
*)
lemma
  "x > 1 --> (\<exists>y :: nat. x < y & y <= 1)"
quickcheck[tester = narrowing, finite_types = false, expect = counterexample]
oops

lemma
  "x > 2 \<longrightarrow> (\<exists>y :: nat. x < y \<and> y \<le> 2)"
quickcheck[tester = narrowing, finite_types = false, size = 10]
oops

lemma
  "\<forall>x. \<exists>y :: nat. x > 3 \<longrightarrow> (y < x \<and> y > 3)"
quickcheck[tester = narrowing, finite_types = false, size = 7]
oops

text \<open>A false conjecture derived from an partial copy-n-paste of @{thm not_distinct_decomp}\<close>
lemma
  "\<not> distinct ws \<Longrightarrow> \<exists>xs ys zs y. ws = xs @ [y] @ ys @ [y]"
quickcheck[tester = narrowing, finite_types = false, default_type = nat, expect = counterexample]
oops

text \<open>A false conjecture derived from theorems @{thm split_list_first} and @{thm split_list_last}\<close>
lemma
  "x \<in> set xs \<Longrightarrow> \<exists>ys zs. xs = ys @ x # zs \<and> x \<notin> set zs \<and> x \<notin> set ys"
quickcheck[tester = narrowing, finite_types = false, default_type = nat, expect = counterexample]
oops

text \<open>A false conjecture derived from @{thm map_eq_Cons_conv} with a typo\<close>
lemma
  "(map f xs = y # ys) = (\<exists>z zs. xs = z' # zs & f z = y \<and> map f zs = ys)"
quickcheck[tester = narrowing, finite_types = false, default_type = nat, expect = counterexample]
oops

lemma "a # xs = ys @ [a] \<Longrightarrow> \<exists>zs. xs = zs @ [a] \<and> ys = a#zs"
quickcheck[narrowing, expect = counterexample]
quickcheck[exhaustive, random, expect = no_counterexample]
oops

subsection \<open>Simple list examples\<close>

lemma "rev xs = xs"
quickcheck[tester = narrowing, finite_types = false, default_type = nat, expect = counterexample]
oops

lemma "rev xs = xs"
quickcheck[tester = narrowing, finite_types = false, default_type = int, expect = counterexample]
oops

lemma "rev xs = xs"
  quickcheck[tester = narrowing, finite_types = true, expect = counterexample]
oops

subsection \<open>Simple examples with functions\<close>

lemma "map f xs = map g xs"
  quickcheck[tester = narrowing, finite_types = false, expect = counterexample]
oops

lemma "map f xs = map f ys ==> xs = ys"
  quickcheck[tester = narrowing, finite_types = false, expect = counterexample]
oops

lemma
  "list_all2 P (rev xs) (rev ys) = list_all2 P xs (rev ys)"
  quickcheck[tester = narrowing, finite_types = false, expect = counterexample]
oops

lemma "map f xs = F f xs"
  quickcheck[tester = narrowing, finite_types = false, expect = counterexample]
oops

lemma "map f xs = F f xs"
  quickcheck[tester = narrowing, finite_types = false, expect = counterexample]
oops

(* requires some work...*)
(*
lemma "R O S = S O R"
  quickcheck[tester = narrowing, size = 2]
oops
*)

subsection \<open>Simple examples with inductive predicates\<close>

inductive even where
  "even 0" |
  "even n ==> even (Suc (Suc n))"

code_pred even .

lemma "even (n - 2) ==> even n"
quickcheck[narrowing, expect = counterexample]
oops

subsection \<open>AVL Trees\<close>

datatype 'a tree = ET |  MKT 'a "'a tree" "'a tree" nat

primrec set_of :: "'a tree \<Rightarrow> 'a set"
where
"set_of ET = {}" |
"set_of (MKT n l r h) = insert n (set_of l \<union> set_of r)"

primrec height :: "'a tree \<Rightarrow> nat"
where
"height ET = 0" |
"height (MKT x l r h) = max (height l) (height r) + 1"

primrec avl :: "'a tree \<Rightarrow> bool"
where
"avl ET = True" |
"avl (MKT x l r h) =
 ((height l = height r \<or> height l = 1+height r \<or> height r = 1+height l) \<and>
  h = max (height l) (height r) + 1 \<and> avl l \<and> avl r)"

primrec is_ord :: "('a::order) tree \<Rightarrow> bool"
where
"is_ord ET = True" |
"is_ord (MKT n l r h) =
 ((\<forall>n' \<in> set_of l. n' < n) \<and> (\<forall>n' \<in> set_of r. n < n') \<and> is_ord l \<and> is_ord r)"

primrec is_in :: "('a::order) \<Rightarrow> 'a tree \<Rightarrow> bool"
where
 "is_in k ET = False" |
 "is_in k (MKT n l r h) = (if k = n then True else
                           if k < n then (is_in k l)
                           else (is_in k r))"

primrec ht :: "'a tree \<Rightarrow> nat"
where
"ht ET = 0" |
"ht (MKT x l r h) = h"

definition
 mkt :: "'a \<Rightarrow> 'a tree \<Rightarrow> 'a tree \<Rightarrow> 'a tree" where
"mkt x l r = MKT x l r (max (ht l) (ht r) + 1)"

(* replaced MKT lrn lrl lrr by MKT lrr lrl *)
fun l_bal where
"l_bal(n, MKT ln ll lr h, r) =
 (if ht ll < ht lr
  then case lr of ET \<Rightarrow> ET \<comment> \<open>impossible\<close>
                | MKT lrn lrr lrl lrh \<Rightarrow>
                  mkt lrn (mkt ln ll lrl) (mkt n lrr r)
  else mkt ln ll (mkt n lr r))"

fun r_bal where
"r_bal(n, l, MKT rn rl rr h) =
 (if ht rl > ht rr
  then case rl of ET \<Rightarrow> ET \<comment> \<open>impossible\<close>
                | MKT rln rll rlr h \<Rightarrow> mkt rln (mkt n l rll) (mkt rn rlr rr)
  else mkt rn (mkt n l rl) rr)"

primrec insrt :: "'a::order \<Rightarrow> 'a tree \<Rightarrow> 'a tree"
where
"insrt x ET = MKT x ET ET 1" |
"insrt x (MKT n l r h) =
   (if x=n
    then MKT n l r h
    else if x<n
         then let l' = insrt x l; hl' = ht l'; hr = ht r
              in if hl' = 2+hr then l_bal(n,l',r)
                 else MKT n l' r (1 + max hl' hr)
         else let r' = insrt x r; hl = ht l; hr' = ht r'
              in if hr' = 2+hl then r_bal(n,l,r')
                 else MKT n l r' (1 + max hl hr'))"

subsubsection \<open>Necessary setup for code generation\<close>

primrec set_of'
where
  "set_of' ET = []"
| "set_of' (MKT n l r h) = n # (set_of' l @ set_of' r)"

lemma set_of':
  "set (set_of' t) = set_of t"
by (induct t) auto

lemma is_ord_mkt:
  "is_ord (MKT n l r h) = ((\<forall>n' \<in> set (set_of' l). n' < n) \<and> (\<forall>n' \<in> set (set_of' r). n < n') \<and> is_ord l \<and> is_ord r)"
by (simp add: set_of')

declare is_ord.simps(1)[code] is_ord_mkt[code]

subsubsection \<open>Invalid Lemma due to typo in \<^const>\<open>l_bal\<close>\<close>

lemma is_ord_l_bal:
 "\<lbrakk> is_ord(MKT (x :: nat) l r h); height l = height r + 2 \<rbrakk> \<Longrightarrow> is_ord(l_bal(x,l,r))"
quickcheck[tester = narrowing, finite_types = false, default_type = nat, size = 6, expect = counterexample]
oops

subsection \<open>Examples with hd and last\<close>

lemma
  "hd (xs @ ys) = hd ys"
quickcheck[narrowing, expect = counterexample]
oops

lemma
  "last(xs @ ys) = last xs"
quickcheck[narrowing, expect = counterexample]
oops

subsection \<open>Examples with underspecified/partial functions\<close>

lemma
  "xs = [] ==> hd xs \<noteq> x"
quickcheck[narrowing, expect = no_counterexample]
oops

lemma
  "xs = [] ==> hd xs = x"
quickcheck[narrowing, expect = no_counterexample]
oops

lemma "xs = [] ==> hd xs = x ==> x = y"
quickcheck[narrowing, expect = no_counterexample]
oops

lemma
  "hd (xs @ ys) = (if xs = [] then hd ys else hd xs)"
quickcheck[narrowing, expect = no_counterexample]
oops

lemma
  "hd (map f xs) = f (hd xs)"
quickcheck[narrowing, expect = no_counterexample]
oops

end


(*  Title:      HOL/Isar_Examples/Basic_Logic.thy
    Author:     Makarius

Basic propositional and quantifier reasoning.
*)

section \<open>Basic logical reasoning\<close>

theory Basic_Logic
  imports MainRLT
begin

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

text \<open>
  In order to get a first idea of how Isabelle/Isar proof documents may look
  like, we consider the propositions \<open>I\<close>, \<open>K\<close>, and \<open>S\<close>. The following (rather
  explicit) proofs should require little extra explanations.
\<close>

lemma I: "A \<longrightarrow> A"
proof
  assume A
  show A by fact
qed

lemma S: "(A \<longrightarrow> B \<longrightarrow> C) \<longrightarrow> (A \<longrightarrow> B) \<longrightarrow> A \<longrightarrow> C"
proof
  assume "A \<longrightarrow> B \<longrightarrow> C"
  show "(A \<longrightarrow> B) \<longrightarrow> A \<longrightarrow> C"
  proof
    assume "A \<longrightarrow> B"
    show "A \<longrightarrow> C"
    proof
      assume A
      show C
      proof (rule mp)
        show "B \<longrightarrow> C" by (rule mp) fact+
        show B by (rule mp) fact+
      qed
    qed
  qed
qed

text \<open>
  Isar provides several ways to fine-tune the reasoning, avoiding excessive
  detail. Several abbreviated language elements are available, enabling the
  writer to express proofs in a more concise way, even without referring to
  any automated proof tools yet.

  Concluding any (sub-)proof already involves solving any remaining goals by
  assumption\<^footnote>\<open>This is not a completely trivial operation, as proof by
  assumption may involve full higher-order unification.\<close>. Thus we may skip the
  rather vacuous body of the above proof.
\<close>

lemma "A \<longrightarrow> A"
proof
qed

text \<open>
  Note that the \<^theory_text>\<open>proof\<close> command refers to the \<open>rule\<close> method (without
  arguments) by default. Thus it implicitly applies a single rule, as
  determined from the syntactic form of the statements involved. The \<^theory_text>\<open>by\<close>
  command abbreviates any proof with empty body, so the proof may be further
  pruned.
\<close>

lemma "A \<longrightarrow> A"
  by rule

text \<open>
  Proof by a single rule may be abbreviated as double-dot.
\<close>

lemma "A \<longrightarrow> A" ..

text \<open>
  Thus we have arrived at an adequate representation of the proof of a
  tautology that holds by a single standard rule.\<^footnote>\<open>Apparently, the
  rule here is implication introduction.\<close>

  \<^medskip>
  Let us also reconsider \<open>K\<close>. Its statement is composed of iterated
  connectives. Basic decomposition is by a single rule at a time, which is why
  our first version above was by nesting two proofs.

  The \<open>intro\<close> proof method repeatedly decomposes a goal's conclusion.\<^footnote>\<open>The
  dual method is \<open>elim\<close>, acting on a goal's premises.\<close>
\<close>

lemma "A \<longrightarrow> B \<longrightarrow> A"
proof (intro impI)
  assume A
  show A by fact
qed

text \<open>Again, the body may be collapsed.\<close>

lemma "A \<longrightarrow> B \<longrightarrow> A"
  by (intro impI)

text \<open>
  Just like \<open>rule\<close>, the \<open>intro\<close> and \<open>elim\<close> proof methods pick standard
  structural rules, in case no explicit arguments are given. While implicit
  rules are usually just fine for single rule application, this may go too far
  with iteration. Thus in practice, \<open>intro\<close> and \<open>elim\<close> would be typically
  restricted to certain structures by giving a few rules only, e.g.\ \<^theory_text>\<open>proof
  (intro impI allI)\<close> to strip implications and universal quantifiers.

  Such well-tuned iterated decomposition of certain structures is the prime
  application of \<open>intro\<close> and \<open>elim\<close>. In contrast, terminal steps that solve a
  goal completely are usually performed by actual automated proof methods
  (such as \<^theory_text>\<open>by blast\<close>.
\<close>

subsection \<open>Variations of backward vs.\ forward reasoning\<close>

text \<open>
  Certainly, any proof may be performed in backward-style only. On the other
  hand, small steps of reasoning are often more naturally expressed in
  forward-style. Isar supports both backward and forward reasoning as a
  first-class concept. In order to demonstrate the difference, we consider
  several proofs of \<open>A \<and> B \<longrightarrow> B \<and> A\<close>.

  The first version is purely backward.
\<close>

lemma "A \<and> B \<longrightarrow> B \<and> A"
proof
  assume "A \<and> B"
  show "B \<and> A"
  proof
    show B by (rule conjunct2) fact
    show A by (rule conjunct1) fact
  qed
qed

text \<open>
  Above, the projection rules \<open>conjunct1\<close> / \<open>conjunct2\<close> had to be named
  explicitly, since the goals \<open>B\<close> and \<open>A\<close> did not provide any structural clue.
  This may be avoided using \<^theory_text>\<open>from\<close> to focus on the \<open>A \<and> B\<close> assumption as the
  current facts, enabling the use of double-dot proofs. Note that \<^theory_text>\<open>from\<close>
  already does forward-chaining, involving the \<open>conjE\<close> rule here.
\<close>

lemma "A \<and> B \<longrightarrow> B \<and> A"
proof
  assume "A \<and> B"
  show "B \<and> A"
  proof
    from \<open>A \<and> B\<close> show B ..
    from \<open>A \<and> B\<close> show A ..
  qed
qed

text \<open>
  In the next version, we move the forward step one level upwards.
  Forward-chaining from the most recent facts is indicated by the \<^theory_text>\<open>then\<close>
  command. Thus the proof of \<open>B \<and> A\<close> from \<open>A \<and> B\<close> actually becomes an
  elimination, rather than an introduction. The resulting proof structure
  directly corresponds to that of the \<open>conjE\<close> rule, including the repeated
  goal proposition that is abbreviated as \<open>?thesis\<close> below.
\<close>

lemma "A \<and> B \<longrightarrow> B \<and> A"
proof
  assume "A \<and> B"
  then show "B \<and> A"
  proof                    \<comment> \<open>rule \<open>conjE\<close> of \<open>A \<and> B\<close>\<close>
    assume B A
    then show ?thesis ..   \<comment> \<open>rule \<open>conjI\<close> of \<open>B \<and> A\<close>\<close>
  qed
qed

text \<open>
  In the subsequent version we flatten the structure of the main body by doing
  forward reasoning all the time. Only the outermost decomposition step is
  left as backward.
\<close>

lemma "A \<and> B \<longrightarrow> B \<and> A"
proof
  assume "A \<and> B"
  from \<open>A \<and> B\<close> have A ..
  from \<open>A \<and> B\<close> have B ..
  from \<open>B\<close> \<open>A\<close> show "B \<and> A" ..
qed

text \<open>
  We can still push forward-reasoning a bit further, even at the risk of
  getting ridiculous. Note that we force the initial proof step to do nothing
  here, by referring to the \<open>-\<close> proof method.
\<close>

lemma "A \<and> B \<longrightarrow> B \<and> A"
proof -
  {
    assume "A \<and> B"
    from \<open>A \<and> B\<close> have A ..
    from \<open>A \<and> B\<close> have B ..
    from \<open>B\<close> \<open>A\<close> have "B \<and> A" ..
  }
  then show ?thesis ..         \<comment> \<open>rule \<open>impI\<close>\<close>
qed

text \<open>
  \<^medskip>
  With these examples we have shifted through a whole range from purely
  backward to purely forward reasoning. Apparently, in the extreme ends we get
  slightly ill-structured proofs, which also require much explicit naming of
  either rules (backward) or local facts (forward).

  The general lesson learned here is that good proof style would achieve just
  the \<^emph>\<open>right\<close> balance of top-down backward decomposition, and bottom-up
  forward composition. In general, there is no single best way to arrange some
  pieces of formal reasoning, of course. Depending on the actual applications,
  the intended audience etc., rules (and methods) on the one hand vs.\ facts
  on the other hand have to be emphasized in an appropriate way. This requires
  the proof writer to develop good taste, and some practice, of course.

  \<^medskip>
  For our example the most appropriate way of reasoning is probably the middle
  one, with conjunction introduction done after elimination.
\<close>

lemma "A \<and> B \<longrightarrow> B \<and> A"
proof
  assume "A \<and> B"
  then show "B \<and> A"
  proof
    assume B A
    then show ?thesis ..
  qed
qed

subsection \<open>A few examples from ``Introduction to Isabelle''\<close>

text \<open>
  We rephrase some of the basic reasoning examples of @{cite
  "isabelle-intro"}, using HOL rather than FOL.
\<close>

subsubsection \<open>A propositional proof\<close>

text \<open>
  We consider the proposition \<open>P \<or> P \<longrightarrow> P\<close>. The proof below involves
  forward-chaining from \<open>P \<or> P\<close>, followed by an explicit case-analysis on the
  two \<^emph>\<open>identical\<close> cases.
\<close>

lemma "P \<or> P \<longrightarrow> P"
proof
  assume "P \<or> P"
  then show P
  proof                    \<comment> \<open>rule \<open>disjE\<close>: \smash{$\infer{\<open>C\<close>}{\<open>A \<or> B\<close> & \infer*{\<open>C\<close>}{[\<open>A\<close>]} & \infer*{\<open>C\<close>}{[\<open>B\<close>]}}$}\<close>
    assume P show P by fact
  next
    assume P show P by fact
  qed
qed

text \<open>
  Case splits are \<^emph>\<open>not\<close> hardwired into the Isar language as a special
  feature. The \<^theory_text>\<open>next\<close> command used to separate the cases above is just a
  short form of managing block structure.

  \<^medskip>
  In general, applying proof methods may split up a goal into separate
  ``cases'', i.e.\ new subgoals with individual local assumptions. The
  corresponding proof text typically mimics this by establishing results in
  appropriate contexts, separated by blocks.

  In order to avoid too much explicit parentheses, the Isar system implicitly
  opens an additional block for any new goal, the \<^theory_text>\<open>next\<close> statement then
  closes one block level, opening a new one. The resulting behaviour is what
  one would expect from separating cases, only that it is more flexible. E.g.\
  an induction base case (which does not introduce local assumptions) would
  \<^emph>\<open>not\<close> require \<^theory_text>\<open>next\<close> to separate the subsequent step case.

  \<^medskip>
  In our example the situation is even simpler, since the two cases actually
  coincide. Consequently the proof may be rephrased as follows.
\<close>

lemma "P \<or> P \<longrightarrow> P"
proof
  assume "P \<or> P"
  then show P
  proof
    assume P
    show P by fact
    show P by fact
  qed
qed

text \<open>Again, the rather vacuous body of the proof may be collapsed.
  Thus the case analysis degenerates into two assumption steps, which
  are implicitly performed when concluding the single rule step of the
  double-dot proof as follows.\<close>

lemma "P \<or> P \<longrightarrow> P"
proof
  assume "P \<or> P"
  then show P ..
qed

subsubsection \<open>A quantifier proof\<close>

text \<open>
  To illustrate quantifier reasoning, let us prove
  \<open>(\<exists>x. P (f x)) \<longrightarrow> (\<exists>y. P y)\<close>. Informally, this holds because any \<open>a\<close> with
  \<open>P (f a)\<close> may be taken as a witness for the second existential statement.

  The first proof is rather verbose, exhibiting quite a lot of (redundant)
  detail. It gives explicit rules, even with some instantiation. Furthermore,
  we encounter two new language elements: the \<^theory_text>\<open>fix\<close> command augments the
  context by some new ``arbitrary, but fixed'' element; the \<^theory_text>\<open>is\<close> annotation
  binds term abbreviations by higher-order pattern matching.
\<close>

lemma "(\<exists>x. P (f x)) \<longrightarrow> (\<exists>y. P y)"
proof
  assume "\<exists>x. P (f x)"
  then show "\<exists>y. P y"
  proof (rule exE)             \<comment> \<open>rule \<open>exE\<close>: \smash{$\infer{\<open>B\<close>}{\<open>\<exists>x. A(x)\<close> & \infer*{\<open>B\<close>}{[\<open>A(x)\<close>]_x}}$}\<close>
    fix a
    assume "P (f a)" (is "P ?witness")
    then show ?thesis by (rule exI [of P ?witness])
  qed
qed

text \<open>
  While explicit rule instantiation may occasionally improve readability of
  certain aspects of reasoning, it is usually quite redundant. Above, the
  basic proof outline gives already enough structural clues for the system to
  infer both the rules and their instances (by higher-order unification). Thus
  we may as well prune the text as follows.
\<close>

lemma "(\<exists>x. P (f x)) \<longrightarrow> (\<exists>y. P y)"
proof
  assume "\<exists>x. P (f x)"
  then show "\<exists>y. P y"
  proof
    fix a
    assume "P (f a)"
    then show ?thesis ..
  qed
qed

text \<open>
  Explicit \<open>\<exists>\<close>-elimination as seen above can become quite cumbersome in
  practice. The derived Isar language element ``\<^theory_text>\<open>obtain\<close>'' provides a more
  handsome way to do generalized existence reasoning.
\<close>

lemma "(\<exists>x. P (f x)) \<longrightarrow> (\<exists>y. P y)"
proof
  assume "\<exists>x. P (f x)"
  then obtain a where "P (f a)" ..
  then show "\<exists>y. P y" ..
qed

text \<open>
  Technically, \<^theory_text>\<open>obtain\<close> is similar to \<^theory_text>\<open>fix\<close> and \<^theory_text>\<open>assume\<close> together with a
  soundness proof of the elimination involved. Thus it behaves similar to any
  other forward proof element. Also note that due to the nature of general
  existence reasoning involved here, any result exported from the context of
  an \<^theory_text>\<open>obtain\<close> statement may \<^emph>\<open>not\<close> refer to the parameters introduced there.
\<close>

subsubsection \<open>Deriving rules in Isabelle\<close>

text \<open>
  We derive the conjunction elimination rule from the corresponding
  projections. The proof is quite straight-forward, since Isabelle/Isar
  supports non-atomic goals and assumptions fully transparently.
\<close>

theorem conjE: "A \<and> B \<Longrightarrow> (A \<Longrightarrow> B \<Longrightarrow> C) \<Longrightarrow> C"
proof -
  assume "A \<and> B"
  assume r: "A \<Longrightarrow> B \<Longrightarrow> C"
  show C
  proof (rule r)
    show A by (rule conjunct1) fact
    show B by (rule conjunct2) fact
  qed
qed

end


section \<open>Bounded semantics\<close>

theory Usemantics imports SeCaV begin

text \<open>In this theory, we define an alternative semantics for SeCaV formulas where the quantifiers
  are bounded to terms in a specific set.
  This is needed to construct a countermodel from a Hintikka set.\<close>

text \<open>This function defines the semantics, which are bounded by the set \<open>u\<close>.\<close>
primrec usemantics where
  \<open>usemantics u e f g (Pre i l) = g i (semantics_list e f l)\<close>
| \<open>usemantics u e f g (Imp p q) = (usemantics u e f g p \<longrightarrow> usemantics u e f g q)\<close>
| \<open>usemantics u e f g (Dis p q) = (usemantics u e f g p \<or> usemantics u e f g q)\<close>
| \<open>usemantics u e f g (Con p q) = (usemantics u e f g p \<and> usemantics u e f g q)\<close>
| \<open>usemantics u e f g (Exi p) = (\<exists>x \<in> u. usemantics u (SeCaV.shift e 0 x) f g p)\<close>
| \<open>usemantics u e f g (Uni p) = (\<forall>x \<in> u. usemantics u (SeCaV.shift e 0 x) f g p)\<close>
| \<open>usemantics u e f g (Neg p) = (\<not> usemantics u e f g p)\<close>

text \<open>An environment is well-formed if the variables are actually in the quantifier set \<open>u\<close>.\<close>
definition is_env :: \<open>'a set \<Rightarrow> (nat \<Rightarrow> 'a) \<Rightarrow> bool\<close> where
  \<open>is_env u e \<equiv> \<forall>n. e n \<in> u\<close>

text \<open>A function interpretation is well-formed if it is closed in the quantifier set \<open>u\<close>.\<close>
definition is_fdenot :: \<open>'a set \<Rightarrow> (nat \<Rightarrow> 'a list \<Rightarrow> 'a) \<Rightarrow> bool\<close> where
  \<open>is_fdenot u f \<equiv> \<forall>i l. list_all (\<lambda>x. x \<in> u) l \<longrightarrow> f i l \<in> u\<close>

text \<open>If we choose to quantify over the universal set, we obtain the usual semantics\<close>
lemma usemantics_UNIV: \<open>usemantics UNIV e f g p \<longleftrightarrow> semantics e f g p\<close>
  by (induct p arbitrary: e) auto

text \<open>If a function name \<open>n\<close> is not in a formula, it does not matter whether it is in
  the function interpretation or not.\<close>
lemma uupd_

text \<open>The semantics of substituting variable i by term t in formula a are well-defined\<close>
lemma usubst_lemma [iff]:
  \<open>usemantics u e f g (subst a t i) \<longleftrightarrow> usemantics u (SeCaV.shift e i (semantics_term e f t)) f g a\<close>
  by (induct a arbitrary: e i t) simp_all

subsubsection \<open>Soundness of SeCaV with regards to the bounded semantics\<close>
text \<open>We would like to prove that the SeCaV proof system is sound under the bounded semantics.\<close>

text \<open>If the environment and the function interpretation are well-formed, the semantics of terms
  are in the quantifier set \<open>u\<close>.\<close>
lemma usemantics_term [simp]:
  assumes \<open>is_env u e\<close> \<open>is_fdenot u f\<close>
  shows \<open>semantics_term e f t \<in> u\<close> \<open>list_all (\<lambda>x. x \<in> u) (semantics_list e f ts)\<close>
  using assms by (induct t and ts rule: semantics_term.induct semantics_list.induct)
    (simp_all add: is_env_def is_fdenot_def)

text \<open>If a function interpretation is well-formed, replacing the value by one in the quantifier set
  results in a well-formed function interpretation.\<close>
lemma is_fdenot_shift [simp]: \<open>is_fdenot u f \<Longrightarrow> x \<in> u \<Longrightarrow> is_fdenot u (f(i := \<lambda>_. x))\<close>
  unfolding is_fdenot_def SeCaV.shift_def by simp

text \<open>If a sequent is provable in the SeCaV proof system and the environment
  and function interpretation are well-formed, the sequent is valid under the bounded semantics.\<close>
theorem sound_usemantics:
  assumes \<open>\<tturnstile> z\<close> and \<open>is_env u e\<close> and \<open>is_fdenot u f\<close>
  shows \<open>\<exists>p \<in> set z. usemantics u e f g p\<close>
  using assms
proof (induct arbitrary: f rule: sequent_calculus.induct)
  case (10 i p z)
  then show ?case
  proof (cases \<open>\<forall>x \<in> u. usemantics u e (f(i := \<lambda>_. x)) g (sub 0 (Fun i []) p)\<close>)
    case False
    moreover have \<open>\<forall>x \<in> u. \<exists>p \<in> set (sub 0 (Fun i []) p # z). usemantics u e (f(i := \<lambda>_. x)) g p\<close>
      using 10 is_fdenot_shift by metis
    ultimately have \<open>\<exists>x \<in> u. \<exists>p \<in> set z. usemantics u e (f(i := \<lambda>_. x)) g p\<close>
      by fastforce
    moreover have \<open>list_all (\<lambda>p. i \<notin> params p) z\<close>
      using 10 by simp
    ultimately show ?thesis
      using 10 Ball_set insert_iff list.set(2) uupd_lemma by metis
  qed simp
next
  case (11 i p z)
  then show ?case
  proof (cases \<open>\<forall>x \<in> u. usemantics u e (f(i := \<lambda>_. x)) g (Neg (sub 0 (Fun i []) p))\<close>)
    case False
    moreover have
      \<open>\<forall>x \<in> u. \<exists>p \<in> set (Neg (sub 0 (Fun i []) p) # z). usemantics u e (f(i := \<lambda>_. x)) g p\<close>
      using 11 is_fdenot_shift by metis
    ultimately have \<open>\<exists>x \<in> u. \<exists>p \<in> set z. usemantics u e (f(i := \<lambda>_. x)) g p\<close>
      by fastforce
    moreover have \<open>list_all (\<lambda>p. i \<notin> params p) z\<close>
      using 11 by simp
    ultimately show ?thesis
      using 11 Ball_set insert_iff list.set(2) uupd_lemma by metis
  qed simp
qed fastforce+

end


(*  Author:     Bernhard Haeupler

Proving equalities in commutative rings done "right" in Isabelle/HOL.
*)

section {* Proving equalities in commutative rings *}

theory Commutative_Ring
imports Main
begin

text {* Syntax of multivariate polynomials (pol) and polynomial expressions. *}

datatype 'a pol =
    Pc 'a
  | Pinj nat "'a pol"
  | PX "'a pol" nat "'a pol"

datatype 'a polex =
    Pol "'a pol"
  | Add "'a polex" "'a polex"
  | Sub "'a polex" "'a polex"
  | Mul "'a polex" "'a polex"
  | Pow "'a polex" nat
  | Neg "'a polex"

text {* Interpretation functions for the shadow syntax. *}

primrec Ipol :: "'a::{comm_ring_1} list \<Rightarrow> 'a pol \<Rightarrow> 'a"
where
    "Ipol l (Pc c) = c"
  | "Ipol l (Pinj i P) = Ipol (drop i l) P"
  | "Ipol l (PX P x Q) = Ipol l P * (hd l)^x + Ipol (drop 1 l) Q"

primrec Ipolex :: "'a::{comm_ring_1} list \<Rightarrow> 'a polex \<Rightarrow> 'a"
where
    "Ipolex l (Pol P) = Ipol l P"
  | "Ipolex l (Add P Q) = Ipolex l P + Ipolex l Q"
  | "Ipolex l (Sub P Q) = Ipolex l P - Ipolex l Q"
  | "Ipolex l (Mul P Q) = Ipolex l P * Ipolex l Q"
  | "Ipolex l (Pow p n) = Ipolex l p ^ n"
  | "Ipolex l (Neg P) = - Ipolex l P"

text {* Create polynomial normalized polynomials given normalized inputs. *}

definition mkPinj :: "nat \<Rightarrow> 'a pol \<Rightarrow> 'a pol"
where
  "mkPinj x P = (case P of
    Pc c \<Rightarrow> Pc c |
    Pinj y P \<Rightarrow> Pinj (x + y) P |
    PX p1 y p2 \<Rightarrow> Pinj x P)"

definition mkPX :: "'a::comm_ring pol \<Rightarrow> nat \<Rightarrow> 'a pol \<Rightarrow> 'a pol"
where
  "mkPX P i Q =
    (case P of
      Pc c \<Rightarrow> if c = 0 then mkPinj 1 Q else PX P i Q
    | Pinj j R \<Rightarrow> PX P i Q
    | PX P2 i2 Q2 \<Rightarrow> if Q2 = Pc 0 then PX P2 (i + i2) Q else PX P i Q)"

text {* Defining the basic ring operations on normalized polynomials *}

lemma pol_size_nz[simp]: "size (p :: 'a pol) \<noteq> 0"
  by (cases p) simp_all

function add :: "'a::comm_ring pol \<Rightarrow> 'a pol \<Rightarrow> 'a pol"  (infixl "\<oplus>" 65)
where
  "Pc a \<oplus> Pc b = Pc (a + b)"
| "Pc c \<oplus> Pinj i P = Pinj i (P \<oplus> Pc c)"
| "Pinj i P \<oplus> Pc c = Pinj i (P \<oplus> Pc c)"
| "Pc c \<oplus> PX P i Q = PX P i (Q \<oplus> Pc c)"
| "PX P i Q \<oplus> Pc c = PX P i (Q \<oplus> Pc c)"
| "Pinj x P \<oplus> Pinj y Q =
    (if x = y then mkPinj x (P \<oplus> Q)
     else (if x > y then mkPinj y (Pinj (x - y) P \<oplus> Q)
       else mkPinj x (Pinj (y - x) Q \<oplus> P)))"
| "Pinj x P \<oplus> PX Q y R =
    (if x = 0 then P \<oplus> PX Q y R
     else (if x = 1 then PX Q y (R \<oplus> P)
       else PX Q y (R \<oplus> Pinj (x - 1) P)))"
| "PX P x R \<oplus> Pinj y Q =
    (if y = 0 then PX P x R \<oplus> Q
     else (if y = 1 then PX P x (R \<oplus> Q)
       else PX P x (R \<oplus> Pinj (y - 1) Q)))"
| "PX P1 x P2 \<oplus> PX Q1 y Q2 =
    (if x = y then mkPX (P1 \<oplus> Q1) x (P2 \<oplus> Q2)
     else (if x > y then mkPX (PX P1 (x - y) (Pc 0) \<oplus> Q1) y (P2 \<oplus> Q2)
       else mkPX (PX Q1 (y-x) (Pc 0) \<oplus> P1) x (P2 \<oplus> Q2)))"
by pat_completeness auto
termination by (relation "measure (\<lambda>(x, y). size x + size y)") auto

function mul :: "'a::{comm_ring} pol \<Rightarrow> 'a pol \<Rightarrow> 'a pol"  (infixl "\<otimes>" 70)
where
  "Pc a \<otimes> Pc b = Pc (a * b)"
| "Pc c \<otimes> Pinj i P =
    (if c = 0 then Pc 0 else mkPinj i (P \<otimes> Pc c))"
| "Pinj i P \<otimes> Pc c =
    (if c = 0 then Pc 0 else mkPinj i (P \<otimes> Pc c))"
| "Pc c \<otimes> PX P i Q =
    (if c = 0 then Pc 0 else mkPX (P \<otimes> Pc c) i (Q \<otimes> Pc c))"
| "PX P i Q \<otimes> Pc c =
    (if c = 0 then Pc 0 else mkPX (P \<otimes> Pc c) i (Q \<otimes> Pc c))"
| "Pinj x P \<otimes> Pinj y Q =
    (if x = y then mkPinj x (P \<otimes> Q) else
       (if x > y then mkPinj y (Pinj (x-y) P \<otimes> Q)
         else mkPinj x (Pinj (y - x) Q \<otimes> P)))"
| "Pinj x P \<otimes> PX Q y R =
    (if x = 0 then P \<otimes> PX Q y R else
       (if x = 1 then mkPX (Pinj x P \<otimes> Q) y (R \<otimes> P)
         else mkPX (Pinj x P \<otimes> Q) y (R \<otimes> Pinj (x - 1) P)))"
| "PX P x R \<otimes> Pinj y Q =
    (if y = 0 then PX P x R \<otimes> Q else
       (if y = 1 then mkPX (Pinj y Q \<otimes> P) x (R \<otimes> Q)
         else mkPX (Pinj y Q \<otimes> P) x (R \<otimes> Pinj (y - 1) Q)))"
| "PX P1 x P2 \<otimes> PX Q1 y Q2 =
    mkPX (P1 \<otimes> Q1) (x + y) (P2 \<otimes> Q2) \<oplus>
      (mkPX (P1 \<otimes> mkPinj 1 Q2) x (Pc 0) \<oplus>
        (mkPX (Q1 \<otimes> mkPinj 1 P2) y (Pc 0)))"
by pat_completeness auto
termination by (relation "measure (\<lambda>(x, y). size x + size y)")
  (auto simp add: mkPinj_def split: pol.split)

text {* Negation*}
primrec neg :: "'a::{comm_ring} pol \<Rightarrow> 'a pol"
where
  "neg (Pc c) = Pc (-c)"
| "neg (Pinj i P) = Pinj i (neg P)"
| "neg (PX P x Q) = PX (neg P) x (neg Q)"

text {* Substraction *}
definition sub :: "'a::{comm_ring} pol \<Rightarrow> 'a pol \<Rightarrow> 'a pol"  (infixl "\<ominus>" 65)
  where "sub P Q = P \<oplus> neg Q"

text {* Square for Fast Exponentation *}
primrec sqr :: "'a::{comm_ring_1} pol \<Rightarrow> 'a pol"
where
  "sqr (Pc c) = Pc (c * c)"
| "sqr (Pinj i P) = mkPinj i (sqr P)"
| "sqr (PX A x B) =
    mkPX (sqr A) (x + x) (sqr B) \<oplus> mkPX (Pc (1 + 1) \<otimes> A \<otimes> mkPinj 1 B) x (Pc 0)"

text {* Fast Exponentation *}

fun pow :: "nat \<Rightarrow> 'a::{comm_ring_1} pol \<Rightarrow> 'a pol"
where
  pow_if [simp del]: "pow n P =
   (if n = 0 then Pc 1 else if even n then pow (n div 2) (sqr P)
    else P \<otimes> pow (n div 2) (sqr P))"

lemma pow_simps [simp]:
  "pow 0 P = Pc 1"
  "pow (2 * n) P = pow n (sqr P)"
  "pow (Suc (2 * n)) P = P \<otimes> pow n (sqr P)"
  by (simp_all add: pow_if)

lemma even_pow:
  "even n \<Longrightarrow> pow n P = pow (n div 2) (sqr P)"
  by (erule evenE) simp

lemma odd_pow:
  "odd n \<Longrightarrow> pow n P = P \<otimes> pow (n div 2) (sqr P)"
  by (erule oddE) simp

text {* Normalization of polynomial expressions *}

primrec norm :: "'a::{comm_ring_1} polex \<Rightarrow> 'a pol"
where
  "norm (Pol P) = P"
| "norm (Add P Q) = norm P \<oplus> norm Q"
| "norm (Sub P Q) = norm P \<ominus> norm Q"
| "norm (Mul P Q) = norm P \<otimes> norm Q"
| "norm (Pow P n) = pow n (norm P)"
| "norm (Neg P) = neg (norm P)"

text {* mkPinj preserve semantics *}
lemma mkPinj_ci: "Ipol l (mkPinj a B) = Ipol l (Pinj a B)"
  by (induct B) (auto simp add: mkPinj_def algebra_simps)

text {* mkPX preserves semantics *}
lemma mkPX_ci: "Ipol l (mkPX A b C) = Ipol l (PX A b C)"
  by (cases A) (auto simp add: mkPX_def mkPinj_ci power_add algebra_simps)

text {* Correctness theorems for the implemented operations *}

text {* Negation *}
lemma neg_ci: "Ipol l (neg P) = -(Ipol l P)"
  by (induct P arbitrary: l) auto

text {* Addition *}
lemma add_ci: "Ipol l (P \<oplus> Q) = Ipol l P + Ipol l Q"
proof (induct P Q arbitrary: l rule: add.induct)
  case (6 x P y Q)
  show ?case
  proof (rule linorder_cases)
    assume "x < y"
    with 6 show ?case by (simp add: mkPinj_ci algebra_simps)
  next
    assume "x = y"
    with 6 show ?case by (simp add: mkPinj_ci)
  next
    assume "x > y"
    with 6 show ?case by (simp add: mkPinj_ci algebra_simps)
  qed
next
  case (7 x P Q y R)
  have "x = 0 \<or> x = 1 \<or> x > 1" by arith
  moreover
  { assume "x = 0" with 7 have ?case by simp }
  moreover
  { assume "x = 1" with 7 have ?case by (simp add: algebra_simps) }
  moreover
  { assume "x > 1" from 7 have ?case by (cases x) simp_all }
  ultimately show ?case by blast
next
  case (8 P x R y Q)
  have "y = 0 \<or> y = 1 \<or> y > 1" by arith
  moreover
  { assume "y = 0" with 8 have ?case by simp }
  moreover
  { assume "y = 1" with 8 have ?case by simp }
  moreover
  { assume "y > 1" with 8 have ?case by simp }
  ultimately show ?case by blast
next
  case (9 P1 x P2 Q1 y Q2)
  show ?case
  proof (rule linorder_cases)
    assume a: "x < y" hence "EX d. d + x = y" by arith
    with 9 a show ?case by (auto simp add: mkPX_ci power_add algebra_simps)
  next
    assume a: "y < x" hence "EX d. d + y = x" by arith
    with 9 a show ?case by (auto simp add: power_add mkPX_ci algebra_simps)
  next
    assume "x = y"
    with 9 show ?case by (simp add: mkPX_ci algebra_simps)
  qed
qed (auto simp add: algebra_simps)

text {* Multiplication *}
lemma mul_ci: "Ipol l (P \<otimes> Q) = Ipol l P * Ipol l Q"
  by (induct P Q arbitrary: l rule: mul.induct)
    (simp_all add: mkPX_ci mkPinj_ci algebra_simps add_ci power_add)

text {* Substraction *}
lemma sub_ci: "Ipol l (P \<ominus> Q) = Ipol l P - Ipol l Q"
  by (simp add: add_ci neg_ci sub_def)

text {* Square *}
lemma sqr_ci: "Ipol ls (sqr P) = Ipol ls P * Ipol ls P"
  by (induct P arbitrary: ls)
    (simp_all add: add_ci mkPinj_ci mkPX_ci mul_ci algebra_simps power_add)

text {* Power *}
lemma pow_ci: "Ipol ls (pow n P) = Ipol ls P ^ n"
proof (induct n arbitrary: P rule: less_induct)
  case (less k)
  show ?case
  proof (cases "k = 0")
    case True then show ?thesis by simp
  next
    case False then have "k > 0" by simp
    then have "k div 2 < k" by arith
    with less have *: "Ipol ls (pow (k div 2) (sqr P)) = Ipol ls (sqr P) ^ (k div 2)"
      by simp
    show ?thesis
    proof (cases "even k")
      case True with * show ?thesis
        by (simp add: even_pow sqr_ci power_mult_distrib power_add [symmetric] mult_2 [symmetric] even_two_times_div_two)
    next
      case False with * show ?thesis
        by (simp add: odd_pow mul_ci sqr_ci power_mult_distrib power_add [symmetric] mult_2 [symmetric] power_Suc [symmetric])
    qed
  qed
qed

text {* Normalization preserves semantics  *}
lemma norm_ci: "Ipolex l Pe = Ipol l (norm Pe)"
  by (induct Pe) (simp_all add: add_ci sub_ci mul_ci neg_ci pow_ci)

text {* Reflection lemma: Key to the (incomplete) decision procedure *}
lemma norm_eq:
  assumes "norm P1 = norm P2"
  shows "Ipolex l P1 = Ipolex l P2"
proof -
  from assms have "Ipol l (norm P1) = Ipol l (norm P2)" by simp
  then show ?thesis by (simp only: norm_ci)
qed

ML_file "commutative_ring_tac.ML"

method_setup comm_ring = {*
  Scan.succeed (SIMPLE_METHOD' o Commutative_Ring_Tac.tac)
*} "reflective decision procedure for equalities over commutative rings"

end


(* Title:      Conway Algebra
   Author:     Alasdair Armstrong, Victor B. F. Gomes, Georg Struth
   Maintainer: Georg Struth <g.struth at sheffield.ac.uk>
               Tjark Weber <tjark.weber at it.uu.se>
*)

section \<open>Conway Algebras\<close>

theory Conway
  imports Dioid
begin

text \<open>
  We define a weak regular algebra which can serve as a common basis for Kleene algebra and demonic reginement algebra.
  It is closely related to an axiomatisation given by Conway~\<^cite>\<open>"conway71regular"\<close>.
\<close>

class dagger_op =
  fixes dagger :: "'a \<Rightarrow> 'a" ("_\<^sup>\<dagger>" [101] 100)

subsection\<open>Near Conway Algebras\<close>

class near_conway_base = near_dioid_one + dagger_op +
  assumes dagger_denest: "(x + y)\<^sup>\<dagger> = (x\<^sup>\<dagger> \<cdot> y)\<^sup>\<dagger> \<cdot> x\<^sup>\<dagger>"
  and dagger_prod_unfold [simp]: "1 + x \<cdot> (y \<cdot> x)\<^sup>\<dagger> \<cdot> y = (x \<cdot> y)\<^sup>\<dagger>"

begin

lemma dagger_unfoldl_eq [simp]: "1 + x \<cdot> x\<^sup>\<dagger> = x\<^sup>\<dagger>"
  by (metis dagger_prod_unfold mult_1_left mult_1_right)

lemma dagger_unfoldl: "1 + x \<cdot> x\<^sup>\<dagger> \<le> x\<^sup>\<dagger>"
  by auto

lemma dagger_unfoldr_eq [simp]: "1 + x\<^sup>\<dagger> \<cdot> x = x\<^sup>\<dagger>"
  by (metis dagger_prod_unfold mult_1_right mult_1_left)

lemma dagger_unfoldr: "1 + x\<^sup>\<dagger> \<cdot> x \<le> x\<^sup>\<dagger>"
  by auto

lemma dagger_unfoldl_distr [simp]: "y + x \<cdot> x\<^sup>\<dagger> \<cdot> y = x\<^sup>\<dagger> \<cdot> y"
  by (metis distrib_right' mult_1_left dagger_unfoldl_eq)

lemma dagger_unfoldr_distr [simp]: "y + x\<^sup>\<dagger> \<cdot> x \<cdot> y = x\<^sup>\<dagger> \<cdot> y"
  by (metis dagger_unfoldr_eq distrib_right' mult_1_left mult.assoc)

lemma dagger_refl: "1 \<le> x\<^sup>\<dagger>"
  using dagger_unfoldl local.join.sup.bounded_iff by blast

lemma dagger_plus_one [simp]: "1 + x\<^sup>\<dagger> = x\<^sup>\<dagger>"
  by (simp add: dagger_refl local.join.sup_absorb2)

lemma star_1l: "x \<cdot> x\<^sup>\<dagger> \<le> x\<^sup>\<dagger>"
  using dagger_unfoldl local.join.sup.bounded_iff by blast

lemma star_1r: "x\<^sup>\<dagger> \<cdot> x \<le> x\<^sup>\<dagger>"
  using dagger_unfoldr local.join.sup.bounded_iff by blast

lemma dagger_ext: "x \<le> x\<^sup>\<dagger>"
  by (metis dagger_unfoldl_distr local.join.sup.boundedE star_1r)

lemma dagger_trans_eq [simp]: "x\<^sup>\<dagger> \<cdot> x\<^sup>\<dagger> = x\<^sup>\<dagger>"
  by (metis dagger_unfoldr_eq local.dagger_denest local.join.sup.idem mult_assoc)

lemma dagger_subdist:  "x\<^sup>\<dagger> \<le> (x + y)\<^sup>\<dagger>"
  by (metis dagger_unfoldr_distr local.dagger_denest local.order_prop)

lemma dagger_subdist_var:  "x\<^sup>\<dagger> + y\<^sup>\<dagger> \<le> (x + y)\<^sup>\<dagger>"
  using dagger_subdist local.join.sup_commute by fastforce

lemma dagger_iso [intro]: "x \<le> y \<Longrightarrow> x\<^sup>\<dagger> \<le> y\<^sup>\<dagger>"
  by (metis less_eq_def dagger_subdist)

lemma star_square: "(x \<cdot> x)\<^sup>\<dagger> \<le> x\<^sup>\<dagger>"
  by (metis dagger_plus_one dagger_subdist dagger_trans_eq dagger_unfoldr_distr dagger_denest
    distrib_right' order.eq_iff join.sup_commute less_eq_def mult_onel mult_assoc)

lemma dagger_rtc1_eq [simp]: "1 + x + x\<^sup>\<dagger> \<cdot> x\<^sup>\<dagger> = x\<^sup>\<dagger>"
  by (simp add: local.dagger_ext local.dagger_refl local.join.sup_absorb2)

text \<open>Nitpick refutes the next lemmas.\<close>

lemma " y + y \<cdot> x\<^sup>\<dagger> \<cdot> x = y \<cdot> x\<^sup>\<dagger>"
(*nitpick [expect=genuine]*)
  oops

lemma "y \<cdot> x\<^sup>\<dagger> = y + y \<cdot> x \<cdot> x\<^sup>\<dagger>"
(*nitpick [expect=genuine]*)
  oops

lemma "(x + y)\<^sup>\<dagger> = x\<^sup>\<dagger> \<cdot> (y \<cdot> x\<^sup>\<dagger>)\<^sup>\<dagger>"
(*nitpick [expect=genuine]*)
  oops

lemma "(x\<^sup>\<dagger>)\<^sup>\<dagger> = x\<^sup>\<dagger>"
(*nitpick [expect=genuine]*)
oops

lemma "(1 + x)\<^sup>\<star> = x\<^sup>\<star>"
(*nitpick [expect = genuine]*)
oops

lemma "x\<^sup>\<dagger> \<cdot> x = x \<cdot> x\<^sup>\<dagger>"
(*nitpick [expect=genuine]*)
oops

end

subsection\<open>Pre-Conway Algebras\<close>

class pre_conway_base = near_conway_base + pre_dioid_one

begin

lemma dagger_subdist_var_3: "x\<^sup>\<dagger> \<cdot> y\<^sup>\<dagger> \<le> (x + y)\<^sup>\<dagger>"
  using local.dagger_subdist_var local.mult_isol_var by fastforce

lemma dagger_subdist_var_2: "x \<cdot> y \<le> (x + y)\<^sup>\<dagger>"
  by (meson dagger_subdist_var_3 local.dagger_ext local.mult_isol_var local.order.trans)

lemma dagger_sum_unfold [simp]: "x\<^sup>\<dagger> + x\<^sup>\<dagger> \<cdot> y \<cdot> (x + y)\<^sup>\<dagger> = (x + y)\<^sup>\<dagger>"
  by (metis local.dagger_denest local.dagger_unfoldl_distr mult_assoc)

end

subsection \<open>Conway Algebras\<close>

class conway_base = pre_conway_base + dioid_one

begin

lemma troeger: "(x + y)\<^sup>\<dagger> \<cdot> z = x\<^sup>\<dagger> \<cdot> (y \<cdot> (x + y)\<^sup>\<dagger> \<cdot> z + z)"
proof -
  have "(x + y)\<^sup>\<dagger> \<cdot> z = x\<^sup>\<dagger> \<cdot> z + x\<^sup>\<dagger> \<cdot> y \<cdot> (x + y)\<^sup>\<dagger> \<cdot> z"
    by (metis dagger_sum_unfold local.distrib_right')
  thus ?thesis
   by (metis add_commute local.distrib_left mult_assoc)
qed

lemma dagger_slide_var1: "x\<^sup>\<dagger> \<cdot> x \<le> x \<cdot> x\<^sup>\<dagger>"
  by (metis local.dagger_unfoldl_distr local.dagger_unfoldr_eq local.distrib_left order.eq_iff local.mult_1_right mult_assoc)

lemma dagger_slide_var1_eq: "x\<^sup>\<dagger> \<cdot> x = x \<cdot> x\<^sup>\<dagger>"
  by (metis local.dagger_unfoldl_distr local.dagger_unfoldr_eq local.distrib_left local.mult_1_right mult_assoc)

lemma dagger_slide_eq: "(x \<cdot> y)\<^sup>\<dagger> \<cdot> x = x \<cdot> (y \<cdot> x)\<^sup>\<dagger>"
proof -
  have "(x \<cdot> y)\<^sup>\<dagger> \<cdot> x = x + x \<cdot> (y \<cdot> x)\<^sup>\<dagger> \<cdot> y \<cdot> x"
    by (metis local.dagger_prod_unfold local.distrib_right' local.mult_onel)
  also have "... = x \<cdot> (1 + (y \<cdot> x)\<^sup>\<dagger> \<cdot> y \<cdot> x)"
    using local.distrib_left local.mult_1_right mult_assoc by presburger
  finally show ?thesis
    by (simp add: mult_assoc)
qed

end

subsection \<open>Conway Algebras with  Zero\<close>

class near_conway_base_zerol = near_conway_base + near_dioid_one_zerol

begin

lemma dagger_annil [simp]: "1 + x \<cdot> 0 = (x \<cdot> 0)\<^sup>\<dagger>"
  by (metis annil dagger_unfoldl_eq mult.assoc)

lemma zero_dagger [simp]: "0\<^sup>\<dagger> = 1"
  by (metis add_0_right annil dagger_annil)

end

class pre_conway_base_zerol = near_conway_base_zerol + pre_dioid

class conway_base_zerol = pre_conway_base_zerol + dioid

subclass (in pre_conway_base_zerol) pre_conway_base ..

subclass (in conway_base_zerol) conway_base ..

context conway_base_zerol
begin

lemma "z \<cdot> x \<le> y \<cdot> z \<Longrightarrow> z \<cdot> x\<^sup>\<dagger> \<le> y\<^sup>\<dagger> \<cdot> z"
(*nitpick [expect=genuine]*)
oops

end

subsection \<open>Conway Algebras with Simulation\<close>

class near_conway = near_conway_base +
  assumes dagger_simr: "z \<cdot> x \<le> y \<cdot> z \<Longrightarrow> z \<cdot> x\<^sup>\<dagger> \<le> y\<^sup>\<dagger> \<cdot> z"

begin

lemma dagger_slide_var: "x \<cdot> (y \<cdot> x)\<^sup>\<dagger> \<le> (x \<cdot> y)\<^sup>\<dagger> \<cdot> x"
  by (metis eq_refl dagger_simr mult.assoc)

text \<open>Nitpick refutes the next lemma.\<close>

lemma dagger_slide: "x \<cdot> (y \<cdot> x)\<^sup>\<dagger> = (x \<cdot> y)\<^sup>\<dagger> \<cdot> x"
(*nitpick [expect=genuine]*)
  oops

text \<open>
  We say that $y$ preserves $x$ if $x \cdot y \cdot x = x \cdot y$ and $!x \cdot y \cdot !x = !x \cdot y$. This definition is taken
  from Solin~\<^cite>\<open>"Solin11"\<close>. It is useful for program transformation.
\<close>

lemma preservation1: "x \<cdot> y \<le> x \<cdot> y \<cdot> x \<Longrightarrow> x \<cdot> y\<^sup>\<dagger> \<le> (x \<cdot> y + z)\<^sup>\<dagger> \<cdot> x"
proof -
  assume "x \<cdot> y \<le> x \<cdot> y \<cdot> x"
  hence "x \<cdot> y \<le> (x \<cdot> y + z) \<cdot> x"
    by (simp add: local.join.le_supI1)
  thus ?thesis
    by (simp add: local.dagger_simr)
qed

end

class near_conway_zerol = near_conway + near_dioid_one_zerol

class pre_conway = near_conway + pre_dioid_one

begin

subclass pre_conway_base ..

lemma dagger_slide: "x \<cdot> (y \<cdot> x)\<^sup>\<dagger> = (x \<cdot> y)\<^sup>\<dagger> \<cdot> x"
  by (metis add.commute dagger_prod_unfold join.sup_least mult_1_right mult.assoc subdistl dagger_slide_var dagger_unfoldl_distr order.antisym)

lemma dagger_denest2: "(x + y)\<^sup>\<dagger> = x\<^sup>\<dagger> \<cdot> (y \<cdot> x\<^sup>\<dagger>)\<^sup>\<dagger>"
  by (metis dagger_denest dagger_slide)

lemma preservation2: "y \<cdot> x \<le> y \<Longrightarrow> (x \<cdot> y)\<^sup>\<dagger> \<cdot> x \<le> x \<cdot> y\<^sup>\<dagger>"
  by (metis dagger_slide local.dagger_iso local.mult_isol)

lemma preservation1_eq: "x \<cdot> y \<le> x \<cdot> y \<cdot> x \<Longrightarrow> y \<cdot> x \<le> y \<Longrightarrow> (x \<cdot> y)\<^sup>\<dagger> \<cdot> x = x \<cdot> y\<^sup>\<dagger>"
  by (simp add: local.dagger_simr order.eq_iff preservation2)

end

class pre_conway_zerol = near_conway_zerol + pre_dioid_one_zerol

begin

subclass pre_conway ..

end

class conway = pre_conway + dioid_one

class conway_zerol = pre_conway + dioid_one_zerol

begin

subclass conway_base ..

text \<open>Nitpick refutes the next lemmas.\<close>

lemma "1 = 1\<^sup>\<dagger>"
(*nitpick [expect=genuine]*)
oops

lemma "(x\<^sup>\<dagger>)\<^sup>\<dagger> = x\<^sup>\<dagger>"
(*nitpick [expect=genuine]*)
oops

lemma dagger_denest_var [simp]: "(x + y)\<^sup>\<dagger> = (x\<^sup>\<dagger> \<cdot> y\<^sup>\<dagger>)\<^sup>\<dagger>"
(* nitpick [expect=genuine]*)
oops

lemma star2 [simp]: "(1 + x)\<^sup>\<dagger> = x\<^sup>\<dagger>"
(*nitpick [expect=genuine]*)
oops

end

end


section \<open>Traversal Set\<close>

text \<open>This theory defines the calculation of m-traversal paths.
      These are paths extended from some state until they visit pairwise r-distinguishable states
      a number of times dependent on m.\<close>

theory Traversal_Set
imports Helper_Algorithms
begin

definition m_traversal_paths_with_witness_up_to_length ::
  "('a,'b,'c) fsm \<Rightarrow> 'a \<Rightarrow> ('a set \<times> 'a set) list \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> (('a\<times>'b\<times>'c\<times>'a) list \<times> ('a set \<times> 'a set)) set"
  where
  "m_traversal_paths_with_witness_up_to_length M q D m k
    = paths_up_to_length_or_condition_with_witness M (\<lambda> p . find (\<lambda> d . length (filter (\<lambda>t . t_target t \<in> fst d) p) \<ge> Suc (m - (card (snd d)))) D) k q"

definition m_traversal_paths_with_witness ::
  "('a,'b,'c) fsm \<Rightarrow> 'a \<Rightarrow> ('a set \<times> 'a set) list \<Rightarrow> nat \<Rightarrow> (('a\<times>'b\<times>'c\<times>'a) list \<times> ('a set \<times> 'a set)) set"
  where
  "m_traversal_paths_with_witness M q D m = m_traversal_paths_with_witness_up_to_length M q D m (Suc (size M * m))"

lemma m_traversal_paths_with_witness_finite : "finite (m_traversal_paths_with_witness M q D m)"
  unfolding m_traversal_paths_with_witness_def m_traversal_paths_with_witness_up_to_length_def
  by (simp add: paths_up_to_length_or_condition_with_witness_finite)

lemma m_traversal_paths_with_witness_up_to_length_max_length :
  assumes "\<And> q . q \<in> nodes M \<Longrightarrow> \<exists> d \<in> set D . q \<in> fst d"
  and     "\<And> d . d \<in> set D \<Longrightarrow> snd d \<subseteq> fst d"
  and     "q \<in> nodes M"
  and     "(p,d) \<in> (m_traversal_paths_with_witness_up_to_length M q D m k)"
shows "length p \<le> Suc ((size M) * m)"
proof (rule ccontr)
  assume "\<not> length p \<le> Suc (FSM.size M * m)"

  let ?f = "(\<lambda> p . find (\<lambda> d . length (filter (\<lambda>t . t_target t \<in> fst d) p) \<ge> Suc (m - (card (snd d)))) D)"

  have "path M q []" using assms(3) by auto

  have "path M q p"
        and "length p \<le> k"
        and "?f p = Some d"
        and "\<forall>p' p''. p = p' @ p'' \<and> p'' \<noteq> [] \<longrightarrow> ?f p' = None"
    using assms(4)
    unfolding m_traversal_paths_with_witness_up_to_length_def paths_up_to_length_or_condition_with_witness_def
    by auto

  let ?p = "take (Suc (m * size M)) p"
  let ?p' = "drop (Suc (m * size M)) p"
  have "path M q ?p"
    using \<open>path M q p\<close> using path_prefix[of M q ?p "drop (Suc (m * size M)) p"]
    by simp
  have "?p' \<noteq> []"
    using \<open>\<not> length p \<le> Suc (FSM.size M * m)\<close>
    by (simp add: mult.commute)

  have "\<exists> q \<in> nodes M . length (filter (\<lambda>t . t_target t = q) ?p) \<ge> Suc m"
  proof (rule ccontr)
    assume "\<not> (\<exists>q\<in>nodes M. Suc m \<le> length (filter (\<lambda>t. t_target t = q) ?p))"
    then have "\<forall> q \<in> nodes M . length (filter (\<lambda>t. t_target t = q) ?p) < Suc m"
      by auto
    then have "\<forall> q \<in> nodes M . length (filter (\<lambda>t. t_target t = q) ?p) \<le> m"
      by auto

    have "(\<Sum>q\<in>nodes M. length (filter (\<lambda>t. t_target t = q) ?p)) \<le> (\<Sum>q\<in>nodes M . m)"
      using \<open>\<forall> q \<in> nodes M . length (filter (\<lambda>t. t_target t = q) ?p) \<le> m\<close> by (meson sum_mono)
    then have "length ?p \<le> m * (size M)"
      using path_length_sum[OF \<open>path M q ?p\<close>]
      using fsm_nodes_finite[of M]
      by (simp add: mult.commute)

    then show "False"
      using \<open>\<not> length p \<le> Suc (FSM.size M * m)\<close>
      by (simp add: mult.commute)
  qed

  then obtain q where "q \<in> nodes M"
                  and "length (filter (\<lambda> t . t_target t = q) ?p) \<ge> Suc m"
    by blast
  then obtain d where "d \<in> set D"
                  and "q \<in> fst d"
    using assms(1) by blast
  then have "\<And> t . t_target t = q \<Longrightarrow> t_target t \<in> fst d" by auto
  then have "length (filter (\<lambda> t . t_target t = q) ?p) \<le> length (filter (\<lambda> t . t_target t \<in> fst d) ?p)"
    using filter_length_weakening[of "\<lambda> t . t_target t = q" "\<lambda> t . t_target t \<in> fst d"] by auto
  then have "Suc m \<le> length (filter (\<lambda>t. t_target t \<in> fst d) ?p)"
    using \<open>length (filter (\<lambda> t . t_target t = q) ?p) \<ge> Suc m\<close> by auto
  then have "?f ?p \<noteq> None"
    using assms(2)
  proof -
    have "\<forall>p. find p D \<noteq> None \<or> \<not> p d"
      by (metis \<open>d \<in> set D\<close> find_from)
    then show ?thesis
      using \<open>Suc m \<le> length (filter (\<lambda>t. t_target t \<in> fst d) (take (Suc (m * FSM.size M)) p))\<close>
            diff_le_self le_trans not_less_eq_eq
      by blast
  qed
  then obtain d' where "?f ?p = Some d'"
    by blast

  then have "p = ?p@?p' \<and> ?p' \<noteq> [] \<and> ?f ?p = Some d'"
    using \<open>?p' \<noteq> []\<close> by auto

  then show "False"
    using \<open>\<forall>p' p''. p = p' @ p'' \<and> p'' \<noteq> [] \<longrightarrow> (?f p') = None\<close>
    by (metis (no_types) option.distinct(1))
qed

lemma m_traversal_paths_with_witness_set :
  assumes "\<And> q . q \<in> nodes M \<Longrightarrow> \<exists> d \<in> set D . q \<in> fst d"
  and     "\<And> d .  d \<in> set D \<Longrightarrow> snd d \<subseteq> fst d"
  and     "q \<in> nodes M"
shows "(m_traversal_paths_with_witness M q D m)
          = {(p,d) | p d . path M q p
                            \<and> find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p)) D = Some d
                            \<and> (\<forall>p' p''. p = p' @ p'' \<and> p'' \<noteq> [] \<longrightarrow> find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p')) D = None)}"
        (is "?MTP = ?P")
proof -
  let ?f = "(\<lambda> p . find (\<lambda> d . length (filter (\<lambda>t . t_target t \<in> fst d) p) \<ge> Suc (m - (card (snd d)))) D)"

  have "path M q []"
    using assms(3) by auto

  have "\<And> p . p \<in> ?MTP \<Longrightarrow> p \<in> ?P"
    unfolding m_traversal_paths_with_witness_def m_traversal_paths_with_witness_up_to_length_def
              paths_up_to_length_or_condition_with_witness_def
    by force
  moreover have "\<And> p . p \<in> ?P \<Longrightarrow> p \<in> ?MTP"
  proof -
    fix px assume "px \<in> ?P"
    then obtain p x where "px = (p,x)"
          and p1: "path M q p"
          and **: "find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p)) D = Some x"
          and ***:"(\<forall>p' p''.
                     p = p' @ p'' \<and> p'' \<noteq> [] \<longrightarrow>
                     find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p')) D = None)"
      using prod.collapse by force

    then have "(p,x) \<in> (m_traversal_paths_with_witness_up_to_length M q D m (length p))"
      unfolding m_traversal_paths_with_witness_up_to_length_def paths_up_to_length_or_condition_with_witness_def
      by force
    then have "length p \<le> Suc (size M * m)"
      using m_traversal_paths_with_witness_up_to_length_max_length[OF assms] by blast

    have "(p,x) \<in> ?MTP"
      using \<open>path M q p\<close> \<open>length p \<le> Suc (size M * m)\<close> \<open>?f p = Some x\<close>
            \<open>\<forall>p' p''. p = p' @ p'' \<and> p'' \<noteq> [] \<longrightarrow> (?f p') = None\<close>
      unfolding m_traversal_paths_with_witness_def m_traversal_paths_with_witness_up_to_length_def
                paths_up_to_length_or_condition_with_witness_def
      by force
    then show "px \<in> ?MTP"
      using \<open>px = (p,x)\<close> by simp
  qed
  ultimately show ?thesis
    by (meson subsetI subset_antisym)
qed

lemma maximal_repetition_sets_from_separators_cover :
  assumes "q \<in> nodes M"
  shows "\<exists> d \<in> (maximal_repetition_sets_from_separators M) . q \<in> fst d"
  unfolding maximal_repetition_sets_from_separators_def
  using maximal_pairwise_r_distinguishable_state_sets_from_separators_cover[OF assms] by auto

lemma maximal_repetition_sets_from_separators_d_reachable_subset :
  shows "\<And> d . d \<in> (maximal_repetition_sets_from_separators M) \<Longrightarrow> snd d \<subseteq> fst d"
  unfolding maximal_repetition_sets_from_separators_def
  by auto

(* Sufficient conditions for a path to be contained in the m-traversal paths *)
lemma m_traversal_paths_with_witness_set_containment :
  assumes "q \<in> nodes M"
  and     "path M q p"
  and     "d \<in> set repSets"
  and     "Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p)"
  and     "\<And> p' p''.
                  p = p' @ p'' \<Longrightarrow> p'' \<noteq> [] \<Longrightarrow>
                  \<not> (\<exists>d\<in>set repSets.
                         Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p'))"
  and     "\<And> q . q\<in>nodes M \<Longrightarrow> \<exists>d\<in>set repSets. q \<in> fst d"
  and     "\<And> d . d\<in>set repSets \<Longrightarrow> snd d \<subseteq> fst d"
shows "\<exists> d' . (p,d') \<in> (m_traversal_paths_with_witness M q repSets m)"
proof -
  obtain d' where "find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p)) repSets = Some d'"
    using assms(3,4) find_None_iff[of "(\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p))" repSets]
    by auto
  moreover have "(\<And> p' p''. p = p' @ p'' \<Longrightarrow> p'' \<noteq> []
                  \<Longrightarrow> find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p')) repSets = None)"
    using assms(5) find_None_iff[of _ repSets] by force
  ultimately show ?thesis
    using m_traversal_paths_with_witness_set[of M repSets q m, OF  assms(6,7,1)]
    using assms(2) by blast
qed

lemma m_traversal_path_exist :
  assumes "completely_specified M"
  and     "q \<in> nodes M"
  and     "inputs M \<noteq> {}"
  and     "\<And> q . q\<in>nodes M \<Longrightarrow> \<exists>d\<in>set D. q \<in> fst d"
  and     "\<And> d . d \<in> set D \<Longrightarrow> snd d \<subseteq> fst d"
shows "\<exists> p' d' . (p',d') \<in> (m_traversal_paths_with_witness M q D m)"
proof -

  obtain p where "path M q p" and "length p = Suc ((size M) * m)"
    using path_of_length_ex[OF assms(1-3)] by blast

  let ?f = "(\<lambda> p . find (\<lambda> d . length (filter (\<lambda>t . t_target t \<in> fst d) p) \<ge> Suc (m - (card (snd d)))) D)"

  have "\<exists> q \<in> nodes M . length (filter (\<lambda>t . t_target t = q) p) \<ge> Suc m"
  proof (rule ccontr)
    assume "\<not> (\<exists>q\<in>nodes M. Suc m \<le> length (filter (\<lambda>t. t_target t = q) p))"
    then have "\<forall> q \<in> nodes M . length (filter (\<lambda>t. t_target t = q) p) < Suc m"
      by auto
    then have "\<forall> q \<in> nodes M . length (filter (\<lambda>t. t_target t = q) p) \<le> m"
      by auto

    have "(\<Sum>q\<in>nodes M. length (filter (\<lambda>t. t_target t = q) p)) \<le> (\<Sum>q\<in>nodes M . m)"
      using \<open>\<forall> q \<in> nodes M . length (filter (\<lambda>t. t_target t = q) p) \<le> m\<close> by (meson sum_mono)
    then have "length p \<le> m * (size M)"
      using path_length_sum[OF \<open>path M q p\<close>]
      using fsm_nodes_finite[of M]
      by (simp add: mult.commute)

    then show "False"
      using \<open>length p = Suc ((size M) * m)\<close>
      by (simp add: mult.commute)
  qed

  then obtain q' where "q' \<in> nodes M"
                   and "length (filter (\<lambda> t . t_target t = q') p) \<ge> Suc m"
    by blast
  then obtain d where "d \<in> set D"
                  and "q' \<in> fst d"
    using assms(4) by blast
  then have "\<And> t . t_target t = q' \<Longrightarrow> t_target t \<in> fst d" by auto
  then have "length (filter (\<lambda> t . t_target t = q') p) \<le> length (filter (\<lambda> t . t_target t \<in> fst d) p)"
    using filter_length_weakening[of "\<lambda> t . t_target t = q'" "\<lambda> t . t_target t \<in> fst d"] by auto
  then have "Suc m \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p)"
    using \<open>length (filter (\<lambda> t . t_target t = q') p) \<ge> Suc m\<close> by auto
  then have "?f p \<noteq> None"
    using assms(2)
  proof -
    have "\<forall>p. find p D \<noteq> None \<or> \<not> p d"
      by (metis \<open>d \<in> set D\<close> find_from)
    have "Suc (m - card (snd d)) \<le> length (filter (\<lambda>p. t_target p \<in> fst d) p)"
      using \<open>Suc m \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p)\<close> by linarith
    then show ?thesis
      using \<open>\<forall>p. find p D \<noteq> None \<or> \<not> p d\<close> by blast
  qed
  then obtain d' where "?f p = Some d'"
    by blast

  show ?thesis proof (cases "(\<forall>p' p''. p = p' @ p'' \<and> p'' \<noteq> [] \<longrightarrow> find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p')) D = None)")
    case True
    then show ?thesis
      using m_traversal_paths_with_witness_set[OF assms(4,5,2), of m] \<open>path M q p\<close> \<open>?f p = Some d'\<close>
      by blast
  next
    case False

    define ps where ps_def: "ps = {p' . \<exists> p''. p = p' @ p'' \<and> p'' \<noteq> []
                                              \<and> find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p')) D \<noteq> None}"
    have "ps \<noteq> {}"
      using False ps_def
      by blast
    moreover have "finite ps"
    proof -
      have "ps \<subseteq> set (prefixes p)"
        unfolding prefixes_set ps_def
        by blast
      then show ?thesis
        by (meson List.finite_set rev_finite_subset)
    qed
    ultimately obtain p' where "p' \<in> ps" and "\<And> p'' . p'' \<in> ps \<Longrightarrow> length p' \<le> length p''"
      by (meson leI min_length_elem)
    then have "\<And>p'' p''' . p' = p'' @ p''' \<Longrightarrow> p''' \<noteq> []
                \<Longrightarrow> find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p'')) D = None"
    proof -
      fix p'' p''' assume "p' = p'' @ p'''" and "p''' \<noteq> []"
      show "find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p'')) D = None"
      proof (rule ccontr)
        assume "find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p'')) D \<noteq> None"
        moreover have "\<exists>p'''. p = p'' @ p''' \<and> p''' \<noteq> []"
          using \<open>p' \<in> ps\<close> \<open>p' = p'' @ p'''\<close> unfolding ps_def by auto
        ultimately have "p'' \<in> ps"
          unfolding ps_def by auto
        moreover have "length p'' < length p'"
          using \<open>p''' \<noteq> []\<close> \<open>p' = p'' @ p'''\<close> by auto
        ultimately show "False"
          using \<open>\<And> p'' . p'' \<in> ps \<Longrightarrow> length p' \<le> length p''\<close>
          using leD by auto
      qed
    qed

    have "path M q p'" and "find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p')) D \<noteq> None"
      using \<open>path M q p\<close> \<open>p' \<in> ps\<close> unfolding ps_def by auto
    then obtain d' where "find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p')) D = Some d'"
      by auto

    then have "path M q p' \<and>
               find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p')) D = Some d' \<and>
               (\<forall>p'' p'''. p' = p'' @ p''' \<and> p''' \<noteq> [] \<longrightarrow> find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p'')) D = None)"
      using \<open>\<And>p'' p''' . p' = p'' @ p''' \<Longrightarrow> p''' \<noteq> [] \<Longrightarrow> find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p'')) D = None\<close>
            \<open>path M q p'\<close>
      by blast
    then have "(p',d') \<in> (m_traversal_paths_with_witness M q D m)"
      using m_traversal_paths_with_witness_set[OF assms(4,5,2), of m] by blast
    then show ?thesis by blast
  qed
qed

lemma m_traversal_path_extension_exist :
  assumes "completely_specified M"
  and     "q \<in> nodes M"
  and     "inputs M \<noteq> {}"
  and     "\<And> q . q\<in>nodes M \<Longrightarrow> \<exists>d\<in>set D. q \<in> fst d"
  and     "\<And> d . d \<in> set D \<Longrightarrow> snd d \<subseteq> fst d"
  and     "path M q p1"
  and     "find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p1)) D = None"
shows "\<exists> p2 d' . (p1@p2,d') \<in> (m_traversal_paths_with_witness M q D m)"
proof -
  obtain p2 where "path M (target q p1) p2" and "length p2 = (Suc ((size M) * m)) - length p1"
    using path_of_length_ex[OF assms(1) path_target_is_node[OF assms(6)] assms(3)]
    by blast

  have "path M q (p1@p2)"
    using assms(6) \<open>path M (target q p1) p2\<close> by auto

  let ?f = "(\<lambda> p . find (\<lambda> d . length (filter (\<lambda>t . t_target t \<in> fst d) p) \<ge> Suc (m - (card (snd d)))) D)"

  have "length p1 < Suc ((size M) * m)"
  proof (rule ccontr)
    assume "\<not> length p1 < Suc (FSM.size M * m)"
    then have "length (take (Suc (FSM.size M * m)) p1) = Suc (FSM.size M * m)"
      by auto
    let ?p = "(take (Suc (FSM.size M * m)) p1)"

    have "path M q ?p"
      using \<open>path M q p1\<close>
      by (metis append_take_drop_id path_append_elim)

    have "\<exists> q \<in> nodes M . length (filter (\<lambda>t . t_target t = q) ?p) \<ge> Suc m"
    proof (rule ccontr)
      assume "\<not> (\<exists>q\<in>nodes M. Suc m \<le> length (filter (\<lambda>t. t_target t = q) ?p))"
      then have "\<forall> q \<in> nodes M . length (filter (\<lambda>t. t_target t = q) ?p) < Suc m"
        by auto
      then have "\<forall> q \<in> nodes M . length (filter (\<lambda>t. t_target t = q) ?p) \<le> m"
        by auto

      have "(\<Sum>q\<in>nodes M. length (filter (\<lambda>t. t_target t = q) ?p)) \<le> (\<Sum>q\<in>nodes M . m)"
        using \<open>\<forall> q \<in> nodes M . length (filter (\<lambda>t. t_target t = q) ?p) \<le> m\<close> by (meson sum_mono)
      then have "length ?p \<le> m * (size M)"
        using path_length_sum[OF \<open>path M q ?p\<close>]
        using fsm_nodes_finite[of M]
        by (simp add: mult.commute)

      then show "False"
        using \<open>length ?p = Suc ((size M) * m)\<close>
        by (simp add: mult.commute)
    qed
    then obtain q' where "q' \<in> nodes M"
                   and "length (filter (\<lambda> t . t_target t = q') ?p) \<ge> Suc m"
      by blast
    then obtain d where "d \<in> set D"
                    and "q' \<in> fst d"
      using assms(4) by blast
    then have "\<And> t . t_target t = q' \<Longrightarrow> t_target t \<in> fst d" by auto
    then have "length (filter (\<lambda> t . t_target t = q') ?p) \<le> length (filter (\<lambda> t . t_target t \<in> fst d) ?p)"
      using filter_length_weakening[of "\<lambda> t . t_target t = q'" "\<lambda> t . t_target t \<in> fst d"] by auto
    then have "Suc m \<le> length (filter (\<lambda>t. t_target t \<in> fst d) ?p)"
      using \<open>length (filter (\<lambda> t . t_target t = q') ?p) \<ge> Suc m\<close> by auto
    moreover have "length (filter (\<lambda>t. t_target t \<in> fst d) ?p) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p1)"
    proof -
      have "\<And> xs P n . length (filter P (take n xs)) \<le> length (filter P xs)"
        by (metis append_take_drop_id filter_append le0 le_add_same_cancel1 length_append)
      then show ?thesis by auto
    qed
    ultimately have "Suc m \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p1)"
      by auto
    then have "?f p1 \<noteq> None"
      using assms(2)
    proof -
      have "\<forall>p. find p D \<noteq> None \<or> \<not> p d"
        by (metis \<open>d \<in> set D\<close> find_from)
      have "Suc (m - card (snd d)) \<le> length (filter (\<lambda>p. t_target p \<in> fst d) p1)"
        using \<open>Suc m \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p1)\<close> by linarith
      then show ?thesis
        using \<open>\<forall>p. find p D \<noteq> None \<or> \<not> p d\<close> by blast
    qed
    then obtain d' where "?f p1 = Some d'"
      by blast
    then show "False"
      using assms(7) by simp
  qed

  have "length (p1@p2) = (Suc ((size M) * m))"
    using \<open>length p2 = (Suc ((size M) * m)) - length p1\<close>
          \<open>length p1 < Suc ((size M) * m)\<close>
    by simp

  have "\<exists> q \<in> nodes M . length (filter (\<lambda>t . t_target t = q) (p1@p2)) \<ge> Suc m"
  proof (rule ccontr)
    assume "\<not> (\<exists>q\<in>nodes M. Suc m \<le> length (filter (\<lambda>t. t_target t = q) (p1@p2)))"
    then have "\<forall> q \<in> nodes M . length (filter (\<lambda>t. t_target t = q) (p1@p2)) < Suc m"
      by auto
    then have "\<forall> q \<in> nodes M . length (filter (\<lambda>t. t_target t = q) (p1@p2)) \<le> m"
      by auto

    have "(\<Sum>q\<in>nodes M. length (filter (\<lambda>t. t_target t = q) (p1@p2))) \<le> (\<Sum>q\<in>nodes M . m)"
      using \<open>\<forall> q \<in> nodes M . length (filter (\<lambda>t. t_target t = q) (p1@p2)) \<le> m\<close> by (meson sum_mono)
    then have "length (p1@p2) \<le> m * (size M)"
      using path_length_sum[OF \<open>path M q (p1@p2)\<close>]
      using fsm_nodes_finite[of M]
      by (simp add: mult.commute)

    then show "False"
      using \<open>length (p1@p2) = Suc ((size M) * m)\<close>
      by (simp add: mult.commute)
  qed
  then obtain q' where "q' \<in> nodes M"
                   and "length (filter (\<lambda> t . t_target t = q') (p1@p2)) \<ge> Suc m"
    by blast
  then obtain d where "d \<in> set D"
                  and "q' \<in> fst d"
    using assms(4) by blast
  then have "\<And> t . t_target t = q' \<Longrightarrow> t_target t \<in> fst d" by auto
  then have "length (filter (\<lambda> t . t_target t = q') (p1@p2)) \<le> length (filter (\<lambda> t . t_target t \<in> fst d) (p1@p2))"
    using filter_length_weakening[of "\<lambda> t . t_target t = q'" "\<lambda> t . t_target t \<in> fst d"]
    by blast
  then have "Suc m \<le> length (filter (\<lambda>t. t_target t \<in> fst d) (p1@p2))"
    using \<open>length (filter (\<lambda> t . t_target t = q') (p1@p2)) \<ge> Suc m\<close> by auto
  then have "?f (p1@p2) \<noteq> None"
    using assms(2)
  proof -
    have "\<forall>p. find p D \<noteq> None \<or> \<not> p d"
      by (metis \<open>d \<in> set D\<close> find_from)
    have "Suc (m - card (snd d)) \<le> length (filter (\<lambda>p. t_target p \<in> fst d) (p1@p2))"
      using \<open>Suc m \<le> length (filter (\<lambda>t. t_target t \<in> fst d) (p1@p2))\<close> by linarith
    then show ?thesis
      using \<open>\<forall>p. find p D \<noteq> None \<or> \<not> p d\<close> by blast
  qed
  then obtain d' where "?f (p1@p2) = Some d'"
    by blast

  show ?thesis proof (cases "(\<forall>p' p''. (p1@p2) = p' @ p'' \<and> p'' \<noteq> []
                                 \<longrightarrow> find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p')) D = None)")
    case True
    then show ?thesis
      using m_traversal_paths_with_witness_set[OF assms(4,5,2), of m] \<open>path M q (p1@p2)\<close> \<open>?f (p1@p2) = Some d'\<close>
      by blast
  next
    case False

    define ps where ps_def: "ps = {p' . \<exists> p''. (p1@p2) = p' @ p'' \<and> p'' \<noteq> []
                                                \<and> find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p')) D \<noteq> None}"
    have "ps \<noteq> {}" using False ps_def by blast
    moreover have "finite ps"
    proof -
      have "ps \<subseteq> set (prefixes (p1@p2))"
        unfolding prefixes_set ps_def
        by auto
      then show ?thesis
        by (meson List.finite_set rev_finite_subset)
    qed
    ultimately obtain p' where "p' \<in> ps" and "\<And> p'' . p'' \<in> ps \<Longrightarrow> length p' \<le> length p''"
      by (meson leI min_length_elem)
    then have "\<And>p'' p''' . p' = p'' @ p''' \<Longrightarrow> p''' \<noteq> []
                            \<Longrightarrow> find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p'')) D = None"
    proof -
      fix p'' p''' assume "p' = p'' @ p'''" and "p''' \<noteq> []"
      show "find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p'')) D = None"
      proof (rule ccontr)
        assume "find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p'')) D \<noteq> None"
        moreover have "\<exists>p'''. (p1@p2) = p'' @ p''' \<and> p''' \<noteq> []"
          using \<open>p' \<in> ps\<close> \<open>p' = p'' @ p'''\<close> unfolding ps_def by auto
        ultimately have "p'' \<in> ps"
          unfolding ps_def by auto
        moreover have "length p'' < length p'"
          using \<open>p''' \<noteq> []\<close> \<open>p' = p'' @ p'''\<close> by auto
        ultimately show "False"
          using \<open>\<And> p'' . p'' \<in> ps \<Longrightarrow> length p' \<le> length p''\<close>
          using leD by auto
      qed
    qed

    obtain p'' where "(p1@p2) = p' @ p''"
               and   "p'' \<noteq> []"
               and   "find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p')) D \<noteq> None"
      using \<open>p' \<in> ps\<close> unfolding ps_def by blast
    then obtain d' where "find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p')) D = Some d'"
      by auto

    have "path M q p'"
      using \<open>path M q (p1@p2)\<close>  unfolding \<open>(p1@p2) = p' @ p''\<close> by auto

    have "length p' > length p1"
    proof (rule ccontr)
      assume "\<not> length p1 < length p'"
      then obtain i where "p' = take i p1"
        by (metis \<open>p1 @ p2 = p' @ p''\<close> append_eq_append_conv_if less_le)

      have "\<And> i . find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) (take i p1))) D = None"
      proof -
        fix i
        show "find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) (take i p1))) D = None"
        proof (rule ccontr)
          assume "find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) (take i p1))) D \<noteq> None"
          then obtain d where "d \<in> set D"
                        and   "Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) (take i p1))"
            using find_None_iff[of "(\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) (take i p1)))" D]
            by meson

          moreover have "length (filter (\<lambda>t. t_target t \<in> fst d) (take i p1)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p1)"
            using filter_take_length by metis
          ultimately have "Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p1)"
            using le_trans by blast
          then show "False"
            using \<open>d \<in> set D\<close> assms(7) unfolding find_None_iff
            by blast
        qed
      qed

      then have "find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p')) D = None"
        unfolding \<open>p' = take i p1\<close> by blast
      then show "False"
        using \<open>find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p')) D \<noteq> None\<close>
        by auto
    qed

    moreover have "p' = take (length p') (p1@p2)"
      using \<open>(p1@p2) = p' @ p''\<close> by auto

    ultimately obtain p where "p' = p1 @ p"
      by auto

    have "path M q p' \<and>
           find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p')) D = Some d' \<and>
           (\<forall>p'' p'''. p' = p'' @ p''' \<and> p''' \<noteq> [] \<longrightarrow> find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p'')) D = None)"
      using \<open>\<And>p'' p''' . p' = p'' @ p''' \<Longrightarrow> p''' \<noteq> [] \<Longrightarrow> find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p'')) D = None\<close>
            \<open>path M q p'\<close> \<open>find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p')) D = Some d'\<close>
      by blast
    then have "(p',d') \<in> (m_traversal_paths_with_witness M q D m)"
      using m_traversal_paths_with_witness_set[OF assms(4,5,2), of m] by blast
    then show ?thesis unfolding \<open>p' = p1 @ p\<close> by blast
  qed
qed

lemma m_traversal_path_extension_exist_for_transition :
  assumes "completely_specified M"
  and     "q \<in> nodes M"
  and     "inputs M \<noteq> {}"
  and     "\<And> q . q\<in>nodes M \<Longrightarrow> \<exists>d\<in>set D. q \<in> fst d"
  and     "\<And> d . d \<in> set D \<Longrightarrow> snd d \<subseteq> fst d"
  and     "path M q p1"
  and     "find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p1)) D = None"
  and     "t \<in> transitions M"
  and     "t_source t = target q p1"
shows "\<exists> p2 d' . (p1@[t]@p2,d') \<in> (m_traversal_paths_with_witness M q D m)"
proof -
  let ?q = "(target q (p1 @ [t]))"
  let ?p = "p1 @ [t]"

  have "path M q ?p"
    using \<open>path M q p1\<close> \<open>t \<in> transitions M\<close> \<open>t_source t = target q p1\<close> path_append_transition by simp

  obtain p2 where "path M ?q p2" and "length p2 = (Suc ((size M) * m)) - (length ?p)"
    using path_of_length_ex[OF assms(1) path_target_is_node[OF \<open>path M q (p1@[t])\<close>] assms(3)]
    by blast

  have "path M q (?p@p2)"
    using \<open>path M q ?p\<close> \<open>path M ?q p2\<close> by auto

  let ?f = "(\<lambda> p . find (\<lambda> d . length (filter (\<lambda>t . t_target t \<in> fst d) p) \<ge> Suc (m - (card (snd d)))) D)"

  have "length p1 < Suc ((size M) * m)"
  proof (rule ccontr)
    assume "\<not> length p1 < Suc (FSM.size M * m)"
    then have "length (take (Suc (FSM.size M * m)) p1) = Suc (FSM.size M * m)"
      by auto
    let ?p = "(take (Suc (FSM.size M * m)) p1)"

    have "path M q ?p"
      using \<open>path M q p1\<close>
      by (metis append_take_drop_id path_append_elim)

    have "\<exists> q \<in> nodes M . length (filter (\<lambda>t . t_target t = q) ?p) \<ge> Suc m"
    proof (rule ccontr)
      assume "\<not> (\<exists>q\<in>nodes M. Suc m \<le> length (filter (\<lambda>t. t_target t = q) ?p))"
      then have "\<forall> q \<in> nodes M . length (filter (\<lambda>t. t_target t = q) ?p) < Suc m"
        by auto
      then have "\<forall> q \<in> nodes M . length (filter (\<lambda>t. t_target t = q) ?p) \<le> m"
        by auto

      have "(\<Sum>q\<in>nodes M. length (filter (\<lambda>t. t_target t = q) ?p)) \<le> (\<Sum>q\<in>nodes M . m)"
        using \<open>\<forall> q \<in> nodes M . length (filter (\<lambda>t. t_target t = q) ?p) \<le> m\<close> by (meson sum_mono)
      then have "length ?p \<le> m * (size M)"
        using path_length_sum[OF \<open>path M q ?p\<close>]
        using fsm_nodes_finite[of M]
        by (simp add: mult.commute)

      then show "False"
        using \<open>length ?p = Suc ((size M) * m)\<close>
        by (simp add: mult.commute)
    qed
    then obtain q' where "q' \<in> nodes M"
                   and "length (filter (\<lambda> t . t_target t = q') ?p) \<ge> Suc m"
      by blast
    then obtain d where "d \<in> set D"
                    and "q' \<in> fst d"
      using assms(4) by blast
    then have "\<And> t . t_target t = q' \<Longrightarrow> t_target t \<in> fst d" by auto
    then have "length (filter (\<lambda> t . t_target t = q') ?p) \<le> length (filter (\<lambda> t . t_target t \<in> fst d) ?p)"
      using filter_length_weakening[of "\<lambda> t . t_target t = q'" "\<lambda> t . t_target t \<in> fst d"] by auto
    then have "Suc m \<le> length (filter (\<lambda>t. t_target t \<in> fst d) ?p)"
      using \<open>length (filter (\<lambda> t . t_target t = q') ?p) \<ge> Suc m\<close> by auto
    moreover have "length (filter (\<lambda>t. t_target t \<in> fst d) ?p) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p1)"
    proof -
      have "\<And> xs P n . length (filter P (take n xs)) \<le> length (filter P xs)"
        by (metis append_take_drop_id filter_append le0 le_add_same_cancel1 length_append)
      then show ?thesis by auto
    qed
    ultimately have "Suc m \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p1)"
      by auto
    then have "?f p1 \<noteq> None"
      using assms(2)
    proof -
      have "\<forall>p. find p D \<noteq> None \<or> \<not> p d"
        by (metis \<open>d \<in> set D\<close> find_from)
      have "Suc (m - card (snd d)) \<le> length (filter (\<lambda>p. t_target p \<in> fst d) p1)"
        using \<open>Suc m \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p1)\<close> by linarith
      then show ?thesis
        using \<open>\<forall>p. find p D \<noteq> None \<or> \<not> p d\<close> by blast
    qed
    then obtain d' where "?f p1 = Some d'"
      by blast
    then show "False"
      using assms(7) by simp
  qed

  have "length (?p@p2) = (Suc ((size M) * m))"
    using \<open>length p2 = (Suc ((size M) * m)) - length ?p\<close>
          \<open>length p1 < Suc ((size M) * m)\<close>
    by simp

  have "\<exists> q \<in> nodes M . length (filter (\<lambda>t . t_target t = q) (?p@p2)) \<ge> Suc m"
  proof (rule ccontr)
    assume "\<not> (\<exists>q\<in>nodes M. Suc m \<le> length (filter (\<lambda>t. t_target t = q) (?p@p2)))"
    then have "\<forall> q \<in> nodes M . length (filter (\<lambda>t. t_target t = q) (?p@p2)) < Suc m"
      by auto
    then have "\<forall> q \<in> nodes M . length (filter (\<lambda>t. t_target t = q) (?p@p2)) \<le> m"
      by auto

    have "(\<Sum>q\<in>nodes M. length (filter (\<lambda>t. t_target t = q) (?p@p2))) \<le> (\<Sum>q\<in>nodes M . m)"
      using \<open>\<forall> q \<in> nodes M . length (filter (\<lambda>t. t_target t = q) (?p@p2)) \<le> m\<close> by (meson sum_mono)
    then have "length (?p@p2) \<le> m * (size M)"
      using path_length_sum[OF \<open>path M q (?p@p2)\<close>]
      using fsm_nodes_finite[of M]
      by (simp add: mult.commute)

    then show "False"
      using \<open>length (?p@p2) = Suc ((size M) * m)\<close>
      by (simp add: mult.commute)
  qed

  then obtain q' where "q' \<in> nodes M"
                   and "length (filter (\<lambda> t . t_target t = q') (?p@p2)) \<ge> Suc m"
    by blast
  then obtain d where "d \<in> set D"
                  and "q' \<in> fst d"
    using assms(4) by blast
  then have "\<And> t . t_target t = q' \<Longrightarrow> t_target t \<in> fst d" by auto
  then have "length (filter (\<lambda> t . t_target t = q') (?p@p2)) \<le> length (filter (\<lambda> t . t_target t \<in> fst d) (?p@p2))"
    using filter_length_weakening[of "\<lambda> t . t_target t = q'" "\<lambda> t . t_target t \<in> fst d"]
    by blast
  then have "Suc m \<le> length (filter (\<lambda>t. t_target t \<in> fst d) (?p@p2))"
    using \<open>length (filter (\<lambda> t . t_target t = q') (?p@p2)) \<ge> Suc m\<close> by auto
  then have "?f (?p@p2) \<noteq> None"
    using assms(2)
  proof -
    have "\<forall>p. find p D \<noteq> None \<or> \<not> p d"
      by (metis \<open>d \<in> set D\<close> find_from)
    have "Suc (m - card (snd d)) \<le> length (filter (\<lambda>p. t_target p \<in> fst d) (?p@p2))"
      using \<open>Suc m \<le> length (filter (\<lambda>t. t_target t \<in> fst d) (?p@p2))\<close> by linarith
    then show ?thesis
      using \<open>\<forall>p. find p D \<noteq> None \<or> \<not> p d\<close> by blast
  qed
  then obtain d' where "?f (?p@p2) = Some d'"
    by blast

  show ?thesis proof (cases "(\<forall>p' p''. (?p@p2) = p' @ p'' \<and> p'' \<noteq> [] \<longrightarrow> find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p')) D = None)")
    case True
    obtain d' where "((?p@p2), d') \<in> m_traversal_paths_with_witness M q D m"
      using m_traversal_paths_with_witness_set[OF assms(4,5,2), of m] \<open>path M q (?p@p2)\<close> \<open>?f (?p@p2) = Some d'\<close> True by force
    then show ?thesis
      unfolding append.assoc[symmetric] by blast
  next
    case False

    show ?thesis proof (cases "find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) ?p)) D")
      case (Some a)

      have *: "(\<forall>p' p''. ?p = p' @ p'' \<and> p'' \<noteq> [] \<longrightarrow> find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p')) D = None)"
      proof -
        have "\<And> p' p''. ?p = p' @ p'' \<Longrightarrow> p'' \<noteq> [] \<Longrightarrow> find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p')) D = None"
        proof -
          fix p' p'' assume "?p = p' @ p''" and "p'' \<noteq> []"
          then have "length p' \<le> length p1" by (induction p'' rule: rev_induct; auto)
          moreover have "p' = take (length p') ?p"
            unfolding \<open>?p = p' @ p''\<close> by auto
          ultimately have "p' = take (length p') p1"
            by auto

          show "find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p')) D = None"
          proof (rule ccontr)
            assume "find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p')) D \<noteq> None"
            moreover have "\<And> x . length (filter (\<lambda>t. t_target t \<in> fst x) p') \<le> length (filter (\<lambda>t. t_target t \<in> fst x) p1)"
              using \<open>p' = take (length p') p1\<close>
              by (metis filter_take_length)
            ultimately have "find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p1)) D \<noteq> None"
              unfolding find_None_iff
              using le_trans by blast
            then show "False"
              using assms(7) by simp
          qed
        qed
        then show ?thesis by blast
      qed

      obtain d' where "(?p, d') \<in> m_traversal_paths_with_witness M q D m"
        using m_traversal_paths_with_witness_set[OF assms(4,5,2), of m] \<open>path M q ?p\<close> Some * by force
      then show ?thesis
        by fastforce
    next
      case None

      define ps where ps_def: "ps = {p' . \<exists> p''. (?p@p2) = p' @ p''
                                                  \<and> p'' \<noteq> []
                                                  \<and> find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p')) D \<noteq> None}"
      have "ps \<noteq> {}" using False ps_def by blast
      moreover have "finite ps"
      proof -
        have "ps \<subseteq> set (prefixes (?p@p2))"
          unfolding prefixes_set ps_def
          by auto
        then show ?thesis
          by (meson List.finite_set rev_finite_subset)
      qed
      ultimately obtain p' where "p' \<in> ps" and "\<And> p'' . p'' \<in> ps \<Longrightarrow> length p' \<le> length p''"
        by (meson leI min_length_elem)
      then have "\<And>p'' p''' . p' = p'' @ p''' \<Longrightarrow> p''' \<noteq> [] \<Longrightarrow> find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p'')) D = None"
      proof -
        fix p'' p''' assume "p' = p'' @ p'''" and "p''' \<noteq> []"
        show "find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p'')) D = None"
        proof (rule ccontr)
          assume "find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p'')) D \<noteq> None"
          moreover have "\<exists>p'''. (?p@p2) = p'' @ p''' \<and> p''' \<noteq> []"
            using \<open>p' \<in> ps\<close> \<open>p' = p'' @ p'''\<close> unfolding ps_def by auto
          ultimately have "p'' \<in> ps"
            unfolding ps_def by auto
          moreover have "length p'' < length p'"
            using \<open>p''' \<noteq> []\<close> \<open>p' = p'' @ p'''\<close> by auto
          ultimately show "False"
            using \<open>\<And> p'' . p'' \<in> ps \<Longrightarrow> length p' \<le> length p''\<close>
            using leD by auto
        qed
      qed

      obtain p'' where "(?p@p2) = p' @ p''"
                 and   "p'' \<noteq> []"
                 and   "find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p')) D \<noteq> None"
        using \<open>p' \<in> ps\<close> unfolding ps_def by blast
      then obtain d' where "find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p')) D = Some d'"
        by auto

      have "path M q p'"
        using \<open>path M q (?p@p2)\<close>  unfolding \<open>(?p@p2) = p' @ p''\<close> by auto

      have "length p' > length ?p"
      proof (rule ccontr)

        assume "\<not> length ?p < length p'"
        then obtain i where "p' = take i ?p"
          by (metis \<open>?p @ p2 = p' @ p''\<close> append_eq_append_conv_if less_le)

        have "\<And> i . find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) (take i ?p))) D = None"
        proof -
          fix i
          show "find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) (take i ?p))) D = None"
          proof (rule ccontr)
            assume "find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) (take i ?p))) D \<noteq> None"
            then obtain d where "d \<in> set D"
                          and   "Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) (take i ?p))"
              using find_None_iff[of "(\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) (take i ?p)))" D]
              by meson

            moreover have "length (filter (\<lambda>t. t_target t \<in> fst d) (take i ?p)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) ?p)"
              using filter_take_length by metis
            ultimately have "Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) ?p)"
              using le_trans by blast
            then show "False"
              using \<open>d \<in> set D\<close> None unfolding find_None_iff
              by blast
          qed
        qed

        then have "find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p')) D = None"
          unfolding \<open>p' = take i ?p\<close> by blast
        then show "False"
          using \<open>find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p')) D \<noteq> None\<close>
          by auto
      qed

      moreover have "p' = take (length p') (?p@p2)"
        using \<open>(?p@p2) = p' @ p''\<close> by auto

      ultimately obtain p where "p' = ?p @ p"
        by (metis dual_order.strict_implies_order take_all take_append)

      have "path M q p' \<and>
             find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p')) D = Some d' \<and>
             (\<forall>p'' p'''. p' = p'' @ p''' \<and> p''' \<noteq> [] \<longrightarrow> find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p'')) D = None)"
        using \<open>\<And>p'' p''' . p' = p'' @ p''' \<Longrightarrow> p''' \<noteq> [] \<Longrightarrow> find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p'')) D = None\<close> \<open>path M q p'\<close> \<open>find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p')) D = Some d'\<close>
        by blast
      then have "(p',d') \<in> (m_traversal_paths_with_witness M q D m)"
        using m_traversal_paths_with_witness_set[OF assms(4,5,2), of m] by blast
      then show ?thesis unfolding \<open>p' = ?p @ p\<close> by fastforce
    qed
  qed
qed

end


(* Property from Case-Analysis for Rippling and Inductive Proof,
   Moa Johansson, Lucas Dixon and Alan Bundy, ITP 2010.
   This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_prop_48
  imports "../../Test_Base"
begin

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

datatype Nat = Z | S "Nat"

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

fun last :: "Nat list => Nat" where
  "last (nil2) = Z"
| "last (cons2 z (nil2)) = z"
| "last (cons2 z (cons2 x2 x3)) = last (cons2 x2 x3)"

fun butlast :: "'a list => 'a list" where
  "butlast (nil2) = nil2"
| "butlast (cons2 z (nil2)) = nil2"
| "butlast (cons2 z (cons2 x2 x3)) =
     cons2 z (butlast (cons2 x2 x3))"

theorem property0 :(*Manually fixed TIP's bug.*)
  "((case xs of
         nil2 => True
         | cons2 y z => False) ==>
      ((x (butlast xs) (cons2 (last xs) (nil2))) = xs))"
  oops

end