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

Basic propositional and quantifier reasoning.
*)

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

theory Basic_Logic
  imports Main
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>\<open>"isabelle-intro"\<close>, 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


(** Score: 10/10 *)

theory GabrielaLimonta
imports "~~/src/HOL/IMP/Hoare_Sound_Complete" "~~/src/HOL/IMP/VCG"
begin

(* Homework 11.1 *)
abbreviation "xx \<equiv> ''x''" abbreviation "yy \<equiv> ''y''"
abbreviation "aa \<equiv> ''a''" abbreviation "bb \<equiv> ''b''"

definition Cdiff :: com where  "Cdiff \<equiv>
  bb ::= N 0;;
  WHILE (Less (V bb) (V xx)) DO
    (yy ::= Plus (V yy) (N (-1));;
    bb ::= Plus (V bb) (N 1))"

definition P_Cdiff :: "int \<Rightarrow> int \<Rightarrow> assn" where
"P_Cdiff x y \<equiv> \<lambda>s. s xx = x \<and> s yy = y \<and> 0 \<le> x"

definition Q_Cdiff :: "int \<Rightarrow> int \<Rightarrow> assn" where
"Q_Cdiff x y \<equiv> \<lambda>t. t yy = y - x"

definition iCdiff :: "int \<Rightarrow> int \<Rightarrow> assn" where
  "iCdiff x y \<equiv> \<lambda>s. s xx = x \<and> y = s yy + s bb \<and> s bb \<le> x"

definition ACdiff :: "int \<Rightarrow> int \<Rightarrow> acom" where
  "ACdiff x y \<equiv>
  (bb ::= N 0) ;;
  {iCdiff x y} WHILE (Less (V bb) (V xx)) DO
    (yy ::= Plus (V yy) (N (-1));;
    bb ::= Plus (V bb) (N 1))"

lemma strip_ACdiff: "strip (ACdiff x y) = Cdiff"
  unfolding Cdiff_def P_Cdiff_def Q_Cdiff_def iCdiff_def ACdiff_def
  by simp

lemma Cdiff_correct: "\<turnstile> {P_Cdiff x y} strip (ACdiff x y) {Q_Cdiff x y}"
  unfolding strip_ACdiff[of x y, symmetric]
  apply(rule vc_sound')
  unfolding Cdiff_def P_Cdiff_def Q_Cdiff_def iCdiff_def ACdiff_def
  by auto

end


section \<open>Implementation of Dijkstra's-Algorithm using the ICF\<close>
theory Dijkstra_Impl
imports
  Dijkstra
  GraphSpec
  HashGraphImpl
  "HOL-Library.Code_Target_Numeral"
begin
text\<open>
  In this second refinement step, we use interfaces from the
  Isabelle Collection Framework (ICF) to implement the priority queue and
  the result map. Moreover, we use a graph interface (that is not contained
  in the ICF, but in this development) to represent the graph.

  The data types of the first refinement step were designed to fit the
  abstract data types of the used ICF-interfaces, which makes this refinement
  quite straightforward.

  Finally, we instantiate the ICF-interfaces by concrete implementations,
  obtaining an executable algorithm, for that we generate code using
  Isabelle/HOL's code generator.
\<close>

locale dijkstraC =
  g: StdGraph g_ops +
  mr: StdMap mr_ops +
  qw: StdUprio qw_ops
  for g_ops :: "('V,'W::weight,'G,'moreg) graph_ops_scheme"
  and mr_ops :: "('V, (('V,'W) path \<times> 'W), 'mr,'more_mr) map_ops_scheme"
  and qw_ops :: "('V ,'W infty,'qw,'more_qw) uprio_ops_scheme"
begin
  definition "\<alpha>sc == map_prod qw.\<alpha> mr.\<alpha>"
  definition "dinvarC_add == \<lambda>(wl,res). qw.invar wl \<and> mr.invar res"

  definition cdinit :: "'G \<Rightarrow> 'V \<Rightarrow> ('qw\<times>'mr) nres" where
    "cdinit g v0 \<equiv> do {
      wl \<leftarrow> FOREACH (nodes (g.\<alpha> g))
        (\<lambda>v wl. RETURN (qw.insert wl v Weight.Infty)) (qw.empty ());
      RETURN (qw.insert wl v0 (Num 0),mr.sng v0 ([],0))
    }"

  definition cpop_min :: "('qw\<times>'mr) \<Rightarrow> ('V\<times>'W infty\<times>('qw\<times>'mr)) nres" where
    "cpop_min \<sigma> \<equiv> do {
      let (wl,res) = \<sigma>;
      let (v,w,wl')=qw.pop wl;
      RETURN (v,w,(wl',res))
    }"

  definition cupdate :: "'G \<Rightarrow> 'V \<Rightarrow> 'W infty \<Rightarrow> ('qw\<times>'mr) \<Rightarrow> ('qw\<times>'mr) nres"
    where
    "cupdate g v wv \<sigma> = do {
      ASSERT (dinvarC_add \<sigma>);
      let (wl,res)=\<sigma>;
      let pv=mpath' (mr.lookup v res);
      FOREACH (succ (g.\<alpha> g) v) (\<lambda>(w',v') (wl,res).
        if (wv + Num w' < mpath_weight' (mr.lookup v' res)) then do {
          RETURN (qw.insert wl v' (wv+Num w'),
                  mr.update v' ((v,w',v')#the pv,val wv + w') res)
        } else RETURN (wl,res)
      ) (wl,res)
    }"

  definition cdijkstra where
    "cdijkstra g v0 \<equiv> do {
      \<sigma>0 \<leftarrow> cdinit g v0;
      (_,res) \<leftarrow> WHILE\<^sub>T (\<lambda>(wl,_). \<not> qw.isEmpty wl)
            (\<lambda>\<sigma>. do { (v,wv,\<sigma>') \<leftarrow> cpop_min \<sigma>; cupdate g v wv \<sigma>' } )
            \<sigma>0;
      RETURN res
    }"

end

locale dijkstraC_fixg = dijkstraC g_ops mr_ops qw_ops +
  Dijkstra ga v0
  for g_ops :: "('V,'W::weight,'G,'moreg) graph_ops_scheme"
  and mr_ops :: "('V, (('V,'W) path \<times> 'W), 'mr,'more_mr) map_ops_scheme"
  and qw_ops :: "('V ,'W infty,'qw,'more_qw) uprio_ops_scheme"
  and ga :: "('V,'W) graph"
  and v0 :: 'V +
  fixes g :: 'G
  assumes g_rel: "(g,ga)\<in>br g.\<alpha> g.invar"
