(*
 * Copyright 2019, Data61
 * Commonwealth Scientific and Industrial Research Organisation (CSIRO)
 * ABN 41 687 119 230.
 *
 * This software may be distributed and modified according to the terms of
 * the BSD 2-Clause license. Note that NO WARRANTY is provided.
 * See "LICENSE_BSD2.txt" for details.
 *
 * @TAG(DATA61_BSD)
 *)

theory FP_Eval_Tests
imports
  Lib.FP_Eval
  "HOL-Library.Sublist"
begin

section \<open>Controlling evaluation\<close>

subsection \<open>Skeletons\<close>

text \<open>
  A "skeleton" is a subterm of a given term. For example,
    "map (\<lambda>x. x + 1) [1, 2, 3]"
  could have the following skeleton (among others):
    "map (\<lambda>x. x + _) _"

  The "_" stand for schematic variables with arbitrary names,
  or dummy patterns (which are implemented as unnamed schematics).

  FP_Eval uses skeletons internally to keep track of which parts of
  a term it has already evaluated. In other words, schematic variables
  indicate already-normalised subterms.

  There are two useful predefined skeletons:
\<close>
ML_val \<open> FP_Eval.skel0 \<close>
text \<open>
  which is a special directive to evaluate all subterms; and
\<close>
ML_val \<open> FP_Eval.skel_skip \<close>
text \<open>
  which tells FP_Eval to skip evaluation.
\<close>