begin
  schematic_goal cdinit_refines:
    notes [refine] = inj_on_id
    shows "cdinit g v0 \<le>\<Down>?R mdinit"
    using g_rel
    unfolding cdinit_def mdinit_def
    apply (refine_rcg)
    apply (refine_dref_type)
    apply (simp_all add: \<alpha>sc_def dinvarC_add_def refine_rel_defs
      qw.correct mr.correct refine_hsimp)
    done

  schematic_goal cpop_min_refines:
    "(\<sigma>,\<sigma>') \<in> build_rel \<alpha>sc dinvarC_add
      \<Longrightarrow> cpop_min \<sigma> \<le> \<Down>?R (mpop_min \<sigma>')"
    unfolding cpop_min_def mpop_min_def
    apply (refine_rcg)
    apply (refine_dref_type)
    apply (simp add: \<alpha>sc_def dinvarC_add_def refine_hsimp refine_rel_defs)
    apply (simp add: \<alpha>sc_def dinvarC_add_def refine_hsimp refine_rel_defs)
    done

  schematic_goal cupdate_refines:
    notes [refine] = inj_on_id
    shows "(\<sigma>,\<sigma>')\<in>build_rel \<alpha>sc dinvarC_add \<Longrightarrow> v=v' \<Longrightarrow> wv=wv' \<Longrightarrow>
    cupdate g v wv \<sigma> \<le> \<Down>?R (mupdate v' wv' \<sigma>')"
    unfolding cupdate_def mupdate_def
    using g_rel
    apply (refine_rcg)
    apply (refine_dref_type)
    apply (simp_all add: \<alpha>sc_def dinvarC_add_def refine_rel_defs
      qw.correct mr.correct refine_hsimp)
    done

  lemma cdijkstra_refines:
    "cdijkstra g v0 \<le> \<Down>(build_rel mr.\<alpha> mr.invar) mdijkstra"
  proof -
    note [refine] = cdinit_refines cpop_min_refines cupdate_refines
    show ?thesis
      unfolding cdijkstra_def mdijkstra_def
      using g_rel
      apply (refine_rcg)

      apply (auto
        split: prod.split prod.split_asm
        simp add: qw.correct mr.correct dinvarC_add_def \<alpha>sc_def refine_hsimp
          refine_rel_defs)
      done
  qed
end

context dijkstraC
begin

  thm g.nodes_it_is_iterator

  schematic_goal idijkstra_refines_aux:
    assumes "g.invar g"
    shows "RETURN ?f \<le> cdijkstra g v0"
    using assms
    unfolding cdijkstra_def cdinit_def cpop_min_def cupdate_def
    apply (refine_transfer)
    done

  concrete_definition idijkstra for g ?v0.0 uses idijkstra_refines_aux

  lemma idijkstra_refines:
    assumes "g.invar g"
    shows "RETURN (idijkstra g v0) \<le> cdijkstra g v0"
    using assms
    by (rule idijkstra.refine)

end

text \<open>
  The following theorem states correctness of the algorithm independent
  from the refinement framework.

  Intuitively, the first goal states that the abstraction of the returned
  result is correct, the second goal states that the result
  datastructure satisfies its invariant, and the third goal states
  that the cached weights in the returned result are correct.

  Note that this is the main theorem for a user of Dijkstra's algorithm in some
  bigger context. It may also be specialized for concrete instances of the
  implementation, as exemplarily done below.
\<close>
theorem (in dijkstraC_fixg) idijkstra_correct:
  shows
  "weighted_graph.is_shortest_path_map ga v0 (\<alpha>r (mr.\<alpha> (idijkstra g v0)))"
    (is ?G1)
  and "mr.invar (idijkstra g v0)" (is ?G2)
  and "Dijkstra.res_invarm (mr.\<alpha> (idijkstra g v0))" (is ?G3)
proof -
  from g_rel have I: "g.invar g" by (simp add: refine_rel_defs)

  note idijkstra_refines[OF I]
  also note cdijkstra_refines
  also note mdijkstra_refines
  finally have Z: "RETURN (idijkstra g v0) \<le>
    \<Down>(build_rel (\<alpha>r \<circ> mr.\<alpha>) (\<lambda>m. mr.invar m \<and> res_invarm (mr.\<alpha> m)))
      dijkstra'"
    apply (subst (asm) conc_fun_chain)
    apply (simp only: br_chain)
    done
  also note dijkstra'_refines[simplified]
  also note dijkstra_correct
  finally show ?G1 ?G2 ?G3
    by (auto elim: RETURN_ref_SPECD simp: refine_rel_defs)
qed

theorem (in dijkstraC) idijkstra_correct:
  assumes INV: "g.invar g"
  assumes V0: "v0 \<in> nodes (g.\<alpha> g)"
  assumes nonneg_weights: "\<And>v w v'. (v,w,v')\<in>edges (g.\<alpha> g) \<Longrightarrow> 0\<le>w"
  shows
  "weighted_graph.is_shortest_path_map (g.\<alpha> g) v0
      (Dijkstra.\<alpha>r (mr.\<alpha> (idijkstra g v0)))" (is ?G1)
  and "Dijkstra.res_invarm (mr.\<alpha> (idijkstra g v0))" (is ?G2)
proof -
  interpret gv: valid_graph "g.\<alpha> g" using g.valid INV .

  interpret dcg: dijkstraC_fixg g_ops mr_ops qw_ops "g.\<alpha> g" v0 g
    apply (rule dijkstraC_fixg.intro)
    apply unfold_locales
    apply (simp_all add: hlg.finite INV V0 hlg_ops_def
      nonneg_weights refine_rel_defs)
    done

  from dcg.idijkstra_correct show ?G1 ?G2 by simp_all
qed

text \<open>
  Example instantiation with HashSet.based graph,
  red-black-tree based result map, and finger-tree based priority queue.
\<close>
setup Locale_Code.open_block
interpretation hrf: dijkstraC hlg_ops rm_ops aluprioi_ops
  by unfold_locales
setup Locale_Code.close_block

definition "hrf_dijkstra \<equiv> hrf.idijkstra"
lemmas hrf_dijkstra_correct = hrf.idijkstra_correct[folded hrf_dijkstra_def]

export_code hrf_dijkstra checking SML
export_code hrf_dijkstra in OCaml
export_code hrf_dijkstra in Haskell
export_code hrf_dijkstra checking Scala

definition hrfn_dijkstra :: "(nat,nat) hlg \<Rightarrow> _"
  where "hrfn_dijkstra \<equiv> hrf_dijkstra"

export_code hrfn_dijkstra in SML

lemmas hrfn_dijkstra_correct =
  hrf_dijkstra_correct[where ?'a = nat and ?'b = nat, folded hrfn_dijkstra_def]

term hrfn_dijkstra
term hlg.from_list

definition "test_hrfn_dijkstra
  \<equiv> rm.to_list
    (hrfn_dijkstra (hlg.from_list ([0..<4],[(0,3,1),(0,4,2),(2,1,3),(1,4,3)])) 0)"

ML_val \<open>
  @{code test_hrfn_dijkstra}

\<close>

end


theory Incredible_Predicate imports
  Abstract_Rules_To_Incredible
  Predicate_Formulas
begin

text \<open>Our example interpretation with predicate logic will cover implication and the
  universal quantifier.\<close>

text \<open>The rules are introduction and elimination of implication and universal quantifiers.\<close>
datatype prop_rule = allI | allE | impI | impE

definition prop_rules :: "prop_rule stream"
  where "prop_rules = cycle [allI, allE, impI, impE]"

lemma iR_prop_rules [simp]: "sset prop_rules = {allI, allE, impI, impE}"
  unfolding prop_rules_def by simp

text \<open>Just some short notation.\<close>
abbreviation X :: "form"
  where "X \<equiv> Var 10 []"
abbreviation Y :: "form"
  where "Y \<equiv> Var 11 []"
abbreviation x :: "form"
  where "x \<equiv> Var 9 []"
abbreviation t :: "form"
  where "t \<equiv> Var 13 []"
abbreviation P :: "form \<Rightarrow> form"
  where "P f \<equiv> Var 12 [f]"
abbreviation Q :: "form \<Rightarrow> form"
  where "Q f \<equiv> Op ''Q'' [f]"
abbreviation imp :: "form \<Rightarrow> form \<Rightarrow> form"
  where "imp f1 f2 \<equiv> Op ''imp'' [f1, f2]"
abbreviation ForallX :: "form \<Rightarrow> form"
  where "ForallX f \<equiv> Quant ''all'' 9 f"

text \<open>Finally the right- and left-hand sides of the rules.\<close>

fun consequent :: "prop_rule \<Rightarrow> form list"
  where "consequent allI = [ForallX (P x)]"
  | "consequent allE = [P t]"
  | "consequent impI = [imp X Y]"
  | "consequent impE = [Y]"

abbreviation allI_input where "allI_input \<equiv> Antecedent {||} (P (LC 0)) {0}"
abbreviation impI_input where "impI_input \<equiv> Antecedent {|X|} Y {}"

fun antecedent :: "prop_rule \<Rightarrow> (form, lconst) antecedent list"
  where "antecedent allI = [allI_input]"
  | "antecedent allE = [plain_ant (ForallX (P x))]"
  | "antecedent impI = [impI_input]"
  | "antecedent impE = [plain_ant (imp X Y), plain_ant X]"

interpretation predicate: Abstract_Rules
  "curry to_nat :: nat \<Rightarrow> var \<Rightarrow> var"
  map_lc
  lc
  "closed"
  subst
  lc_subst
  map_lc_subst
  "Var 0 []"
  antecedent
  consequent
  prop_rules
proof
  show "\<forall>xs\<in>sset prop_rules. consequent xs \<noteq> []"
    unfolding prop_rules_def
    using consequent.elims by blast
next
  show "\<forall>xs\<in>sset prop_rules. \<Union>(lc ` set (consequent xs)) = {}"
    by auto
next
  fix i' r i ia
  assume "r \<in> sset prop_rules"
    and "ia < length (antecedent r)"
    and "i' < length (antecedent r)"
  then show "a_fresh (antecedent r ! ia) \<inter> a_fresh (antecedent r ! i') = {} \<or> ia = i'"
    by (cases i'; auto)
next
  fix r p
  assume "r \<in> sset prop_rules"
  and "p \<in> set (antecedent r)"
  thus "lc (a_conc p) \<union> \<Union>(lc ` fset (a_hyps p)) \<subseteq> a_fresh p" by auto
qed

end


(* Author: Tobias Nipkow *)

section "AA Tree Implementation of Maps"

theory AA_Map
imports
  AA_Set
  Lookup2
begin

fun update :: "'a::linorder \<Rightarrow> 'b \<Rightarrow> ('a*'b) aa_tree \<Rightarrow> ('a*'b) aa_tree" where
"update x y Leaf = Node 1 Leaf (x,y) Leaf" |
"update x y (Node lv t1 (a,b) t2) =
  (case cmp x a of
     LT \<Rightarrow> split (skew (Node lv (update x y t1) (a,b) t2)) |
     GT \<Rightarrow> split (skew (Node lv t1 (a,b) (update x y t2))) |
     EQ \<Rightarrow> Node lv t1 (x,y) t2)"

fun delete :: "'a::linorder \<Rightarrow> ('a*'b) aa_tree \<Rightarrow> ('a*'b) aa_tree" where
"delete _ Leaf = Leaf" |
"delete x (Node lv l (a,b) r) =
  (case cmp x a of
     LT \<Rightarrow> adjust (Node lv (delete x l) (a,b) r) |
     GT \<Rightarrow> adjust (Node lv l (a,b) (delete x r)) |
     EQ \<Rightarrow> (if l = Leaf then r
            else let (l',ab') = del_max l in adjust (Node lv l' ab' r)))"

subsection "Invariance"

subsubsection "Proofs for insert"

lemma lvl_update_aux:
  "lvl (update x y t) = lvl t \<or> lvl (update x y t) = lvl t + 1 \<and> sngl (update x y t)"
apply(induction t)
apply (auto simp: lvl_skew)
apply (metis Suc_eq_plus1 lvl.simps(2) lvl_split lvl_skew)+
done

lemma lvl_update: obtains
  (Same) "lvl (update x y t) = lvl t" |
  (Incr) "lvl (update x y t) = lvl t + 1" "sngl (update x y t)"
using lvl_update_aux by fastforce

declare invar.simps(2)[simp]

lemma lvl_update_sngl: "invar t \<Longrightarrow> sngl t \<Longrightarrow> lvl(update x y t) = lvl t"
proof (induction t rule: update.induct)
  case (2 x y lv t1 a b t2)
  consider (LT) "x < a" | (GT) "x > a" | (EQ) "x = a"
    using less_linear by blast
  thus ?case proof cases
    case LT
    thus ?thesis using 2 by (auto simp add: skew_case split_case split: tree.splits)
  next
    case GT
    thus ?thesis using 2 proof (cases t1)
      case Node
      thus ?thesis using 2 GT
        apply (auto simp add: skew_case split_case split: tree.splits)
        by (metis less_not_refl2 lvl.simps(2) lvl_update_aux n_not_Suc_n sngl.simps(3))+
    qed (auto simp add: lvl_0_iff)
  qed simp
qed simp

lemma lvl_update_incr_iff: "(lvl(update a b t) = lvl t + 1) \<longleftrightarrow>
  (EX l x r. update a b t = Node (lvl t + 1) l x r \<and> lvl l = lvl r)"
apply(cases t)
apply(auto simp add: skew_case split_case split: if_splits)
apply(auto split: tree.splits if_splits)
done

lemma invar_update: "invar t \<Longrightarrow> invar(update a b t)"
proof(induction t)
  case (Node n l xy r)
  hence il: "invar l" and ir: "invar r" by auto
  obtain x y where [simp]: "xy = (x,y)" by fastforce
  note N = Node
  let ?t = "Node n l xy r"
  have "a < x \<or> a = x \<or> x < a" by auto
  moreover
  { assume "a < x"
    note iil = Node.IH(1)[OF il]
    have ?case
    proof (cases rule: lvl_update[of a b l])
      case (Same) thus ?thesis
        using \<open>a<x\<close> invar_NodeL[OF Node.prems iil Same]
        by (simp add: skew_invar split_invar del: invar.simps)
    next
      case (Incr)
      then obtain t1 w t2 where ial[simp]: "update a b l = Node n t1 w t2"
        using Node.prems by (auto simp: lvl_Suc_iff)
      have l12: "lvl t1 = lvl t2"
        by (metis Incr(1) ial lvl_update_incr_iff tree.inject)
      have "update a b ?t = split(skew(Node n (update a b l) xy r))"
        by(simp add: \<open>a<x\<close>)
      also have "skew(Node n (update a b l) xy r) = Node n t1 w (Node n t2 xy r)"
        by(simp)
      also have "invar(split \<dots>)"
      proof (cases r)
        case Leaf
        hence "l = Leaf" using Node.prems by(auto simp: lvl_0_iff)
        thus ?thesis using Leaf ial by simp
      next
        case [simp]: (Node m t3 y t4)
        show ?thesis (*using N(3) iil l12 by(auto)*)
        proof cases
          assume "m = n" thus ?thesis using N(3) iil by(auto)
        next
          assume "m \<noteq> n" thus ?thesis using N(3) iil l12 by(auto)
        qed
      qed
      finally show ?thesis .
    qed
  }
  moreover
  { assume "x < a"
    note iir = Node.IH(2)[OF ir]
    from \<open>invar ?t\<close> have "n = lvl r \<or> n = lvl r + 1" by auto
    hence ?case
    proof
      assume 0: "n = lvl r"
      have "update a b ?t = split(skew(Node n l xy (update a b r)))"
        using \<open>a>x\<close> by(auto)
      also have "skew(Node n l xy (update a b r)) = Node n l xy (update a b r)"
        using Node.prems by(simp add: skew_case split: tree.split)
      also have "invar(split \<dots>)"
      proof -
        from lvl_update_sngl[OF ir sngl_if_invar[OF \<open>invar ?t\<close> 0], of a b]
        obtain t1 p t2 where iar: "update a b r = Node n t1 p t2"
          using Node.prems 0 by (auto simp: lvl_Suc_iff)
        from Node.prems iar 0 iir
        show ?thesis by (auto simp: split_case split: tree.splits)
      qed
      finally show ?thesis .
    next
      assume 1: "n = lvl r + 1"
      hence "sngl ?t" by(cases r) auto
      show ?thesis
      proof (cases rule: lvl_update[of a b r])
        case (Same)
        show ?thesis using \<open>x<a\<close> il ir invar_NodeR[OF Node.prems 1 iir Same]
          by (auto simp add: skew_invar split_invar)
      next
        case (Incr)
        thus ?thesis using invar_NodeR2[OF `invar ?t` Incr(2) 1 iir] 1 \<open>x < a\<close>
          by (auto simp add: skew_invar split_invar split: if_splits)
      qed
    qed
  }
  moreover { assume "a = x" hence ?case using Node.prems by auto }
  ultimately show ?case by blast
qed simp

subsubsection "Proofs for delete"

declare invar.simps(2)[simp del]

theorem post_delete: "invar t \<Longrightarrow> post_del t (delete x t)"
proof (induction t)
  case (Node lv l ab r)

  obtain a b where [simp]: "ab = (a,b)" by fastforce

  let ?l' = "delete x l" and ?r' = "delete x r"
  let ?t = "Node lv l ab r" let ?t' = "delete x ?t"

  from Node.prems have inv_l: "invar l" and inv_r: "invar r" by (auto)

  note post_l' = Node.IH(1)[OF inv_l]
  note preL = pre_adj_if_postL[OF Node.prems post_l']

  note post_r' = Node.IH(2)[OF inv_r]
  note preR = pre_adj_if_postR[OF Node.prems post_r']

  show ?case
  proof (cases rule: linorder_cases[of x a])
    case less
    thus ?thesis using Node.prems by (simp add: post_del_adjL preL)
  next
    case greater
    thus ?thesis using Node.prems preR by (simp add: post_del_adjR post_r')
  next
    case equal
    show ?thesis
    proof cases
      assume "l = Leaf" thus ?thesis using equal Node.prems
        by(auto simp: post_del_def invar.simps(2))
    next
      assume "l \<noteq> Leaf" thus ?thesis using equal Node.prems
        by simp (metis inv_l post_del_adjL post_del_max pre_adj_if_postL)
    qed
  qed
qed (simp add: post_del_def)

subsection {* Functional Correctness Proofs *}

theorem inorder_update:
  "sorted1(inorder t) \<Longrightarrow> inorder(update x y t) = upd_list x y (inorder t)"
by (induct t) (auto simp: upd_list_simps inorder_split inorder_skew)

theorem inorder_delete:
  "\<lbrakk>invar t; sorted1(inorder t)\<rbrakk> \<Longrightarrow>
  inorder (delete x t) = del_list x (inorder t)"
by(induction t)
  (auto simp: del_list_simps inorder_adjust pre_adj_if_postL pre_adj_if_postR
              post_del_max post_delete del_maxD split: prod.splits)

interpretation I: Map_by_Ordered
where empty = Leaf and lookup = lookup and update = update and delete = delete
and inorder = inorder and inv = invar
proof (standard, goal_cases)
  case 1 show ?case by simp
next
  case 2 thus ?case by(simp add: lookup_map_of)
next
  case 3 thus ?case by(simp add: inorder_update)
next
  case 4 thus ?case by(simp add: inorder_delete)
next
  case 5 thus ?case by(simp)
next
  case 6 thus ?case by(simp add: invar_update)
next
  case 7 thus ?case using post_delete by(auto simp: post_del_def)
qed

end


theory Limit
imports LocalLexing
begin

definition setmonotone :: "('a set \<Rightarrow> 'a set) \<Rightarrow> bool"
where
  "setmonotone f = (\<forall> X. X \<subseteq> f X)"

lemma setmonotone_funpower: "setmonotone f \<Longrightarrow> setmonotone (funpower f n)"
  by (induct n, auto simp add: setmonotone_def)

lemma subset_setmonotone: "setmonotone f \<Longrightarrow> X \<subseteq> f X"
  by (simp add: setmonotone_def)

lemma elem_setmonotone: "setmonotone f \<Longrightarrow> x \<in> X \<Longrightarrow> x \<in> f X"
  by (auto simp add: setmonotone_def)

lemma elem_natUnion: "(\<forall> n. x \<in> f n) \<Longrightarrow> x \<in> natUnion f"
  by (auto simp add: natUnion_def)

lemma subset_natUnion: "(\<forall> n. X \<subseteq> f n) \<Longrightarrow> X \<subseteq> natUnion f"
  by (auto simp add: natUnion_def)

lemma setmonotone_limit:
  assumes fmono: "setmonotone f"
  shows "setmonotone (limit f)"
proof -
  show "setmonotone (limit f)"
    apply (auto simp add: setmonotone_def limit_def)
    apply (rule elem_natUnion, auto)
    apply (rule elem_setmonotone[OF setmonotone_funpower])
    by (auto simp add: fmono)
qed

lemma[simp]: "limit id = id"
  by (rule ext, auto simp add: limit_def natUnion_def)

lemma natUnion_decompose[consumes 1, case_names Decompose]:
  assumes p: "p \<in> natUnion S"
  assumes decompose: "\<And> n p. p \<in> S n \<Longrightarrow> P p"
  shows "P p"
proof -
  from p have "\<exists> n. p \<in> S n"
    by (auto simp add: natUnion_def)
  then obtain n where "p \<in> S n" by blast
  from decompose[OF this] show ?thesis .
qed

lemma limit_induct[consumes 1, case_names Init Iterate]:
  assumes p: "(p :: 'a) \<in> limit f X"
  assumes init: "\<And> p. p \<in> X \<Longrightarrow> P p"
  assumes iterate: "\<And> p Y. (\<And> q . q \<in> Y \<Longrightarrow> P q) \<Longrightarrow> p \<in> f Y \<Longrightarrow> P p"
  shows "P p"
proof -
  from p have p_in_natUnion: "p \<in> natUnion (\<lambda> n. funpower f n X)"
    by (simp add: limit_def)
  {
    fix p :: 'a
    fix n :: nat
    have "p \<in> funpower f n X \<Longrightarrow> P p"
    proof (induct n arbitrary: p)
      case 0 thus ?case using init[OF 0[simplified]] by simp
    next
      case (Suc n) show ?case
        using iterate[OF Suc(1) Suc(2)[simplified], simplified] by simp
    qed
  }
  with p_in_natUnion show ?thesis
    by (induct rule: natUnion_decompose)
qed

definition chain :: "(nat \<Rightarrow> 'a set) \<Rightarrow> bool"
where
  "chain C = (\<forall> i. C i \<subseteq> C (i + 1))"

definition continuous :: "('a set \<Rightarrow> 'b set) \<Rightarrow> bool"
where
  "continuous f = (\<forall> C. chain C \<longrightarrow> (chain (f o C) \<and> f (natUnion C) = natUnion (f o C)))"

lemma continuous_apply:
  "continuous f \<Longrightarrow> chain C \<Longrightarrow> f (natUnion C) = natUnion (f o C)"
by (simp add: continuous_def)

lemma continuous_imp_mono:
  assumes continuous: "continuous f"
  shows "mono f"
proof -
  {
    fix A :: "'a set"
    fix B :: "'a set"
    assume sub: "A \<subseteq> B"
    let ?C = "\<lambda> (i::nat). if (i = 0) then A else B"
    have "chain ?C" by (simp add: chain_def sub)
    then have fC: "chain (f o ?C)" using continuous continuous_def by blast
    then have "f (?C 0) \<subseteq> f (?C (0 + 1))"
    proof -
      have "\<And>f n. \<not> chain f \<or> (f n::'b set) \<subseteq> f (Suc n)"
        by (metis Suc_eq_plus1 chain_def)
      then show ?thesis using fC by fastforce
    qed
    then have "f A \<subseteq> f B" by auto
  }
  then show "mono f" by (simp add: monoI)
qed

lemma mono_maps_chain_to_chain:
  assumes f: "mono f"
  assumes C: "chain C"
  shows "chain (f o C)"
by (metis C comp_def f chain_def mono_def)

lemma natUnion_upperbound:
  "(\<And> n. f n \<subseteq> G) \<Longrightarrow> (natUnion f) \<subseteq> G"
by (auto simp add: natUnion_def)

lemma funpower_upperbound:
  "(\<And> I. I \<subseteq> G \<Longrightarrow> f I \<subseteq> G) \<Longrightarrow> I \<subseteq> G \<Longrightarrow> funpower f n I \<subseteq> G"
proof (induct n)
  case 0 thus ?case by simp
next
  case (Suc n) thus ?case by simp
qed

lemma limit_upperbound:
  "(\<And> I. I \<subseteq> G \<Longrightarrow> f I \<subseteq> G) \<Longrightarrow> I \<subseteq> G \<Longrightarrow> limit f I \<subseteq> G"
by (simp add: funpower_upperbound limit_def natUnion_upperbound)

lemma elem_limit_simp: "x \<in> limit f X = (\<exists> n. x \<in> funpower f n X)"
by (auto simp add: limit_def natUnion_def)

definition pointwise :: "('a set \<Rightarrow> 'b set) \<Rightarrow> bool" where
  "pointwise f = (\<forall> X. f X = \<Union> { f {x} | x. x \<in> X})"

lemma pointwise_simp:
  assumes f: "pointwise f"
  shows "f X =  \<Union> { f {x} | x. x \<in> X}"
proof -
  from f have "\<forall> X. f X = \<Union> { f {x} | x. x \<in> X}"
    by (rule iffD1[OF pointwise_def[where f=f]])
  then show ?thesis by blast
qed

lemma natUnion_elem: "x \<in> f n \<Longrightarrow> x \<in> natUnion f"
using natUnion_def by fastforce

lemma limit_elem: "x \<in> funpower f n X \<Longrightarrow> x \<in> limit f X"
by (simp add: limit_def natUnion_elem)

lemma limit_step_pointwise:
  assumes x: "x \<in> limit f X"
  assumes f: "pointwise f"
  assumes y: "y \<in> f {x}"
  shows "y \<in> limit f X"
proof -
  from x have "\<exists> n. x \<in> funpower f n X"
    by (simp add: elem_limit_simp)
  then obtain n where n: "x \<in> funpower f n X" by blast
  have "y \<in> funpower f (Suc n) X"
    apply simp
    apply (subst pointwise_simp[OF f])
    using y n by auto
  then show "y \<in> limit f X" by (meson limit_elem)
qed

definition pointbase :: "('a set \<Rightarrow> 'b set) \<Rightarrow> 'a set \<Rightarrow> 'b set" where
  "pointbase F I = \<Union> { F X | X. finite X \<and> X \<subseteq> I }"

definition pointbased :: "('a set \<Rightarrow> 'b set) \<Rightarrow> bool" where
  "pointbased f = (\<exists> F. f = pointbase F)"

lemma pointwise_implies_pointbased:
  assumes pointwise: "pointwise f"
  shows "pointbased f"
proof -
  let ?F = "\<lambda> X. f X"
  {
    fix I :: "'a set"
    fix x :: "'b"
    have lr: "x \<in> pointbase ?F I \<Longrightarrow> x \<in> f I"
    proof -
      assume x: "x \<in> pointbase ?F I"
      have "\<exists> X. x \<in> f X \<and> X \<subseteq> I"
        proof -
          have "x \<in> \<Union>{f A |A. finite A \<and> A \<subseteq> I}"
            by (metis pointbase_def x)
          then show ?thesis
            by blast
        qed
      then obtain X where X:"x \<in> f X \<and> X \<subseteq> I" by blast
      have "\<exists> y. y \<in> I \<and> x \<in> f {y}"
        using X apply (simp add: pointwise_simp[OF pointwise, where X=X])
        by blast
      then show "x \<in> f I"
        apply (simp add: pointwise_simp[OF pointwise, where X=I])
        by blast
    qed
    have rl: "x \<in> f I \<Longrightarrow> x \<in> pointbase ?F I"
    proof -
      assume x: "x \<in> f I"
      have "\<exists> y. y \<in> I \<and> x \<in> f {y}"
        using x apply (simp add: pointwise_simp[OF pointwise, where X=I])
        by blast
      then obtain y where "y \<in> I \<and> x \<in> f {y}" by blast
      then have "\<exists> X. x \<in> f X \<and> finite X \<and> X \<subseteq> I" by blast
      then show "x \<in> pointbase f I"
        apply (simp add: pointbase_def)
        by blast
    qed
    note lr rl
  }
  then have "\<And> I. pointbase f I = f I" by blast
  then have "pointbase f = f" by blast
  then show ?thesis by (metis pointbased_def)
qed

lemma pointbase_is_mono:
  "mono (pointbase f)"
proof -
  {
    fix A :: "'a set"
    fix B :: "'a set"
    assume subset: "A \<subseteq> B"
    have "(pointbase f) A \<subseteq> (pointbase f) B"
      apply (simp add: pointbase_def)
      using subset by fastforce
  }
  then show ?thesis by (simp add: mono_def)
qed

lemma chain_implies_mono: "chain C \<Longrightarrow> mono C"
by (simp add: chain_def mono_iff_le_Suc)

lemma chain_cover_witness: "finite X \<Longrightarrow> chain C \<Longrightarrow> X \<subseteq> natUnion C \<Longrightarrow> \<exists> n. X \<subseteq> C n"
proof (induct rule: finite.induct)
  case emptyI thus ?case by blast
next
  case (insertI X x)
  then have "X \<subseteq> natUnion C" by simp
  with insertI have "\<exists> n. X \<subseteq> C n" by blast
  then obtain n where n: "X \<subseteq> C n" by blast
  have x: "x \<in> natUnion C" using insertI.prems(2) by blast
  then have "\<exists> m. x \<in> C m"
  proof -
    have "x \<in> \<Union>{A. \<exists>n. A = C n}" by (metis x natUnion_def)
    then show ?thesis by blast
  qed
  then obtain m where m: "x \<in> C m" by blast
  have mono_C: "\<And> i j. i \<le> j \<Longrightarrow> C i \<subseteq> C j"
    using chain_implies_mono insertI(3) mono_def by blast
  show ?case
    apply (rule_tac x="max n m" in exI)
    apply auto
    apply (meson contra_subsetD m max.cobounded2 mono_C)
    by (metis max_def mono_C n subsetCE)
qed

lemma pointbase_is_continuous:
  "continuous (pointbase f)"
proof -
  {
    fix C :: "nat \<Rightarrow> 'a set"
    assume C: "chain C"
    have mono: "chain ((pointbase f) o C)"
      by (simp add: C mono_maps_chain_to_chain pointbase_is_mono)
    have subset1: "natUnion ((pointbase f) o C) \<subseteq> (pointbase f) (natUnion C)"
    proof (auto)
      fix y :: "'b"
      assume "y \<in> natUnion ((pointbase f) o C)"
      then show "y \<in> (pointbase f) (natUnion C)"
      proof (induct rule: natUnion_decompose)
        case (Decompose n p)
          thus ?case by (metis comp_apply contra_subsetD mono_def natUnion_elem
            pointbase_is_mono subsetI)
      qed
    qed
    have subset2: "(pointbase f) (natUnion C) \<subseteq> natUnion ((pointbase f) o C)"
    proof (auto)
      fix y :: "'b"
      assume y: "y \<in> (pointbase f) (natUnion C)"
      have "\<exists> X. finite X \<and> X \<subseteq> natUnion C \<and> y \<in> f X"
      proof -
        have "y \<in> \<Union>{f A |A. finite A \<and> A \<subseteq> natUnion C}"
          by (metis y pointbase_def)
        then show ?thesis by blast
      qed
      then obtain X where X: "finite X \<and> X \<subseteq> natUnion C \<and> y \<in> f X" by blast
      then have "\<exists> n. X \<subseteq> C n" using chain_cover_witness C by blast
      then obtain n where X_sub_C: "X \<subseteq> C n" by blast
      show "y \<in> natUnion ((pointbase f) o C)"
        apply (rule_tac natUnion_elem[where n=n])
        proof -
          have "y \<in> \<Union>{f A |A. finite A \<and> A \<subseteq> C n}"
          using X X_sub_C by blast
          then show "y \<in> (pointbase f \<circ> C) n" by (simp add: pointbase_def)
      qed
    qed
    note mono subset1 subset2
  }
  then show ?thesis by (simp add: continuous_def subset_antisym)
qed

lemma pointbased_implies_continuous:
  "pointbased f \<Longrightarrow> continuous f"
  using pointbase_is_continuous pointbased_def by force

lemma setmonotone_implies_chain_funpower:
  assumes setmonotone: "setmonotone f"
  shows "chain (\<lambda> n. funpower f n I)"
by (simp add: chain_def setmonotone subset_setmonotone)

lemma natUnion_subset: "(\<And> n. \<exists> m. f n \<subseteq> g m) \<Longrightarrow> natUnion f \<subseteq> natUnion g"
  by (meson natUnion_elem natUnion_upperbound subset_iff)

lemma natUnion_eq[case_names Subset Superset]:
  "(\<And> n. \<exists> m. f n \<subseteq> g m) \<Longrightarrow> (\<And> n. \<exists> m. g n \<subseteq> f m) \<Longrightarrow> natUnion f = natUnion g"
by (simp add: natUnion_subset subset_antisym)

lemma natUnion_shift[symmetric]:
  assumes chain: "chain C"
  shows "natUnion C = natUnion (\<lambda> n. C (n + m))"
proof (induct rule: natUnion_eq)
  case (Subset n)
    show ?case using chain chain_implies_mono le_add1 mono_def by blast
next
  case (Superset n)
    show ?case by blast
qed

definition regular :: "('a set \<Rightarrow> 'a set) \<Rightarrow> bool"
where
  "regular f = (setmonotone f \<and> continuous f)"

lemma regular_fixpoint:
  assumes regular: "regular f"
  shows "f (limit f I) = limit f I"
proof -
  have setmonotone: "setmonotone f" using regular regular_def by blast
  have continuous: "continuous f" using regular regular_def by blast

  let ?C = "\<lambda> n. funpower f n I"
  have chain: "chain ?C"
    by (simp add: setmonotone setmonotone_implies_chain_funpower)
  have "f (limit f I) = f (natUnion ?C)"
    using limit_def by metis
  also have "f (natUnion ?C) = natUnion (f o ?C)"
    by (metis continuous continuous_def chain)
  also have "natUnion (f o ?C) = natUnion (\<lambda> n. f(funpower f n I))"
    by (meson comp_apply)
  also have "natUnion (\<lambda> n. f(funpower f n I)) = natUnion (\<lambda> n. ?C (n + 1))"
    by simp
  also have "natUnion (\<lambda> n. ?C(n + 1)) = natUnion ?C"
    apply (subst natUnion_shift)
    using chain by (blast+)
  finally show ?thesis by (simp add: limit_def)
qed

lemma fix_is_fix_of_limit:
  assumes fixpoint: "f I = I"
  shows "limit f I = I"
proof -
  have funpower: "\<And> n. funpower f n I = I"
  proof -
    fix n :: nat
    from fixpoint show "funpower f n I = I"
      by (induct n, auto)
  qed
  show ?thesis by (simp add: limit_def funpower natUnion_def)
qed

lemma limit_is_idempotent: "regular f \<Longrightarrow> limit f (limit f I) = limit f I"
by (simp add: fix_is_fix_of_limit regular_fixpoint)

definition mk_regular1 :: "('b \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> ('b \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow> 'a set \<Rightarrow> 'a set" where
  "mk_regular1 P F I = I \<union> { F q x | q x. x \<in> I \<and> P q x }"

definition mk_regular2 :: "('b \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> ('b \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow> 'a set \<Rightarrow> 'a set" where
  "mk_regular2 P F I = I \<union> { F q x y | q x y. x \<in> I \<and> y \<in> I \<and> P q x y }"

lemma setmonotone_mk_regular1: "setmonotone (mk_regular1 P F)"
by (simp add: mk_regular1_def setmonotone_def)

lemma setmonotone_mk_regular2: "setmonotone (mk_regular2 P F)"
by (simp add: mk_regular2_def setmonotone_def)

lemma pointbased_mk_regular1: "pointbased (mk_regular1 P F)"
proof -
  let ?f = "\<lambda> X. X \<union> { F q x | q x. x \<in> X \<and> P q x }"
  {
    fix I :: "'a set"
    have 1: "pointbase ?f I \<subseteq> mk_regular1 P F I"
      by (auto simp add: pointbase_def mk_regular1_def)
    have 2: "mk_regular1 P F I \<subseteq> pointbase ?f I"
      apply (simp add: pointbase_def mk_regular1_def)
      apply blast
      done
    from 1 2 have "pointbase ?f I = mk_regular1 P F I" by blast
  }
  then show ?thesis
    apply (subst pointbased_def)
    apply (rule_tac x="?f" in exI)
    by blast
qed

lemma pointbased_mk_regular2: "pointbased (mk_regular2 P F)"
proof -
  let ?f = "\<lambda> X. X \<union> { F q x y | q x y. x \<in> X \<and> y \<in> X \<and> P q x y }"
  {
    fix I :: "'a set"
    have 1: "pointbase ?f I \<subseteq> mk_regular2 P F I"
      by (auto simp add: pointbase_def mk_regular2_def)
    have 2: "mk_regular2 P F I \<subseteq> pointbase ?f I"
      apply (auto simp add: pointbase_def mk_regular2_def)
      apply blast
      proof -
        fix q x y
        assume x: "x \<in> I"
        assume y: "y \<in> I"
        assume P: "P q x y"
        let ?X = "{x, y}"
        let ?A = "?X \<union> {F q x y |q x y. x \<in> ?X \<and> y \<in> ?X \<and> P q x y}"
        show "\<exists>A. (\<exists>X. A = X \<union> {F q x y |q x y. x \<in> X \<and> y \<in> X \<and> P q x y} \<and>
          finite X \<and> X \<subseteq> I) \<and> F q x y \<in> A"
          apply (rule_tac x="?A" in exI)
          apply (rule conjI)
          apply (rule_tac x="?X" in exI)
          apply (auto simp add: x y)[1]
          using x y P by blast
      qed
    from 1 2 have "pointbase ?f I = mk_regular2 P F I" by blast
  }
  then show ?thesis
    apply (subst pointbased_def)
    apply (rule_tac x="?f" in exI)
    by blast
qed

lemma regular1:"regular (mk_regular1 P F)"
by (simp add: pointbased_implies_continuous pointbased_mk_regular1 regular_def
  setmonotone_mk_regular1)

lemma regular2: "regular (mk_regular2 P F)"
by (simp add: pointbased_implies_continuous pointbased_mk_regular2 regular_def
  setmonotone_mk_regular2)

lemma continuous_comp:
  assumes f: "continuous f"
  assumes g: "continuous g"
  shows "continuous (g o f)"
by (metis (no_types, lifting) comp_assoc comp_def continuous_def f g)

lemma setmonotone_comp:
  assumes f: "setmonotone f"
  assumes g: "setmonotone g"
  shows "setmonotone (g o f)"
by (metis (mono_tags, lifting) comp_def f g rev_subsetD setmonotone_def subsetI)

lemma regular_comp:
  assumes f: "regular f"
  assumes g: "regular g"
  shows "regular (g o f)"
using continuous_comp f g regular_def setmonotone_comp by blast

lemma setmonotone_id[simp]: "setmonotone id"
  by (simp add: id_def setmonotone_def)

lemma continuous_id[simp]: "continuous id"
  by (simp add: continuous_def)

lemma regular_id[simp]: "regular id"
  by (simp add: regular_def)

lemma regular_funpower: "regular f \<Longrightarrow> regular (funpower f n)"
proof (induct n)
  case 0 thus ?case by (simp add: id_def[symmetric])
next
  case (Suc n)
  have funpower: "funpower f (Suc n) = f o (funpower f n)"
    apply (rule ext)
    by simp
  with Suc show ?case
    by (auto simp only: funpower regular_comp)
qed

lemma mono_id[simp]: "mono id"
  by (simp add: mono_def id_def)

lemma mono_funpower:
  assumes mono: "mono f"
  shows "mono (funpower f n)"
proof (induct n)
  case 0 thus ?case by (simp add: id_def[symmetric])
next
  case (Suc n)
  show ?case by (simp add: Suc.hyps mono monoD monoI)
qed

lemma mono_limit:
  assumes mono: "mono f"
  shows "mono (limit f)"
proof(auto simp add: mono_def limit_def)
  fix A :: "'a set"
  fix B :: "'a set"
  fix x
  assume subset: "A \<subseteq> B"
  assume "x \<in> natUnion (\<lambda>n. funpower f n A)"
  then have "\<exists> n. x \<in> funpower f n A" using elem_limit_simp limit_def by fastforce
  then obtain n where n: "x \<in> funpower f n A" by blast
  then have mono: "mono (funpower f n)" by (simp add: mono mono_funpower)
  then have "x \<in> funpower f n B" by (meson contra_subsetD monoD n subset)
  then show "x \<in> natUnion (\<lambda>n. funpower f n B)" by (simp add: natUnion_elem)
qed

lemma continuous_funpower:
  assumes continuous: "continuous f"
  shows "continuous (funpower f n)"
proof (induct n)
  case 0 thus ?case by (simp add: id_def[symmetric])
next
  case (Suc n)
  have mono: "mono (funpower f (Suc n))"
    by (simp add: continuous continuous_imp_mono mono_funpower)
  have chain: "\<forall> C. chain C \<longrightarrow> chain ((funpower f (Suc n)) o C)"
    by (simp del: funpower.simps add: mono mono_maps_chain_to_chain)
  have limit: "\<And> C. chain C \<Longrightarrow> (funpower f (Suc n)) (natUnion C) =
      natUnion ((funpower f (Suc n)) o C)"
      apply simp
      apply (subst continuous_apply[OF Suc])
      apply simp
      apply (subst continuous_apply[OF continuous])
      apply (simp add: Suc.hyps continuous_imp_mono mono_maps_chain_to_chain)
      apply (rule arg_cong[where f="natUnion"])
      apply (rule ext)
      by simp
  from chain limit show ?case using continuous_def by blast
qed

lemma natUnion_swap:
  "natUnion (\<lambda> i. natUnion (\<lambda> j. f i j)) = natUnion (\<lambda> j. natUnion (\<lambda> i. f i j))"
by (metis (no_types, lifting) natUnion_elem natUnion_upperbound subsetI subset_antisym)

lemma continuous_limit:
  assumes continuous: "continuous f"
  shows "continuous (limit f)"
proof -
  have mono: "mono (limit f)"
    by (simp add: continuous continuous_imp_mono mono_limit)
  have chain: "\<And> C. chain C \<Longrightarrow> chain ((limit f) o C)"
    by (simp add: mono mono_maps_chain_to_chain)
  have "\<And> C. chain C \<Longrightarrow> (limit f) (natUnion C) = natUnion ((limit f) o C)"
  proof -
    fix C :: "nat \<Rightarrow> 'a set"
    assume chain_C: "chain C"
    have contpower: "\<And> n. continuous (funpower f n)"
      by (simp add: continuous continuous_funpower)
    have comp: "\<And> n F. F o C = (\<lambda> i. F (C i))"
      by auto
    have "(limit f) (natUnion C) = natUnion (\<lambda> n. funpower f n (natUnion C))"
      by (simp add: limit_def)
    also have "natUnion (\<lambda> n. funpower f n (natUnion C)) =
          natUnion (\<lambda> n. natUnion ((funpower f n) o C))"
      apply (subst continuous_apply[OF contpower])
      apply (simp add: chain_C)+
      done
    also have "natUnion (\<lambda> n. natUnion ((funpower f n) o C)) =
      natUnion (\<lambda> n. natUnion (\<lambda> i. funpower f n (C i)))"
      apply (subst comp)
      apply blast
      done
    also have "natUnion (\<lambda> n. natUnion (\<lambda> i. funpower f n (C i))) =
      natUnion (\<lambda> i. natUnion (\<lambda> n. funpower f n (C i)))"
      apply (subst natUnion_swap)
      apply blast
      done
    also have "natUnion (\<lambda> i. natUnion (\<lambda> n. funpower f n (C i))) =
      (natUnion (\<lambda> i. limit f (C i)))"
      apply (simp add: limit_def)
      done
    also have "natUnion (\<lambda> i. limit f (C i)) = natUnion ((limit f) o C)"
      apply (subst comp)
      apply simp
      done
    finally show "(limit f) (natUnion C) = natUnion ((limit f) o C)" by blast
  qed
  with chain show ?thesis by (simp add: continuous_def)
qed

lemma regular_limit: "regular f \<Longrightarrow> regular (limit f)"
by (simp add: continuous_limit regular_def setmonotone_limit)

lemma regular_implies_mono: "regular f \<Longrightarrow> mono f"
by (simp add: continuous_imp_mono regular_def)

lemma regular_implies_setmonotone: "regular f \<Longrightarrow> setmonotone f"
by (simp add: regular_def)

lemma regular_implies_continuous: "regular f \<Longrightarrow> continuous f"
by (simp add: regular_def)

end


(*<*)
theory ex09_2tmpl
imports
  "~~/src/HOL/Data_Structures/Tree23_Set"
begin
(*>*)

text \<open>\Exercise{Joining 2-3-Trees}

  Write a join function for 2-3-trees: The function shall take two
  2-3-trees \<open>l\<close> and \<open>r\<close> and an element \<open>x\<close>, and return a new 2-3-tree with
  the inorder-traversal \<open>l x r\<close> .

  Write two functions, one for the height of \<open>l\<close> being greater, the
  other for the height of \<open>r\<close> being greater.
\<close>

text \<open>\<open>height l\<close> greater\<close>
fun joinR :: "'a tree23 \<Rightarrow> 'a \<Rightarrow> 'a tree23 \<Rightarrow> 'a up\<^sub>i"
where
  "joinR l x r = (
    if height l = height r then Up\<^sub>i l x r
    else case l of
      Node2 l1 a l2 \<Rightarrow> (case joinR l2 x r of
        T\<^sub>i t \<Rightarrow> T\<^sub>i (Node2 l1 a t)
      | Up\<^sub>i l2' x' r' \<Rightarrow> T\<^sub>i (Node3 l1 a l2' x' r')
      )
    | Node3 l1 a l2 b l3 \<Rightarrow> (case joinR l3 x r of
        T\<^sub>i t \<Rightarrow> T\<^sub>i (Node3 l1 a l2 b t)
      | Up\<^sub>i l2' x' r' \<Rightarrow> Up\<^sub>i (Node2 l1 a l2) b (Node2 l2' x' r')
    )
    )"

declare joinR.simps[simp del]

lemma inorder_joinR: "\<lbrakk> bal l; bal r; height l \<ge> height r \<rbrakk> \<Longrightarrow> inorder (tree\<^sub>i (joinR l x r)) = inorder l @x # inorder r"
  apply (induction l x r rule: joinR.induct)
  apply (subst joinR.simps)
  apply (fastforce split!: tree23.split up\<^sub>i.split)
  done

lemma bal_joinR: "\<lbrakk> bal l; bal r; height l \<ge> height r \<rbrakk> \<Longrightarrow>
  bal (tree\<^sub>i (joinR l x r)) \<and> height(joinR l x r) = height l"
  sorry

text \<open>\<open>height r\<close> greater\<close>
fun joinL :: "'a tree23 \<Rightarrow> 'a \<Rightarrow> 'a tree23 \<Rightarrow> 'a up\<^sub>i"
where
  "joinL l x r = undefined"

lemma bal_joinL: "\<lbrakk> bal l; bal r; height l \<le> height r \<rbrakk> \<Longrightarrow>
  bal (tree\<^sub>i (joinL l x r)) \<and> height(joinL l x r) = height r"
  text \<open>Note the generalization: We augmented the lemma with a statement about the height of the result.\<close>
  sorry

lemma inorder_joinL: "\<lbrakk> bal l; bal r; height l \<le> height r \<rbrakk> \<Longrightarrow> inorder (tree\<^sub>i (joinL l x r)) = inorder l @x # inorder r"
  sorry

text \<open>Combine both functions\<close>
fun join :: "'a tree23 \<Rightarrow> 'a \<Rightarrow> 'a tree23 \<Rightarrow> 'a tree23"
where
"join l x r = undefined"

lemma "\<lbrakk> bal l; bal r \<rbrakk> \<Longrightarrow> bal (join l x r)"
  sorry

lemma "\<lbrakk> bal l; bal r \<rbrakk> \<Longrightarrow> inorder (join l x r) = inorder l @x # inorder r"
  sorry

(*<*)
end
(*>*)


theory prop_58
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin
  datatype 'a list = Nil2 | Cons2 "'a" "'a list"
  datatype ('a, 'b) Pair2 = Pair "'a" "'b"
  datatype Nat = Z | S "Nat"
  fun zip2 :: "'a list => 'b list => (('a, 'b) Pair2) list" where
  "zip2 (Nil2) y = Nil2"
  | "zip2 (Cons2 z x2) (Nil2) = Nil2"
  | "zip2 (Cons2 z x2) (Cons2 x3 x4) = Cons2 (Pair z x3) (zip2 x2 x4)"
  fun drop :: "Nat => 'a list => 'a list" where
  "drop (Z) y = y"
  | "drop (S z) (Nil2) = Nil2"
  | "drop (S z) (Cons2 x2 x3) = drop z x3"
  (*hipster zip drop *)
lemma lemma_a [thy_expl]: "drop x3 Nil2 = Nil2"
by (hipster_induct_schemes drop.simps)

lemma lemma_aa [thy_expl]: "drop (S Z) (drop x3 y3) = drop (S x3) y3"
by (hipster_induct_schemes drop.simps)

(*hipster zip2*)
lemma lemma_ab [thy_expl]: "zip2 Nil2 x1 = zip2 x1 Nil2"
by (hipster_induct_schemes zip2.simps)

lemma lemma_ac [thy_expl]: "zip2 Nil2 x1 = zip2 y1 Nil2"
by (hipster_induct_schemes zip2.simps)

(*hipster zip2 drop*)

  theorem x0 :
    "(drop n (zip2 xs ys)) = (zip2 (drop n xs) (drop n ys))"
    by (hipster_induct_schemes drop.simps zip2.simps  Nat.exhaust)
(*
    apply(induction xs ys arbitrary: n rule: zip2.induct)
    apply(simp_all)
    apply(metis drop.simps thy_expl zip2.simps)
    apply(metis drop.simps thy_expl zip2.simps)

    apply(metis drop.simps thy_expl zip2.simps  Nat.exhaust)
by (tactic {* Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1 *})*)
end


theory VertexCover
  imports Main tsp.Misc tsp.Berge
begin

definition "is_vc E X \<equiv> (\<forall>e \<in> E. e \<inter> X \<noteq> {}) \<and> X \<subseteq> Vs E"

lemma is_vsI:
  assumes "\<And>e. e \<in> E \<Longrightarrow> e \<inter> X \<noteq> {}" "X \<subseteq> Vs E"
  shows "is_vc E X"
  unfolding is_vc_def using assms by auto

lemma is_vcE:
  assumes "is_vc E X"
  shows "\<And>e. e \<in> E \<Longrightarrow> e \<inter> X \<noteq> {}" "X \<subseteq> Vs E"
  using assms[unfolded is_vc_def] by auto

definition "is_min_vc E X \<equiv> is_vc E X \<and> (\<forall>X'. is_vc E X' \<longrightarrow> card X \<le> card X')"

lemma is_min_vsI:
  assumes "is_vc E X" "\<And>X'. is_vc E X' \<Longrightarrow> card X \<le> card X'"
  shows "is_min_vc E X"
  unfolding is_min_vc_def using assms by auto

lemma is_min_vcE:
  assumes "is_min_vc E X"
  shows "is_vc E X" "\<And>V'. is_vc E X' \<Longrightarrow> card X \<le> card X'"
  using assms[unfolded is_min_vc_def] by auto

context graph_abs
begin

lemma is_vc_vertexE:
  assumes "is_vc E X" "e \<in> E"
  obtains v where "v \<in> X" "v \<in> e"
proof -
  obtain u v where "e = {u,v}" "u \<noteq> v"
    using assms graph by auto
  moreover have "e \<inter> X \<noteq> {}"
    using assms is_vcE by auto
  ultimately consider "u \<in> X" "u \<in> e" | "v \<in> X" "v \<in> e"
    by auto
  thus ?thesis
    using that by auto
qed

lemma E_subset_covered_edges:
  assumes "is_vc E X"
  shows "E \<subseteq> \<Union> {{e \<in> E. v \<in> e} | v. v \<in> X}"
proof
  fix e
  assume "e \<in> E"
  moreover then obtain v where "v \<in> X" "v \<in> e"
    using assms by (elim is_vc_vertexE)
  ultimately show "e \<in> \<Union> {{e \<in> E. v \<in> e} | v. v \<in> X}"
    by auto
qed

lemma covered_edges_leq_degree:
  assumes "degree E v \<le> enat k"
  shows "card {e \<in> E. v \<in> e} \<le> k"
  using assms[unfolded degree_def2] by (intro card'_leq)

lemma vc_finite:
  assumes "is_vc E X"
  shows "finite X"
proof (rule finite_subset)
  show "X \<subseteq> Vs E"
    using assms by (elim is_vcE)
  show "finite (Vs E)"
    using graph by auto
qed

lemma card_E_leq_max_degree_card_vc:
  assumes "\<And>v. v \<in> Vs E \<Longrightarrow> degree E v \<le> enat k" "is_vc E X"
  shows "card E \<le> k * card X"
proof -
  have "X \<subseteq> Vs E"
    using assms by (elim is_vcE)
  hence "\<And>v. v \<in> X \<Longrightarrow> card {e \<in> E. v \<in> e} \<le> k"
    using assms by (auto intro: covered_edges_leq_degree)
  moreover have "\<Union> {{e \<in> E. v \<in> e} | v. v \<in> X} \<subseteq> E"
    by auto
  moreover hence "finite (\<Union> {{e \<in> E. v \<in> e} | v. v \<in> X})"
    using finite_E by (rule finite_subset)
  ultimately have "card E \<le> card (\<Union> {{e \<in> E. v \<in> e} | v. v \<in> X})"
    using assms E_subset_covered_edges by (intro card_mono)
  also have "... \<le> sum card {{e \<in> E. v \<in> e} | v. v \<in> X}"
    by (rule card_Union_le_sum_card)
  also have "... \<le> sum card ((\<lambda>v. {e \<in> E. v \<in> e}) ` X)"
    apply (subst setcompr_eq_image)
    apply simp
    done
  also have "... \<le> sum (card o (\<lambda>v. {e \<in> E. v \<in> e})) X"
    apply (rule sum_image_le)
    using vc_finite[OF \<open>is_vc E X\<close>] apply auto
    done
  also have "... \<le> sum (\<lambda>v. card {e \<in> E. v \<in> e}) X"
    by auto
  also have "... \<le> sum (\<lambda>v. k) X"
    using \<open>\<And>v. v \<in> X \<Longrightarrow> card {e \<in> E. v \<in> e} \<le> k\<close> by (rule sum_mono)
  also have "... = of_nat (card X) * k"
    by (rule sum_constant)
  also have "... = k * card X"
    by auto
  finally show ?thesis .
qed (* TODO: clean up! *)

end

end


(* Property from Productive Use of Failure in Inductive Proof,
   Andrew Ireland and Alan Bundy, JAR 1996.
   This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.
   Some proofs were added by Yutaka Nagashima.*)
  theory TIP_prop_23
  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 length :: "'a list => Nat" where
  "length (nil2) = Z"
| "length (cons2 z xs) = S (length xs)"

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

theorem property0 :
  "((half (length (x y z))) = (half (length (x z y))))"
  oops

end


theory DemoITP
imports "$HIPSTER_HOME/IsaHipster"
begin

(* Normal list datatype *)
datatype 'a Lst =
   Nil
  | Cons "'a" "'a Lst" (infix ";" 65)

(* The append function. Syntactic sugar: we use +++ instead of Haskell's ++ *)
fun app :: "'a Lst \<Rightarrow> 'a Lst \<Rightarrow> 'a Lst" (infix "+++" 60)
where
  "Nil +++ xs = xs"
| "(x;xs) +++ ys = x;(xs +++ ys)"

(* The reverse function *)
fun rev :: "'a Lst \<Rightarrow> 'a Lst"
where
  "rev Nil = Nil"
| "rev (x;xs) = (rev xs) +++ (x;Nil)"

(* Datatype for binary trees from your exercises *)
datatype 'a Tree =
  Empty
  | Node "'a" "'a Tree" "'a Tree"

(* The swap function: swaps the left and right subtree. *)
fun swap :: "'a Tree => 'a Tree"
where
  "swap Empty = Empty"
| "swap (Node data l r) = Node data (swap r) (swap l)"

(* The flatten function: turn a tree into a list *)
fun flatten :: "'a Tree \<Rightarrow> 'a Lst"
where
  "flatten Empty = Nil"
| "flatten (Node data l r) =  ((flatten l) +++ (data;Nil)) +++ (flatten r)"

(* Last week's exercise 10 *)
theorem exercise10: "flatten (swap p) = rev (flatten p)"
  apply hipster_induct

(* A tail recursive reverse function *)
fun qrev :: "'a Lst \<Rightarrow> 'a Lst \<Rightarrow> 'a Lst"
where
  "qrev Nil acc  = acc"
| "qrev (x;xs) acc = qrev xs (x;acc)"

(* Hard exercise (optional) *)
theorem hardExercise: "rev xs = qrev xs Nil"

(* The spine function: turns a list into a tree. *)
(* fun spine :: "'a Lst \<Rightarrow> 'a Tree"
where
  "spine Nil = Empty"
| "spine (x;xs) = Node x Empty (spine xs)"

hipster spine flatten
lemma lemma_af [thy_expl]: "flatten (spine y) = y"
  apply (induct y)
  by simp_all
*)

end