text \<open>
  If we use the full FP_Eval interface, we can input a skeleton manually
  and get the final skeleton as output.

  It's useful to input a nontrivial skeleton for the following reasons:
   \<bullet> if most of the term is known to be normalised, this can
      save unnecessary computation.
   \<bullet> if a tool runs FP_Eval on behalf of an end user, it may
      want to avoid evaluating function calls in the user's input terms.
      Alternatively, use explicit quotation terms
      (see "Preventing evaluation", below) if finer control is needed.

  The partial skeleton should match the structure of the input term.
  If there is any mismatch, FP_Eval tries to be conservative and
  evaluates the whole subterm (as if "skel0" had been given).
  However, this should not be relied upon.
  (FIXME: maybe stricter check in eval')

  By default, FP_Eval attempts full evaluation of the input, so it
  usually returns "skel_skip".

  However, evaluation is not complete when:
   \<bullet> the input skeleton skips some subterms;
   \<bullet> FP_Eval doesn't descend into un-applied lambdas;
   \<bullet> evaluation delayed due to cong rules.
  In these cases, FP_Eval would return a partial skeleton.
\<close>

(* TODO: add examples *)

subsection \<open>Congruence rules\<close>

text \<open>
  Use FP_Eval.add_cong or the second argument of FP_Eval.make_rules.
  These accept weak congruence rules, e.g.:
\<close>
thm if_weak_cong option.case_cong_weak

text \<open>
  Note that @{thm let_weak_cong} contains a hidden eta expansion, which FP_Eval
  currently doesn't understand. Use our alternative:
\<close>
thm FP_Eval.let_weak_cong'

ML_val \<open>
  @{assert} (not (Thm.eq_thm_prop (@{thm let_weak_cong}, @{thm FP_Eval.let_weak_cong'})));
\<close>

text \<open>
  Example: avoid evaluating both branches of an @{const If}
\<close>

ML_val \<open>
local
  fun eval eqns congs =
    FP_Eval.eval @{context} (FP_Eval.make_rules eqns congs)
  val input = (@{cterm "subseq [0::nat, 2, 4] [0, 1, 2, 3, 4, 5]"}, Bound 0);
in
  (* No cong rule -- blowup *)
  val r1 = eval @{thms list_emb_code} @{thms} input
           |> fst |> fst;
  (* if_weak_cong prevents early evaluation of branches *)
  val r2 = eval @{thms list_emb_code} @{thms if_weak_cong} input
           |> fst |> fst;

  (* Compare performance counters: *)
  val eqns = @{thms list_emb_code rel_simps simp_thms if_True if_False};
  val p1 = eval eqns @{thms} input |> snd;
  val p2 = eval eqns @{thms if_weak_cong} input |> snd;
end
\<close>

subsection \<open>Preventing evaluation\<close>

text \<open>
  Sometimes it is useful to prevent evaluation of any arguments.
  This can be done by adding a cong rule with no premises:
\<close>
context FP_Eval begin
definition "quote x \<equiv> x"
lemma quote_cong:
  "quote x = quote x"
  by simp
lemma quote:
  "x \<equiv> quote x"
  by (simp add: quote_def)
end

ML_val \<open>
local
  fun eval eqns congs =
    FP_Eval.eval @{context} (FP_Eval.make_rules eqns congs);
in
  (* By default, fp_eval evaluates all subterms *)
  val r1 = eval @{thms fun_upd_def} @{thms}
             (@{cterm "FP_Eval.quote (fun_upd f a b) c"}, Bound 0);
  (* Use quote_cong to hold all quoted subterms.
     Note how the resulting skeleton indicates unevaluated subterms. *)
  val r2 = eval @{thms fun_upd_def} @{thms FP_Eval.quote_cong}
             (@{cterm "FP_Eval.quote (fun_upd f a b) c"}, Bound 0);
  (* Now remove the quote_cong hold. fp_eval continues evaluation
     according to the previous skeleton. *)
  val r3 = fst r2 |> apfst Thm.rhs_of
           |> eval @{thms fun_upd_def} @{thms};
end;
\<close>

section \<open>Tests\<close>

subsection \<open>Basic tests\<close>

ML_val \<open>
local
  fun eval eqns congs =
    FP_Eval.eval @{context} (FP_Eval.make_rules eqns congs);
  val input = (@{cterm "2 + 2 :: nat"}, Bound 0);
in
  val ((result, Var _), counters) = eval @{thms arith_simps} @{thms} input;
  val _ = @{assert} (Thm.prop_of result aconv @{term "(2 + 2 :: nat) \<equiv> 4"});
end;
\<close>

text \<open>fp_eval does not rewrite under lambda abstractions\<close>
ML_val \<open>
local
  fun eval eqns congs =
    FP_Eval.eval @{context} (FP_Eval.make_rules eqns congs);
  val input = (@{cterm "(\<lambda>x. x + (2 + 2::nat))"}, Bound 0);
in
  val ((result, skel), _) = eval @{thms arith_simps} @{thms} input;
  val _ = @{assert} (not (is_Var skel) andalso Thm.is_reflexive result);
end
\<close>

subsection \<open>Cong rules\<close>

text \<open>Test for @{thm if_weak_cong}\<close>
ML_val \<open>
local
  fun eval eqns congs =
    FP_Eval.eval @{context} (FP_Eval.make_rules eqns congs);
  val input = (@{cterm "subseq [2::int,3,5,7,11] [0,1,2,3,4,5,6,7,8,9,10,11,12,13]"}, Bound 0);
in
  val r1 = eval @{thms list_emb_code rel_simps refl if_True if_False} @{thms} input;
  val r2 = eval @{thms list_emb_code rel_simps refl if_True if_False} @{thms if_weak_cong} input;

  val _ = @{assert} (Thm.term_of (Thm.rhs_of (fst (fst r1))) = @{term True});
  val _ = @{assert} (Thm.term_of (Thm.rhs_of (fst (fst r2))) = @{term True});

  (* Compare performance counters: *)
  val (SOME r1_rewrs, SOME r2_rewrs) =
        apply2 (snd #> Symtab.make #> (fn t => Symtab.lookup t "rewrites")) (r1, r2);
  val _ = @{assert} (r1_rewrs > 10000);
  val _ = @{assert} (r2_rewrs < 100);
end
\<close>

subsection \<open>Advanced usage\<close>

subsubsection \<open>Triggering breakpoints\<close>
ML_val \<open>
local
  fun break_4 t = Thm.term_of t = @{term "4 :: nat"};
  fun eval eqns congs break =
    FP_Eval.eval' @{context} (K (K ())) break false (FP_Eval.make_rules eqns congs);
  val input = (@{cterm "map Suc [2 + 2 :: nat, 2 + 3, 2 + 4, 2 + 5, 2 + 6]"}, Bound 0);
in
  (* Normal evaluation *)
  val ((result, Var _), _) = eval @{thms list.map arith_simps} @{thms} (K false) input;
  val _ = @{assert} (Thm.term_of (Thm.rhs_of result) aconv
                        @{term "[Suc 4, Suc 5, Suc 6, Suc 7, Suc 8]"});

  (* Evaluation stops after "4" is encountered *)
  val ((result2, skel), _) = eval @{thms list.map arith_simps} @{thms} break_4 input;
  val _ = @{assert} (Thm.term_of (Thm.rhs_of result2) aconv
                        @{term "map Suc [4::nat, 5, 2 + 4, 2 + 5, 2 + 6]"});
  (* Skeleton indicates evaluation is unfinished *)
  val _ = @{assert} (not (is_Var skel));
end;
\<close>

subsubsection \<open>Rule set manipulation\<close>
ML_val \<open>
local
  val rules0 = FP_Eval.empty_rules;
  val rules1 = FP_Eval.make_rules @{thms simp_thms arith_simps} @{thms if_weak_cong};
  val rules2 = FP_Eval.make_rules @{thms simp_thms if_False if_True fun_upd_apply}
                                @{thms if_weak_cong option.case_cong_weak};
in
  (* dest_rules returns rules *)
  val _ = @{assert} (apply2 length (FP_Eval.dest_rules rules1) <> (0, 0));
  (* test round-trip conversion *)
  val _ = @{assert} (let val (thms, congs) = FP_Eval.dest_rules rules2;
                         val (thms', congs') = FP_Eval.dest_rules (FP_Eval.make_rules thms congs);
                     in forall Thm.eq_thm_prop (thms ~~ thms')
                        andalso forall Thm.eq_thm_prop (congs ~~ congs') end);
  (* test that merging succeeds and actually merges rules *)
  fun test_merge r1 r2 =
    let val (r1_eqns, r1_congs) = FP_Eval.dest_rules r1;
        val (r2_eqns, r2_congs) = FP_Eval.dest_rules r2;
        val (r12_eqns, r12_congs) = FP_Eval.dest_rules (FP_Eval.merge_rules (r1, r2));
    in eq_set Thm.eq_thm_prop (r12_eqns, union Thm.eq_thm_prop r1_eqns r2_eqns)
       andalso eq_set Thm.eq_thm_prop (r12_congs, union Thm.eq_thm_prop r1_congs r2_congs)
    end;

  val _ = @{assert} (test_merge rules0 rules1);
  val _ = @{assert} (test_merge rules0 rules2);
  val _ = @{assert} (test_merge rules1 rules2);

  (* test that rules with conflicting arity are not allowed *)
  val conflict_arity = FP_Eval.make_rules @{thms fun_upd_def} @{thms};
  val _ = @{assert} (is_none (try FP_Eval.merge_rules (rules2, conflict_arity)));
  (* test that installing different cong rules is not allowed *)
  val conflict_cong = FP_Eval.make_rules @{thms} @{thms if_weak_cong[OF refl]};
  val _ = @{assert} (is_none (try FP_Eval.merge_rules (rules2, conflict_cong)));
end
\<close>

subsubsection \<open>Ordering of rules\<close>
text \<open>
  In the current implementation, equations are picked based on the default
  Net ordering. This should be improved in the future.
\<close>
ML_val \<open>
local
  fun eval eqns congs =
    FP_Eval.eval @{context} (FP_Eval.make_rules eqns congs);
  val input = (@{cterm "list_all (\<lambda>x::nat. x \<le> x) [100000, 314159, 2718281845]"}, Bound 0);
  val basic_eqns = @{thms list_all_simps rel_simps simp_thms};
  fun get_counter cs x = the (Symtab.lookup (Symtab.make cs) x);
in
  (* evaluate \<le> slowly *)
  val ((r1, _), counters1) = eval basic_eqns @{thms} input;
  (* shortcut for \<le> *)
  val ((r2, _), counters2) = eval (@{thms order.refl} @ basic_eqns) @{thms} input;
  val ((r3, _), counters3) = eval (basic_eqns @ @{thms order.refl}) @{thms} input;

  (* Bug: shortcut is never used -- no effect on runtime *)
  val _ = @{assert} (length (distinct op= [counters1, counters2, counters3]) = 1);

  (* desired outcome *)
  val ((r4, _), counters4) = eval @{thms list_all_simps simp_thms order.refl} @{thms} input;
  val _ = @{assert} (get_counter counters4 "rewrites" < get_counter counters1 "rewrites");
end
\<close>

subsection \<open>Miscellaneous and regression tests\<close>

text \<open>Test for partial arity and arg_conv\<close>
ML_val \<open>
local
  fun eval eqns congs =
    FP_Eval.eval @{context} (FP_Eval.make_rules eqns congs);
  val input = (@{cterm "(if 2 + 2 = 4 then Suc else id) x"}, FP_Eval.skel0);
  (* Need to build these manually, as @{cterm} itself does beta-eta normalisation *)
  val input_abs1 = (fold (fn x => fn f => Thm.apply f x)
                         [@{cterm "f::nat\<Rightarrow>nat"}, @{cterm "4::nat"}]
                         @{cterm "\<lambda>f. fun_upd (f::nat\<Rightarrow>nat) (2+2) y"},
                    FP_Eval.skel0);
  val input_abs2 = (fold (fn x => fn f => Thm.apply f x)
                         [@{cterm "f::nat\<Rightarrow>nat"}, @{cterm "4::nat"}]
                         @{cterm "\<lambda>f x z. z + fun_upd (f::nat\<Rightarrow>nat) (2+2) y x"},
                    FP_Eval.skel0);
  val Abs (_, _, Abs (_, _, Abs _)) $ _ $ _ = Thm.term_of (fst input_abs2); (* check *)
in
  (* Head (= If) is rewritten *)
  val ((result, Var _), _) = eval @{thms arith_simps refl if_True} @{thms} input;
  val _ = @{assert} (Thm.term_of (Thm.rhs_of result) = @{term "Suc x"});

  (* Head is not rewritten *)
  val ((result2, Var _ $ _), _) = eval @{thms arith_simps refl if_False} @{thms} input;
  val _ = @{assert} (Thm.term_of (Thm.rhs_of result2) = @{term "(if True then Suc else id) x"});

  (* Head is Abs *)
  val ((result3, Var _), _) = eval @{thms arith_simps refl fun_upd_apply if_True} @{thms} input_abs1;
  val _ = @{assert} (Thm.term_of (Thm.rhs_of result3) = @{term "y::nat"});

  (* Partially applied Abs *)
  val ((result4, Abs _), _) = eval @{thms arith_simps refl fun_upd_apply if_True} @{thms} input_abs2;
  val _ = @{assert} (Thm.term_of (Thm.rhs_of result4) = @{term "\<lambda>z. z + fun_upd (f::nat\<Rightarrow>nat) (2+2) y 4"});
end;
\<close>

text \<open>Check that skel_skip is not returned for intermediate Abs\<close>
ML_val \<open>
local
  fun eval eqns congs = FP_Eval.eval @{context} (FP_Eval.make_rules eqns congs);
  val input = (@{cterm "map (\<lambda>((x, y), z). ((id x, id y), id z)) [((a::'a, b::'b), c::'c)]"}, Bound 0);
in
  val ((result, Var _), counters) = eval @{thms list.map prod.case arith_simps} @{thms} input;
  val _ = @{assert} (Thm.term_of (Thm.rhs_of result) = @{term "[((id a::'a, id b::'b), id c::'c)]"});
end;
\<close>

text \<open>Test conversion of some basic non-equation rules to equations\<close>
ML_val \<open>
let val thms = @{thms simp_thms rel_simps arith_simps};
in @{assert} (length (map_filter FP_Eval.maybe_convert_eqn thms) = length thms) end
\<close>

end


(*
 * Copyright 2014, NICTA
 *
 * This software may be distributed and modified according to the terms of
 * the BSD 2-Clause license. Note that NO WARRANTY is provided.
 * See "LICENSE_BSD2.txt" for details.
 *
 * @TAG(NICTA_BSD)
 *)

theory WhileLoopRules
imports "wp/NonDetMonadVCG"
begin

section "Well-ordered measures"

(* A version of "measure" that takes any wellorder, instead of
 * being fixed to "nat". *)
definition measure' :: "('a \<Rightarrow> 'b::wellorder) => ('a \<times> 'a) set"
where "measure' = (\<lambda>f. {(a, b). f a < f b})"

lemma in_measure'[simp, code_unfold]:
    "((x,y) : measure' f) = (f x < f y)"
  by (simp add:measure'_def)

lemma wf_measure' [iff]: "wf (measure' f)"
  apply (clarsimp simp: measure'_def)
  apply (insert wf_inv_image [OF wellorder_class.wf, where f=f])
  apply (clarsimp simp: inv_image_def)
  done

lemma wf_wellorder_measure: "wf {(a, b). (M a :: 'a :: wellorder) < M b}"
  apply (subgoal_tac "wf (inv_image ({(a, b). a < b}) M)")
   apply (clarsimp simp: inv_image_def)
  apply (rule wf_inv_image)
  apply (rule wellorder_class.wf)
  done

section "whileLoop lemmas"

text {*
  The following @{const whileLoop} definitions with additional
  invariant/variant annotations allow the user to annotate
  @{const whileLoop} terms with information that can be used
  by automated tools.
*}
definition
  "whileLoop_inv (C :: 'a \<Rightarrow> 'b \<Rightarrow> bool) B x (I :: 'a \<Rightarrow> 'b \<Rightarrow> bool) (R :: (('a \<times> 'b) \<times> ('a \<times> 'b)) set) \<equiv> whileLoop C B x"

definition
  "whileLoopE_inv (C :: 'a \<Rightarrow> 'b \<Rightarrow> bool) B x (I :: 'a \<Rightarrow> 'b \<Rightarrow> bool) (R :: (('a \<times> 'b) \<times> ('a \<times> 'b)) set) \<equiv> whileLoopE C B x"

lemma whileLoop_add_inv: "whileLoop B C = (\<lambda>x. whileLoop_inv B C x I (measure' M))"
  by (clarsimp simp: whileLoop_inv_def)

lemma whileLoopE_add_inv: "whileLoopE B C = (\<lambda>x. whileLoopE_inv B C x I (measure' M))"
  by (clarsimp simp: whileLoopE_inv_def)

subsection "Simple base rules"

lemma whileLoop_terminates_unfold:
  "\<lbrakk> whileLoop_terminates C B r s; (r', s') \<in> fst (B r s); C r s \<rbrakk>
        \<Longrightarrow> whileLoop_terminates C B r' s'"
  apply (erule whileLoop_terminates.cases)
   apply simp
  apply force
  done

lemma snd_whileLoop_first_step: "\<lbrakk> \<not> snd (whileLoop C B r s); C r s \<rbrakk> \<Longrightarrow> \<not> snd (B r s)"
  apply (subst (asm) whileLoop_unroll)
  apply (clarsimp simp: bind_def condition_def)
  done

lemma snd_whileLoopE_first_step: "\<lbrakk> \<not> snd (whileLoopE C B r s); C r s \<rbrakk> \<Longrightarrow> \<not> snd (B r s)"
  apply (subgoal_tac "\<lbrakk> \<not> snd (whileLoopE C B r s); C r s \<rbrakk> \<Longrightarrow> \<not> snd ((lift B (Inr r)) s)")
   apply (clarsimp simp: lift_def)
  apply (unfold whileLoopE_def)
  apply (erule snd_whileLoop_first_step)
  apply clarsimp
  done

lemma snd_whileLoop_unfold:
      "\<lbrakk> \<not> snd (whileLoop C B r s); C r s; (r', s') \<in> fst (B r s) \<rbrakk> \<Longrightarrow> \<not> snd (whileLoop C B r' s')"
  apply (clarsimp simp: whileLoop_def)
  apply (auto simp: elim: whileLoop_results.cases whileLoop_terminates.cases
     intro: whileLoop_results.intros whileLoop_terminates.intros)
  done

lemma snd_whileLoopE_unfold:
      "\<lbrakk> \<not> snd (whileLoopE C B r s); (Inr r', s') \<in> fst (B r s); C r s \<rbrakk> \<Longrightarrow> \<not> snd (whileLoopE C B r' s')"
  apply (clarsimp simp: whileLoopE_def)
  apply (drule snd_whileLoop_unfold)
    apply clarsimp
   apply (clarsimp simp: lift_def)
   apply assumption
  apply (clarsimp simp: lift_def)
  done

lemma whileLoop_results_cong [cong]:
  assumes C:  "\<And>r s. C r s = C' r s"
  and B:"\<And>(r :: 'r) (s :: 's). C' r s \<Longrightarrow> B r s = B' r s"
  shows "whileLoop_results C B = whileLoop_results C' B'"
proof -
  {
    fix x y C B C' B'
    have  "\<lbrakk> (x, y) \<in> whileLoop_results C B;
                 \<And>(r :: 'r) (s :: 's). C r s = C' r s;
                 \<And>r s. C' r s \<Longrightarrow> B r s = B' r s \<rbrakk>
               \<Longrightarrow> (x, y) \<in> whileLoop_results C' B'"
      apply (induct rule: whileLoop_results.induct)
         apply clarsimp
        apply clarsimp
       apply (rule whileLoop_results.intros, auto)[1]
      apply clarsimp
      apply (rule whileLoop_results.intros, auto)[1]
      done
  }

  thus ?thesis
    apply -
    apply (rule set_eqI, rule iffI)
     apply (clarsimp split: prod.splits)
     apply (clarsimp simp: C B split: prod.splits)
    apply (clarsimp split: prod.splits)
    apply (clarsimp simp: C [symmetric] B [symmetric] split: prod.splits)
  done
qed

lemma whileLoop_terminates_cong [cong]:
  assumes r: "r = r'"
  and s: "s = s'"
  and C: "\<And>r s. C r s = C' r s"
  and B: "\<And>r s. C' r s \<Longrightarrow> B r s = B' r s"
  shows "whileLoop_terminates C B r s = whileLoop_terminates C' B' r' s'"
proof (rule iffI)
  assume T: "whileLoop_terminates C B r s"
  show "whileLoop_terminates C' B' r' s'"
    apply (insert T r s)
    apply (induct arbitrary: r' s' rule: whileLoop_terminates.induct)
     apply (clarsimp simp: C)
     apply (erule whileLoop_terminates.intros)
    apply (clarsimp simp: C B split: prod.splits)
    apply (rule whileLoop_terminates.intros, assumption)
    apply (clarsimp simp: C B split: prod.splits)
    done
next
  assume T: "whileLoop_terminates C' B' r' s'"
  show "whileLoop_terminates C B r s"
    apply (insert T r s)
    apply (induct arbitrary: r s rule: whileLoop_terminates.induct)
     apply (rule whileLoop_terminates.intros)
     apply (clarsimp simp: C)
    apply (rule whileLoop_terminates.intros, fastforce simp: C)
    apply (clarsimp simp: C B split: prod.splits)
    done
qed

lemma whileLoop_cong [cong]:
  "\<lbrakk> \<And>r s. C r s = C' r s; \<And>r s. C r s \<Longrightarrow> B r s = B' r s \<rbrakk> \<Longrightarrow> whileLoop C B = whileLoop C' B'"
  apply (rule ext, clarsimp simp: whileLoop_def)
  done

lemma whileLoopE_cong [cong]:
  "\<lbrakk> \<And>r s. C r s = C' r s ; \<And>r s. C r s \<Longrightarrow> B r s = B' r s \<rbrakk>
                 \<Longrightarrow> whileLoopE C B = whileLoopE C' B'"
  apply (clarsimp simp: whileLoopE_def)
  apply (rule whileLoop_cong [THEN arg_cong])
    apply (clarsimp split: sum.splits)
   apply (clarsimp split: sum.splits)
  apply (clarsimp simp: lift_def throwError_def split: sum.splits)
  done

lemma whileLoop_terminates_wf:
    "wf {(x, y). C (fst y) (snd y) \<and> x \<in> fst (B (fst y) (snd y)) \<and> whileLoop_terminates C B (fst y) (snd y)}"
  apply (rule wfI [where A="UNIV" and B="{(r, s). whileLoop_terminates C B r s}"])
   apply clarsimp
  apply clarsimp
  apply (erule whileLoop_terminates.induct)
   apply blast
  apply blast
  done

subsection "Basic induction helper lemmas"

lemma whileLoop_results_induct_lemma1:
    "\<lbrakk> (a, b) \<in> whileLoop_results C B; b = Some (x, y) \<rbrakk> \<Longrightarrow> \<not> C x y"
    apply (induct rule: whileLoop_results.induct, auto)
    done

lemma whileLoop_results_induct_lemma1':
    "\<lbrakk> (a, b) \<in> whileLoop_results C B; a \<noteq> b \<rbrakk> \<Longrightarrow> \<exists>x. a = Some x \<and> C (fst x) (snd x)"
    apply (induct rule: whileLoop_results.induct, auto)
    done

lemma whileLoop_results_induct_lemma2 [consumes 1]:
  "\<lbrakk> (a, b) \<in> whileLoop_results C B;
     a = Some (x :: 'a \<times> 'b); b = Some y;
     P x; \<And>s t. \<lbrakk> P s; t \<in> fst (B (fst s) (snd s)); C (fst s) (snd s) \<rbrakk> \<Longrightarrow> P t \<rbrakk> \<Longrightarrow> P y"
  apply (induct arbitrary: x y rule: whileLoop_results.induct)
    apply simp
   apply simp
  apply atomize
  apply fastforce
  done

lemma whileLoop_results_induct_lemma3 [consumes 1]:
  assumes result: "(Some (r, s), Some (r', s')) \<in> whileLoop_results C B"
  and inv_start: "I r s"
  and inv_step: "\<And>r s r' s'. \<lbrakk> I r s; C r s; (r', s') \<in> fst (B r s) \<rbrakk> \<Longrightarrow> I r' s'"
  shows "I r' s'"
  apply (rule whileLoop_results_induct_lemma2 [where P="split I" and y="(r', s')" and x="(r, s)",
      simplified split_def, simplified])
      apply (rule result)
     apply simp
    apply simp
   apply fact
  apply (erule (1) inv_step)
  apply clarsimp
  done

subsection "Inductive reasoning about whileLoop results"

lemma in_whileLoop_induct [consumes 1]:
  assumes in_whileLoop: "(r', s') \<in> fst (whileLoop C B r s)"
  and init_I: "\<And> r s. \<not> C r s \<Longrightarrow> I r s r s"
  and step:
     "\<And>r s r' s' r'' s''.
        \<lbrakk> C r s; (r', s') \<in> fst (B r s);
          (r'', s'') \<in> fst (whileLoop C B r' s');
           I r' s' r'' s'' \<rbrakk> \<Longrightarrow> I r s r'' s''"
  shows "I r s r' s'"
proof cases
  assume "C r s"

  {
    obtain a where a_def: "a = Some (r, s)"
      by blast
    obtain b where b_def: "b = Some (r', s')"
      by blast

    have "\<lbrakk> (a, b) \<in> whileLoop_results C B; \<exists>x. a = Some x;  \<exists>x. b = Some x \<rbrakk>
        \<Longrightarrow> I (fst (the a)) (snd (the a)) (fst (the b)) (snd (the b))"
      apply (induct rule: whileLoop_results.induct)
      apply (auto simp: init_I whileLoop_def intro: step)
      done

    hence "(Some (r, s), Some (r', s')) \<in> whileLoop_results C B
                 \<Longrightarrow> I r s r' s'"
      by (clarsimp simp: a_def b_def)
   }

   thus ?thesis
     using in_whileLoop
     by (clarsimp simp: whileLoop_def)
next
  assume "\<not> C r s"

  hence "r' = r \<and> s' = s"
    using in_whileLoop
    by (subst (asm) whileLoop_unroll,
             clarsimp simp: condition_def return_def)

  thus ?thesis
    by (metis init_I `\<not> C r s`)
qed

lemma snd_whileLoop_induct [consumes 1]:
  assumes induct: "snd (whileLoop C B r s)"
  and terminates: "\<not> whileLoop_terminates C B r s \<Longrightarrow> I r s"
  and init: "\<And> r s. \<lbrakk> snd (B r s); C r s \<rbrakk> \<Longrightarrow> I r s"
  and step: "\<And>r s r' s' r'' s''.
        \<lbrakk> C r s; (r', s') \<in> fst (B r s);
           snd (whileLoop C B r' s');
           I r' s' \<rbrakk> \<Longrightarrow> I r s"
  shows "I r s"
  apply (insert init induct)
  apply atomize
  apply (unfold whileLoop_def)
  apply clarsimp
  apply (erule disjE)
   apply (erule rev_mp)
   apply (induct "Some (r, s)" "None :: ('a \<times> 'b) option"
        arbitrary: r s rule: whileLoop_results.induct)
    apply clarsimp
   apply clarsimp
   apply (erule (1) step)
    apply (clarsimp simp: whileLoop_def)
   apply clarsimp
  apply (metis terminates)
  done

lemma whileLoop_terminatesE_induct [consumes 1]:
  assumes induct: "whileLoop_terminatesE C B r s"
  and init: "\<And>r s. \<not> C r s \<Longrightarrow> I r s"
  and step: "\<And>r s r' s'. \<lbrakk> C r s; \<forall>(v', s') \<in> fst (B r s). case v' of Inl _ \<Rightarrow> True | Inr r' \<Rightarrow> I r' s' \<rbrakk> \<Longrightarrow> I r s"
  shows "I r s"
  apply (insert induct)
  apply (clarsimp simp: whileLoop_terminatesE_def)
  apply (subgoal_tac "(\<lambda>r s. case (Inr r) of Inl x \<Rightarrow> True | Inr x \<Rightarrow> I x s) r s")
   apply simp
  apply (induction rule: whileLoop_terminates.induct)
   apply (case_tac r)
    apply simp
   apply clarsimp
   apply (erule init)
  apply (clarsimp split: sum.splits)
  apply (rule step)
   apply simp
  apply (clarsimp simp: lift_def split: sum.splits)
  apply force
  done

subsection "Direct reasoning about whileLoop components"

lemma fst_whileLoop_cond_false:
  assumes loop_result: "(r', s') \<in> fst (whileLoop C B r s)"
  shows "\<not> C r' s'"
  using loop_result
  by (rule in_whileLoop_induct, auto)

lemma snd_whileLoop:
  assumes init_I: "I r s"
      and cond_I: "C r s"
      and non_term:  "\<And>r. \<lbrace> \<lambda>s. I r s \<and> C r s \<and> \<not> snd (B r s) \<rbrace>
                                   B r \<exists>\<lbrace> \<lambda>r' s'. C r' s' \<and> I r' s' \<rbrace>"
      shows "snd (whileLoop C B r s)"
  apply (clarsimp simp: whileLoop_def)
  apply (rotate_tac)
  apply (insert init_I cond_I)
  apply (induct rule: whileLoop_terminates.induct)
   apply clarsimp
  apply (cut_tac r=r in non_term)
  apply (clarsimp simp: exs_valid_def)
   apply (subst (asm) (2) whileLoop_results.simps)
   apply clarsimp
  apply (insert whileLoop_results.simps)
  apply fast
  done

lemma whileLoop_terminates_inv:
  assumes init_I: "I r s"
  assumes inv: "\<And>r s. \<lbrace>\<lambda>s'. I r s' \<and> C r s' \<and> s' = s \<rbrace> B r \<lbrace> \<lambda>r' s'. I r' s' \<and> ((r', s'), (r, s)) \<in> R \<rbrace>"
  assumes wf_R: "wf R"
  shows "whileLoop_terminates C B r s"
  apply (insert init_I)
  using wf_R
  apply (induction "(r, s)" arbitrary: r s)
  apply atomize
  apply (subst whileLoop_terminates_simps)
  apply clarsimp
  apply (erule use_valid)
  apply (rule hoare_strengthen_post, rule inv)
   apply force
  apply force
  done

lemma not_snd_whileLoop:
  assumes init_I: "I r s"
      and inv_holds: "\<And>r s. \<lbrace>\<lambda>s'. I r s' \<and> C r s' \<and> s' = s \<rbrace> B r \<lbrace> \<lambda>r' s'. I r' s' \<and> ((r', s'), (r, s)) \<in> R \<rbrace>!"
      and wf_R: "wf R"
      shows "\<not> snd (whileLoop C B r s)"
proof -
  {
    fix x y
    have "\<lbrakk> (x, y) \<in> whileLoop_results C B; x = Some (r, s); y = None \<rbrakk> \<Longrightarrow> False"
      apply (insert init_I)
      apply (induct arbitrary: r s rule: whileLoop_results.inducts)
         apply simp
        apply simp
       apply (insert snd_validNF [OF inv_holds])[1]
       apply blast
      apply (drule use_validNF [OF _ inv_holds])
       apply simp
      apply clarsimp
      apply blast
      done
  }

  also have "whileLoop_terminates C B r s"
     apply (rule whileLoop_terminates_inv [where I=I, OF init_I _ wf_R])
     apply (insert inv_holds)
     apply (clarsimp simp: validNF_def)
     done

  ultimately show ?thesis
     by (clarsimp simp: whileLoop_def, blast)
qed

lemma valid_whileLoop:
  assumes first_step: "\<And>s. P r s \<Longrightarrow> I r s"
      and inv_step: "\<And>r. \<lbrace> \<lambda>s. I r s \<and> C r s \<rbrace> B r \<lbrace> I \<rbrace>"
      and final_step: "\<And>r s. \<lbrakk> I r s; \<not> C r s \<rbrakk> \<Longrightarrow> Q r s"
   shows "\<lbrace> P r \<rbrace> whileLoop C B r \<lbrace> Q \<rbrace>"
proof -
  {
    fix r' s' s
    assume inv: "I r s"
    assume step: "(r', s') \<in> fst (whileLoop C B r s)"

    have "I r' s'"
     using step inv
      apply (induct rule: in_whileLoop_induct)
       apply simp
      apply (drule use_valid, rule inv_step, auto)
      done
  }

  thus ?thesis
    apply (clarsimp simp: valid_def)
    apply (drule first_step)
    apply (rule final_step, simp)
    apply (metis fst_whileLoop_cond_false)
    done
qed

lemma whileLoop_wp:
  "\<lbrakk> \<And>r. \<lbrace> \<lambda>s. I r s \<and> C r s \<rbrace> B r \<lbrace> I \<rbrace>;
     \<And>r s. \<lbrakk> I r s; \<not> C r s \<rbrakk> \<Longrightarrow> Q r s \<rbrakk> \<Longrightarrow>
  \<lbrace> I r \<rbrace> whileLoop C B r \<lbrace> Q \<rbrace>"
  by (rule valid_whileLoop)

lemma whileLoop_wp_inv [wp]:
  "\<lbrakk> \<And>r. \<lbrace>\<lambda>s. I r s \<and> C r s\<rbrace> B r \<lbrace>I\<rbrace>; \<And>r s. \<lbrakk>I r s; \<not> C r s\<rbrakk> \<Longrightarrow> Q r s \<rbrakk>
      \<Longrightarrow> \<lbrace> I r \<rbrace> whileLoop_inv C B r I M \<lbrace> Q \<rbrace>"
  apply (clarsimp simp: whileLoop_inv_def)
  apply (rule valid_whileLoop [where P=I and I=I], auto)
  done

lemma validE_whileLoopE:
  "\<lbrakk>\<And>s. P r s \<Longrightarrow> I r s;
    \<And>r. \<lbrace> \<lambda>s. I r s \<and> C r s \<rbrace> B r \<lbrace> I \<rbrace>,\<lbrace> A \<rbrace>;
    \<And>r s. \<lbrakk> I r s; \<not> C r s \<rbrakk> \<Longrightarrow> Q r s
   \<rbrakk> \<Longrightarrow> \<lbrace> P r \<rbrace> whileLoopE C B r \<lbrace> Q \<rbrace>,\<lbrace> A \<rbrace>"
  apply (clarsimp simp: whileLoopE_def validE_def)
  apply (rule valid_whileLoop [where I="\<lambda>r s. (case r of Inl x \<Rightarrow> A x s | Inr x \<Rightarrow> I x s)"
             and Q="\<lambda>r s. (case r of Inl x \<Rightarrow> A x s | Inr x \<Rightarrow> Q x s)"])
    apply atomize
    apply (clarsimp simp: valid_def lift_def split: sum.splits)
   apply (clarsimp simp: valid_def lift_def split: sum.splits)
  apply (clarsimp split: sum.splits)
  done

lemma whileLoopE_wp:
  "\<lbrakk> \<And>r. \<lbrace> \<lambda>s. I r s \<and> C r s \<rbrace> B r \<lbrace> I \<rbrace>, \<lbrace> A \<rbrace>;
     \<And>r s. \<lbrakk> I r s; \<not> C r s \<rbrakk> \<Longrightarrow> Q r s \<rbrakk> \<Longrightarrow>
  \<lbrace> I r \<rbrace> whileLoopE C B r \<lbrace> Q \<rbrace>, \<lbrace> A \<rbrace>"
  by (rule validE_whileLoopE)

lemma exs_valid_whileLoop:
 assumes init_T: "\<And>s. P s \<Longrightarrow> T r s"
    and iter_I: "\<And> r s0.
         \<lbrace> \<lambda>s. T r s \<and> C r s \<and> s = s0 \<rbrace>
                B r \<exists>\<lbrace>\<lambda>r' s'. T r' s' \<and> ((r', s'),(r, s0)) \<in> R\<rbrace>"
    and wf_R: "wf R"
    and final_I: "\<And>r s. \<lbrakk> T r s; \<not> C r s  \<rbrakk> \<Longrightarrow> Q r s"
 shows "\<lbrace> P \<rbrace> whileLoop C B r \<exists>\<lbrace> Q \<rbrace>"
proof (clarsimp simp: exs_valid_def Bex_def)
  fix s
  assume "P s"

  {
    fix x
    have "T (fst x) (snd x) \<Longrightarrow>
             \<exists>r' s'. (r', s') \<in> fst (whileLoop C B (fst x) (snd x)) \<and> T r' s'"
      using wf_R
      apply induction
      apply atomize
      apply (case_tac "C (fst x) (snd x)")
       apply (subst whileLoop_unroll)
       apply (clarsimp simp: condition_def bind_def' split: prod.splits)
       apply (cut_tac ?s0.0=b and r=a in iter_I)
       apply (clarsimp simp: exs_valid_def)
       apply blast
      apply (subst whileLoop_unroll)
      apply (clarsimp simp: condition_def bind_def' return_def)
      done
  }

  thus "\<exists>r' s'. (r', s') \<in> fst (whileLoop C B r s) \<and> Q r' s'"
    by (metis `P s` fst_conv init_T snd_conv
                  final_I fst_whileLoop_cond_false)
qed

lemma empty_fail_whileLoop:
  assumes body_empty_fail: "\<And>r. empty_fail (B r)"
  shows "empty_fail (whileLoop C B r)"
proof -
  {
    fix s A
    assume empty: "fst (whileLoop C B r s) = {}"

    have cond_true: "\<And>x s. fst (whileLoop C B x s) = {} \<Longrightarrow> C x s"
      apply (subst (asm) whileLoop_unroll)
      apply (clarsimp simp: condition_def return_def split: split_if_asm)
      done

    have  "snd (whileLoop C B r s)"
      apply (rule snd_whileLoop [where I="\<lambda>x s. fst (whileLoop C B x s) = {}"])
        apply fact
       apply (rule cond_true, fact)
      apply (clarsimp simp: exs_valid_def)
      apply (case_tac "fst (B r s) = {}")
       apply (metis empty_failD [OF body_empty_fail])
      apply (subst (asm) whileLoop_unroll)
      apply (fastforce simp: condition_def bind_def split_def cond_true)
      done
   }

  thus ?thesis
    by (clarsimp simp: empty_fail_def)
qed

lemma empty_fail_whileLoopE:
  assumes body_empty_fail: "\<And>r. empty_fail (B r)"
  shows "empty_fail (whileLoopE C B r)"
  apply (clarsimp simp: whileLoopE_def)
  apply (rule empty_fail_whileLoop)
  apply (insert body_empty_fail)
  apply (clarsimp simp: empty_fail_def lift_def throwError_def return_def split: sum.splits)
  done

lemma whileLoop_results_bisim:
  assumes base: "(a, b) \<in> whileLoop_results C B"
  and vars1: "Q = (case a of Some (r, s) \<Rightarrow> Some (rt r, st s) | _ \<Rightarrow> None)"
  and vars2: "R = (case b of Some (r, s) \<Rightarrow> Some (rt r, st s) | _ \<Rightarrow> None)"
  and inv_init: "case a of Some (r, s) \<Rightarrow> I r s | _ \<Rightarrow> True"
  and inv_step: "\<And>r s r' s'. \<lbrakk> I r s; C r s; (r', s') \<in> fst (B r s) \<rbrakk> \<Longrightarrow> I r' s'"
  and cond_match: "\<And>r s. I r s \<Longrightarrow> C r s = C' (rt r) (st s)"
  and fail_step: "\<And>r s. \<lbrakk>C r s; snd (B r s); I r s\<rbrakk>
          \<Longrightarrow> (Some (rt r, st s), None) \<in> whileLoop_results C' B'"
  and refine: "\<And>r s r' s'. \<lbrakk> I r s; C r s; (r', s') \<in>  fst (B r s) \<rbrakk>
                           \<Longrightarrow> (rt r', st s') \<in> fst (B' (rt r) (st s))"
  shows "(Q, R) \<in> whileLoop_results C' B'"
  apply (subst vars1)
  apply (subst vars2)
  apply (insert base inv_init)
  apply (induct rule: whileLoop_results.induct)
    apply clarsimp
    apply (subst (asm) cond_match)
     apply (clarsimp simp: option.splits)
    apply (clarsimp simp: option.splits)
   apply (clarsimp simp: option.splits)
   apply (metis fail_step)
  apply (case_tac z)
   apply (clarsimp simp: option.splits)
  apply (metis cond_match inv_step refine whileLoop_results.intros(3))
   apply (clarsimp simp: option.splits)
 apply (metis cond_match inv_step refine whileLoop_results.intros(3))
 done

lemma whileLoop_terminates_liftE:
  "whileLoop_terminatesE C (\<lambda>r. liftE (B r)) r s = whileLoop_terminates C B r s"
  apply (subst eq_sym_conv)
  apply (clarsimp simp: whileLoop_terminatesE_def)
  apply (rule iffI)
   apply (erule whileLoop_terminates.induct)
    apply (rule whileLoop_terminates.intros)
    apply clarsimp
   apply (clarsimp simp: split_def)
   apply (rule whileLoop_terminates.intros(2))
    apply clarsimp
   apply (clarsimp simp: liftE_def in_bind return_def lift_def [abs_def]
               bind_def lift_def throwError_def o_def split: sum.splits
               cong: sum.case_cong)
   apply (drule (1) bspec)
   apply clarsimp
  apply (subgoal_tac "case (Inr r) of Inl _ \<Rightarrow> True | Inr r \<Rightarrow>
      whileLoop_terminates (\<lambda>r s. (\<lambda>r s. case r of Inl _ \<Rightarrow> False | Inr v \<Rightarrow> C v s) (Inr r) s)
           (\<lambda>r. (lift (\<lambda>r. liftE (B r)) (Inr r)) >>= (\<lambda>x. return (theRight x))) r s")
   apply (clarsimp simp: liftE_def lift_def)
  apply (erule whileLoop_terminates.induct)
   apply (clarsimp simp: liftE_def lift_def split: sum.splits)
   apply (erule whileLoop_terminates.intros)
  apply (clarsimp simp: liftE_def split: sum.splits)
  apply (clarsimp simp: bind_def return_def split_def lift_def)
  apply (erule whileLoop_terminates.intros)
  apply force
  done

lemma snd_X_return [simp]:
     "\<And>A X s. snd ((A >>= (\<lambda>a. return (X a))) s) = snd (A s)"
  by (clarsimp simp: return_def bind_def split_def)

lemma whileLoopE_liftE:
  "whileLoopE C (\<lambda>r. liftE (B r)) r = liftE (whileLoop C B r)"
  apply (rule ext)
  apply (clarsimp simp: whileLoopE_def)
  apply (rule prod_eqI)
   apply (rule set_eqI, rule iffI)
    apply clarsimp
    apply (clarsimp simp: in_bind whileLoop_def liftE_def)
    apply (rule_tac x="b" in exI)
    apply (rule_tac x="theRight a" in exI)
    apply (rule conjI)
     apply (erule whileLoop_results_bisim [where rt=theRight and st="\<lambda>x. x" and I="\<lambda>r s. case r of Inr x \<Rightarrow> True | _ \<Rightarrow> False"],
        auto intro: whileLoop_results.intros intro!: bexI simp: bind_def return_def lift_def split: sum.splits)[1]
    apply (drule whileLoop_results_induct_lemma2 [where P="\<lambda>(r, s). case r of Inr x \<Rightarrow> True | _ \<Rightarrow> False"] )
        apply (rule refl)
       apply (rule refl)
      apply clarsimp
     apply (clarsimp simp: return_def bind_def lift_def split: sum.splits)
    apply (clarsimp simp: return_def bind_def lift_def split: sum.splits)
   apply (clarsimp simp: in_bind whileLoop_def liftE_def)
   apply (erule whileLoop_results_bisim [where rt=Inr and st="\<lambda>x. x" and I="\<lambda>r s. True"],
     auto intro: whileLoop_results.intros intro!: bexI simp: bind_def return_def lift_def split: sum.splits)[1]
  apply (rule iffI)
   apply (clarsimp simp: whileLoop_def liftE_def del: notI)
   apply (erule disjE)
    apply (erule whileLoop_results_bisim [where rt=theRight and st="\<lambda>x. x" and I="\<lambda>r s. case r of Inr x \<Rightarrow> True | _ \<Rightarrow> False"],
      auto intro: whileLoop_results.intros intro!: bexI simp: bind_def return_def lift_def split: sum.splits)[1]
   apply (subst (asm) whileLoop_terminates_liftE [symmetric])
   apply (fastforce simp: whileLoop_def liftE_def whileLoop_terminatesE_def)
  apply (clarsimp simp: whileLoop_def liftE_def del: notI)
  apply (subst (asm) whileLoop_terminates_liftE [symmetric])
  apply (clarsimp simp: whileLoop_def liftE_def whileLoop_terminatesE_def)
  apply (erule disjE)
   apply (erule whileLoop_results_bisim [where rt=Inr and st="\<lambda>x. x" and I="\<lambda>r s. True"])
         apply (clarsimp split: option.splits)
        apply (clarsimp split: option.splits)
       apply (clarsimp split: option.splits)
      apply (auto intro: whileLoop_results.intros intro!: bexI simp: bind_def return_def lift_def split: sum.splits)
  done

lemma validNF_whileLoop:
  assumes pre: "\<And>s. P r s \<Longrightarrow> I r s"
  and inv: "\<And>r s. \<lbrace>\<lambda>s'. I r s' \<and> C r s' \<and> s' = s \<rbrace> B r \<lbrace> \<lambda>r' s'. I r' s' \<and> ((r', s'), (r, s)) \<in> R \<rbrace>!"
  and wf: "wf R"
  and post_cond: "\<And>r s. \<lbrakk>I r s; \<not> C r s\<rbrakk> \<Longrightarrow> Q r s"
  shows "\<lbrace>P r\<rbrace> whileLoop C B r \<lbrace>Q\<rbrace>!"
  apply rule
   apply (rule valid_whileLoop)
     apply fact
    apply (insert inv, clarsimp simp: validNF_def
        valid_def split: prod.splits, force)[1]
   apply (metis post_cond)
  apply (unfold no_fail_def)
  apply (intro allI impI)
  apply (rule not_snd_whileLoop [where I=I and R=R])
    apply (auto intro: assms)
  done

lemma validNF_whileLoop_inv [wp]:
  assumes inv: "\<And>r s. \<lbrace>\<lambda>s'. I r s' \<and> C r s' \<and> s' = s \<rbrace> B r \<lbrace> \<lambda>r' s'. I r' s' \<and> ((r', s'), (r, s)) \<in> R \<rbrace>!"
  and wf: "wf R"
  and post_cond: "\<And>r s. \<lbrakk>I r s; \<not> C r s\<rbrakk> \<Longrightarrow> Q r s"
  shows "\<lbrace>I r\<rbrace> whileLoop_inv C B r I R \<lbrace>Q\<rbrace>!"
  apply (clarsimp simp: whileLoop_inv_def)
  apply (rule validNF_whileLoop [where I=I and R=R])
     apply simp
    apply (rule inv)
   apply (rule wf)
  apply (metis post_cond)
  done

lemma validNF_whileLoop_inv_measure [wp]:
  assumes inv: "\<And>r s. \<lbrace>\<lambda>s'. I r s' \<and> C r s' \<and> s' = s \<rbrace> B r \<lbrace> \<lambda>r' s'. I r' s' \<and> M r' s' < M r s \<rbrace>!"
  and post_cond: "\<And>r s. \<lbrakk>I r s; \<not> C r s\<rbrakk> \<Longrightarrow> Q r s"
  shows "\<lbrace>I r\<rbrace> whileLoop_inv C B r I (measure' (\<lambda>(r, s). M r s)) \<lbrace>Q\<rbrace>!"
  apply (clarsimp simp: whileLoop_inv_def)
    apply (rule validNF_whileLoop [where R="measure' (\<lambda>(r, s). M r s)" and I=I])
     apply simp
    apply clarsimp
    apply (rule inv)
   apply simp
  apply (metis post_cond)
  done

lemma validNF_whileLoop_inv_measure_twosteps:
  assumes inv: "\<And>r s. \<lbrace>\<lambda>s'. I r s' \<and> C r s' \<rbrace> B r \<lbrace> \<lambda>r' s'. I r' s' \<rbrace>!"
  assumes measure: "\<And>r m. \<lbrace>\<lambda>s. I r s \<and> C r s \<and> M r s = m \<rbrace> B r \<lbrace> \<lambda>r' s'. M r' s' < m \<rbrace>"
  and post_cond: "\<And>r s. \<lbrakk>I r s; \<not> C r s\<rbrakk> \<Longrightarrow> Q r s"
  shows "\<lbrace>I r\<rbrace> whileLoop_inv C B r I (measure' (\<lambda>(r, s). M r s)) \<lbrace>Q\<rbrace>!"
  apply (rule validNF_whileLoop_inv_measure)
   apply (rule validNF_weaken_pre)
    apply (rule validNF_post_comb_conj_L)
     apply (rule inv)
    apply (rule measure)
   apply fast
  apply (metis post_cond)
  done

lemma wf_custom_measure:
  "\<lbrakk> \<And>a b. (a, b) \<in> R \<Longrightarrow> f a < (f :: 'a \<Rightarrow> nat) b \<rbrakk> \<Longrightarrow>  wf R"
  by (metis in_measure wf_def wf_measure)

lemma validNF_whileLoopE:
  assumes pre: "\<And>s. P r s \<Longrightarrow> I r s"
  and inv: "\<And>r s. \<lbrace>\<lambda>s'. I r s' \<and> C r s' \<and> s' = s \<rbrace> B r \<lbrace> \<lambda>r' s'. I r' s' \<and> ((r', s'), (r, s)) \<in> R \<rbrace>,\<lbrace> E \<rbrace>!"
  and wf: "wf R"
  and post_cond: "\<And>r s. \<lbrakk>I r s; \<not> C r s\<rbrakk> \<Longrightarrow> Q r s"
  shows "\<lbrace> P r \<rbrace> whileLoopE C B r \<lbrace> Q \<rbrace>,\<lbrace> E \<rbrace>!"
  apply (unfold validE_NF_alt_def whileLoopE_def)
   apply (rule validNF_whileLoop [
     where I="\<lambda>r s. case r of Inl x \<Rightarrow> E x s | Inr x \<Rightarrow> I x s"
     and R="{((r', s'), (r, s)). \<exists>x x'. r' = Inl x' \<and> r = Inr x}
     \<union> {((r', s'), (r, s)). \<exists>x x'. r' = Inr x' \<and> r = Inr x \<and> ((x', s'),(x, s)) \<in> R}"])
     apply (simp add: pre)
    apply (insert inv)[1]
    apply (fastforce simp: lift_def validNF_def valid_def
           validE_NF_def throwError_def no_fail_def return_def
           validE_def split: sum.splits prod.splits)
   apply (rule wf_Un)
     apply (rule wf_custom_measure [where f="\<lambda>(r, s). case r of Inl _ \<Rightarrow> 0 | _ \<Rightarrow> 1"])
     apply clarsimp
    apply (insert wf_inv_image [OF wf, where f="\<lambda>(r, s). (theRight r, s)"])
    apply (drule wf_Int1 [where r'="{((r', s'),(r, s)). (\<exists>x. r = Inr x) \<and> (\<exists>x. r' = Inr x)}"])
    apply (erule wf_subset)
    apply rule
    apply (clarsimp simp: inv_image_def split: prod.splits sum.splits)
   apply clarsimp
   apply rule
    apply rule
    apply clarsimp
   apply clarsimp
  apply (clarsimp split: sum.splits)
  apply (blast intro: post_cond)
  done

lemma validNF_whileLoopE_inv [wp]:
  assumes inv: "\<And>r s. \<lbrace>\<lambda>s'. I r s' \<and> C r s' \<and> s' = s \<rbrace> B r \<lbrace> \<lambda>r' s'. I r' s' \<and> ((r', s'), (r, s)) \<in> R \<rbrace>,\<lbrace> E \<rbrace>!"
  and wf_R: "wf R"
  and post_cond: "\<And>r s. \<lbrakk>I r s; \<not> C r s\<rbrakk> \<Longrightarrow> Q r s"
  shows "\<lbrace>I r\<rbrace> whileLoopE_inv C B r I R \<lbrace>Q\<rbrace>,\<lbrace>E\<rbrace>!"
  apply (clarsimp simp: whileLoopE_inv_def)
  apply (metis validNF_whileLoopE [OF _ inv] post_cond wf_R)
  done

lemma validNF_whileLoopE_inv_measure [wp]:
  assumes inv: "\<And>r s. \<lbrace>\<lambda>s'. I r s' \<and> C r s' \<and> s' = s \<rbrace> B r \<lbrace> \<lambda>r' s'. I r' s' \<and> M r' s' < M r s \<rbrace>, \<lbrace> E \<rbrace>!"
  and post_cond: "\<And>r s. \<lbrakk>I r s; \<not> C r s\<rbrakk> \<Longrightarrow> Q r s"
  shows "\<lbrace>I r\<rbrace> whileLoopE_inv C B r I (measure' (\<lambda>(r, s). M r s)) \<lbrace>Q\<rbrace>,\<lbrace>E\<rbrace>!"
  apply (rule validNF_whileLoopE_inv)
    apply clarsimp
    apply (rule inv)
   apply clarsimp
  apply (metis post_cond)
  done

lemma validNF_whileLoopE_inv_measure_twosteps:
  assumes inv: "\<And>r s. \<lbrace>\<lambda>s'. I r s' \<and> C r s' \<rbrace> B r \<lbrace> \<lambda>r' s'. I r' s' \<rbrace>, \<lbrace> E \<rbrace>!"
  assumes measure: "\<And>r m. \<lbrace>\<lambda>s. I r s \<and> C r s \<and> M r s = m \<rbrace> B r \<lbrace> \<lambda>r' s'. M r' s' < m \<rbrace>, \<lbrace> \<lambda>_ _. True \<rbrace>"
  and post_cond: "\<And>r s. \<lbrakk>I r s; \<not> C r s\<rbrakk> \<Longrightarrow> Q r s"
  shows "\<lbrace>I r\<rbrace> whileLoopE_inv C B r I (measure' (\<lambda>(r, s). M r s)) \<lbrace>Q\<rbrace>, \<lbrace>E\<rbrace>!"
  apply (rule validNF_whileLoopE_inv_measure)
   apply (rule validE_NF_weaken_pre)
    apply (rule validE_NF_post_comb_conj_L)
     apply (rule inv)
    apply (rule measure)
   apply fast
  apply (metis post_cond)
  done

lemma whileLoopE_wp_inv [wp]:
  "\<lbrakk> \<And>r. \<lbrace>\<lambda>s. I r s \<and> C r s\<rbrace> B r \<lbrace>I\<rbrace>,\<lbrace>E\<rbrace>; \<And>r s. \<lbrakk>I r s; \<not> C r s\<rbrakk> \<Longrightarrow> Q r s \<rbrakk>
      \<Longrightarrow> \<lbrace> I r \<rbrace> whileLoopE_inv C B r I M \<lbrace> Q \<rbrace>,\<lbrace> E \<rbrace>"
  apply (clarsimp simp: whileLoopE_inv_def)
  apply (rule validE_whileLoopE [where I=I], auto)
  done

subsection "Stronger whileLoop rules"

lemma whileLoop_rule_strong:
  assumes init_U: "\<lbrace> \<lambda>s'. s' = s \<rbrace> whileLoop C B r \<lbrace> \<lambda>r s. (r, s) \<in> fst Q \<rbrace>"
  and path_exists: "\<And>r'' s''. \<lbrakk> (r'', s'') \<in> fst Q \<rbrakk> \<Longrightarrow> \<lbrace> \<lambda>s'. s' = s \<rbrace> whileLoop C B r \<exists>\<lbrace> \<lambda>r s. r = r'' \<and> s = s'' \<rbrace>"
  and loop_fail: "snd Q \<Longrightarrow> snd (whileLoop C B r s)"
  and loop_nofail: "\<not> snd Q \<Longrightarrow> \<lbrace> \<lambda>s'. s' = s \<rbrace> whileLoop C B r \<lbrace> \<lambda>_ _. True \<rbrace>!"
  shows "whileLoop C B r s = Q"
  using assms
  apply atomize
  apply (clarsimp simp: valid_def exs_valid_def validNF_def no_fail_def)
  apply rule
    apply blast
   apply blast
  apply blast
  done

lemma whileLoop_rule_strong_no_fail:
  assumes init_U: "\<lbrace> \<lambda>s'. s' = s \<rbrace> whileLoop C B r \<lbrace> \<lambda>r s. (r, s) \<in> fst Q \<rbrace>!"
  and path_exists: "\<And>r'' s''. \<lbrakk> (r'', s'') \<in> fst Q \<rbrakk> \<Longrightarrow> \<lbrace> \<lambda>s'. s' = s \<rbrace> whileLoop C B r \<exists>\<lbrace> \<lambda>r s. r = r'' \<and> s = s'' \<rbrace>"
  and loop_no_fail: "\<not> snd Q"
  shows "whileLoop C B r s = Q"
  apply (rule whileLoop_rule_strong)
     apply (metis init_U validNF_valid)
    apply (metis path_exists)
   apply (metis loop_no_fail)
  apply (metis (lifting, no_types) init_U validNF_chain)
  done

subsection "Miscellaneous rules"

(* Failure of one whileLoop implies the failure of another whileloop
 * which will only ever fail more. *)
lemma snd_whileLoop_subset:
    assumes a_fails: "snd (whileLoop C A r s)"
    and b_success_step:
        "\<And>r s r' s'. \<lbrakk> C r s; (r', s') \<in> fst (A r s); \<not> snd (B r s) \<rbrakk>
             \<Longrightarrow> (r', s') \<in> fst (B r s)"
    and b_fail_step: "\<And>r s. \<lbrakk> C r s; snd (A r s) \<rbrakk> \<Longrightarrow> snd (B r s) "
   shows "snd (whileLoop C B r s)"
  apply (insert a_fails)
  apply (induct rule: snd_whileLoop_induct)
    apply (unfold whileLoop_def snd_conv)[1]
    apply (rule disjCI, simp)
    apply rotate_tac
    apply (induct rule: whileLoop_terminates.induct)
     apply (subst (asm) whileLoop_terminates.simps)
     apply simp
    apply (subst (asm) (3) whileLoop_terminates.simps, clarsimp)
    apply (subst whileLoop_results.simps, clarsimp)
    apply (rule classical)
    apply (frule b_success_step, assumption, simp)
    apply (drule (1) bspec)
    apply clarsimp
   apply (frule (1) b_fail_step)
   apply (metis snd_whileLoop_first_step)
  apply (metis b_success_step snd_whileLoop_first_step snd_whileLoop_unfold)
  done

end


(*<*)
theory Isar
imports LaTeXsugar
begin
declare [[quick_and_dirty]]
(*>*)
text{*
Apply-scripts are unreadable and hard to maintain. The language of choice
for larger proofs is \concept{Isar}. The two key features of Isar are:
\begin{itemize}
\item It is structured, not linear.
\item It is readable without its being run because
you need to state what you are proving at any given point.
\end{itemize}
Whereas apply-scripts are like assembly language programs, Isar proofs
are like structured programs with comments. A typical Isar proof looks like this:
*}text{*
\begin{tabular}{@ {}l}
\isacom{proof}\\
\quad\isacom{assume} @{text"\""}$\mathit{formula}_0$@{text"\""}\\
\quad\isacom{have} @{text"\""}$\mathit{formula}_1$@{text"\""} \quad\isacom{by} @{text simp}\\
\quad\vdots\\
\quad\isacom{have} @{text"\""}$\mathit{formula}_n$@{text"\""} \quad\isacom{by} @{text blast}\\
\quad\isacom{show} @{text"\""}$\mathit{formula}_{n+1}$@{text"\""} \quad\isacom{by} @{text \<dots>}\\
\isacom{qed}
\end{tabular}
*}text{*
It proves $\mathit{formula}_0 \Longrightarrow \mathit{formula}_{n+1}$
(provided each proof step succeeds).
The intermediate \isacom{have} statements are merely stepping stones
on the way towards the \isacom{show} statement that proves the actual
goal. In more detail, this is the Isar core syntax:
\medskip

\begin{tabular}{@ {}lcl@ {}}
\textit{proof} &=& \indexed{\isacom{by}}{by} \textit{method}\\
      &$\mid$& \indexed{\isacom{proof}}{proof} [\textit{method}] \ \textit{step}$^*$ \ \indexed{\isacom{qed}}{qed}
\end{tabular}
\medskip

\begin{tabular}{@ {}lcl@ {}}
\textit{step} &=& \indexed{\isacom{fix}}{fix} \textit{variables} \\
      &$\mid$& \indexed{\isacom{assume}}{assume} \textit{proposition} \\
      &$\mid$& [\indexed{\isacom{from}}{from} \textit{fact}$^+$] (\indexed{\isacom{have}}{have} $\mid$ \indexed{\isacom{show}}{show}) \ \textit{proposition} \ \textit{proof}
\end{tabular}
\medskip

\begin{tabular}{@ {}lcl@ {}}
\textit{proposition} &=& [\textit{name}:] @{text"\""}\textit{formula}@{text"\""}
\end{tabular}
\medskip

\begin{tabular}{@ {}lcl@ {}}
\textit{fact} &=& \textit{name} \ $\mid$ \ \dots
\end{tabular}
\medskip

\noindent A proof can either be an atomic \isacom{by} with a single proof
method which must finish off the statement being proved, for example @{text
auto},  or it can be a \isacom{proof}--\isacom{qed} block of multiple
steps. Such a block can optionally begin with a proof method that indicates
how to start off the proof, e.g., \mbox{@{text"(induction xs)"}}.

A step either assumes a proposition or states a proposition
together with its proof. The optional \isacom{from} clause
indicates which facts are to be used in the proof.
Intermediate propositions are stated with \isacom{have}, the overall goal
is stated with \isacom{show}. A step can also introduce new local variables with
\isacom{fix}. Logically, \isacom{fix} introduces @{text"\<And>"}-quantified
variables, \isacom{assume} introduces the assumption of an implication
(@{text"\<Longrightarrow>"}) and \isacom{have}/\isacom{show} introduce the conclusion.

Propositions are optionally named formulas. These names can be referred to in
later \isacom{from} clauses. In the simplest case, a fact is such a name.
But facts can also be composed with @{text OF} and @{text of} as shown in
\autoref{sec:forward-proof} --- hence the \dots\ in the above grammar.  Note
that assumptions, intermediate \isacom{have} statements and global lemmas all
have the same status and are thus collectively referred to as
\conceptidx{facts}{fact}.

Fact names can stand for whole lists of facts. For example, if @{text f} is
defined by command \isacom{fun}, @{text"f.simps"} refers to the whole list of
recursion equations defining @{text f}. Individual facts can be selected by
writing @{text"f.simps(2)"}, whole sublists by writing @{text"f.simps(2-4)"}.

\section{Isar by Example}

We show a number of proofs of Cantor's theorem that a function from a set to
its powerset cannot be surjective, illustrating various features of Isar. The
constant @{const surj} is predefined.
*}

lemma "\<not> surj(f :: 'a \<Rightarrow> 'a set)"
proof
  assume 0: "surj f"
  from 0 have 1: "\<forall>A. \<exists>a. A = f a" by(simp add: surj_def)
  from 1 have 2: "\<exists>a. {x. x \<notin> f x} = f a" by blast
  from 2 show "False" by blast
qed

text{*
The \isacom{proof} command lacks an explicit method by which to perform
the proof. In such cases Isabelle tries to use some standard introduction
rule, in the above case for @{text"\<not>"}:
\[
\inferrule{
\mbox{@{thm (prem 1) notI}}}
{\mbox{@{thm (concl) notI}}}
\]
In order to prove @{prop"~ P"}, assume @{text P} and show @{text False}.
Thus we may assume @{prop"surj f"}. The proof shows that names of propositions
may be (single!) digits --- meaningful names are hard to invent and are often
not necessary. Both \isacom{have} steps are obvious. The second one introduces
the diagonal set @{term"{x. x \<notin> f x}"}, the key idea in the proof.
If you wonder why @{text 2} directly implies @{text False}: from @{text 2}
it follows that @{prop"a \<notin> f a \<longleftrightarrow> a \<in> f a"}.

\subsection{\indexed{@{text this}}{this}, \indexed{\isacom{then}}{then}, \indexed{\isacom{hence}}{hence} and \indexed{\isacom{thus}}{thus}}

Labels should be avoided. They interrupt the flow of the reader who has to
scan the context for the point where the label was introduced. Ideally, the
proof is a linear flow, where the output of one step becomes the input of the
next step, piping the previously proved fact into the next proof, like
in a UNIX pipe. In such cases the predefined name @{text this} can be used
to refer to the proposition proved in the previous step. This allows us to
eliminate all labels from our proof (we suppress the \isacom{lemma} statement):
*}
(*<*)
lemma "\<not> surj(f :: 'a \<Rightarrow> 'a set)"
(*>*)
proof
  assume "surj f"
  from this have "\<exists>a. {x. x \<notin> f x} = f a" by(auto simp: surj_def)
  from this show "False" by blast
qed

text{* We have also taken the opportunity to compress the two \isacom{have}
steps into one.

To compact the text further, Isar has a few convenient abbreviations:
\medskip

\begin{tabular}{r@ {\quad=\quad}l}
\isacom{then} & \isacom{from} @{text this}\\
\isacom{thus} & \isacom{then} \isacom{show}\\
\isacom{hence} & \isacom{then} \isacom{have}
\end{tabular}
\medskip

\noindent
With the help of these abbreviations the proof becomes
*}
(*<*)
lemma "\<not> surj(f :: 'a \<Rightarrow> 'a set)"
(*>*)
proof
  assume "surj f"
  hence "\<exists>a. {x. x \<notin> f x} = f a" by(auto simp: surj_def)
  thus "False" by blast
qed
text{*

There are two further linguistic variations:
\medskip

\begin{tabular}{r@ {\quad=\quad}l}
(\isacom{have}$\mid$\isacom{show}) \ \textit{prop} \ \indexed{\isacom{using}}{using} \ \textit{facts}
&
\isacom{from} \ \textit{facts} \ (\isacom{have}$\mid$\isacom{show}) \ \textit{prop}\\
\indexed{\isacom{with}}{with} \ \textit{facts} & \isacom{from} \ \textit{facts} \isa{this}
\end{tabular}
\medskip

\noindent The \isacom{using} idiom de-emphasizes the used facts by moving them
behind the proposition.

\subsection{Structured Lemma Statements: \indexed{\isacom{fixes}}{fixes}, \indexed{\isacom{assumes}}{assumes}, \indexed{\isacom{shows}}{shows}}
\index{lemma@\isacom{lemma}}
Lemmas can also be stated in a more structured fashion. To demonstrate this
feature with Cantor's theorem, we rephrase @{prop"\<not> surj f"}
a little:
*}

lemma
  fixes f :: "'a \<Rightarrow> 'a set"
  assumes s: "surj f"
  shows "False"

txt{* The optional \isacom{fixes} part allows you to state the types of
variables up front rather than by decorating one of their occurrences in the
formula with a type constraint. The key advantage of the structured format is
the \isacom{assumes} part that allows you to name each assumption; multiple
assumptions can be separated by \isacom{and}. The
\isacom{shows} part gives the goal. The actual theorem that will come out of
the proof is @{prop"surj f \<Longrightarrow> False"}, but during the proof the assumption
@{prop"surj f"} is available under the name @{text s} like any other fact.
*}

proof -
  have "\<exists> a. {x. x \<notin> f x} = f a" using s
    by(auto simp: surj_def)
  thus "False" by blast
qed

text{*
\begin{warn}
Note the hyphen after the \isacom{proof} command.
It is the null method that does nothing to the goal. Leaving it out would be asking
Isabelle to try some suitable introduction rule on the goal @{const False} --- but
there is no such rule and \isacom{proof} would fail.
\end{warn}
In the \isacom{have} step the assumption @{prop"surj f"} is now
referenced by its name @{text s}. The duplication of @{prop"surj f"} in the
above proofs (once in the statement of the lemma, once in its proof) has been
eliminated.

Stating a lemma with \isacom{assumes}-\isacom{shows} implicitly introduces the
name \indexed{@{text assms}}{assms} that stands for the list of all assumptions. You can refer
to individual assumptions by @{text"assms(1)"}, @{text"assms(2)"}, etc.,
thus obviating the need to name them individually.

\section{Proof Patterns}

We show a number of important basic proof patterns. Many of them arise from
the rules of natural deduction that are applied by \isacom{proof} by
default. The patterns are phrased in terms of \isacom{show} but work for
\isacom{have} and \isacom{lemma}, too.

We start with two forms of \concept{case analysis}:
starting from a formula @{text P} we have the two cases @{text P} and
@{prop"~P"}, and starting from a fact @{prop"P \<or> Q"}
we have the two cases @{text P} and @{text Q}:
*}text_raw{*
\begin{tabular}{@ {}ll@ {}}
\begin{minipage}[t]{.4\textwidth}
\isa{%
*}
(*<*)lemma "R" proof-(*>*)
show "R"
proof cases
  assume "P"
  text_raw{*\\\mbox{}\quad$\vdots$\\\mbox{}\hspace{-1.4ex}*}
  show "R" (*<*)sorry(*>*)text_raw{*\ $\dots$\\*}
next
  assume "\<not> P"
  text_raw{*\\\mbox{}\quad$\vdots$\\\mbox{}\hspace{-1.4ex}*}
  show "R" (*<*)sorry(*>*)text_raw{*\ $\dots$\\*}
qed(*<*)oops(*>*)
text_raw {* }
\end{minipage}\index{cases@@{text cases}}
&
\begin{minipage}[t]{.4\textwidth}
\isa{%
*}
(*<*)lemma "R" proof-(*>*)
have "P \<or> Q" (*<*)sorry(*>*)text_raw{*\ $\dots$\\*}
then show "R"
proof
  assume "P"
  text_raw{*\\\mbox{}\quad$\vdots$\\\mbox{}\hspace{-1.4ex}*}
  show "R" (*<*)sorry(*>*)text_raw{*\ $\dots$\\*}
next
  assume "Q"
  text_raw{*\\\mbox{}\quad$\vdots$\\\mbox{}\hspace{-1.4ex}*}
  show "R" (*<*)sorry(*>*)text_raw{*\ $\dots$\\*}
qed(*<*)oops(*>*)

text_raw {* }
\end{minipage}
\end{tabular}
\medskip
\begin{isamarkuptext}%
How to prove a logical equivalence:
\end{isamarkuptext}%
\isa{%
*}
(*<*)lemma "P\<longleftrightarrow>Q" proof-(*>*)
show "P \<longleftrightarrow> Q"
proof
  assume "P"
  text_raw{*\\\mbox{}\quad$\vdots$\\\mbox{}\hspace{-1.4ex}*}
  show "Q" (*<*)sorry(*>*) text_raw{*\ $\dots$\\*}
next
  assume "Q"
  text_raw{*\\\mbox{}\quad$\vdots$\\\mbox{}\hspace{-1.4ex}*}
  show "P" (*<*)sorry(*>*) text_raw{*\ $\dots$\\*}
qed(*<*)qed(*>*)
text_raw {* }
\medskip
\begin{isamarkuptext}%
Proofs by contradiction (@{thm[source] ccontr} stands for ``classical contradiction''):
\end{isamarkuptext}%
\begin{tabular}{@ {}ll@ {}}
\begin{minipage}[t]{.4\textwidth}
\isa{%
*}
(*<*)lemma "\<not> P" proof-(*>*)
show "\<not> P"
proof
  assume "P"
  text_raw{*\\\mbox{}\quad$\vdots$\\\mbox{}\hspace{-1.4ex}*}
  show "False" (*<*)sorry(*>*)text_raw{*\ $\dots$\\*}
qed(*<*)oops(*>*)

text_raw {* }
\end{minipage}
&
\begin{minipage}[t]{.4\textwidth}
\isa{%
*}
(*<*)lemma "P" proof-(*>*)
show "P"
proof (rule ccontr)
  assume "\<not>P"
  text_raw{*\\\mbox{}\quad$\vdots$\\\mbox{}\hspace{-1.4ex}*}
  show "False" (*<*)sorry(*>*)text_raw{*\ $\dots$\\*}
qed(*<*)oops(*>*)

text_raw {* }
\end{minipage}
\end{tabular}
\medskip
\begin{isamarkuptext}%
How to prove quantified formulas:
\end{isamarkuptext}%
\begin{tabular}{@ {}ll@ {}}
\begin{minipage}[t]{.4\textwidth}
\isa{%
*}
(*<*)lemma "ALL x. P x" proof-(*>*)
show "\<forall>x. P(x)"
proof
  fix x
  text_raw{*\\\mbox{}\quad$\vdots$\\\mbox{}\hspace{-1.4ex}*}
  show "P(x)" (*<*)sorry(*>*)text_raw{*\ $\dots$\\*}
qed(*<*)oops(*>*)

text_raw {* }
\end{minipage}
&
\begin{minipage}[t]{.4\textwidth}
\isa{%
*}
(*<*)lemma "EX x. P(x)" proof-(*>*)
show "\<exists>x. P(x)"
proof
  text_raw{*\\\mbox{}\quad$\vdots$\\\mbox{}\hspace{-1.4ex}*}
  show "P(witness)" (*<*)sorry(*>*)text_raw{*\ $\dots$\\*}
qed
(*<*)oops(*>*)

text_raw {* }
\end{minipage}
\end{tabular}
\medskip
\begin{isamarkuptext}%
In the proof of \noquotes{@{prop[source]"\<forall>x. P(x)"}},
the step \indexed{\isacom{fix}}{fix}~@{text x} introduces a locally fixed variable @{text x}
into the subproof, the proverbial ``arbitrary but fixed value''.
Instead of @{text x} we could have chosen any name in the subproof.
In the proof of \noquotes{@{prop[source]"\<exists>x. P(x)"}},
@{text witness} is some arbitrary
term for which we can prove that it satisfies @{text P}.

How to reason forward from \noquotes{@{prop[source] "\<exists>x. P(x)"}}:
\end{isamarkuptext}%
*}
(*<*)lemma True proof- assume 1: "EX x. P x"(*>*)
have "\<exists>x. P(x)" (*<*)by(rule 1)(*>*)text_raw{*\ $\dots$\\*}
then obtain x where p: "P(x)" by blast
(*<*)oops(*>*)
text{*
After the \indexed{\isacom{obtain}}{obtain} step, @{text x} (we could have chosen any name)
is a fixed local
variable, and @{text p} is the name of the fact
\noquotes{@{prop[source] "P(x)"}}.
This pattern works for one or more @{text x}.
As an example of the \isacom{obtain} command, here is the proof of
Cantor's theorem in more detail:
*}

lemma "\<not> surj(f :: 'a \<Rightarrow> 'a set)"
proof
  assume "surj f"
  hence  "\<exists>a. {x. x \<notin> f x} = f a" by(auto simp: surj_def)
  then obtain a where  "{x. x \<notin> f x} = f a"  by blast
  hence  "a \<notin> f a \<longleftrightarrow> a \<in> f a"  by blast
  thus "False" by blast
qed

text_raw{*
\begin{isamarkuptext}%

Finally, how to prove set equality and subset relationship:
\end{isamarkuptext}%
\begin{tabular}{@ {}ll@ {}}
\begin{minipage}[t]{.4\textwidth}
\isa{%
*}
(*<*)lemma "A = (B::'a set)" proof-(*>*)
show "A = B"
proof
  show "A \<subseteq> B" (*<*)sorry(*>*)text_raw{*\ $\dots$\\*}
next
  show "B \<subseteq> A" (*<*)sorry(*>*)text_raw{*\ $\dots$\\*}
qed(*<*)qed(*>*)

text_raw {* }
\end{minipage}
&
\begin{minipage}[t]{.4\textwidth}
\isa{%
*}
(*<*)lemma "A <= (B::'a set)" proof-(*>*)
show "A \<subseteq> B"
proof
  fix x
  assume "x \<in> A"
  text_raw{*\\\mbox{}\quad$\vdots$\\\mbox{}\hspace{-1.4ex}*}
  show "x \<in> B" (*<*)sorry(*>*)text_raw{*\ $\dots$\\*}
qed(*<*)qed(*>*)

text_raw {* }
\end{minipage}
\end{tabular}
\begin{isamarkuptext}%
\section{Streamlining Proofs}

\subsection{Pattern Matching and Quotations}

In the proof patterns shown above, formulas are often duplicated.
This can make the text harder to read, write and maintain. Pattern matching
is an abbreviation mechanism to avoid such duplication. Writing
\begin{quote}
\isacom{show} \ \textit{formula} @{text"("}\indexed{\isacom{is}}{is} \textit{pattern}@{text")"}
\end{quote}
matches the pattern against the formula, thus instantiating the unknowns in
the pattern for later use. As an example, consider the proof pattern for
@{text"\<longleftrightarrow>"}:
\end{isamarkuptext}%
*}
(*<*)lemma "formula\<^sub>1 \<longleftrightarrow> formula\<^sub>2" proof-(*>*)
show "formula\<^sub>1 \<longleftrightarrow> formula\<^sub>2" (is "?L \<longleftrightarrow> ?R")
proof
  assume "?L"
  text_raw{*\\\mbox{}\quad$\vdots$\\\mbox{}\hspace{-1.4ex}*}
  show "?R" (*<*)sorry(*>*) text_raw{*\ $\dots$\\*}
next
  assume "?R"
  text_raw{*\\\mbox{}\quad$\vdots$\\\mbox{}\hspace{-1.4ex}*}
  show "?L" (*<*)sorry(*>*) text_raw{*\ $\dots$\\*}
qed(*<*)qed(*>*)

text{* Instead of duplicating @{text"formula\<^sub>i"} in the text, we introduce
the two abbreviations @{text"?L"} and @{text"?R"} by pattern matching.
Pattern matching works wherever a formula is stated, in particular
with \isacom{have} and \isacom{lemma}.

The unknown \indexed{@{text"?thesis"}}{thesis} is implicitly matched against any goal stated by
\isacom{lemma} or \isacom{show}. Here is a typical example: *}

lemma "formula"
proof -
  text_raw{*\\\mbox{}\quad$\vdots$\\\mbox{}\hspace{-1.4ex}*}
  show ?thesis (*<*)sorry(*>*) text_raw{*\ $\dots$\\*}
qed

text{*
Unknowns can also be instantiated with \indexed{\isacom{let}}{let} commands
\begin{quote}
\isacom{let} @{text"?t"} = @{text"\""}\textit{some-big-term}@{text"\""}
\end{quote}
Later proof steps can refer to @{text"?t"}:
\begin{quote}
\isacom{have} @{text"\""}\dots @{text"?t"} \dots@{text"\""}
\end{quote}
\begin{warn}
Names of facts are introduced with @{text"name:"} and refer to proved
theorems. Unknowns @{text"?X"} refer to terms or formulas.
\end{warn}

Although abbreviations shorten the text, the reader needs to remember what
they stand for. Similarly for names of facts. Names like @{text 1}, @{text 2}
and @{text 3} are not helpful and should only be used in short proofs. For
longer proofs, descriptive names are better. But look at this example:
\begin{quote}
\isacom{have} \ @{text"x_gr_0: \"x > 0\""}\\
$\vdots$\\
\isacom{from} @{text "x_gr_0"} \dots
\end{quote}
The name is longer than the fact it stands for! Short facts do not need names;
one can refer to them easily by quoting them:
\begin{quote}
\isacom{have} \ @{text"\"x > 0\""}\\
$\vdots$\\
\isacom{from} @{text "`x>0`"} \dots\index{$IMP053@@{text"`...`"}}
\end{quote}
Note that the quotes around @{text"x>0"} are \conceptnoidx{back quotes}.
They refer to the fact not by name but by value.

\subsection{\indexed{\isacom{moreover}}{moreover}}
\index{ultimately@\isacom{ultimately}}

Sometimes one needs a number of facts to enable some deduction. Of course
one can name these facts individually, as shown on the right,
but one can also combine them with \isacom{moreover}, as shown on the left:
*}text_raw{*
\begin{tabular}{@ {}ll@ {}}
\begin{minipage}[t]{.4\textwidth}
\isa{%
*}
(*<*)lemma "P" proof-(*>*)
have "P\<^sub>1" (*<*)sorry(*>*)text_raw{*\ $\dots$\\*}
moreover have "P\<^sub>2" (*<*)sorry(*>*)text_raw{*\ $\dots$\\*}
moreover
text_raw{*\\$\vdots$\\\hspace{-1.4ex}*}(*<*)have "True" ..(*>*)
moreover have "P\<^sub>n" (*<*)sorry(*>*)text_raw{*\ $\dots$\\*}
ultimately have "P"  (*<*)sorry(*>*)text_raw{*\ $\dots$\\*}
(*<*)oops(*>*)

text_raw {* }
\end{minipage}
&
\qquad
\begin{minipage}[t]{.4\textwidth}
\isa{%
*}
(*<*)lemma "P" proof-(*>*)
have lab\<^sub>1: "P\<^sub>1" (*<*)sorry(*>*)text_raw{*\ $\dots$\\*}
have lab\<^sub>2: "P\<^sub>2" (*<*)sorry(*>*)text_raw{*\ $\dots$*}
text_raw{*\\$\vdots$\\\hspace{-1.4ex}*}
have lab\<^sub>n: "P\<^sub>n" (*<*)sorry(*>*)text_raw{*\ $\dots$\\*}
from lab\<^sub>1 lab\<^sub>2 text_raw{*\ $\dots$\\*}
have "P"  (*<*)sorry(*>*)text_raw{*\ $\dots$\\*}
(*<*)oops(*>*)

text_raw {* }
\end{minipage}
\end{tabular}
\begin{isamarkuptext}%
The \isacom{moreover} version is no shorter but expresses the structure more
clearly and avoids new names.

\subsection{Raw Proof Blocks}

Sometimes one would like to prove some lemma locally within a proof,
a lemma that shares the current context of assumptions but that
has its own assumptions and is generalized over its locally fixed
variables at the end. This is what a \concept{raw proof block} does:
\begin{quote}\index{$IMP053@@{text"{ ... }"} (proof block)}
@{text"{"} \isacom{fix} @{text"x\<^sub>1 \<dots> x\<^sub>n"}\\
\mbox{}\ \ \ \isacom{assume} @{text"A\<^sub>1 \<dots> A\<^sub>m"}\\
\mbox{}\ \ \ $\vdots$\\
\mbox{}\ \ \ \isacom{have} @{text"B"}\\
@{text"}"}
\end{quote}
proves @{text"\<lbrakk> A\<^sub>1; \<dots> ; A\<^sub>m \<rbrakk> \<Longrightarrow> B"}
where all @{text"x\<^sub>i"} have been replaced by unknowns @{text"?x\<^sub>i"}.
\begin{warn}
The conclusion of a raw proof block is \emph{not} indicated by \isacom{show}
but is simply the final \isacom{have}.
\end{warn}

As an example we prove a simple fact about divisibility on integers.
The definition of @{text "dvd"} is @{thm dvd_def}.
\end{isamarkuptext}%
*}

lemma fixes a b :: int assumes "b dvd (a+b)" shows "b dvd a"
proof -
  { fix k assume k: "a+b = b*k"
    have "\<exists>k'. a = b*k'"
    proof
      show "a = b*(k - 1)" using k by(simp add: algebra_simps)
    qed }
  then show ?thesis using assms by(auto simp add: dvd_def)
qed

text{* Note that the result of a raw proof block has no name. In this example
it was directly piped (via \isacom{then}) into the final proof, but it can
also be named for later reference: you simply follow the block directly by a
\isacom{note} command:
\begin{quote}
\indexed{\isacom{note}}{note} \ @{text"name = this"}
\end{quote}
This introduces a new name @{text name} that refers to @{text this},
the fact just proved, in this case the preceding block. In general,
\isacom{note} introduces a new name for one or more facts.

\subsection*{Exercises}

\exercise
Give a readable, structured proof of the following lemma:
*}
lemma assumes T: "\<forall>x y. T x y \<or> T y x"
  and A: "\<forall>x y. A x y \<and> A y x \<longrightarrow> x = y"
  and TA: "\<forall>x y. T x y \<longrightarrow> A x y" and "A x y"
  shows "T x y"
(*<*)oops(*>*)
text{*
\endexercise

\exercise
Give a readable, structured proof of the following lemma:
*}
lemma "(\<exists>ys zs. xs = ys @ zs \<and> length ys = length zs)
      \<or> (\<exists>ys zs. xs = ys @ zs \<and> length ys = length zs + 1)"
(*<*)oops(*>*)
text{*
Hint: There are predefined functions @{const_typ take} and @{const_typ drop}
such that @{text"take k [x\<^sub>1,\<dots>] = [x\<^sub>1,\<dots>,x\<^sub>k]"} and
@{text"drop k [x\<^sub>1,\<dots>] = [x\<^bsub>k+1\<^esub>,\<dots>]"}. Let sledgehammer find and apply
the relevant @{const take} and @{const drop} lemmas for you.
\endexercise

\section{Case Analysis and Induction}

\subsection{Datatype Case Analysis}
\index{case analysis|(}

We have seen case analysis on formulas. Now we want to distinguish
which form some term takes: is it @{text 0} or of the form @{term"Suc n"},
is it @{term"[]"} or of the form @{term"x#xs"}, etc. Here is a typical example
proof by case analysis on the form of @{text xs}:
*}

lemma "length(tl xs) = length xs - 1"
proof (cases xs)
  assume "xs = []"
  thus ?thesis by simp
next
  fix y ys assume "xs = y#ys"
  thus ?thesis by simp
qed

text{*\index{cases@@{text"cases"}|(}Function @{text tl} (''tail'') is defined by @{thm list.sel(2)} and
@{thm list.sel(3)}. Note that the result type of @{const length} is @{typ nat}
and @{prop"0 - 1 = (0::nat)"}.

This proof pattern works for any term @{text t} whose type is a datatype.
The goal has to be proved for each constructor @{text C}:
\begin{quote}
\isacom{fix} \ @{text"x\<^sub>1 \<dots> x\<^sub>n"} \isacom{assume} @{text"\"t = C x\<^sub>1 \<dots> x\<^sub>n\""}
\end{quote}\index{case@\isacom{case}|(}
Each case can be written in a more compact form by means of the \isacom{case}
command:
\begin{quote}
\isacom{case} @{text "(C x\<^sub>1 \<dots> x\<^sub>n)"}
\end{quote}
This is equivalent to the explicit \isacom{fix}-\isacom{assume} line
but also gives the assumption @{text"\"t = C x\<^sub>1 \<dots> x\<^sub>n\""} a name: @{text C},
like the constructor.
Here is the \isacom{case} version of the proof above:
*}
(*<*)lemma "length(tl xs) = length xs - 1"(*>*)
proof (cases xs)
  case Nil
  thus ?thesis by simp
next
  case (Cons y ys)
  thus ?thesis by simp
qed

text{* Remember that @{text Nil} and @{text Cons} are the alphanumeric names
for @{text"[]"} and @{text"#"}. The names of the assumptions
are not used because they are directly piped (via \isacom{thus})
into the proof of the claim.
\index{case analysis|)}

\subsection{Structural Induction}
\index{induction|(}
\index{structural induction|(}

We illustrate structural induction with an example based on natural numbers:
the sum (@{text"\<Sum>"}) of the first @{text n} natural numbers
(@{text"{0..n::nat}"}) is equal to \mbox{@{term"n*(n+1) div 2::nat"}}.
Never mind the details, just focus on the pattern:
*}

lemma "\<Sum>{0..n::nat} = n*(n+1) div 2"
proof (induction n)
  show "\<Sum>{0..0::nat} = 0*(0+1) div 2" by simp
next
  fix n assume "\<Sum>{0..n::nat} = n*(n+1) div 2"
  thus "\<Sum>{0..Suc n} = Suc n*(Suc n+1) div 2" by simp
qed

text{* Except for the rewrite steps, everything is explicitly given. This
makes the proof easily readable, but the duplication means it is tedious to
write and maintain. Here is how pattern
matching can completely avoid any duplication: *}

lemma "\<Sum>{0..n::nat} = n*(n+1) div 2" (is "?P n")
proof (induction n)
  show "?P 0" by simp
next
  fix n assume "?P n"
  thus "?P(Suc n)" by simp
qed

text{* The first line introduces an abbreviation @{text"?P n"} for the goal.
Pattern matching @{text"?P n"} with the goal instantiates @{text"?P"} to the
function @{term"\<lambda>n. \<Sum>{0..n::nat} = n*(n+1) div 2"}.  Now the proposition to
be proved in the base case can be written as @{text"?P 0"}, the induction
hypothesis as @{text"?P n"}, and the conclusion of the induction step as
@{text"?P(Suc n)"}.

Induction also provides the \isacom{case} idiom that abbreviates
the \isacom{fix}-\isacom{assume} step. The above proof becomes
*}
(*<*)lemma "\<Sum>{0..n::nat} = n*(n+1) div 2"(*>*)
proof (induction n)
  case 0
  show ?case by simp
next
  case (Suc n)
  thus ?case by simp
qed

text{*
The unknown @{text"?case"}\index{case?@@{text"?case"}|(} is set in each case to the required
claim, i.e., @{text"?P 0"} and \mbox{@{text"?P(Suc n)"}} in the above proof,
without requiring the user to define a @{text "?P"}. The general
pattern for induction over @{typ nat} is shown on the left-hand side:
*}text_raw{*
\begin{tabular}{@ {}ll@ {}}
\begin{minipage}[t]{.4\textwidth}
\isa{%
*}
(*<*)lemma "P(n::nat)" proof -(*>*)
show "P(n)"
proof (induction n)
  case 0
  text_raw{*\\\mbox{}\ \ $\vdots$\\\mbox{}\hspace{-1ex}*}
  show ?case (*<*)sorry(*>*) text_raw{*\ $\dots$\\*}
next
  case (Suc n)
  text_raw{*\\\mbox{}\ \ $\vdots$\\\mbox{}\hspace{-1ex}*}
  show ?case (*<*)sorry(*>*) text_raw{*\ $\dots$\\*}
qed(*<*)qed(*>*)

text_raw {* }
\end{minipage}
&
\begin{minipage}[t]{.4\textwidth}
~\\
~\\
\isacom{let} @{text"?case = \"P(0)\""}\\
~\\
~\\
~\\[1ex]
\isacom{fix} @{text n} \isacom{assume} @{text"Suc: \"P(n)\""}\\
\isacom{let} @{text"?case = \"P(Suc n)\""}\\
\end{minipage}
\end{tabular}
\medskip
*}
text{*
On the right side you can see what the \isacom{case} command
on the left stands for.

In case the goal is an implication, induction does one more thing: the
proposition to be proved in each case is not the whole implication but only
its conclusion; the premises of the implication are immediately made
assumptions of that case. That is, if in the above proof we replace
\isacom{show}~@{text"\"P(n)\""} by
\mbox{\isacom{show}~@{text"\"A(n) \<Longrightarrow> P(n)\""}}
then \isacom{case}~@{text 0} stands for
\begin{quote}
\isacom{assume} \ @{text"0: \"A(0)\""}\\
\isacom{let} @{text"?case = \"P(0)\""}
\end{quote}
and \isacom{case}~@{text"(Suc n)"} stands for
\begin{quote}
\isacom{fix} @{text n}\\
\isacom{assume} @{text"Suc:"}
  \begin{tabular}[t]{l}@{text"\"A(n) \<Longrightarrow> P(n)\""}\\@{text"\"A(Suc n)\""}\end{tabular}\\
\isacom{let} @{text"?case = \"P(Suc n)\""}
\end{quote}
The list of assumptions @{text Suc} is actually subdivided
into @{text"Suc.IH"}, the induction hypotheses (here @{text"A(n) \<Longrightarrow> P(n)"}),
and @{text"Suc.prems"}, the premises of the goal being proved
(here @{text"A(Suc n)"}).

Induction works for any datatype.
Proving a goal @{text"\<lbrakk> A\<^sub>1(x); \<dots>; A\<^sub>k(x) \<rbrakk> \<Longrightarrow> P(x)"}
by induction on @{text x} generates a proof obligation for each constructor
@{text C} of the datatype. The command \isacom{case}~@{text"(C x\<^sub>1 \<dots> x\<^sub>n)"}
performs the following steps:
\begin{enumerate}
\item \isacom{fix} @{text"x\<^sub>1 \<dots> x\<^sub>n"}
\item \isacom{assume} the induction hypotheses (calling them @{text C.IH}\index{IH@@{text".IH"}})
 and the premises \mbox{@{text"A\<^sub>i(C x\<^sub>1 \<dots> x\<^sub>n)"}} (calling them @{text"C.prems"}\index{prems@@{text".prems"}})
 and calling the whole list @{text C}
\item \isacom{let} @{text"?case = \"P(C x\<^sub>1 \<dots> x\<^sub>n)\""}
\end{enumerate}
\index{structural induction|)}

\subsection{Rule Induction}
\index{rule induction|(}

Recall the inductive and recursive definitions of even numbers in
\autoref{sec:inductive-defs}:
*}

inductive ev :: "nat \<Rightarrow> bool" where
ev0: "ev 0" |
evSS: "ev n \<Longrightarrow> ev(Suc(Suc n))"

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

text{* We recast the proof of @{prop"ev n \<Longrightarrow> evn n"} in Isar. The
left column shows the actual proof text, the right column shows
the implicit effect of the two \isacom{case} commands:*}text_raw{*
\begin{tabular}{@ {}l@ {\qquad}l@ {}}
\begin{minipage}[t]{.5\textwidth}
\isa{%
*}

lemma "ev n \<Longrightarrow> evn n"
proof(induction rule: ev.induct)
  case ev0
  show ?case by simp
next
  case evSS

  thus ?case by simp
qed

text_raw {* }
\end{minipage}
&
\begin{minipage}[t]{.5\textwidth}
~\\
~\\
\isacom{let} @{text"?case = \"evn 0\""}\\
~\\
~\\
\isacom{fix} @{text n}\\
\isacom{assume} @{text"evSS:"}
  \begin{tabular}[t]{l} @{text"\"ev n\""}\\@{text"\"evn n\""}\end{tabular}\\
\isacom{let} @{text"?case = \"evn(Suc(Suc n))\""}\\
\end{minipage}
\end{tabular}
\medskip
*}
text{*
The proof resembles structural induction, but the induction rule is given
explicitly and the names of the cases are the names of the rules in the
inductive definition.
Let us examine the two assumptions named @{thm[source]evSS}:
@{prop "ev n"} is the premise of rule @{thm[source]evSS}, which we may assume
because we are in the case where that rule was used; @{prop"evn n"}
is the induction hypothesis.
\begin{warn}
Because each \isacom{case} command introduces a list of assumptions
named like the case name, which is the name of a rule of the inductive
definition, those rules now need to be accessed with a qualified name, here
@{thm[source] ev.ev0} and @{thm[source] ev.evSS}.
\end{warn}

In the case @{thm[source]evSS} of the proof above we have pretended that the
system fixes a variable @{text n}.  But unless the user provides the name
@{text n}, the system will just invent its own name that cannot be referred
to.  In the above proof, we do not need to refer to it, hence we do not give
it a specific name. In case one needs to refer to it one writes
\begin{quote}
\isacom{case} @{text"(evSS m)"}
\end{quote}
like \isacom{case}~@{text"(Suc n)"} in earlier structural inductions.
The name @{text m} is an arbitrary choice. As a result,
case @{thm[source] evSS} is derived from a renamed version of
rule @{thm[source] evSS}: @{text"ev m \<Longrightarrow> ev(Suc(Suc m))"}.
Here is an example with a (contrived) intermediate step that refers to @{text m}:
*}

lemma "ev n \<Longrightarrow> evn n"
proof(induction rule: ev.induct)
  case ev0 show ?case by simp
next
  case (evSS m)
  have "evn(Suc(Suc m)) = evn m" by simp
  thus ?case using `evn m` by blast
qed

text{*
\indent
In general, let @{text I} be a (for simplicity unary) inductively defined
predicate and let the rules in the definition of @{text I}
be called @{text "rule\<^sub>1"}, \dots, @{text "rule\<^sub>n"}. A proof by rule
induction follows this pattern:\index{inductionrule@@{text"induction ... rule:"}}
*}

(*<*)
inductive I where rule\<^sub>1: "I()" |  rule\<^sub>2: "I()" |  rule\<^sub>n: "I()"
lemma "I x \<Longrightarrow> P x" proof-(*>*)
show "I x \<Longrightarrow> P x"
proof(induction rule: I.induct)
  case rule\<^sub>1
  text_raw{*\\[-.4ex]\mbox{}\ \ $\vdots$\\[-.4ex]\mbox{}\hspace{-1ex}*}
  show ?case (*<*)sorry(*>*)text_raw{*\ $\dots$\\*}
next
  text_raw{*\\[-.4ex]$\vdots$\\[-.4ex]\mbox{}\hspace{-1ex}*}
(*<*)
  case rule\<^sub>2
  show ?case sorry
(*>*)
next
  case rule\<^sub>n
  text_raw{*\\[-.4ex]\mbox{}\ \ $\vdots$\\[-.4ex]\mbox{}\hspace{-1ex}*}
  show ?case (*<*)sorry(*>*)text_raw{*\ $\dots$\\*}
qed(*<*)qed(*>*)

text{*
One can provide explicit variable names by writing
\isacom{case}~@{text"(rule\<^sub>i x\<^sub>1 \<dots> x\<^sub>k)"}, thus renaming the first @{text k}
free variables in rule @{text i} to @{text"x\<^sub>1 \<dots> x\<^sub>k"},
going through rule @{text i} from left to right.

\subsection{Assumption Naming}
\label{sec:assm-naming}

In any induction, \isacom{case}~@{text name} sets up a list of assumptions
also called @{text name}, which is subdivided into three parts:
\begin{description}
\item[@{text name.IH}]\index{IH@@{text".IH"}} contains the induction hypotheses.
\item[@{text name.hyps}]\index{hyps@@{text".hyps"}} contains all the other hypotheses of this case in the
induction rule. For rule inductions these are the hypotheses of rule
@{text name}, for structural inductions these are empty.
\item[@{text name.prems}]\index{prems@@{text".prems"}} contains the (suitably instantiated) premises
of the statement being proved, i.e., the @{text A\<^sub>i} when
proving @{text"\<lbrakk> A\<^sub>1; \<dots>; A\<^sub>n \<rbrakk> \<Longrightarrow> A"}.
\end{description}
\begin{warn}
Proof method @{text induct} differs from @{text induction}
only in this naming policy: @{text induct} does not distinguish
@{text IH} from @{text hyps} but subsumes @{text IH} under @{text hyps}.
\end{warn}

More complicated inductive proofs than the ones we have seen so far
often need to refer to specific assumptions --- just @{text name} or even
@{text name.prems} and @{text name.IH} can be too unspecific.
This is where the indexing of fact lists comes in handy, e.g.,
@{text"name.IH(2)"} or @{text"name.prems(1-2)"}.

\subsection{Rule Inversion}
\label{sec:rule-inversion}
\index{rule inversion|(}

Rule inversion is case analysis of which rule could have been used to
derive some fact. The name \conceptnoidx{rule inversion} emphasizes that we are
reasoning backwards: by which rules could some given fact have been proved?
For the inductive definition of @{const ev}, rule inversion can be summarized
like this:
@{prop[display]"ev n \<Longrightarrow> n = 0 \<or> (EX k. n = Suc(Suc k) \<and> ev k)"}
The realisation in Isabelle is a case analysis.
A simple example is the proof that @{prop"ev n \<Longrightarrow> ev (n - 2)"}. We
already went through the details informally in \autoref{sec:Logic:even}. This
is the Isar proof:
*}
(*<*)
notepad
begin fix n
(*>*)
  assume "ev n"
  from this have "ev(n - 2)"
  proof cases
    case ev0 thus "ev(n - 2)" by (simp add: ev.ev0)
  next
    case (evSS k) thus "ev(n - 2)" by (simp add: ev.evSS)
  qed
(*<*)
end
(*>*)

text{* The key point here is that a case analysis over some inductively
defined predicate is triggered by piping the given fact
(here: \isacom{from}~@{text this}) into a proof by @{text cases}.
Let us examine the assumptions available in each case. In case @{text ev0}
we have @{text"n = 0"} and in case @{text evSS} we have @{prop"n = Suc(Suc k)"}
and @{prop"ev k"}. In each case the assumptions are available under the name
of the case; there is no fine-grained naming schema like there is for induction.

Sometimes some rules could not have been used to derive the given fact
because constructors clash. As an extreme example consider
rule inversion applied to @{prop"ev(Suc 0)"}: neither rule @{text ev0} nor
rule @{text evSS} can yield @{prop"ev(Suc 0)"} because @{text"Suc 0"} unifies
neither with @{text 0} nor with @{term"Suc(Suc n)"}. Impossible cases do not
have to be proved. Hence we can prove anything from @{prop"ev(Suc 0)"}:
*}
(*<*)
notepad begin fix P
(*>*)
  assume "ev(Suc 0)" then have P by cases
(*<*)
end
(*>*)

text{* That is, @{prop"ev(Suc 0)"} is simply not provable: *}

lemma "\<not> ev(Suc 0)"
proof
  assume "ev(Suc 0)" then show False by cases
qed

text{* Normally not all cases will be impossible. As a simple exercise,
prove that \mbox{@{prop"\<not> ev(Suc(Suc(Suc 0)))"}.}

\subsection{Advanced Rule Induction}
\label{sec:advanced-rule-induction}

So far, rule induction was always applied to goals of the form @{text"I x y z \<Longrightarrow> \<dots>"}
where @{text I} is some inductively defined predicate and @{text x}, @{text y}, @{text z}
are variables. In some rare situations one needs to deal with an assumption where
not all arguments @{text r}, @{text s}, @{text t} are variables:
\begin{isabelle}
\isacom{lemma} @{text"\"I r s t \<Longrightarrow> \<dots>\""}
\end{isabelle}
Applying the standard form of
rule induction in such a situation will lead to strange and typically unprovable goals.
We can easily reduce this situation to the standard one by introducing
new variables @{text x}, @{text y}, @{text z} and reformulating the goal like this:
\begin{isabelle}
\isacom{lemma} @{text"\"I x y z \<Longrightarrow> x = r \<Longrightarrow> y = s \<Longrightarrow> z = t \<Longrightarrow> \<dots>\""}
\end{isabelle}
Standard rule induction will work fine now, provided the free variables in
@{text r}, @{text s}, @{text t} are generalized via @{text"arbitrary"}.

However, induction can do the above transformation for us, behind the curtains, so we never
need to see the expanded version of the lemma. This is what we need to write:
\begin{isabelle}
\isacom{lemma} @{text"\"I r s t \<Longrightarrow> \<dots>\""}\isanewline
\isacom{proof}@{text"(induction \"r\" \"s\" \"t\" arbitrary: \<dots> rule: I.induct)"}\index{inductionrule@@{text"induction ... rule:"}}\index{arbitrary@@{text"arbitrary:"}}
\end{isabelle}
Like for rule inversion, cases that are impossible because of constructor clashes
will not show up at all. Here is a concrete example: *}

lemma "ev (Suc m) \<Longrightarrow> \<not> ev m"
proof(induction "Suc m" arbitrary: m rule: ev.induct)
  fix n assume IH: "\<And>m. n = Suc m \<Longrightarrow> \<not> ev m"
  show "\<not> ev (Suc n)"
  proof --"contradiction"
    assume "ev(Suc n)"
    thus False
    proof cases --"rule inversion"
      fix k assume "n = Suc k" "ev k"
      thus False using IH by auto
    qed
  qed
qed

text{*
Remarks:
\begin{itemize}
\item
Instead of the \isacom{case} and @{text ?case} magic we have spelled all formulas out.
This is merely for greater clarity.
\item
We only need to deal with one case because the @{thm[source] ev0} case is impossible.
\item
The form of the @{text IH} shows us that internally the lemma was expanded as explained
above: \noquotes{@{prop[source]"ev x \<Longrightarrow> x = Suc m \<Longrightarrow> \<not> ev m"}}.
\item
The goal @{prop"\<not> ev (Suc n)"} may surprise. The expanded version of the lemma
would suggest that we have a \isacom{fix} @{text m} \isacom{assume} @{prop"Suc(Suc n) = Suc m"}
and need to show @{prop"\<not> ev m"}. What happened is that Isabelle immediately
simplified @{prop"Suc(Suc n) = Suc m"} to @{prop"Suc n = m"} and could then eliminate
@{text m}. Beware of such nice surprises with this advanced form of induction.
\end{itemize}
\begin{warn}
This advanced form of induction does not support the @{text IH}
naming schema explained in \autoref{sec:assm-naming}:
the induction hypotheses are instead found under the name @{text hyps},
as they are for the simpler
@{text induct} method.
\end{warn}
\index{induction|)}
\index{cases@@{text"cases"}|)}
\index{case@\isacom{case}|)}
\index{case?@@{text"?case"}|)}
\index{rule induction|)}
\index{rule inversion|)}

\subsection*{Exercises}

\exercise
Give a structured proof by rule inversion:
*}

lemma assumes a: "ev(Suc(Suc n))" shows "ev n"
(*<*)oops(*>*)

text{*
\endexercise

\begin{exercise}
Give a structured proof of @{prop "\<not> ev(Suc(Suc(Suc 0)))"}
by rule inversions. If there are no cases to be proved you can close
a proof immediately with \isacom{qed}.
\end{exercise}

\begin{exercise}
Recall predicate @{text star} from \autoref{sec:star} and @{text iter}
from Exercise~\ref{exe:iter}. Prove @{prop "iter r n x y \<Longrightarrow> star r x y"}
in a structured style; do not just sledgehammer each case of the
required induction.
\end{exercise}

\begin{exercise}
Define a recursive function @{text "elems ::"} @{typ"'a list \<Rightarrow> 'a set"}
and prove @{prop "x : elems xs \<Longrightarrow> \<exists>ys zs. xs = ys @ x # zs \<and> x \<notin> elems ys"}.
\end{exercise}

\begin{exercise}
Extend Exercise~\ref{exe:cfg} with a function that checks if some
\mbox{@{text "alpha list"}} is a balanced
string of parentheses. More precisely, define a \mbox{recursive} function
@{text "balanced :: nat \<Rightarrow> alpha list \<Rightarrow> bool"} such that @{term"balanced n w"}
is true iff (informally) @{text"S (a\<^sup>n @ w)"}. Formally, prove that
@{prop "balanced n w \<longleftrightarrow> S (replicate n a @ w)"} where
@{const replicate} @{text"::"} @{typ"nat \<Rightarrow> 'a \<Rightarrow> 'a list"} is predefined
and @{term"replicate n x"} yields the list @{text"[x, \<dots>, x]"} of length @{text n}.
\end{exercise}
*}

(*<*)
end
(*>*)