(*<*)
theory Proof_Context
  imports Main
  keywords "guess_by_rule" :: prf_asm % "proof" and "rule_context" :: thy_defn
begin
(*>*)

section \<open>Local context, proof stack and local theories\<close>

subsection \<open>Problems\<close>

text \<open>
  The will-known shape of elimination (but not induction(!)) rules with a single case:\\
  \<open>A\<^sub>1 \<Longrightarrow> \<dots> \<Longrightarrow> A\<^sub>n \<Longrightarrow> (\<And> \<^bold>x. B\<^sub>1 \<^bold>x \<Longrightarrow> \<dots> \<Longrightarrow> B\<^sub>m \<^bold>x \<Longrightarrow> ?theiss) \<Longrightarrow> ?thesis\<close>\\
  suggest a quite natural use of these rules as means to enrich the local context with the
  variables \<open>\<^bold>x\<close> and assumptions \<open>B\<^sub>1 \<^bold>x, \<dots>, B\<^sub>m \<^bold>x\<close> given the facts \<open>A\<^sub>1, \<dots>, A\<^sub>n\<close>. However, there are
  several limitations the such use of elimination rules in the current implementation of Isabelle/Pure. Notably,
  obtained variables \<open>\<^bold>x\<close> cannot be used to instantiate schematic variables in the goal during goal refinement.
  Also, there is no method equivalent of the @{command "obtain"} command, neither there is an equivalent for local
  theories (to introduce new variables and assumptions into a locale). So to ensure that these limitations are
  \<^emph>\<open>in fact all purely pragmatic\<close>, let's implement the following features in Isabelle/ML:
  \<^enum> Implement a forward transformation of theorems depending on the local context obtained from the elimination rule
    into the external context, even for the case of obtained parameters. Use Hilbert Epsilon-operator to circumvent the
    limitation (it is part of HOL, not Pure, that is one of the reasons this feature is not part of Isar).
  \<^enum> Based on that transformation, implement all the desired features: the method to enrich the proof context
    as provided by the elimination rule as well as the new analogue of the @{command "obtain"} command and
    the local theory equivalent of it. To simplify the task, do not re-implement the full capabilities of
    @{command "obtain"}, just extract the necessary names from the @{attribute case_names} attribute and the
    names of the labmda-bound variables in the rule itself. So the commands would only have just a single argument --
    the elimination rule. The method and the Isar proof element can also naturally use chained facts to resolve them
    with the rule assumptions. The local theory command can just require the rule with no assumptions (it can
    be preliminarily obtained as a separate lemma).
\<close>

subsection \<open>Solutions (all at once, with tests)\<close>

ML \<open>
infix 0 CCOMPN CCOMP
signature BASIC_UTIL = sig
  val CCOMPN : thm * (int * thm) -> thm
  val CCOMP : thm * thm -> thm
end
structure Util = struct
  fun super_thy (thy1, thy2) =
    if Context.subthy (thy1, thy2) then thy1
    else if Context.subthy (thy2, thy1) then thy2
    else raise THEORY ("No proper supertheory", [thy1, thy2])
  val super_thy_of = apply2 Thm.theory_of_thm #> super_thy
  fun unifiers context max (t1, t2) =
    Unify.unifiers (context, Envir.empty max, [(t1, t2)])
    |> Seq.map
      (fn (e as Envir.Envir { tyenv, tenv, ... }, _) =>
        (tyenv |> Vartab.dest |>
         map
           (fn (xi, (S, T)) =>
             ((xi, S), T |> Envir.norm_type tyenv |> Context.cases Thm.global_ctyp_of Thm.ctyp_of context)),
         tenv |> Vartab.dest |>
         map
           (fn (xi, (T, t)) =>
             ((xi, Envir.norm_type tyenv T),
              Envir.norm_term e t |> Context.cases Thm.global_cterm_of Thm.cterm_of context))))
  fun r CCOMPN (i, s) =
    let
      val thy = super_thy_of (r, s)
      val max = Thm.maxidx_of r + Thm.maxidx_of s + 2
    in
      Logic.get_goal (Thm.prop_of s) i
      |> pair [] |> perhaps (I ##>> Logic.dest_all #>> swap #>> uncurry cons |> try |> perhaps_loop)
      |>> Term.rename_wrt_term (Thm.prop_of r)
      ||> pair (Thm.forall_elim_vars (Thm.maxidx_of r + 1) r |> Drule.incr_indexes s)
      ||> `(apfst Thm.prop_of #> unifiers (Context.Theory thy) max #> Seq.hd) ||> apsnd fst
      ||> `(uncurry instantiate_normalize) ||> apsnd (fst o fst)
      |> (fn (vars, (r, tys)) =>
        vars
        |> map (typ_subst_TVars (map (fst |> apfst ##> Thm.typ_of) tys) |> apsnd #> Free #> Thm.global_cterm_of thy)
        |> rpair r |-> forall_intr_list
        |> rpair (i, s) |> Scan.triple2 |> Drule.compose |> zero_var_indexes)
    end
  fun r CCOMP s = r CCOMPN (1, s)
  val id_t = Unsynchronized.ref NONE
  fun register_id_ (t : term) = (id_t := SOME t; t)
  fun id_ T = !id_t |> the |> dest_Const ||> K (T --> T) |> Const
end
structure Basic_Util : BASIC_UTIL = Util
open Basic_Util
\<close>

setup \<open>Sign.declare_const_global ((\<^binding>\<open>id_\<close>, \<^typ>\<open>'a \<Rightarrow> 'a\<close>), NoSyn) #>> Util.register_id_ #> snd\<close>

setup \<open>
  pair (\<^binding>\<open>id__def\<close>, \<^term>\<open>I x \<equiv> x\<close> |> subst_free [(\<^term>\<open>I :: 'a \<Rightarrow> 'a\<close>, Util.id_ \<^typ>\<open>'a\<close>)])
  #>> Thm.simple_fact #-> Global_Theory.add_defs false #> snd
\<close>

ML \<open>
structure Hilbert_Guess = struct
  fun meta_eq e = e RS @{thm atomize_eq[THEN equal_elim_rule2]}
  val prod_conv_thms = [@{thm fst_conv}, @{thm snd_conv}] |> map meta_eq
  fun prod_sel_tac ctxt = rewrite_goal_tac ctxt prod_conv_thms THEN' resolve_tac ctxt [@{thm refl}]
  fun wrap_id_ t = Util.id_ (type_of t) $ t
  fun nth_conv ctxt n k =
    let
      val (xs, Ts) =
        ("a", Name.aT) |> apply2 (fn s => Name.invent (Variable.names_of ctxt) s n)
        ||> map (rpair (Proof_Context.theory_of ctxt |> Sign.defaultS) #> TFree)
      val ts = xs ~~ Ts |> map Free
      val t = nth ts (k - 1)
      val (last, m) = if n = k then (HOLogic.mk_snd, n - 2) else (HOLogic.mk_fst, k - 1)
      val lhs = HOLogic.mk_tuple ts |> wrap_id_ |> funpow m HOLogic.mk_snd |> last
    in
      Goal.prove ctxt xs [] (HOLogic.mk_eq (lhs, t) |> HOLogic.mk_Trueprop)
        (HEADGOAL (rewrite_goal_tac ctxt [@{thm id__def}] THEN' prod_sel_tac ctxt) |> K)
    end
  val nth_conv = fn ctxt => fn n => if n = 1 then K (@{thm id__def} RS @{thm meta_eq_to_obj_eq}) else nth_conv ctxt n
  val True_simp = @{lemma "(True \<and> A) = A" by simp} |> meta_eq
  fun conj_elim_tac ctxt = (REPEAT_ALL_NEW (eresolve_tac ctxt [@{thm conjE}]) ORELSE' (K all_tac)) THEN' assume_tac ctxt
  fun maybe_skolem ctxt = Variable.is_body ctxt ? Name.skolem
  fun maybe_dest_skolem ctxt = Variable.is_body ctxt ? Name.dest_skolem
  \<comment> \<open>
  Export local theorem \<open>G \<^bold>x\<close> (\<open>thm\<close> over \<open>vars\<close>) valid under \<open>\<^bold>H \<^bold>x\<close> (\<open>chyps\<close>)
  into the global context. Note that \<open>\<^bold>x\<close> \<^emph>\<open>may\<close> occur in \<open>G\<close>, hence the need in all those Hilbert Epsilon tricks.
  What we want to get is basically \<open>\<^bold>H ?\<^bold>x \<Longrightarrow> G' (\<epsilon>(\<^bold>x) (\<And>\<^bold>H) \<^bold>x))\<close>, where bold font denotes vectors, bold in
  parenthesis denotes tuples and \<open>\<epsilon>\<close> is the Hilbert Epsilon-operator.
  Here's the basic approach:\\
  — (1). \<open>\<^bold>H \<^bold>x \<turnstile> G \<^bold>x \<Longrightarrow> (\<^bold>H \<^bold>x \<Longrightarrow> G \<^bold>x)\<close>\\
  — (2). \<open>\<dots> \<Longrightarrow> ((\<And>\<^bold>H) \<^bold>x \<Longrightarrow> G \<^bold>x)\<close>\\
  — (3). \<open>\<dots> \<Longrightarrow> ((\<And>\<^bold>H') (\<^bold>x) \<Longrightarrow> G' (\<^bold>x))\<close>\\
  — (4). \<open>\<dots> \<Longrightarrow> ((\<And>\<^bold>H') ?x \<Longrightarrow> G' ?x)\<close>\\
  — (5). \<open>\<dots> \<Longrightarrow> ((\<And>\<^bold>H') ?x \<Longrightarrow> G' (\<epsilon>x (\<And>\<^bold>H') x))\<close>\\
  — (6). \<open>\<dots> \<Longrightarrow> ((\<And>\<^bold>H') (\<^bold>x) \<Longrightarrow> G' (\<epsilon>x (\<And>\<^bold>H') x))\<close>\\
  — (7). \<open>\<dots> \<Longrightarrow> (\<^bold>H \<^bold>x \<Longrightarrow> G' (\<epsilon>x (\<And>\<^bold>H') x))\<close>\\
  — (8). \<open>\<dots> \<Longrightarrow> (\<^bold>H ?\<^bold>x \<Longrightarrow> G' (\<epsilon>(\<^bold>x) (\<And>\<^bold>H) \<^bold>x))\<close>\\
  \<close>
  fun export0 ctxt vars chyps thm =
    let
      val gens = ([], map fst vars)
      val (gthm, intro) = \<comment> \<open>(1, 2)\<close>
        let
          val phyps = map Thm.term_of chyps
          val ahyps = map (Object_Logic.atomize_term ctxt) phyps
          val pconj =
            ahyps
            |> List.foldl (HOLogic.mk_conj o swap) \<^term>\<open>True\<close>
            |> Raw_Simplifier.rewrite_term (Proof_Context.theory_of ctxt) [True_simp] []
            |> HOLogic.mk_Trueprop
          val cconj = Thm.cterm_of ctxt pconj
          val intros =
            map
              (HOLogic.mk_Trueprop
               #> curry Logic.mk_implies pconj
               #> Thm.cterm_of ctxt
               #> rpair (HEADGOAL (conj_elim_tac ctxt) |> K) #-> Goal.prove_internal ctxt []
               #> Conv.fconv_rule (Object_Logic.atomize ctxt))
              ahyps |>
            rpair (map (curry Logic.mk_implies pconj #> Thm.cterm_of ctxt) phyps) |>
            op ~~ |>
            map
              (fn (a, g) =>
                Goal.prove_internal ctxt [] g
                  (HEADGOAL (Object_Logic.full_atomize_tac ctxt THEN' resolve_tac ctxt [a]) |> K)
                |> curry op RS (Thm.assume cconj))
          val intro =
            Goal.prove_internal ctxt [] (List.foldr Logic.mk_implies pconj phyps |> Thm.cterm_of ctxt)
              (HEADGOAL
                (Object_Logic.atomize_prems_tac ctxt
                 THEN' rewrite_goal_tac ctxt [@{thm conj_assoc}]
                 THEN' REPEAT_ALL_NEW (ares_tac ctxt [@{thm conjI}, @{thm TrueI}])) |> K)
        in
          fold_rev Thm.implies_intr chyps thm \<comment> \<open>(1)\<close>
          |> fold (curry op CCOMP) intros |> Thm.implies_intr cconj \<comment> \<open>(2)\<close>
          |> rpair intro
        end
      val frees = map Free vars
      val cfrees = map (Thm.cterm_of ctxt) frees
      val n = length vars
      val subs = 1 upto n |> map (nth_conv ctxt n #> meta_eq #> infer_instantiate' ctxt (map SOME cfrees))
      \<comment> \<open>prop of (3):\<close>
      val gprop = gthm |> Thm.prop_of |> subst_free (map (swap o Logic.dest_equals o Thm.prop_of) subs)
      fun induct k = \<comment> \<open>induction rules for (4)\<close>
        let
          val m = n - k - 1
          val sub = HOLogic.mk_tuple (drop m frees)
          val x = Term.variant_frees gprop [("x", type_of sub)] |> the_single
          val subs = apply2 (fn x => take m frees @ [x] |> HOLogic.mk_tuple |> wrap_id_) (sub, Free x) |> single
        in
          gprop
          |> Object_Logic.atomize_term ctxt
          |> Pattern.rewrite_term (Proof_Context.theory_of ctxt) subs []
          |> lambda (Free x) |> Thm.cterm_of ctxt |> SOME |> single
          |> rpair @{thm prod.induct} |-> infer_instantiate' ctxt |> Drule.generalize gens
        end
      val gthm = \<comment> \<open>(3,4,5)\<close>
        Goal.prove_internal ctxt [] (Thm.cterm_of ctxt gprop)
          (HEADGOAL (rewrite_goal_tac ctxt subs THEN' solve_tac ctxt [gthm]) |> K) \<comment> \<open>(3)\<close>
        |> Conv.fconv_rule (Object_Logic.atomize ctxt)
        |> fold_rev Thm.forall_intr cfrees
        |> fold (fn n => fn thm => thm CCOMP induct n) (1 upto n - 1) \<comment> \<open>(4)\<close>
        |> rpair @{thm mp} |> op CCOMP |> rpair (2, @{thm someI2}) |> op CCOMPN \<comment> \<open>(5)\<close>
     val u = \<comment> \<open>instantiation for (6)\<close>
        (gprop, Thm.prop_of gthm) |> apply2 (Logic.dest_implies #> fst)
        |> Util.unifiers (Context.Proof ctxt) (Thm.maxidx_of gthm) |> Seq.hd
     val eps_simps = \<comment> \<open>optional rewrite rule for (8)\<close>
       let
         val vars' = map (maybe_dest_skolem ctxt |> apfst) vars
         val frees' = vars' |> Term.variant_frees (gprop |> subst_free (map (rpair Term.dummy) frees)) |> map Free
         val prop = gprop |> Logic.dest_implies |> fst |> HOLogic.dest_Trueprop
         val rhs =
           prop
           |> Raw_Simplifier.rewrite_term (Proof_Context.theory_of ctxt) ((@{thm conj_assoc} |> meta_eq) :: subs) []
           |> subst_free (frees ~~ frees') |> HOLogic.tupled_lambda (HOLogic.mk_tuple frees')
         val lhs = prop |> lambda (HOLogic.mk_tuple frees |> wrap_id_)
       in
         if lhs aconv rhs then []
         else
           [Goal.prove ctxt [] [] (HOLogic.mk_eq (lhs, rhs) |> HOLogic.mk_Trueprop)
             (HEADGOAL
               (rewrite_goal_tac ctxt (map meta_eq [@{thm split_beta'}, @{thm conj_assoc}])
                THEN' resolve_tac ctxt [@{thm refl}]) |> K) |> meta_eq]
       end
    in
      instantiate_normalize u gthm \<comment> \<open>(6)\<close>
      |> rewrite_rule ctxt subs |> curry op RS intro \<comment> \<open>(7)\<close>
      |> rewrite_rule ctxt (@{thm id__def} :: eps_simps) |> Drule.generalize gens |> zero_var_indexes \<comment> \<open>(8)\<close>
    end
  fun dest_premise ctxt ethm =
    let
      val prem = ethm |> Thm.prems_of |> hd
      val fix_typ = map_type_tvar (TFree o apfst fst)
      val vars = Logic.strip_params prem |> map (apfst (maybe_skolem ctxt) ##> fix_typ)
      val chyps =
        Logic.strip_assums_hyp prem
        |> map (pair (vars |> rev |> map Free) #> subst_bounds #> map_types fix_typ #> Thm.cterm_of ctxt)
    in
      (vars, chyps)
    end
  fun export ctxt ethm thm =
    let
      val (vars, chyps) = dest_premise ctxt ethm
      val idx = Thm.maxidx_of thm + 1
      val prop = Thm.prop_of thm
      val prop' =
        prop
        |> map_aterms
          (fn Free (v, T) =>
            if member (op = o apsnd fst) vars v
            then Var ((v, idx), T)
            else Free (v, T) | t => t)
        |> map_types (map_type_tfree (fn (t, S) => TVar ((t, idx), S)))
      val thm = rewrite_rule ctxt [@{thm prop_def}] thm
      val athm =
        if inter (op =) vars (Term.add_frees prop []) |> null
        then
          thm |> Conv.fconv_rule (Object_Logic.atomize ctxt)
          |> fold_rev Thm.implies_intr chyps
          |> Drule.generalize ([], map fst vars)
          |> rpair ethm |> op CCOMP
        else export0 ctxt vars chyps thm CCOMP ethm
    in
      Goal.prove ctxt [] [] prop'
        (HEADGOAL
          (rewrite_goal_tac ctxt [@{thm prop_def}]
           THEN' Object_Logic.full_atomize_tac ctxt
           THEN' resolve_tac ctxt [athm]) |> K)
    end
  fun export_term ctxt ethm =
    Thm.cterm_of ctxt #> Thm.reflexive
    #> export ctxt ethm
    #> Thm.prop_of #> Logic.dest_equals #> fst
  fun guess ctxt' ctxt (thm, pos) facts =
    let
      val thm = singleton (Attrib.eval_thms ctxt') thm
      val ethm = List.foldl (op CCOMP) thm facts
      val binds = Rule_Cases.get thm |> fst |> the_single |> fst |> snd
      val (vars, hyps) = dest_premise ctxt ethm |>> map (maybe_dest_skolem ctxt |> apfst) ||> map Thm.term_of
      fun exports _ _ = (export ctxt ethm, export_term ctxt ethm)
      val fixes = vars |> map (apfst (rpair pos #> Binding.make) #> apsnd SOME #> rpair NoSyn #> Scan.triple1)
      val assms =
        binds ~~ hyps |> map (apsnd (rpair []) ##> single #>> rpair pos #>> Binding.make #>> Thm.no_attributes)
    in
      { exports = exports, fixes = fixes, assms = assms }
    end
  structure Ctxt = Proof_Data (type T = Proof.context option fun init _ = NONE)
  fun hilbert_guess_meth thm_pos ctxt' facts (ctxt, st) =
    let
      val { exports, fixes, assms } = guess ctxt' ctxt thm_pos facts
    in
      ctxt
      |> Ctxt.put (SOME ctxt)
      |> Proof_Context.add_fixes fixes |> snd
      |> Proof_Context.add_assms exports assms |> snd
      |> rpair st |> Seq.succeed |> Seq.make_results
    end
    handle ListPair.UnequalLengths => Seq.single (Seq.Error (fn () => "No enough chained facts or hyp names"))
  fun export_meth _ _ (ctxt, st) =
    if can (Thm.prop_of #> Term.no_dummy_patterns) st
    then TACTIC_CONTEXT ctxt (singleton (Ctxt.get ctxt |> the |> Proof_Context.goal_export ctxt) st |> Seq.single)
    else Seq.single (Seq.Error (fn () => "Illegal dummy patterns in goal"))
  fun guess_from_rule_cmd thm_pos state =
    let
      val ctxt = Proof.context_of state
      val facts = if can Proof.assert_chain state then Proof.the_facts state else []
      val { exports, fixes, assms } = guess ctxt ctxt thm_pos facts
    in
      state
      |> Proof.assert_forward_or_chain
      |> Proof.enter_forward
      |> Proof.fix fixes
      |> Proof.assm exports [] [] assms
    end
  fun rule_context_cmd thm_pos lthy =
    let
      val { exports, fixes, assms } = guess lthy lthy thm_pos []
      val abbrevs =
        fixes |> map (fn (b, typ, mx) => ((b, mx), Free (Binding.name_of b, the typ) |> snd (exports false [])))
      val notes = assms |> map (map (fst #> Thm.cterm_of lthy #> Thm.assume #> fst (exports false [])) |> apsnd)
      fun abbreviate a =
        Local_Theory.abbrev Syntax.mode_default a #> snd #>
        (fn lthy =>
          Local_Theory.map_contexts
            (Proof_Context.revert_abbrev
              "" (Binding.name_of (a |> fst |> fst) |> Long_Name.qualify (Named_Target.locale_of lthy |> the)) |> K)
            lthy)
    in
      lthy
      |> fold abbreviate abbrevs
      |> fold (snd oo Local_Theory.note) notes
    end
  val meth : (Proof.context -> Method.method) context_parser =
    Scan.lift (Parse.position Parse.thm) >> hilbert_guess_meth
  val export_meth : (Proof.context -> Method.method) context_parser =
    Scan.lift (Scan.succeed ()) >> K export_meth
  val _ =
    Outer_Syntax.command \<^command_keyword>\<open>guess_by_rule\<close> "wild guessing using an elimination rule"
      (Parse.position Parse.thm >> (Toplevel.proof o guess_from_rule_cmd))
  val _ =
    Outer_Syntax.command \<^command_keyword>\<open>rule_context\<close> "intoducing declarations from an elimination rule"
      (Parse.position Parse.thm >> (Toplevel.local_theory NONE NONE o rule_context_cmd))
end
\<close>

method_setup hilbert_guess = \<open>Hilbert_Guess.meth\<close> "Elimination into local context"
method_setup export = \<open>Hilbert_Guess.export_meth\<close> "Preventively export the goal state into the outer context"

thm wf_asym wfE_min bij_pointE finite_subset_Union int_diff_cases zip_eq_ConsE prod_cases

lemma wf_asym': assumes wf: "wf R" shows "asym R" proof (intro asymI)
  fix a b assume "(a, b) \<in> R"
  with wf show "(b, a) \<notin> R" apply (hilbert_guess wf_asym[case_names _[asym]]) by (rule asym)
qed

lemma wf_asym'':
  assumes wf: "wf R" and ab: "(a, b) \<in> R"
  shows
    "(b, c) \<in> R \<Longrightarrow> c = a \<Longrightarrow> False"
    "b = c \<Longrightarrow> (c, a) \<in> R \<Longrightarrow> False"
proof-
  presume ba: "(b, a) \<in> R"
  from wf ab show False apply (hilbert_guess wf_asym[case_names _[asym]]) by (rule cnf.clause2raw_notE[OF ba asym])
  thus False .
next
  assume "(b, c) \<in> R" "c = a"
  thus "(b, a) \<in> R" by (elim subst)
next
  assume "b = c" "(c, a) \<in> R"
  thus "(b, a) \<in> R" by (subst (asm) eq_commute) (elim subst)
qed

lemma underE: assumes "y \<in> under R z" obtains "(y, z) \<in> R" using assms unfolding under_def by simp

lemma wf_min:
  assumes wf: "wf R" and nonemp: "x \<in> Q"
  shows "\<exists>z\<in>Q.\<forall>y\<in>under R z. y \<notin> Q"
  using wf nonemp
  apply (hilbert_guess wfE_min[rename_abs z, case_names _[member min]])
proof  (intro bexI[of _ z] ballI impI member)
  fix y assume "y \<in> under R z"
  hence "(y, z) \<in> R" apply (hilbert_guess underE[case_names _[prod]]) by (rule prod)
  thus "y \<notin> Q" by (rule min)
qed export

lemma wf_min':
  assumes wf: "wf R" and nonemp: "x \<in> Q"
  shows "\<exists>z\<in>Q.\<forall>y\<in>under R z. y \<notin> Q"
  apply (intro bexI)
  using wf nonemp apply (hilbert_guess wfE_min[rename_abs z, case_names _[member min]])
proof (intro ballI impI)
  fix y assume "y \<in> under R z"
  hence "(y, z) \<in> R" apply (hilbert_guess underE[case_names _[prod]]) by (rule prod)
  thus "y \<notin> Q" by (rule min)
next
  show "z \<in> Q" by (rule member)
qed export

schematic_goal wf_min'':
  assumes wf: "wf R" and nonemp: "x \<in> Q"
  shows "?z \<in>Q" "\<forall>y\<in>under R ?z. y \<notin> Q"
  using wf nonemp apply (hilbert_guess wfE_min[case_names _[member min]])
   apply (rule member)
proof (intro ballI impI)
  fix y assume "y \<in> under R z"
  hence "(y, z) \<in> R" apply (hilbert_guess underE[case_names _[prod]]) by (rule prod)
  thus "y \<notin> Q" by (rule min)
qed

lemma bij_point:
  assumes bij: "bij f"
  shows "\<exists>!x. y = f x"
proof (intro ex1I)
  from bij guess_by_rule bij_pointE[where y=y, rename_abs x, case_names _[ex 1]]
  from ex show "y = f x" .
  from 1 show "y = f x'  \<Longrightarrow> x' = x" for x' .
qed

schematic_goal bij_point':
  assumes bij: "bij f"
  shows "y = f ?x" and "\<And> x'. y = f x'  \<Longrightarrow> x' = ?x"
proof-
  from bij guess_by_rule bij_pointE[where y=y, rename_abs x, case_names _[ex 1]]
  from ex show "y = f x" .
  from 1 show "y = f x'  \<Longrightarrow> x' = x" for x' .
qed

lemma bij_point'':
  assumes bij: "bij f"
  shows "\<exists>!x. y = f x"
proof (intro ex1I)
  from bij_pointE bij guess x .
  note Ex = this
  from Ex(1) show "y = f x" oops

lemma finite_subset_Union':
  assumes "finite A" "A \<subseteq> \<Union> \<B>"
  obtains \<F> where "finite \<F>" "\<F> \<subseteq> \<B>" "A \<subseteq> \<Union> \<F>"
proof
  {
    from assms guess_by_rule finite_subset_Union[rename_abs \<F>, case_names _[finite sub subset]]
    thm finite sub subset
    thus "finite \<F>" "\<F> \<subseteq> \<B>" "A \<subseteq> \<Union> \<F>" .
  }
qed

lemma finite_subset_Union'':
  assumes "finite A" "A \<subseteq> \<Union> \<B>"
  obtains \<F> where "finite \<F>" "\<F> \<subseteq> \<B>" "A \<subseteq> \<Union> \<F>"
proof
  {
    from finite_subset_Union assms guess \<F> .
    thus "finite \<F>" "\<F> \<subseteq> \<B>" "A \<subseteq> \<Union> \<F>" oops

lemma int_nats: "\<exists> m n. z = int m - int n"
  apply (intro exI)
  apply (hilbert_guess int_diff_cases[rename_abs m n, of z, case_names _[diff]])
  apply (rule diff)
  by export

lemma ex_tails:
  assumes "zip xs ys = xy # xys"
  obtains xs' ys' where "xys = zip xs' ys'"
proof
  {
    from assms guess_by_rule zip_eq_ConsE[rename_abs _ xs' _ ys', case_names _[_ _ _ tails]]
    from tails show "xys = zip  xs' ys'" .
  }
qed

schematic_goal "(?a, ?b) = x"
proof
  {
    guess_by_rule prod_cases[rename_abs a b, of _ x]
    have "fst (a, b) = fst x \<or> fst (a, b) \<noteq> fst  x" by simp
  }
  oops

locale empty = fixes a :: int  begin
rule_context int_diff_cases[of 5, case_names _[diff]]
lemma u: "m > n" using diff by simp
end

term empty.n
thm empty.u

(*<*)
end
(*>*)


(*
 * Copyright 2016, NICTA
 *
 * This software may be distributed and modified according to the terms of
 * the GNU General Public License version 2. Note that NO WARRANTY is provided.
 * See "LICENSE_GPLv2.txt" for details.
 *
 * @TAG(NICTA_GPL)
 *)

theory Util
imports Main
        "~~/src/HOL/Word/Word"
begin

definition
  fun_app :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b" (infixr "$" 10)
where
  "f $ v \<equiv> f v"

declare fun_app_def [simp]

definition
  checked_shift :: "(('a :: len) word \<Rightarrow> nat \<Rightarrow> 'a word) \<Rightarrow> 'a word \<Rightarrow> 'a word \<Rightarrow> 'a word"
where
  checked_shift_def[simp]:
  "checked_shift shifter x y = (if y < of_nat (len_of TYPE('a)) then shifter x (unat y) else 0)"

definition
  checked_div :: "'a \<Rightarrow> 'a \<Rightarrow> ('a :: {zero, Divides.div})"
where
  "checked_div x y = (if y = 0 then 0 else x div y)"

definition
  checked_mod :: "'a \<Rightarrow> 'a \<Rightarrow> ('a :: {zero, Divides.div})"
where
  checked_mod_def[simp]:
  "checked_mod x y = (if y = 0 then 0 else x mod y)"

definition
  Let\<^sub>d\<^sub>s :: "'a \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> 'b"
where
 "Let\<^sub>d\<^sub>s s f \<equiv> f s"

definition
  take\<^sub>c\<^sub>o\<^sub>g\<^sub>e\<^sub>n\<^sub>t :: "'a \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> ('b \<times> 'a)"
where
 "take\<^sub>c\<^sub>o\<^sub>g\<^sub>e\<^sub>n\<^sub>t rec field  \<equiv> (field rec, rec)"

(* for n in range(2, 15+1):
     for k in range(1, n+1):
       print('definition "P{n}_p{k}\\<^sub>f \\<equiv> \\<lambda>({tup}). p{k}"'
             .format(n=n, k=k, tup=', '.join('p' + str(k) for k in range(1, n+1))))
     print('') *)
definition "P2_p1\<^sub>f \<equiv> \<lambda>(p1, p2). p1"
definition "P2_p2\<^sub>f \<equiv> \<lambda>(p1, p2). p2"

definition "P3_p1\<^sub>f \<equiv> \<lambda>(p1, p2, p3). p1"
definition "P3_p2\<^sub>f \<equiv> \<lambda>(p1, p2, p3). p2"
definition "P3_p3\<^sub>f \<equiv> \<lambda>(p1, p2, p3). p3"

definition "P4_p1\<^sub>f \<equiv> \<lambda>(p1, p2, p3, p4). p1"
definition "P4_p2\<^sub>f \<equiv> \<lambda>(p1, p2, p3, p4). p2"
definition "P4_p3\<^sub>f \<equiv> \<lambda>(p1, p2, p3, p4). p3"
definition "P4_p4\<^sub>f \<equiv> \<lambda>(p1, p2, p3, p4). p4"

definition "P5_p1\<^sub>f \<equiv> \<lambda>(p1, p2, p3, p4, p5). p1"
definition "P5_p2\<^sub>f \<equiv> \<lambda>(p1, p2, p3, p4, p5). p2"
definition "P5_p3\<^sub>f \<equiv> \<lambda>(p1, p2, p3, p4, p5). p3"
definition "P5_p4\<^sub>f \<equiv> \<lambda>(p1, p2, p3, p4, p5). p4"
definition "P5_p5\<^sub>f \<equiv> \<lambda>(p1, p2, p3, p4, p5). p5"

definition "P6_p1\<^sub>f \<equiv> \<lambda>(p1, p2, p3, p4, p5, p6). p1"
definition "P6_p2\<^sub>f \<equiv> \<lambda>(p1, p2, p3, p4, p5, p6). p2"
definition "P6_p3\<^sub>f \<equiv> \<lambda>(p1, p2, p3, p4, p5, p6). p3"
definition "P6_p4\<^sub>f \<equiv> \<lambda>(p1, p2, p3, p4, p5, p6). p4"
definition "P6_p5\<^sub>f \<equiv> \<lambda>(p1, p2, p3, p4, p5, p6). p5"
definition "P6_p6\<^sub>f \<equiv> \<lambda>(p1, p2, p3, p4, p5, p6). p6"

definition "P7_p1\<^sub>f \<equiv> \<lambda>(p1, p2, p3, p4, p5, p6, p7). p1"
definition "P7_p2\<^sub>f \<equiv> \<lambda>(p1, p2, p3, p4, p5, p6, p7). p2"
definition "P7_p3\<^sub>f \<equiv> \<lambda>(p1, p2, p3, p4, p5, p6, p7). p3"
definition "P7_p4\<^sub>f \<equiv> \<lambda>(p1, p2, p3, p4, p5, p6, p7). p4"
definition "P7_p5\<^sub>f \<equiv> \<lambda>(p1, p2, p3, p4, p5, p6, p7). p5"
definition "P7_p6\<^sub>f \<equiv> \<lambda>(p1, p2, p3, p4, p5, p6, p7). p6"
definition "P7_p7\<^sub>f \<equiv> \<lambda>(p1, p2, p3, p4, p5, p6, p7). p7"

definition "P8_p1\<^sub>f \<equiv> \<lambda>(p1, p2, p3, p4, p5, p6, p7, p8). p1"
definition "P8_p2\<^sub>f \<equiv> \<lambda>(p1, p2, p3, p4, p5, p6, p7, p8). p2"
definition "P8_p3\<^sub>f \<equiv> \<lambda>(p1, p2, p3, p4, p5, p6, p7, p8). p3"
definition "P8_p4\<^sub>f \<equiv> \<lambda>(p1, p2, p3, p4, p5, p6, p7, p8). p4"
definition "P8_p5\<^sub>f \<equiv> \<lambda>(p1, p2, p3, p4, p5, p6, p7, p8). p5"
definition "P8_p6\<^sub>f \<equiv> \<lambda>(p1, p2, p3, p4, p5, p6, p7, p8). p6"
definition "P8_p7\<^sub>f \<equiv> \<lambda>(p1, p2, p3, p4, p5, p6, p7, p8). p7"
definition "P8_p8\<^sub>f \<equiv> \<lambda>(p1, p2, p3, p4, p5, p6, p7, p8). p8"

definition "P9_p1\<^sub>f \<equiv> \<lambda>(p1, p2, p3, p4, p5, p6, p7, p8, p9). p1"
definition "P9_p2\<^sub>f \<equiv> \<lambda>(p1, p2, p3, p4, p5, p6, p7, p8, p9). p2"
definition "P9_p3\<^sub>f \<equiv> \<lambda>(p1, p2, p3, p4, p5, p6, p7, p8, p9). p3"
definition "P9_p4\<^sub>f \<equiv> \<lambda>(p1, p2, p3, p4, p5, p6, p7, p8, p9). p4"
definition "P9_p5\<^sub>f \<equiv> \<lambda>(p1, p2, p3, p4, p5, p6, p7, p8, p9). p5"
definition "P9_p6\<^sub>f \<equiv> \<lambda>(p1, p2, p3, p4, p5, p6, p7, p8, p9). p6"
definition "P9_p7\<^sub>f \<equiv> \<lambda>(p1, p2, p3, p4, p5, p6, p7, p8, p9). p7"
definition "P9_p8\<^sub>f \<equiv> \<lambda>(p1, p2, p3, p4, p5, p6, p7, p8, p9). p8"
definition "P9_p9\<^sub>f \<equiv> \<lambda>(p1, p2, p3, p4, p5, p6, p7, p8, p9). p9"

definition "P10_p1\<^sub>f \<equiv> \<lambda>(p1, p2, p3, p4, p5, p6, p7, p8, p9, p10). p1"
definition "P10_p2\<^sub>f \<equiv> \<lambda>(p1, p2, p3, p4, p5, p6, p7, p8, p9, p10). p2"
definition "P10_p3\<^sub>f \<equiv> \<lambda>(p1, p2, p3, p4, p5, p6, p7, p8, p9, p10). p3"
definition "P10_p4\<^sub>f \<equiv> \<lambda>(p1, p2, p3, p4, p5, p6, p7, p8, p9, p10). p4"
definition "P10_p5\<^sub>f \<equiv> \<lambda>(p1, p2, p3, p4, p5, p6, p7, p8, p9, p10). p5"
definition "P10_p6\<^sub>f \<equiv> \<lambda>(p1, p2, p3, p4, p5, p6, p7, p8, p9, p10). p6"
definition "P10_p7\<^sub>f \<equiv> \<lambda>(p1, p2, p3, p4, p5, p6, p7, p8, p9, p10). p7"
definition "P10_p8\<^sub>f \<equiv> \<lambda>(p1, p2, p3, p4, p5, p6, p7, p8, p9, p10). p8"
definition "P10_p9\<^sub>f \<equiv> \<lambda>(p1, p2, p3, p4, p5, p6, p7, p8, p9, p10). p9"
definition "P10_p10\<^sub>f \<equiv> \<lambda>(p1, p2, p3, p4, p5, p6, p7, p8, p9, p10). p10"

definition "P11_p1\<^sub>f \<equiv> \<lambda>(p1, p2, p3, p4, p5, p6, p7, p8, p9, p10, p11). p1"
definition "P11_p2\<^sub>f \<equiv> \<lambda>(p1, p2, p3, p4, p5, p6, p7, p8, p9, p10, p11). p2"
definition "P11_p3\<^sub>f \<equiv> \<lambda>(p1, p2, p3, p4, p5, p6, p7, p8, p9, p10, p11). p3"
definition "P11_p4\<^sub>f \<equiv> \<lambda>(p1, p2, p3, p4, p5, p6, p7, p8, p9, p10, p11). p4"
definition "P11_p5\<^sub>f \<equiv> \<lambda>(p1, p2, p3, p4, p5, p6, p7, p8, p9, p10, p11). p5"
definition "P11_p6\<^sub>f \<equiv> \<lambda>(p1, p2, p3, p4, p5, p6, p7, p8, p9, p10, p11). p6"
definition "P11_p7\<^sub>f \<equiv> \<lambda>(p1, p2, p3, p4, p5, p6, p7, p8, p9, p10, p11). p7"
definition "P11_p8\<^sub>f \<equiv> \<lambda>(p1, p2, p3, p4, p5, p6, p7, p8, p9, p10, p11). p8"
definition "P11_p9\<^sub>f \<equiv> \<lambda>(p1, p2, p3, p4, p5, p6, p7, p8, p9, p10, p11). p9"
definition "P11_p10\<^sub>f \<equiv> \<lambda>(p1, p2, p3, p4, p5, p6, p7, p8, p9, p10, p11). p10"
definition "P11_p11\<^sub>f \<equiv> \<lambda>(p1, p2, p3, p4, p5, p6, p7, p8, p9, p10, p11). p11"

definition "P12_p1\<^sub>f \<equiv> \<lambda>(p1, p2, p3, p4, p5, p6, p7, p8, p9, p10, p11, p12). p1"
definition "P12_p2\<^sub>f \<equiv> \<lambda>(p1, p2, p3, p4, p5, p6, p7, p8, p9, p10, p11, p12). p2"
definition "P12_p3\<^sub>f \<equiv> \<lambda>(p1, p2, p3, p4, p5, p6, p7, p8, p9, p10, p11, p12). p3"
definition "P12_p4\<^sub>f \<equiv> \<lambda>(p1, p2, p3, p4, p5, p6, p7, p8, p9, p10, p11, p12). p4"
definition "P12_p5\<^sub>f \<equiv> \<lambda>(p1, p2, p3, p4, p5, p6, p7, p8, p9, p10, p11, p12). p5"
definition "P12_p6\<^sub>f \<equiv> \<lambda>(p1, p2, p3, p4, p5, p6, p7, p8, p9, p10, p11, p12). p6"
definition "P12_p7\<^sub>f \<equiv> \<lambda>(p1, p2, p3, p4, p5, p6, p7, p8, p9, p10, p11, p12). p7"
definition "P12_p8\<^sub>f \<equiv> \<lambda>(p1, p2, p3, p4, p5, p6, p7, p8, p9, p10, p11, p12). p8"
definition "P12_p9\<^sub>f \<equiv> \<lambda>(p1, p2, p3, p4, p5, p6, p7, p8, p9, p10, p11, p12). p9"
definition "P12_p10\<^sub>f \<equiv> \<lambda>(p1, p2, p3, p4, p5, p6, p7, p8, p9, p10, p11, p12). p10"
definition "P12_p11\<^sub>f \<equiv> \<lambda>(p1, p2, p3, p4, p5, p6, p7, p8, p9, p10, p11, p12). p11"
definition "P12_p12\<^sub>f \<equiv> \<lambda>(p1, p2, p3, p4, p5, p6, p7, p8, p9, p10, p11, p12). p12"

definition "P13_p1\<^sub>f \<equiv> \<lambda>(p1, p2, p3, p4, p5, p6, p7, p8, p9, p10, p11, p12, p13). p1"
definition "P13_p2\<^sub>f \<equiv> \<lambda>(p1, p2, p3, p4, p5, p6, p7, p8, p9, p10, p11, p12, p13). p2"
definition "P13_p3\<^sub>f \<equiv> \<lambda>(p1, p2, p3, p4, p5, p6, p7, p8, p9, p10, p11, p12, p13). p3"
definition "P13_p4\<^sub>f \<equiv> \<lambda>(p1, p2, p3, p4, p5, p6, p7, p8, p9, p10, p11, p12, p13). p4"
definition "P13_p5\<^sub>f \<equiv> \<lambda>(p1, p2, p3, p4, p5, p6, p7, p8, p9, p10, p11, p12, p13). p5"
definition "P13_p6\<^sub>f \<equiv> \<lambda>(p1, p2, p3, p4, p5, p6, p7, p8, p9, p10, p11, p12, p13). p6"
definition "P13_p7\<^sub>f \<equiv> \<lambda>(p1, p2, p3, p4, p5, p6, p7, p8, p9, p10, p11, p12, p13). p7"
definition "P13_p8\<^sub>f \<equiv> \<lambda>(p1, p2, p3, p4, p5, p6, p7, p8, p9, p10, p11, p12, p13). p8"
definition "P13_p9\<^sub>f \<equiv> \<lambda>(p1, p2, p3, p4, p5, p6, p7, p8, p9, p10, p11, p12, p13). p9"
definition "P13_p10\<^sub>f \<equiv> \<lambda>(p1, p2, p3, p4, p5, p6, p7, p8, p9, p10, p11, p12, p13). p10"
definition "P13_p11\<^sub>f \<equiv> \<lambda>(p1, p2, p3, p4, p5, p6, p7, p8, p9, p10, p11, p12, p13). p11"
definition "P13_p12\<^sub>f \<equiv> \<lambda>(p1, p2, p3, p4, p5, p6, p7, p8, p9, p10, p11, p12, p13). p12"
definition "P13_p13\<^sub>f \<equiv> \<lambda>(p1, p2, p3, p4, p5, p6, p7, p8, p9, p10, p11, p12, p13). p13"

definition "P14_p1\<^sub>f \<equiv> \<lambda>(p1, p2, p3, p4, p5, p6, p7, p8, p9, p10, p11, p12, p13, p14). p1"
definition "P14_p2\<^sub>f \<equiv> \<lambda>(p1, p2, p3, p4, p5, p6, p7, p8, p9, p10, p11, p12, p13, p14). p2"
definition "P14_p3\<^sub>f \<equiv> \<lambda>(p1, p2, p3, p4, p5, p6, p7, p8, p9, p10, p11, p12, p13, p14). p3"
definition "P14_p4\<^sub>f \<equiv> \<lambda>(p1, p2, p3, p4, p5, p6, p7, p8, p9, p10, p11, p12, p13, p14). p4"
definition "P14_p5\<^sub>f \<equiv> \<lambda>(p1, p2, p3, p4, p5, p6, p7, p8, p9, p10, p11, p12, p13, p14). p5"
definition "P14_p6\<^sub>f \<equiv> \<lambda>(p1, p2, p3, p4, p5, p6, p7, p8, p9, p10, p11, p12, p13, p14). p6"
definition "P14_p7\<^sub>f \<equiv> \<lambda>(p1, p2, p3, p4, p5, p6, p7, p8, p9, p10, p11, p12, p13, p14). p7"
definition "P14_p8\<^sub>f \<equiv> \<lambda>(p1, p2, p3, p4, p5, p6, p7, p8, p9, p10, p11, p12, p13, p14). p8"
definition "P14_p9\<^sub>f \<equiv> \<lambda>(p1, p2, p3, p4, p5, p6, p7, p8, p9, p10, p11, p12, p13, p14). p9"
definition "P14_p10\<^sub>f \<equiv> \<lambda>(p1, p2, p3, p4, p5, p6, p7, p8, p9, p10, p11, p12, p13, p14). p10"
definition "P14_p11\<^sub>f \<equiv> \<lambda>(p1, p2, p3, p4, p5, p6, p7, p8, p9, p10, p11, p12, p13, p14). p11"
definition "P14_p12\<^sub>f \<equiv> \<lambda>(p1, p2, p3, p4, p5, p6, p7, p8, p9, p10, p11, p12, p13, p14). p12"
definition "P14_p13\<^sub>f \<equiv> \<lambda>(p1, p2, p3, p4, p5, p6, p7, p8, p9, p10, p11, p12, p13, p14). p13"
definition "P14_p14\<^sub>f \<equiv> \<lambda>(p1, p2, p3, p4, p5, p6, p7, p8, p9, p10, p11, p12, p13, p14). p14"

definition "P15_p1\<^sub>f \<equiv> \<lambda>(p1, p2, p3, p4, p5, p6, p7, p8, p9, p10, p11, p12, p13, p14, p15). p1"
definition "P15_p2\<^sub>f \<equiv> \<lambda>(p1, p2, p3, p4, p5, p6, p7, p8, p9, p10, p11, p12, p13, p14, p15). p2"
definition "P15_p3\<^sub>f \<equiv> \<lambda>(p1, p2, p3, p4, p5, p6, p7, p8, p9, p10, p11, p12, p13, p14, p15). p3"
definition "P15_p4\<^sub>f \<equiv> \<lambda>(p1, p2, p3, p4, p5, p6, p7, p8, p9, p10, p11, p12, p13, p14, p15). p4"
definition "P15_p5\<^sub>f \<equiv> \<lambda>(p1, p2, p3, p4, p5, p6, p7, p8, p9, p10, p11, p12, p13, p14, p15). p5"
definition "P15_p6\<^sub>f \<equiv> \<lambda>(p1, p2, p3, p4, p5, p6, p7, p8, p9, p10, p11, p12, p13, p14, p15). p6"
definition "P15_p7\<^sub>f \<equiv> \<lambda>(p1, p2, p3, p4, p5, p6, p7, p8, p9, p10, p11, p12, p13, p14, p15). p7"
definition "P15_p8\<^sub>f \<equiv> \<lambda>(p1, p2, p3, p4, p5, p6, p7, p8, p9, p10, p11, p12, p13, p14, p15). p8"
definition "P15_p9\<^sub>f \<equiv> \<lambda>(p1, p2, p3, p4, p5, p6, p7, p8, p9, p10, p11, p12, p13, p14, p15). p9"
definition "P15_p10\<^sub>f \<equiv> \<lambda>(p1, p2, p3, p4, p5, p6, p7, p8, p9, p10, p11, p12, p13, p14, p15). p10"
definition "P15_p11\<^sub>f \<equiv> \<lambda>(p1, p2, p3, p4, p5, p6, p7, p8, p9, p10, p11, p12, p13, p14, p15). p11"
definition "P15_p12\<^sub>f \<equiv> \<lambda>(p1, p2, p3, p4, p5, p6, p7, p8, p9, p10, p11, p12, p13, p14, p15). p12"
definition "P15_p13\<^sub>f \<equiv> \<lambda>(p1, p2, p3, p4, p5, p6, p7, p8, p9, p10, p11, p12, p13, p14, p15). p13"
definition "P15_p14\<^sub>f \<equiv> \<lambda>(p1, p2, p3, p4, p5, p6, p7, p8, p9, p10, p11, p12, p13, p14, p15). p14"
definition "P15_p15\<^sub>f \<equiv> \<lambda>(p1, p2, p3, p4, p5, p6, p7, p8, p9, p10, p11, p12, p13, p14, p15). p15"

(* for n in range(2, 15+1):
     print('lemmas P{}_px ='.format(n))
     for k in range(1, n+1):
       print('  P{}_p{}\\<^sub>f_def'.format(n, k))
     print('') *)
lemmas P2_px =
  P2_p1\<^sub>f_def
  P2_p2\<^sub>f_def

lemmas P3_px =
  P3_p1\<^sub>f_def
  P3_p2\<^sub>f_def
  P3_p3\<^sub>f_def

lemmas P4_px =
  P4_p1\<^sub>f_def
  P4_p2\<^sub>f_def
  P4_p3\<^sub>f_def
  P4_p4\<^sub>f_def

lemmas P5_px =
  P5_p1\<^sub>f_def
  P5_p2\<^sub>f_def
  P5_p3\<^sub>f_def
  P5_p4\<^sub>f_def
  P5_p5\<^sub>f_def

lemmas P6_px =
  P6_p1\<^sub>f_def
  P6_p2\<^sub>f_def
  P6_p3\<^sub>f_def
  P6_p4\<^sub>f_def
  P6_p5\<^sub>f_def
  P6_p6\<^sub>f_def

lemmas P7_px =
  P7_p1\<^sub>f_def
  P7_p2\<^sub>f_def
  P7_p3\<^sub>f_def
  P7_p4\<^sub>f_def
  P7_p5\<^sub>f_def
  P7_p6\<^sub>f_def
  P7_p7\<^sub>f_def

lemmas P8_px =
  P8_p1\<^sub>f_def
  P8_p2\<^sub>f_def
  P8_p3\<^sub>f_def
  P8_p4\<^sub>f_def
  P8_p5\<^sub>f_def
  P8_p6\<^sub>f_def
  P8_p7\<^sub>f_def
  P8_p8\<^sub>f_def

lemmas P9_px =
  P9_p1\<^sub>f_def
  P9_p2\<^sub>f_def
  P9_p3\<^sub>f_def
  P9_p4\<^sub>f_def
  P9_p5\<^sub>f_def
  P9_p6\<^sub>f_def
  P9_p7\<^sub>f_def
  P9_p8\<^sub>f_def
  P9_p9\<^sub>f_def

lemmas P10_px =
  P10_p1\<^sub>f_def
  P10_p2\<^sub>f_def
  P10_p3\<^sub>f_def
  P10_p4\<^sub>f_def
  P10_p5\<^sub>f_def
  P10_p6\<^sub>f_def
  P10_p7\<^sub>f_def
  P10_p8\<^sub>f_def
  P10_p9\<^sub>f_def
  P10_p10\<^sub>f_def

lemmas P11_px =
  P11_p1\<^sub>f_def
  P11_p2\<^sub>f_def
  P11_p3\<^sub>f_def
  P11_p4\<^sub>f_def
  P11_p5\<^sub>f_def
  P11_p6\<^sub>f_def
  P11_p7\<^sub>f_def
  P11_p8\<^sub>f_def
  P11_p9\<^sub>f_def
  P11_p10\<^sub>f_def
  P11_p11\<^sub>f_def

lemmas P12_px =
  P12_p1\<^sub>f_def
  P12_p2\<^sub>f_def
  P12_p3\<^sub>f_def
  P12_p4\<^sub>f_def
  P12_p5\<^sub>f_def
  P12_p6\<^sub>f_def
  P12_p7\<^sub>f_def
  P12_p8\<^sub>f_def
  P12_p9\<^sub>f_def
  P12_p10\<^sub>f_def
  P12_p11\<^sub>f_def
  P12_p12\<^sub>f_def

lemmas P13_px =
  P13_p1\<^sub>f_def
  P13_p2\<^sub>f_def
  P13_p3\<^sub>f_def
  P13_p4\<^sub>f_def
  P13_p5\<^sub>f_def
  P13_p6\<^sub>f_def
  P13_p7\<^sub>f_def
  P13_p8\<^sub>f_def
  P13_p9\<^sub>f_def
  P13_p10\<^sub>f_def
  P13_p11\<^sub>f_def
  P13_p12\<^sub>f_def
  P13_p13\<^sub>f_def

lemmas P14_px =
  P14_p1\<^sub>f_def
  P14_p2\<^sub>f_def
  P14_p3\<^sub>f_def
  P14_p4\<^sub>f_def
  P14_p5\<^sub>f_def
  P14_p6\<^sub>f_def
  P14_p7\<^sub>f_def
  P14_p8\<^sub>f_def
  P14_p9\<^sub>f_def
  P14_p10\<^sub>f_def
  P14_p11\<^sub>f_def
  P14_p12\<^sub>f_def
  P14_p13\<^sub>f_def
  P14_p14\<^sub>f_def

lemmas P15_px =
  P15_p1\<^sub>f_def
  P15_p2\<^sub>f_def
  P15_p3\<^sub>f_def
  P15_p4\<^sub>f_def
  P15_p5\<^sub>f_def
  P15_p6\<^sub>f_def
  P15_p7\<^sub>f_def
  P15_p8\<^sub>f_def
  P15_p9\<^sub>f_def
  P15_p10\<^sub>f_def
  P15_p11\<^sub>f_def
  P15_p12\<^sub>f_def
  P15_p13\<^sub>f_def
  P15_p14\<^sub>f_def
  P15_p15\<^sub>f_def

(* print('lemmas Px_px = ' + ' '.join('P{}_px'.format(n) for n in range(2, 15+1))) *)
lemmas Px_px = P2_px P3_px P4_px P5_px P6_px P7_px P8_px P9_px P10_px P11_px P12_px P13_px P14_px P15_px

(*
for n in range(2, 15+1):
  vars = ' '.join('x' + str(k) for k in range(1, n+1))
  print('  "(let ' +
        ';\n        '.join('(x{k}, r) = take\\<^sub>c\\<^sub>d\\<^sub>s\\<^sub>l {r} P{n}_p{k}\\<^sub>f'.
                           format(n=n, k=k, r='r' if k>1 else 'R'+str(n)) for k in range(1, n+1)) +
        '\n    in Q' + str(n) + ' ' + vars + ') =\n' +
        '   (let (' + ', '.join('x' + str(k) for k in range(1, n+1)) + ') = R' + str(n) + ' in Q' + str(n) + ' ' + vars + ')"')
*)
lemma tuple_simps:
  "(let (x1, r) = take\<^sub>c\<^sub>o\<^sub>g\<^sub>e\<^sub>n\<^sub>t R2 P2_p1\<^sub>f;
        (x2, r) = take\<^sub>c\<^sub>o\<^sub>g\<^sub>e\<^sub>n\<^sub>t r P2_p2\<^sub>f
    in Q2 x1 x2) =
   (let (x1, x2) = R2 in Q2 x1 x2)"
  "(let (x1, r) = take\<^sub>c\<^sub>o\<^sub>g\<^sub>e\<^sub>n\<^sub>t R3 P3_p1\<^sub>f;
        (x2, r) = take\<^sub>c\<^sub>o\<^sub>g\<^sub>e\<^sub>n\<^sub>t r P3_p2\<^sub>f;
        (x3, r) = take\<^sub>c\<^sub>o\<^sub>g\<^sub>e\<^sub>n\<^sub>t r P3_p3\<^sub>f
    in Q3 x1 x2 x3) =
   (let (x1, x2, x3) = R3 in Q3 x1 x2 x3)"
  "(let (x1, r) = take\<^sub>c\<^sub>o\<^sub>g\<^sub>e\<^sub>n\<^sub>t R4 P4_p1\<^sub>f;
        (x2, r) = take\<^sub>c\<^sub>o\<^sub>g\<^sub>e\<^sub>n\<^sub>t r P4_p2\<^sub>f;
        (x3, r) = take\<^sub>c\<^sub>o\<^sub>g\<^sub>e\<^sub>n\<^sub>t r P4_p3\<^sub>f;
        (x4, r) = take\<^sub>c\<^sub>o\<^sub>g\<^sub>e\<^sub>n\<^sub>t r P4_p4\<^sub>f
    in Q4 x1 x2 x3 x4) =
   (let (x1, x2, x3, x4) = R4 in Q4 x1 x2 x3 x4)"
  "(let (x1, r) = take\<^sub>c\<^sub>o\<^sub>g\<^sub>e\<^sub>n\<^sub>t R5 P5_p1\<^sub>f;
        (x2, r) = take\<^sub>c\<^sub>o\<^sub>g\<^sub>e\<^sub>n\<^sub>t r P5_p2\<^sub>f;
        (x3, r) = take\<^sub>c\<^sub>o\<^sub>g\<^sub>e\<^sub>n\<^sub>t r P5_p3\<^sub>f;
        (x4, r) = take\<^sub>c\<^sub>o\<^sub>g\<^sub>e\<^sub>n\<^sub>t r P5_p4\<^sub>f;
        (x5, r) = take\<^sub>c\<^sub>o\<^sub>g\<^sub>e\<^sub>n\<^sub>t r P5_p5\<^sub>f
    in Q5 x1 x2 x3 x4 x5) =
   (let (x1, x2, x3, x4, x5) = R5 in Q5 x1 x2 x3 x4 x5)"
  "(let (x1, r) = take\<^sub>c\<^sub>o\<^sub>g\<^sub>e\<^sub>n\<^sub>t R6 P6_p1\<^sub>f;
        (x2, r) = take\<^sub>c\<^sub>o\<^sub>g\<^sub>e\<^sub>n\<^sub>t r P6_p2\<^sub>f;
        (x3, r) = take\<^sub>c\<^sub>o\<^sub>g\<^sub>e\<^sub>n\<^sub>t r P6_p3\<^sub>f;
        (x4, r) = take\<^sub>c\<^sub>o\<^sub>g\<^sub>e\<^sub>n\<^sub>t r P6_p4\<^sub>f;
        (x5, r) = take\<^sub>c\<^sub>o\<^sub>g\<^sub>e\<^sub>n\<^sub>t r P6_p5\<^sub>f;
        (x6, r) = take\<^sub>c\<^sub>o\<^sub>g\<^sub>e\<^sub>n\<^sub>t r P6_p6\<^sub>f
    in Q6 x1 x2 x3 x4 x5 x6) =
   (let (x1, x2, x3, x4, x5, x6) = R6 in Q6 x1 x2 x3 x4 x5 x6)"
  "(let (x1, r) = take\<^sub>c\<^sub>o\<^sub>g\<^sub>e\<^sub>n\<^sub>t R7 P7_p1\<^sub>f;
        (x2, r) = take\<^sub>c\<^sub>o\<^sub>g\<^sub>e\<^sub>n\<^sub>t r P7_p2\<^sub>f;
        (x3, r) = take\<^sub>c\<^sub>o\<^sub>g\<^sub>e\<^sub>n\<^sub>t r P7_p3\<^sub>f;
        (x4, r) = take\<^sub>c\<^sub>o\<^sub>g\<^sub>e\<^sub>n\<^sub>t r P7_p4\<^sub>f;
        (x5, r) = take\<^sub>c\<^sub>o\<^sub>g\<^sub>e\<^sub>n\<^sub>t r P7_p5\<^sub>f;
        (x6, r) = take\<^sub>c\<^sub>o\<^sub>g\<^sub>e\<^sub>n\<^sub>t r P7_p6\<^sub>f;
        (x7, r) = take\<^sub>c\<^sub>o\<^sub>g\<^sub>e\<^sub>n\<^sub>t r P7_p7\<^sub>f
    in Q7 x1 x2 x3 x4 x5 x6 x7) =
   (let (x1, x2, x3, x4, x5, x6, x7) = R7 in Q7 x1 x2 x3 x4 x5 x6 x7)"
  "(let (x1, r) = take\<^sub>c\<^sub>o\<^sub>g\<^sub>e\<^sub>n\<^sub>t R8 P8_p1\<^sub>f;
        (x2, r) = take\<^sub>c\<^sub>o\<^sub>g\<^sub>e\<^sub>n\<^sub>t r P8_p2\<^sub>f;
        (x3, r) = take\<^sub>c\<^sub>o\<^sub>g\<^sub>e\<^sub>n\<^sub>t r P8_p3\<^sub>f;
        (x4, r) = take\<^sub>c\<^sub>o\<^sub>g\<^sub>e\<^sub>n\<^sub>t r P8_p4\<^sub>f;
        (x5, r) = take\<^sub>c\<^sub>o\<^sub>g\<^sub>e\<^sub>n\<^sub>t r P8_p5\<^sub>f;
        (x6, r) = take\<^sub>c\<^sub>o\<^sub>g\<^sub>e\<^sub>n\<^sub>t r P8_p6\<^sub>f;
        (x7, r) = take\<^sub>c\<^sub>o\<^sub>g\<^sub>e\<^sub>n\<^sub>t r P8_p7\<^sub>f;
        (x8, r) = take\<^sub>c\<^sub>o\<^sub>g\<^sub>e\<^sub>n\<^sub>t r P8_p8\<^sub>f
    in Q8 x1 x2 x3 x4 x5 x6 x7 x8) =
   (let (x1, x2, x3, x4, x5, x6, x7, x8) = R8 in Q8 x1 x2 x3 x4 x5 x6 x7 x8)"
  "(let (x1, r) = take\<^sub>c\<^sub>o\<^sub>g\<^sub>e\<^sub>n\<^sub>t R9 P9_p1\<^sub>f;
        (x2, r) = take\<^sub>c\<^sub>o\<^sub>g\<^sub>e\<^sub>n\<^sub>t r P9_p2\<^sub>f;
        (x3, r) = take\<^sub>c\<^sub>o\<^sub>g\<^sub>e\<^sub>n\<^sub>t r P9_p3\<^sub>f;
        (x4, r) = take\<^sub>c\<^sub>o\<^sub>g\<^sub>e\<^sub>n\<^sub>t r P9_p4\<^sub>f;
        (x5, r) = take\<^sub>c\<^sub>o\<^sub>g\<^sub>e\<^sub>n\<^sub>t r P9_p5\<^sub>f;
        (x6, r) = take\<^sub>c\<^sub>o\<^sub>g\<^sub>e\<^sub>n\<^sub>t r P9_p6\<^sub>f;
        (x7, r) = take\<^sub>c\<^sub>o\<^sub>g\<^sub>e\<^sub>n\<^sub>t r P9_p7\<^sub>f;
        (x8, r) = take\<^sub>c\<^sub>o\<^sub>g\<^sub>e\<^sub>n\<^sub>t r P9_p8\<^sub>f;
        (x9, r) = take\<^sub>c\<^sub>o\<^sub>g\<^sub>e\<^sub>n\<^sub>t r P9_p9\<^sub>f
    in Q9 x1 x2 x3 x4 x5 x6 x7 x8 x9) =
   (let (x1, x2, x3, x4, x5, x6, x7, x8, x9) = R9 in Q9 x1 x2 x3 x4 x5 x6 x7 x8 x9)"
  "(let (x1, r) = take\<^sub>c\<^sub>o\<^sub>g\<^sub>e\<^sub>n\<^sub>t R10 P10_p1\<^sub>f;
        (x2, r) = take\<^sub>c\<^sub>o\<^sub>g\<^sub>e\<^sub>n\<^sub>t r P10_p2\<^sub>f;
        (x3, r) = take\<^sub>c\<^sub>o\<^sub>g\<^sub>e\<^sub>n\<^sub>t r P10_p3\<^sub>f;
        (x4, r) = take\<^sub>c\<^sub>o\<^sub>g\<^sub>e\<^sub>n\<^sub>t r P10_p4\<^sub>f;
        (x5, r) = take\<^sub>c\<^sub>o\<^sub>g\<^sub>e\<^sub>n\<^sub>t r P10_p5\<^sub>f;
        (x6, r) = take\<^sub>c\<^sub>o\<^sub>g\<^sub>e\<^sub>n\<^sub>t r P10_p6\<^sub>f;
        (x7, r) = take\<^sub>c\<^sub>o\<^sub>g\<^sub>e\<^sub>n\<^sub>t r P10_p7\<^sub>f;
        (x8, r) = take\<^sub>c\<^sub>o\<^sub>g\<^sub>e\<^sub>n\<^sub>t r P10_p8\<^sub>f;
        (x9, r) = take\<^sub>c\<^sub>o\<^sub>g\<^sub>e\<^sub>n\<^sub>t r P10_p9\<^sub>f;
        (x10, r) = take\<^sub>c\<^sub>o\<^sub>g\<^sub>e\<^sub>n\<^sub>t r P10_p10\<^sub>f
    in Q10 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10) =
   (let (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10) = R10 in Q10 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10)"
  "(let (x1, r) = take\<^sub>c\<^sub>o\<^sub>g\<^sub>e\<^sub>n\<^sub>t R11 P11_p1\<^sub>f;
        (x2, r) = take\<^sub>c\<^sub>o\<^sub>g\<^sub>e\<^sub>n\<^sub>t r P11_p2\<^sub>f;
        (x3, r) = take\<^sub>c\<^sub>o\<^sub>g\<^sub>e\<^sub>n\<^sub>t r P11_p3\<^sub>f;
        (x4, r) = take\<^sub>c\<^sub>o\<^sub>g\<^sub>e\<^sub>n\<^sub>t r P11_p4\<^sub>f;
        (x5, r) = take\<^sub>c\<^sub>o\<^sub>g\<^sub>e\<^sub>n\<^sub>t r P11_p5\<^sub>f;
        (x6, r) = take\<^sub>c\<^sub>o\<^sub>g\<^sub>e\<^sub>n\<^sub>t r P11_p6\<^sub>f;
        (x7, r) = take\<^sub>c\<^sub>o\<^sub>g\<^sub>e\<^sub>n\<^sub>t r P11_p7\<^sub>f;
        (x8, r) = take\<^sub>c\<^sub>o\<^sub>g\<^sub>e\<^sub>n\<^sub>t r P11_p8\<^sub>f;
        (x9, r) = take\<^sub>c\<^sub>o\<^sub>g\<^sub>e\<^sub>n\<^sub>t r P11_p9\<^sub>f;
        (x10, r) = take\<^sub>c\<^sub>o\<^sub>g\<^sub>e\<^sub>n\<^sub>t r P11_p10\<^sub>f;
        (x11, r) = take\<^sub>c\<^sub>o\<^sub>g\<^sub>e\<^sub>n\<^sub>t r P11_p11\<^sub>f
    in Q11 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11) =
   (let (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11) = R11 in Q11 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11)"
  "(let (x1, r) = take\<^sub>c\<^sub>o\<^sub>g\<^sub>e\<^sub>n\<^sub>t R12 P12_p1\<^sub>f;
        (x2, r) = take\<^sub>c\<^sub>o\<^sub>g\<^sub>e\<^sub>n\<^sub>t r P12_p2\<^sub>f;
        (x3, r) = take\<^sub>c\<^sub>o\<^sub>g\<^sub>e\<^sub>n\<^sub>t r P12_p3\<^sub>f;
        (x4, r) = take\<^sub>c\<^sub>o\<^sub>g\<^sub>e\<^sub>n\<^sub>t r P12_p4\<^sub>f;
        (x5, r) = take\<^sub>c\<^sub>o\<^sub>g\<^sub>e\<^sub>n\<^sub>t r P12_p5\<^sub>f;
        (x6, r) = take\<^sub>c\<^sub>o\<^sub>g\<^sub>e\<^sub>n\<^sub>t r P12_p6\<^sub>f;
        (x7, r) = take\<^sub>c\<^sub>o\<^sub>g\<^sub>e\<^sub>n\<^sub>t r P12_p7\<^sub>f;
        (x8, r) = take\<^sub>c\<^sub>o\<^sub>g\<^sub>e\<^sub>n\<^sub>t r P12_p8\<^sub>f;
        (x9, r) = take\<^sub>c\<^sub>o\<^sub>g\<^sub>e\<^sub>n\<^sub>t r P12_p9\<^sub>f;
        (x10, r) = take\<^sub>c\<^sub>o\<^sub>g\<^sub>e\<^sub>n\<^sub>t r P12_p10\<^sub>f;
        (x11, r) = take\<^sub>c\<^sub>o\<^sub>g\<^sub>e\<^sub>n\<^sub>t r P12_p11\<^sub>f;
        (x12, r) = take\<^sub>c\<^sub>o\<^sub>g\<^sub>e\<^sub>n\<^sub>t r P12_p12\<^sub>f
    in Q12 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12) =
   (let (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12) = R12 in Q12 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12)"
  "(let (x1, r) = take\<^sub>c\<^sub>o\<^sub>g\<^sub>e\<^sub>n\<^sub>t R13 P13_p1\<^sub>f;
        (x2, r) = take\<^sub>c\<^sub>o\<^sub>g\<^sub>e\<^sub>n\<^sub>t r P13_p2\<^sub>f;
        (x3, r) = take\<^sub>c\<^sub>o\<^sub>g\<^sub>e\<^sub>n\<^sub>t r P13_p3\<^sub>f;
        (x4, r) = take\<^sub>c\<^sub>o\<^sub>g\<^sub>e\<^sub>n\<^sub>t r P13_p4\<^sub>f;
        (x5, r) = take\<^sub>c\<^sub>o\<^sub>g\<^sub>e\<^sub>n\<^sub>t r P13_p5\<^sub>f;
        (x6, r) = take\<^sub>c\<^sub>o\<^sub>g\<^sub>e\<^sub>n\<^sub>t r P13_p6\<^sub>f;
        (x7, r) = take\<^sub>c\<^sub>o\<^sub>g\<^sub>e\<^sub>n\<^sub>t r P13_p7\<^sub>f;
        (x8, r) = take\<^sub>c\<^sub>o\<^sub>g\<^sub>e\<^sub>n\<^sub>t r P13_p8\<^sub>f;
        (x9, r) = take\<^sub>c\<^sub>o\<^sub>g\<^sub>e\<^sub>n\<^sub>t r P13_p9\<^sub>f;
        (x10, r) = take\<^sub>c\<^sub>o\<^sub>g\<^sub>e\<^sub>n\<^sub>t r P13_p10\<^sub>f;
        (x11, r) = take\<^sub>c\<^sub>o\<^sub>g\<^sub>e\<^sub>n\<^sub>t r P13_p11\<^sub>f;
        (x12, r) = take\<^sub>c\<^sub>o\<^sub>g\<^sub>e\<^sub>n\<^sub>t r P13_p12\<^sub>f;
        (x13, r) = take\<^sub>c\<^sub>o\<^sub>g\<^sub>e\<^sub>n\<^sub>t r P13_p13\<^sub>f
    in Q13 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13) =
   (let (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13) = R13 in Q13 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13)"
  "(let (x1, r) = take\<^sub>c\<^sub>o\<^sub>g\<^sub>e\<^sub>n\<^sub>t R14 P14_p1\<^sub>f;
        (x2, r) = take\<^sub>c\<^sub>o\<^sub>g\<^sub>e\<^sub>n\<^sub>t r P14_p2\<^sub>f;
        (x3, r) = take\<^sub>c\<^sub>o\<^sub>g\<^sub>e\<^sub>n\<^sub>t r P14_p3\<^sub>f;
        (x4, r) = take\<^sub>c\<^sub>o\<^sub>g\<^sub>e\<^sub>n\<^sub>t r P14_p4\<^sub>f;
        (x5, r) = take\<^sub>c\<^sub>o\<^sub>g\<^sub>e\<^sub>n\<^sub>t r P14_p5\<^sub>f;
        (x6, r) = take\<^sub>c\<^sub>o\<^sub>g\<^sub>e\<^sub>n\<^sub>t r P14_p6\<^sub>f;
        (x7, r) = take\<^sub>c\<^sub>o\<^sub>g\<^sub>e\<^sub>n\<^sub>t r P14_p7\<^sub>f;
        (x8, r) = take\<^sub>c\<^sub>o\<^sub>g\<^sub>e\<^sub>n\<^sub>t r P14_p8\<^sub>f;
        (x9, r) = take\<^sub>c\<^sub>o\<^sub>g\<^sub>e\<^sub>n\<^sub>t r P14_p9\<^sub>f;
        (x10, r) = take\<^sub>c\<^sub>o\<^sub>g\<^sub>e\<^sub>n\<^sub>t r P14_p10\<^sub>f;
        (x11, r) = take\<^sub>c\<^sub>o\<^sub>g\<^sub>e\<^sub>n\<^sub>t r P14_p11\<^sub>f;
        (x12, r) = take\<^sub>c\<^sub>o\<^sub>g\<^sub>e\<^sub>n\<^sub>t r P14_p12\<^sub>f;
        (x13, r) = take\<^sub>c\<^sub>o\<^sub>g\<^sub>e\<^sub>n\<^sub>t r P14_p13\<^sub>f;
        (x14, r) = take\<^sub>c\<^sub>o\<^sub>g\<^sub>e\<^sub>n\<^sub>t r P14_p14\<^sub>f
    in Q14 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14) =
   (let (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14) = R14 in Q14 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14)"
  "(let (x1, r) = take\<^sub>c\<^sub>o\<^sub>g\<^sub>e\<^sub>n\<^sub>t R15 P15_p1\<^sub>f;
        (x2, r) = take\<^sub>c\<^sub>o\<^sub>g\<^sub>e\<^sub>n\<^sub>t r P15_p2\<^sub>f;
        (x3, r) = take\<^sub>c\<^sub>o\<^sub>g\<^sub>e\<^sub>n\<^sub>t r P15_p3\<^sub>f;
        (x4, r) = take\<^sub>c\<^sub>o\<^sub>g\<^sub>e\<^sub>n\<^sub>t r P15_p4\<^sub>f;
        (x5, r) = take\<^sub>c\<^sub>o\<^sub>g\<^sub>e\<^sub>n\<^sub>t r P15_p5\<^sub>f;
        (x6, r) = take\<^sub>c\<^sub>o\<^sub>g\<^sub>e\<^sub>n\<^sub>t r P15_p6\<^sub>f;
        (x7, r) = take\<^sub>c\<^sub>o\<^sub>g\<^sub>e\<^sub>n\<^sub>t r P15_p7\<^sub>f;
        (x8, r) = take\<^sub>c\<^sub>o\<^sub>g\<^sub>e\<^sub>n\<^sub>t r P15_p8\<^sub>f;
        (x9, r) = take\<^sub>c\<^sub>o\<^sub>g\<^sub>e\<^sub>n\<^sub>t r P15_p9\<^sub>f;
        (x10, r) = take\<^sub>c\<^sub>o\<^sub>g\<^sub>e\<^sub>n\<^sub>t r P15_p10\<^sub>f;
        (x11, r) = take\<^sub>c\<^sub>o\<^sub>g\<^sub>e\<^sub>n\<^sub>t r P15_p11\<^sub>f;
        (x12, r) = take\<^sub>c\<^sub>o\<^sub>g\<^sub>e\<^sub>n\<^sub>t r P15_p12\<^sub>f;
        (x13, r) = take\<^sub>c\<^sub>o\<^sub>g\<^sub>e\<^sub>n\<^sub>t r P15_p13\<^sub>f;
        (x14, r) = take\<^sub>c\<^sub>o\<^sub>g\<^sub>e\<^sub>n\<^sub>t r P15_p14\<^sub>f;
        (x15, r) = take\<^sub>c\<^sub>o\<^sub>g\<^sub>e\<^sub>n\<^sub>t r P15_p15\<^sub>f
    in Q15 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15) =
   (let (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15) = R15 in Q15 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15)"
  by (simp add: Let_def prod.case_eq_if take\<^sub>c\<^sub>o\<^sub>g\<^sub>e\<^sub>n\<^sub>t_def Px_px)+

end


chapter \<open>IMP with Arrays\<close>
theory IMPArrayHoareTotal
imports
  Main
  "~~/src/HOL/Library/Monad_Syntax"
  "~~/src/HOL/Eisbach/Eisbach"
  "~~/src/HOL/Library/Rewrite"
begin

ML_val \<open>
  open Splitter
\<close>

ML \<open>
  local
    val ctxt = @{context} |> Splitter.del_split @{thm if_split}
    val ctxt = ctxt
      delsimps @{thms fun_upd_apply}
      addsimps @{thms fun_upd_same fun_upd_other}
  in
    val IMP_basic_ss = Simplifier.simpset_of ctxt
  end
\<close>

setup \<open>
  let
    open Simplifier

    (* FIXME: Copied from Simplifier, as these things are not exposed to the user *)

    val simpN = "simp";
    val congN = "cong";
    val onlyN = "only";
    val no_asmN = "no_asm";
    val no_asm_useN = "no_asm_use";
    val no_asm_simpN = "no_asm_simp";
    val asm_lrN = "asm_lr";

    val simp_options =
     (Args.parens (Args.$$$ no_asmN) >> K simp_tac ||
      Args.parens (Args.$$$ no_asm_simpN) >> K asm_simp_tac ||
      Args.parens (Args.$$$ no_asm_useN) >> K full_simp_tac ||
      Args.parens (Args.$$$ asm_lrN) >> K asm_lr_simp_tac ||
      Scan.succeed asm_full_simp_tac);

    fun transform_context f (ctxt,ts) = ((),(Context.map_proof f ctxt,ts))

    fun simp_method more_mods meth =
      Scan.lift simp_options --| transform_context (put_simpset IMP_basic_ss) --|
        Method.sections (more_mods @ simp_modifiers') >>
        (fn tac => fn ctxt => METHOD (fn facts => meth ctxt tac facts));

    (** setup **)

    fun method_setup more_mods =
      Method.setup @{binding imp_basic_simp}
        (simp_method more_mods (fn ctxt => fn tac => fn facts =>
          HEADGOAL (Method.insert_tac ctxt facts THEN'
            (CHANGED_PROP oo tac) ctxt)))
        "simplification with basic simpset for IMP"
  in
    method_setup []
  end
\<close>

text \<open>
  Extension of IMP by generalized arrays and the common arithmetic and Boolean operations.

  In this language, each variable stores a map from integers to integers.

  Initially, all integers are mapped to zero.

  In an expression, and on the LHS of an assignment, only indexed variables are allowed.
  That is, all expressions compute with single integers.
  \<open> x[3] ::= y[0] + 5 \<close>

  The Clear operation resets the mapping of a variable to all zeroes.
  \<open>CLR x\<close>

  If the index is omitted, variables are indexed at zero.
  This allows to use the variables as if they held single values.
  \<open>x ::= y + 5\<close> is the same as \<open>x[0] ::= y[0] + 5\<close>

  Summarized:
    \<^item> Every variable is an array, but, by default, we only use index zero.
    \<^item> Arrays can be indexed by arbitrary integers (including negative ones),
      and dynamically grow as needed.
\<close>

section \<open>Miscellaneous\<close>
(* Required to "instantiate" existential without introducing new variable,
  which would not unify with already introduced schematic *)
lemma ex_eq_some: "(\<exists>x. P x) \<longleftrightarrow> P (SOME x. P x)"
  by (meson someI)

section \<open>Syntax\<close>

subsection \<open>Variables and Constants\<close>
type_synonym vname = string

type_synonym val = int

subsection \<open>Arithmetic Expressions\<close>
datatype aexp =
    N int            -- \<open>Constant\<close>
  | V vname aexp     -- \<open>Array at index \<open>x[i]\<close>\<close>
  | Binop "int \<Rightarrow> int \<Rightarrow> int" aexp aexp -- \<open>Binary operation\<close>

abbreviation "V0 x \<equiv> V (x) (N 0)" -- \<open>Abbreviation for \<open>x[0]\<close>\<close>

abbreviation "Plus \<equiv> Binop (op+)"
abbreviation "Minus \<equiv> Binop (op-)"
abbreviation "Times \<equiv> Binop (op*)"

text \<open>Warning, the following two also give defined results on division by zero!\<close>
value "a div (0::int)" value "a mod (0::int)"
abbreviation "Div \<equiv> Binop (op div)"
abbreviation "Mod \<equiv> Binop (op mod)"

subsection \<open>Boolean Expressions\<close>
datatype bexp =
    Bc bool    -- \<open>True or False\<close>
  | Not bexp   -- \<open>Negation\<close>
  | BBop "bool\<Rightarrow>bool\<Rightarrow>bool" bexp bexp   -- \<open>Binary boolean operation\<close>
  | Cmpop "int \<Rightarrow> int \<Rightarrow> bool" aexp aexp -- \<open>Comparison operation\<close>

abbreviation "And \<equiv> BBop op \<and>"
abbreviation "Or \<equiv> BBop op \<or>"
abbreviation "BNEq \<equiv> BBop op \<noteq>"
abbreviation "BEq \<equiv> BBop op \<longleftrightarrow>"

abbreviation "Less \<equiv> Cmpop op <"
abbreviation "Leq \<equiv> Cmpop op \<le>"
abbreviation "Greater \<equiv> Cmpop op >"
abbreviation "Geq \<equiv> Cmpop op \<ge>"
abbreviation "Equal \<equiv> Cmpop op ="
abbreviation "NEqual \<equiv> Cmpop op \<noteq>"

subsection \<open>Commands\<close>

datatype
  com = SKIP
      | Assign vname aexp aexp  -- \<open> Assignment to index of array. \<open>x[i] = a\<close>\<close>
      | Clear  vname            -- \<open> Set all indices of array to 0\<close>
      | Seq    com  com         -- \<open> Sequential composition \<open>c\<^sub>1; c\<^sub>2\<close>\<close>
      | If     bexp com com     -- \<open> Conditional. \<open>if (b) c\<^sub>1 else c\<^sub>2\<close>\<close>
      | While  bexp com         -- \<open> While loop. \<open>while (b) c\<close>\<close>

subsection \<open>Concrete Syntax\<close>

text \<open>Like the original IMP, we only expose a minimal syntax for commands by default\<close>

notation
  Assign  ("_[_] ::= _" [1000,900, 41] 41) and
  Clear   ("CLR _" [41] 41) and
  Seq     ("_;;/ _"  [40, 41] 40) and
  If      ("(IF _/ THEN _/ ELSE _)"  [0, 0, 41] 41) and
  While   ("(WHILE _/ DO _)"  [0, 41] 41)

text \<open>Shortcut notation for assigning to index 0. \<close>
abbreviation Assign0 ("_ ::= _" [1000, 41] 41)
  where "x ::= v \<equiv> (x[N 0] ::= v)"

abbreviation true where "true \<equiv> Bc True"
abbreviation false where "false \<equiv> Bc False"

text \<open>
  However, we provide a bundle with somewhat more fancy syntax.
\<close>

abbreviation (input) "IMP_Variable \<equiv> V0"
syntax "_IMPVariable" :: "id \<Rightarrow> aexp"
translations "CONST IMP_Variable" \<rightharpoonup> "_IMPVariable"

abbreviation (input) "IMP_VariableI \<equiv> V"
syntax "_IMPVariableI" :: "id \<Rightarrow> aexp \<Rightarrow> aexp"
translations "CONST IMP_VariableI" \<rightharpoonup> "_IMPVariableI"

abbreviation (input) "IMP_Assign x v \<equiv> Assign x (N 0) v"
syntax "_IMPAssign" :: "id \<Rightarrow> aexp \<Rightarrow> com"
translations "CONST IMP_Assign" \<rightharpoonup> "_IMPAssign"

abbreviation (input) "IMP_AssignI x i v \<equiv> Assign x i v"
syntax "_IMPAssignI" :: "id \<Rightarrow> aexp \<Rightarrow> aexp \<Rightarrow> com"
translations "CONST IMP_AssignI" \<rightharpoonup> "_IMPAssignI"

abbreviation (input) "IMP_Clear x \<equiv> Clear x"
syntax "_IMPClear" :: "id \<Rightarrow> com"
translations "CONST IMP_Clear" \<rightharpoonup> "_IMPClear"

ML \<open>
  structure IMP_Translation = struct

    val cfg_var_syntax = Attrib.setup_config_bool @{binding IMP_var_syntax} (K false)

    fun
      var_tr ctxt [(c as Const (@{syntax_const "_constrain"}, _)) $ t $ u] =
        c $ var_tr ctxt [t] $ u
    | var_tr _ [Free (str,_)] = Syntax.const (@{const_syntax V0}) $ HOLogic.mk_string str
    | var_tr _ ts = raise (TERM ("IMP_Variable",ts))

    fun
      vari_tr ctxt [(c as Const (@{syntax_const "_constrain"}, _)) $ t $ u, it] =
        c $ vari_tr ctxt [t,it] $ u
    | vari_tr _ [Free (str,_),it] = Syntax.const (@{const_syntax V}) $ HOLogic.mk_string str $ it
    | vari_tr _ ts = raise (TERM ("IMP_VariableI",ts))

    fun
      ass_tr ctxt [(c as Const (@{syntax_const "_constrain"}, _)) $ t $ u, rhst] =
        c $ ass_tr ctxt [t,rhst] $ u
    | ass_tr _ [Free (str,_),rhst] = Syntax.const (@{const_syntax Assign0}) $ HOLogic.mk_string str $ rhst
    | ass_tr _ ts = raise (TERM ("IMP_AssignI",ts))

    fun
      assi_tr ctxt [(c as Const (@{syntax_const "_constrain"}, _)) $ t $ u, it, rhst] =
        c $ assi_tr ctxt [t,it,rhst] $ u
    | assi_tr _ [Free (str,_),it,rhst] = Syntax.const (@{const_syntax Assign}) $ HOLogic.mk_string str $ it $ rhst
    | assi_tr _ ts = raise (TERM ("IMP_Assign",ts))

    fun
      clr_tr ctxt [(c as Const (@{syntax_const "_constrain"}, _)) $ t $ u] =
        c $ clr_tr ctxt [t] $ u
    | clr_tr _ [Free (str,_)] = Syntax.const (@{const_syntax Clear}) $ HOLogic.mk_string str
    | clr_tr _ ts = raise (TERM ("IMP_Clear",ts))

    fun
      dest_list_syntax (Const (@{const_syntax List.Cons},_)$x$xs)
        = x::dest_list_syntax xs
    | dest_list_syntax (Const (@{const_syntax List.Nil},_)) = []
    | dest_list_syntax _ = raise Match

    fun
      dest_char_syntax (Const (@{const_syntax String.Char}, _) $ c) =
        let
          val n = Numeral.dest_num_syntax c
          val s = chr n
        in
          s
        end
    | dest_char_syntax _ = raise Match

    fun dest_var_syntax t = let
      val s =
          dest_list_syntax t
        |> map dest_char_syntax
        |> implode
      val _ = Symbol.is_ascii_identifier s orelse raise Match
    in
      s
    end

    fun
      var_tr' _ [t:term] =
        Syntax.const @{const_syntax "IMP_Variable"} $ Syntax.const (dest_var_syntax t)
    | var_tr' _ [t:term,it] =
        Syntax.const @{const_syntax "IMP_VariableI"} $ Syntax.const (dest_var_syntax t) $ it
    | var_tr' _ _ = raise Match

    fun
      ass_tr' _ [t:term,vt] =
        Syntax.const @{const_syntax "IMP_Assign"} $ Syntax.const (dest_var_syntax t) $ vt
    | ass_tr' _ [t:term,it,vt] =
        Syntax.const @{const_syntax "IMP_AssignI"} $ Syntax.const (dest_var_syntax t) $ it $ vt
    | ass_tr' _ _ = raise Match

    fun
      clr_tr' _ [t:term] =
        Syntax.const @{const_syntax "IMP_Clear"} $ Syntax.const (dest_var_syntax t)
    | clr_tr' _ _ = raise Match

    fun if_var_syntax f ctxt =
      if Config.get ctxt cfg_var_syntax then
        f ctxt
      else
        raise Match

    val _ = Theory.setup (
      Sign.print_translation [
        (@{const_syntax "V0"}, if_var_syntax var_tr'),
        (@{const_syntax "V"}, if_var_syntax var_tr'),
        (@{const_syntax "Assign0"}, if_var_syntax ass_tr'),
        (@{const_syntax "Assign"}, if_var_syntax ass_tr'),
        (@{const_syntax "Clear"}, if_var_syntax clr_tr')
      ]
    )
    val _ = Theory.setup (
      Sign.parse_translation [
        (@{syntax_const "_IMPVariable"}, if_var_syntax var_tr),
        (@{syntax_const "_IMPVariableI"}, if_var_syntax vari_tr),
        (@{syntax_const "_IMPAssign"}, if_var_syntax ass_tr),
        (@{syntax_const "_IMPAssignI"}, if_var_syntax assi_tr),
        (@{syntax_const "_IMPClear"}, if_var_syntax clr_tr)
      ]
    )

  end
\<close>

consts
  eplus :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"
  eminus :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"
  etimes :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"
  edivide :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"
  emodulo :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"
  eequal :: "'a \<Rightarrow> 'a \<Rightarrow> 'b"
  neequal :: "'a \<Rightarrow> 'a \<Rightarrow> 'b"
  eless :: "'a \<Rightarrow> 'a \<Rightarrow> 'b"
  egreater :: "'a \<Rightarrow> 'a \<Rightarrow> 'b"

bundle IMP_Syntax begin

notation IMP_Variable ("$_" [100] 100)
notation IMP_VariableI ("_\<^bold>[_\<^bold>]" [100,100] 100)

no_notation
  Assign0 ("_ ::= _" [1000, 41] 41) and
  Assign  ("_[_] ::= _" [1000,900, 41] 41) and
  Clear   ("CLR _" [41] 41)

notation
  IMP_Assign ("_ ::= _" [1000, 41] 41) and
  IMP_AssignI  ("_\<^bold>[_\<^bold>] ::= _" [1000,0, 41] 41) and
  IMP_Clear   ("CLR _" [41] 41)

declare [[IMP_var_syntax]]

notation N ("\<acute>_" [105] 105)

no_notation
  plus  (infixl "+" 65) and
  minus (infixl "-" 65) and
  times (infixl "*" 70) and
  divide (infixl "div" 70) and
  modulo (infixl "mod" 70)

notation
  eplus   (infixl "+" 65)   and
  eminus  (infixl "-" 65)   and
  etimes  (infixl "*" 70)   and
  edivide (infixl "div" 70) and
  emodulo (infixl "mod" 70)

adhoc_overloading eplus plus Plus
adhoc_overloading eminus minus Minus
adhoc_overloading etimes times Times
adhoc_overloading edivide divide Div
adhoc_overloading emodulo modulo Mod

notation Or (infixr "||" 30)
notation And (infixr "&&" 35)
notation Not ("!_" [90] 90)

no_notation "Pure.eq" (infix "==" 2)

notation
  eequal  (infix "==" 50) and
  neequal (infix "!=" 50)

adhoc_overloading eequal BEq Equal
adhoc_overloading neequal BNEq NEqual

no_notation
  less ("(_/ < _)"  [51, 51] 50) and
  greater  (infix ">" 50) and
  less_eq  ("(_/ <= _)" [51, 51] 50) and
  greater_eq  (infix ">=" 50)

notation
  eless ("(_/ < _)"  [51, 51] 50) and
  egreater (infix ">" 50)

adhoc_overloading eless less Less
adhoc_overloading egreater greater Greater

notation
  Leq  ("(_/ <= _)" [51, 51] 50) and
  Geq  (infix ">=" 50)

end

subsection \<open>Syntax Overview\<close>

text \<open>Activate the Syntax locally in a context\<close>
context
  includes IMP_Syntax
begin

  subsubsection \<open>Arithmetic expressions\<close>

  text \<open>Idiosyncrasies:
    \<^item> For array indexing, we use bold brackets \<open>\<^bold>[ \<^bold>]\<close>. Type \<open>\ bold [\<close> and \<open>\ bold ]\<close>
    \<^item> Prefixing a variable with \<open>$\<close> refers to index 0 of this variable.
      This way, variables, which hold maps, can conveniently be used as single values.
  \<close>

  term "$foo"       term "V0 ''foo''"
  term "bar\<^bold>[\<acute>3\<^bold>]"   term "V ''bar'' (N 3)" -- \<open>Type "\ bold [" and "\ bold ]" \<close>

  term "$a + $b"        term "Plus (V0 ''a'') (V0 ''b'')"
  term "$a + $b * $c"   term "Plus (V0 ''a'') (Times (V0 ''b'') (V0 ''c''))"
  term "($a + $b) * $c" term "Times (Plus (V0 ''a'') (V0 ''b'')) (V0 ''c'')"

  term "a\<^bold>[$i\<^bold>] + $b - $c*$d div $e mod $f"

  text \<open>Boolean Expressions\<close>
  text \<open>Idiosyncrasies:
    \<^item> Not \<open>!\<close> binds with high priority, higher than any other operator
  \<close>

  term "$a < $b"
  term "$a > $b"
  term "$a <= $b"
  term "$a >= $b"
  term "$x == $y"
  term "$x != $y"

  term "true && false"
  term "true || false"
  term "true != false"
  term "true == true"

  term "(!true == false)  = ( (!true) == false )"
  term "!(true == false)"

  text \<open>Commands\<close>
  text \<open>Idiosyncrasies:
    \<^item> Using \<open>::=\<close> for assignment, and, again, bold brackets for array indexing
  \<close>

  term "CLR x"                term "Clear ''x''"
  term "x ::= $a + \<acute>1"       term "Assign0 ''x'' (Plus (V0 ''a'') (N 1))"
  term "x\<^bold>[$i\<^bold>] ::= $a + \<acute>1"   term "Assign ''x'' (V0 ''i'') (Plus (V0 ''a'') (N 1))"

  term "x ::= $a;; y ::= $b"
  term "IF $x<\<acute>5 THEN SKIP ELSE x::=$x - \<acute>1"
  term "WHILE $x<\<acute>5 DO x::=$x + \<acute>1"

end

subsection \<open>Example Program\<close>
locale Imp_Array_Examples begin
unbundle IMP_Syntax
abbreviation "array_sum \<equiv>
  CLR r;;             (* It's good practice to clear auxiliary variables before use *)
  r ::= N 0;;         (* Not strictly necessary, but documents that r is used as plain variable  *)
  WHILE $l < $h DO (
    r ::= $r + a\<^bold>[$l\<^bold>];;
    l ::= $l + (\<acute>1)
  )"

term array_sum

end

section \<open>Semantics\<close>

subsection \<open>States and Configuration\<close>
text \<open>
  Each variable holds an unlimited amount of values, indexed by integers
\<close>
type_synonym state = "vname \<Rightarrow> (int \<Rightarrow> val)"
type_synonym config = "com \<times> state"

text {* A little syntax magic to write larger states compactly: *}

(* All variables hold zeroes initially.
*)
definition null_state ("<>") where
  "null_state \<equiv> \<lambda>_ _. 0"
syntax
  "_State" :: "updbinds => 'a" ("<_>")
translations
  "_State ms" == "_Update <> ms"
  "_State (_updbinds b bs)" <= "_Update (_State b) bs"

lemma null_state_app[simp]: "<> x = (\<lambda>_. 0)" by (auto simp: null_state_def)

text \<open>Constructing a generalized array from a list\<close>
definition vlist :: "int list \<Rightarrow> int \<Rightarrow> int" where
  "vlist l i \<equiv> if 0\<le>i \<and> nat i<length l then l!nat i else 0"

text \<open>Plain variable: Value at index 0 only\<close>
abbreviation "var x \<equiv> vlist [x]"

lemma list_nth[simp]: "\<lbrakk>0\<le>i; nat i<length l\<rbrakk> \<Longrightarrow> vlist l i = l!nat i"
  by (auto simp: vlist_def)

lemma list_subst[simp]: "\<lbrakk> 0\<le>i; nat i<length l \<rbrakk> \<Longrightarrow> (vlist l)(i:=x) = vlist (l[nat i:=x])"
  by (auto simp: vlist_def intro!: ext)

lemma list_fold[simp]: "(\<lambda>_. 0)(0:=x) = var x"
  by (auto simp: vlist_def intro!: ext)

lemma list_inj[simp]: "length l = length l' \<Longrightarrow> vlist l = vlist l' \<longleftrightarrow> l=l'"
  apply (auto simp: vlist_def[abs_def] split: if_splits)
  by (metis (mono_tags, hide_lams) nat_int nth_equalityI of_nat_0_le_iff)

subsection \<open>Arithmetic Expressions\<close>

fun aval :: "aexp \<Rightarrow> state \<Rightarrow> val" where
"aval (N n) s = n" |
"aval (V x i) s = (s x) (aval i s)" |
"aval (Binop f a1 a2) s = f (aval a1 s) (aval a2 s)"

subsection \<open>Boolean Expressions\<close>

fun bval :: "bexp \<Rightarrow> state \<Rightarrow> bool" where
"bval (Bc v) s \<longleftrightarrow> v" |
"bval (Not b) s \<longleftrightarrow> \<not>(bval b s)" |
"bval (BBop f b1 b2) s \<longleftrightarrow> f (bval b1 s) (bval b2 s)" |
"bval (Cmpop f a1 a2) s \<longleftrightarrow> f (aval a1 s) (aval a2 s)"

subsection \<open>Big-Step\<close>

inductive
  big_step :: "com \<times> state \<Rightarrow> state \<Rightarrow> bool" (infix "\<Rightarrow>" 55)
where
Skip: "(SKIP,s) \<Rightarrow> s" |
Assign: "(x[i] ::= a,s) \<Rightarrow> s(x := ((s x)(aval i s := aval a s)))" |
Clear: "(CLR x, s) \<Rightarrow> s(x:=(\<lambda>_. 0))" |
Seq: "\<lbrakk> (c\<^sub>1,s\<^sub>1) \<Rightarrow> s\<^sub>2;  (c\<^sub>2,s\<^sub>2) \<Rightarrow> s\<^sub>3 \<rbrakk> \<Longrightarrow> (c\<^sub>1;;c\<^sub>2, s\<^sub>1) \<Rightarrow> s\<^sub>3" |
IfTrue: "\<lbrakk> bval b s; (c\<^sub>1,s) \<Rightarrow> t \<rbrakk> \<Longrightarrow> (IF b THEN c\<^sub>1 ELSE c\<^sub>2, s) \<Rightarrow> t" |
IfFalse: "\<lbrakk> \<not>bval b s;  (c\<^sub>2,s) \<Rightarrow> t \<rbrakk> \<Longrightarrow> (IF b THEN c\<^sub>1 ELSE c\<^sub>2, s) \<Rightarrow> t" |
WhileFalse: "\<not>bval b s \<Longrightarrow> (WHILE b DO c,s) \<Rightarrow> s" |
WhileTrue:
"\<lbrakk> bval b s\<^sub>1;  (c,s\<^sub>1) \<Rightarrow> s\<^sub>2;  (WHILE b DO c, s\<^sub>2) \<Rightarrow> s\<^sub>3 \<rbrakk>
\<Longrightarrow> (WHILE b DO c, s\<^sub>1) \<Rightarrow> s\<^sub>3"

subsubsection \<open>Automatic Derivation\<close>
text \<open>The following is a method to execute a configuration by deriving it's big-step semantics\<close>
method Bs_simp = simp add: vlist_def
method If = (rule IfTrue, (Bs_simp;fail)) | (rule IfFalse, (Bs_simp;fail))
method While = (rule WhileTrue, (Bs_simp;fail)) | (rule WhileFalse, (Bs_simp;fail))
method BigStep = simp?; ((rule Skip Assign Seq Clear) | If | While)
method BigSteps = BigStep+

context Imp_Array_Examples begin
  schematic_goal "(array_sum,<''l'':=vlist [1], ''h'':=vlist [5], ''a'':=vlist [100,1,2,3,4,200,300]>) \<Rightarrow> ?s"
    by BigSteps

end

subsubsection \<open>Proof Automation Setup\<close>
declare big_step.intros [intro]

lemmas big_step_induct = big_step.induct[split_format(complete)]

inductive_cases SkipE[elim!]: "(SKIP,s) \<Rightarrow> t"

inductive_cases AssignE[elim!]: "(x[i] ::= a,s) \<Rightarrow> t"
thm AssignE
inductive_cases ClearE[elim!]: "(CLR x,s) \<Rightarrow> t"
thm ClearE
inductive_cases SeqE[elim!]: "(c1;;c2,s1) \<Rightarrow> s3"
thm SeqE
inductive_cases IfE[elim!]: "(IF b THEN c1 ELSE c2,s) \<Rightarrow> t"
thm IfE
inductive_cases WhileE[elim]: "(WHILE b DO c,s) \<Rightarrow> t"
thm WhileE

subsubsection \<open>Properties\<close>

text \<open>Sequential composition is associative\<close>
lemma Seq_assoc:
  "(c1;; c2;; c3, s) \<Rightarrow> s' \<longleftrightarrow> (c1;; (c2;; c3), s) \<Rightarrow> s'"
proof
  assume "(c1;; c2;; c3, s) \<Rightarrow> s'"
  then obtain s1 s2 where
    c1: "(c1, s) \<Rightarrow> s1" and
    c2: "(c2, s1) \<Rightarrow> s2" and
    c3: "(c3, s2) \<Rightarrow> s'" by auto
  from c2 c3
  have "(c2;; c3, s1) \<Rightarrow> s'" by (rule Seq)
  with c1
  show "(c1;; (c2;; c3), s) \<Rightarrow> s'" by (rule Seq)
next
  -- "The other direction is analogous"
  assume "(c1;; (c2;; c3), s) \<Rightarrow> s'"
  thus "(c1;; c2;; c3, s) \<Rightarrow> s'" by auto
qed

text \<open>The big-step semantics is deterministic\<close>
theorem big_step_determ: "\<lbrakk> (c,s) \<Rightarrow> t; (c,s) \<Rightarrow> u \<rbrakk> \<Longrightarrow> u = t"
proof (induction arbitrary: u rule: big_step.induct)
  case (Skip s)
  then show ?case by auto
next
  case (Assign x i a s u)
  then show ?case by auto
next
  case (Clear x s)
  then show ?case by auto
next
  case (Seq c\<^sub>1 s\<^sub>1 s\<^sub>2 c\<^sub>2 s\<^sub>3)
  then show ?case by blast
next
  case (IfTrue b s c\<^sub>1 t c\<^sub>2)
  from IfTrue.prems IfTrue.hyps(1) IfTrue.IH
  show ?case by auto
next
  case (IfFalse b s c\<^sub>2 t c\<^sub>1)
  from IfFalse.prems IfFalse.hyps(1) IfFalse.IH
  show ?case by auto
next
  case (WhileFalse b s c)
  then show ?case by auto
next
  case (WhileTrue b s\<^sub>1 c s\<^sub>2 s\<^sub>3) then show ?case by blast
qed

subsection \<open>Small-Step\<close>

fun small_step :: "com * state \<Rightarrow> com * state" where
  "small_step (SKIP;;c\<^sub>2,s) = (c\<^sub>2,s)"
| "small_step (x[i] ::= a, s) = (SKIP, s(x := ((s x)(aval i s := aval a s))))"
| "small_step (CLR x, s) = (SKIP, s(x:=(\<lambda>_. 0)))"
| "small_step (c\<^sub>1;;c\<^sub>2,s) = (let (c\<^sub>1',s) = small_step (c\<^sub>1,s) in (c\<^sub>1';;c\<^sub>2,s))"
| "small_step (IF b THEN c1 ELSE c2, s) = (if bval b s then (c1, s) else (c2, s))"
| "small_step (WHILE b DO c,s) = (IF b THEN c;; WHILE b DO c ELSE SKIP,s)"
| "small_step (SKIP,s) = undefined"

abbreviation is_small_step (infix "\<rightarrow>" 55)
  where "is_small_step cs cs' \<equiv> fst cs \<noteq> SKIP \<and> small_step cs = cs'"

abbreviation
  small_steps :: "com * state \<Rightarrow> com * state \<Rightarrow> bool" (infix "\<rightarrow>*" 55)
  where "x \<rightarrow>* y == (op \<rightarrow>)\<^sup>*\<^sup>* x y"

subsubsection{* Proof infrastructure *}

text{* The default induction rule @{thm[source] small_step.induct} only works
for lemmas of the form @{text"a \<rightarrow> b \<Longrightarrow> \<dots>"} where @{text a} and @{text b} are
not already pairs @{text"(DUMMY,DUMMY)"}. We can generate a suitable variant
of @{thm[source] small_step.induct} for pairs by ``splitting'' the arguments
@{text"\<rightarrow>"} into pairs: *}
lemmas small_step_induct = small_step.induct[split_format(complete)]

subsubsection "Equivalence with big-step semantics"

lemma ss_seq2: "(c,s) \<rightarrow> (c',s') \<Longrightarrow> (c;;cx,s) \<rightarrow> (c';;cx,s')"
  by (induction c s arbitrary: c' s' rule: small_step_induct) auto

lemma star_seq2: "(c1,s) \<rightarrow>* (c1',s') \<Longrightarrow> (c1;;c2,s) \<rightarrow>* (c1';;c2,s')"
  apply (induction rule: converse_rtranclp_induct2)
  apply (auto simp: ss_seq2 converse_rtranclp_into_rtranclp)
  done

lemma seq_comp:
  "\<lbrakk> (c1,s1) \<rightarrow>* (SKIP,s2); (c2,s2) \<rightarrow>* (SKIP,s3) \<rbrakk>
   \<Longrightarrow> (c1;;c2, s1) \<rightarrow>* (SKIP,s3)"
proof -
  assume a1: "(c2, s2) \<rightarrow>* (SKIP, s3)"
  assume a2: "(c1, s1) \<rightarrow>* (SKIP, s2)"
  have "(SKIP;; c2, s2) \<rightarrow>* (SKIP, s3)"
    using a1 by (simp add: converse_rtranclp_into_rtranclp)
  then have "\<And>p. p \<rightarrow>* (SKIP, s3) \<or> \<not> p \<rightarrow>* (SKIP;; c2, s2)"
    by (metis (lifting) rtranclp.rtrancl_into_rtrancl rtranclp_idemp)
  then show ?thesis
    using a2 star_seq2 by blast
qed

lemma big_to_small:
  "cs \<Rightarrow> t \<Longrightarrow> cs \<rightarrow>* (SKIP,t)"
proof (induction rule: big_step.induct)
  case Skip show ?case by blast
next
  case Assign then show ?case
    by (auto intro!: r_into_rtranclp ext)
next
  case Clear then show ?case
    by (auto intro!: r_into_rtranclp ext)
next
  case Seq thus ?case by (blast intro: seq_comp)
next
  case IfTrue thus ?case
    by (auto intro: converse_rtranclp_into_rtranclp)
next
  case IfFalse thus ?case
    by (auto intro: converse_rtranclp_into_rtranclp)
next
  case WhileFalse thus ?case
    by (fastforce intro: converse_rtranclp_into_rtranclp)

next
  case WhileTrue
  thus ?case
    apply (rule_tac converse_rtranclp_into_rtranclp)
    apply simp
    apply (rule_tac converse_rtranclp_into_rtranclp)
    apply simp
    by (simp add: seq_comp)

qed

lemma small1_big_continue:
  "cs \<rightarrow> cs' \<Longrightarrow> cs' \<Rightarrow> t \<Longrightarrow> cs \<Rightarrow> t"
apply (induction arbitrary: cs' t rule: small_step.induct)
apply (auto split: prod.splits if_splits)
done

lemma small_to_big:
  "cs \<rightarrow>* (SKIP,t) \<Longrightarrow> cs \<Rightarrow> t"
apply (induction rule: converse_rtranclp_induct)
apply (auto intro: small1_big_continue)
done

text {*
  Finally, the equivalence theorem:
*}
theorem big_iff_small:
  "cs \<Rightarrow> t \<longleftrightarrow> cs \<rightarrow>* (SKIP,t)"
  using small_to_big big_to_small by blast

subsection \<open>Termination\<close>
definition "final cs \<equiv> \<nexists>cs'. cs\<rightarrow>cs'"

lemma SKIP_final[simp]: "final (c,s) \<longleftrightarrow> c=SKIP"
  by (auto simp: final_def)

section \<open>Hoare-Logic for Partial Correctness\<close>

type_synonym assn = "state \<Rightarrow> bool"

definition
hoare_valid :: "assn \<Rightarrow> com \<Rightarrow> (assn) \<Rightarrow> bool" ("\<Turnstile> {(1_)}/ (_)/ {(1_)}" 50) where
"\<Turnstile> {P}c{Q} = (\<forall>s t. P s \<and> (c,s) \<Rightarrow> t \<longrightarrow> Q t)"

context
  notes [simp] = hoare_valid_def
begin
  lemma hoare_validI:
    assumes "\<And>s t. \<lbrakk> P s; (c,s) \<Rightarrow> t \<rbrakk> \<Longrightarrow> Q t"
    shows "\<Turnstile> {P}c{Q}"
    using assms by auto

  lemma conseq_rule:
    assumes "\<And>s. P s \<Longrightarrow> P' s"
    assumes "\<Turnstile> {P'} c {Q'}"
    assumes "\<And>s. Q' s \<Longrightarrow> Q s"
    shows "\<Turnstile> {P} c {Q}"
    using assms by auto

  (* One-sided versions of the consequence rule *)
  lemma conseq_pre_rule:
    assumes "\<Turnstile> {P'} c {Q}"
    assumes "\<And>s. P s \<Longrightarrow> P' s"
    shows "\<Turnstile> {P} c {Q}"
    using assms using conseq_rule by blast

  lemma conseq_post_rule:
    assumes "\<And>s. Q s \<Longrightarrow> Q' s"
    assumes "\<Turnstile> {P} c {Q}"
    shows "\<Turnstile> {P} c {Q'}"
    using assms using conseq_rule by blast

  lemma skip_rule: "\<Turnstile> {P} SKIP {P}"
    by (auto simp: hoare_valid_def)

  lemma assign_rule: "\<Turnstile> {\<lambda>s. P (s( x := (s x)(aval i s := aval a s) )) } x[i]::=a {P}"
    by (auto)

  lemma clear_rule: "\<Turnstile> {\<lambda>s. P (s( x := (\<lambda>_. 0) )) } CLR x {P}"
    by (auto)

  lemma basic_seq_rule:
    assumes "\<Turnstile> {P} c\<^sub>1 {Q}" "\<Turnstile> {Q} c\<^sub>2 {R}"
    shows "\<Turnstile> {P} c\<^sub>1;;c\<^sub>2 {R}"
    using assms by auto

  definition "COND b P Q \<equiv> if b then P else Q"

  lemma if_rule:
    assumes "\<Turnstile> {P1} c\<^sub>1 {Q}" "\<Turnstile> {P2} c\<^sub>2 {Q}"
    shows "\<Turnstile> {\<lambda>s. COND (bval b s) (P1 s) (P2 s)} IF b THEN c\<^sub>1 ELSE c\<^sub>2 {Q}"
    using assms unfolding COND_def by auto

  lemma basic_while_rule:
    assumes "\<Turnstile> {\<lambda>s. P s \<and> bval b s} c {P}"
    shows "\<Turnstile> {P} WHILE b DO c {\<lambda>s. P s \<and> \<not> bval b s}"
  proof (rule hoare_validI)
    fix s t
    assume "(WHILE b DO c, s) \<Rightarrow> t" "P s"
    then show "P t \<and> \<not> bval b t"
    proof (induction "WHILE b DO c" s t rule: big_step_induct)
      case (WhileFalse s)
      then show ?case by simp
    next
      case (WhileTrue s\<^sub>1 s\<^sub>2 s\<^sub>3)
      note IH = \<open>P s\<^sub>2 \<Longrightarrow> P s\<^sub>3 \<and> \<not> bval b s\<^sub>3\<close>

      from \<open>P s\<^sub>1\<close> \<open>bval b s\<^sub>1\<close> \<open>(c, s\<^sub>1) \<Rightarrow> s\<^sub>2\<close> \<open>\<Turnstile> {\<lambda>s. P s \<and> bval b s} c {P}\<close> have "P s\<^sub>2"
        unfolding hoare_valid_def by auto
      with IH show "P s\<^sub>3 \<and> \<not> bval b s\<^sub>3" .
    qed
  qed

  text \<open>We swap the premises of the sequence rule, as our
    verification condition generator will work on sequences
    from right to left.\<close>
  lemma seq_rule:
    assumes "\<Turnstile> {Q} c\<^sub>2 {R}" "\<Turnstile> {P} c\<^sub>1 {Q}"
    shows "\<Turnstile> {P} c\<^sub>1;;c\<^sub>2 {R}"
    using basic_seq_rule assms by blast

  text \<open>We combine the while-rule with a consequence rule, to
    make it more usable in verification condition generation\<close>

  (* Explicit backwards derivation *)
  lemma while_rule:
    assumes "\<Turnstile> {R} c {P}"
    assumes "\<And>s. \<lbrakk>P s; bval b s\<rbrakk> \<Longrightarrow> R s"
    assumes "\<And>s. \<lbrakk>P s; \<not>bval b s\<rbrakk> \<Longrightarrow> Q s"
    shows "\<Turnstile> {P} WHILE b DO c {Q}"
    apply (rule conseq_post_rule[where Q="\<lambda>s. P s \<and> \<not>bval b s"])
    apply (rule assms(3); simp)
    apply (rule basic_while_rule)
    apply (rule conseq_pre_rule)
    apply (rule assms(1))
    apply (rule assms(2); auto)
    done

end

section \<open>Hoare-Logic for Total Correctness\<close>

definition
hoaret_valid :: "assn \<Rightarrow> com \<Rightarrow> (assn) \<Rightarrow> bool" ("\<Turnstile>\<^sub>t {(1_)}/ (_)/ {(1_)}" 50) where
"\<Turnstile>\<^sub>t {P}c{Q} = (\<forall>s. P s \<longrightarrow> (\<exists>t. (c,s) \<Rightarrow> t \<and> Q t))"

context
  notes [simp] = hoaret_valid_def
begin
  lemma hoaret_validI:
    assumes "\<And>s. P s \<Longrightarrow> \<exists>t. (c,s) \<Rightarrow> t \<and> Q t"
    shows "\<Turnstile>\<^sub>t {P}c{Q}"
    using assms by auto

  lemma conseq_trule:
    assumes "\<And>s. P s \<Longrightarrow> P' s"
    assumes "\<Turnstile>\<^sub>t {P'} c {Q'}"
    assumes "\<And>s. Q' s \<Longrightarrow> Q s"
    shows "\<Turnstile>\<^sub>t {P} c {Q}"
    using assms by force

  (* One-sided versions of the consequence rule *)
  lemma conseq_pre_trule:
    assumes "\<Turnstile>\<^sub>t {P'} c {Q}"
    assumes "\<And>s. P s \<Longrightarrow> P' s"
    shows "\<Turnstile>\<^sub>t {P} c {Q}"
    using assms using conseq_trule by blast

  lemma conseq_post_trule:
    assumes "\<And>s. Q s \<Longrightarrow> Q' s"
    assumes "\<Turnstile>\<^sub>t {P} c {Q}"
    shows "\<Turnstile>\<^sub>t {P} c {Q'}"
    using assms using conseq_trule by blast

  lemma skip_trule: "\<Turnstile>\<^sub>t {P} SKIP {P}"
    by (auto)

  lemma assign_trule: "\<Turnstile>\<^sub>t {\<lambda>s. P (s( x := (s x)(aval i s := aval a s) )) } x[i]::=a {P}"
    by (auto)

  lemma assign_trule_workaround: (* Workaround to strange unification problem *)
    assumes "\<And>s. P (s( x := (s x)(aval i s := aval a s))) = P' s"
    shows "\<Turnstile>\<^sub>t {P'} Assign x i a {P}"
    using assms
    by (auto)

  lemma clear_trule: "\<Turnstile>\<^sub>t {\<lambda>s. P (s( x := (\<lambda>_. 0) )) } CLR x {P}"
    by (auto)

  lemma basic_seq_trule:
    assumes "\<Turnstile>\<^sub>t {P} c\<^sub>1 {Q}" "\<Turnstile>\<^sub>t {Q} c\<^sub>2 {R}"
    shows "\<Turnstile>\<^sub>t {P} c\<^sub>1;;c\<^sub>2 {R}"
    using assms by force

  lemma if_trule:
    assumes "\<Turnstile>\<^sub>t {P1} c\<^sub>1 {Q}" "\<Turnstile>\<^sub>t {P2} c\<^sub>2 {Q}"
    shows "\<Turnstile>\<^sub>t {\<lambda>s. COND (bval b s) (P1 s) (P2 s)} IF b THEN c\<^sub>1 ELSE c\<^sub>2 {Q}"
    using assms unfolding COND_def by force

  lemma basic_while_trule:
    assumes WF: "wf R"
    assumes S: "\<And>s\<^sub>0. \<Turnstile>\<^sub>t {\<lambda>s. P s \<and> bval b s \<and> s=s\<^sub>0} c {\<lambda>s. P s \<and> (s,s\<^sub>0)\<in>R}"
    shows "\<Turnstile>\<^sub>t {P} WHILE b DO c {\<lambda>s. P s \<and> \<not> bval b s}"
  proof (rule hoaret_validI)
    fix s
    assume I0: "P s"
    with WF show "\<exists>t. (WHILE b DO c, s) \<Rightarrow> t \<and> P t \<and> \<not> bval b t"
    proof (induction s rule: wf_induct_rule)
      case (less s)
      show ?case proof (cases "bval b s")
        case True
        with S less.prems obtain s' where "(c,s) \<Rightarrow> s'" "P s'" "(s',s)\<in>R"
          by auto
        with less.IH obtain t where "(WHILE b DO c, s') \<Rightarrow> t" "P t" "\<not> bval b t"
          by blast
        with WhileTrue[OF True \<open>(c,s) \<Rightarrow> s'\<close>] show ?thesis by blast
      next
        case False
        with less.prems show ?thesis by auto
      qed
    qed
  qed

  text \<open>We swap the premises of the sequence rule, as our
    verification condition generator will work on sequences
    from right to left.\<close>
  lemma seq_trule:
    assumes "\<Turnstile>\<^sub>t {Q} c\<^sub>2 {R}" "\<Turnstile>\<^sub>t {P} c\<^sub>1 {Q}"
    shows "\<Turnstile>\<^sub>t {P} c\<^sub>1;;c\<^sub>2 {R}"
    using basic_seq_trule assms by blast

  text \<open>We combine the while-rule with a consequence rule, to
    make it more usable in verification condition generation.

    Moreover, we write \<open>Ph s s\<close> as \<open>id (Ph s) s\<close>, to persuade
    Isabelle's unification algorithm not to generate flex-flex pairs,
    which will make it explode later.
    The initial goal simplification of the VCG will remove the \<open>id\<close>, once
    \<open>Ph\<close> has been instantiated.
    \<close>

  (* Explicit backwards derivation *)
  lemma while_trule:
    fixes m :: "state \<Rightarrow> nat"
    assumes "wf R"
    assumes "\<And>s\<^sub>0. \<Turnstile>\<^sub>t {Ph s\<^sub>0} c {\<lambda>s. P s \<and> (s, s\<^sub>0) \<in> R}"
    assumes "\<And>s. \<lbrakk>P s; bval b s\<rbrakk> \<Longrightarrow> id (Ph s) s"
    assumes "\<And>s. \<lbrakk>P s; \<not>bval b s\<rbrakk> \<Longrightarrow> Q s"
    shows "\<Turnstile>\<^sub>t {P} WHILE b DO c {Q}"
    apply (rule conseq_post_trule[where Q="\<lambda>s. P s \<and> \<not>bval b s"])
    apply (rule assms; simp)
    apply (rule basic_while_trule)
    apply (rule assms)
    apply (rule conseq_pre_trule)
    apply (rule assms)
    apply clarify
    apply (rule assms[simplified]; simp)
    done

end

section \<open>Verification Condition Generator\<close>

subsection \<open>Simplifier Setup\<close>
  named_theorems vcg_vars_mksimps

  (* TODO: These functions may be of general interest *)
  ML \<open>
    fun eq_classes_witness _ [] = []
      | eq_classes_witness f (x::xs) = let
          val w = f x
          val (this,other) = List.partition (fn y => f y = w) xs
        in
          (w,x::this)::eq_classes_witness f other
        end

    fun gen_assoc_map l = eq_classes_witness fst l |> map (apsnd (map snd))
  \<close>

  ML \<open>

    fun add_vars_mksimps ctxt = let

      fun make_pair thm = let
        fun get_cname [Const (@{const_name Trueprop},_)$c] = get_cname [c]
          | get_cname [t$_] = get_cname [t]
          | get_cname [Const (name,_)] = SOME name
          | get_cname _ = NONE

      in
        case get_cname (Thm.prems_of thm) of
          SOME n => SOME (n,thm)
        | NONE => (
            warning ("Invalid mksimps_pair thm: " ^ @{make_string} thm); (* TODO: Pretty-print thm! *)
            NONE
        )
      end

      val thms = Named_Theorems.get ctxt @{named_theorems vcg_vars_mksimps}
      val pairs = map_filter make_pair thms |> gen_assoc_map

      val mksimps_pairs =
        pairs @ mksimps_pairs |> gen_assoc_map |> map (apsnd flat)
      val ctxt = Simplifier.set_mksimps (mksimps mksimps_pairs) ctxt

    in
      ctxt
    end

  \<close>

  method_setup vars_clarsimp = \<open>
      Scan.succeed (fn ctxt => SIMPLE_METHOD' (CHANGED_PROP o (
        let
          val ctxt = Splitter.del_split @{thm if_split} ctxt
            delsimps @{thms fun_upd_apply}
            addsimps @{thms fun_upd_same fun_upd_other}
        in
          clarsimp_tac (add_vars_mksimps ctxt)
        end
      )))
  \<close>

subsection \<open>Variable Binding\<close>
  definition imap :: "vname \<Rightarrow> ('a \<Rightarrow> int \<Rightarrow> val) \<Rightarrow> 'a \<Rightarrow> state \<Rightarrow> bool" where "imap x ty v s \<equiv> s x = ty v"

  definition VAR_BIND :: "vname \<Rightarrow> _ \<Rightarrow> ('a \<Rightarrow> assn) \<Rightarrow> assn" where
    "VAR_BIND x ty Q s \<equiv> \<exists>v. imap x ty v s \<and> Q v s"
  definition VAR_CHANGED :: "(int \<Rightarrow> val) \<Rightarrow> ('a \<Rightarrow> int \<Rightarrow> val) \<Rightarrow> ('a \<Rightarrow> assn) \<Rightarrow> assn" where
    "VAR_CHANGED k ty Q s \<equiv> \<exists>v. k = ty v \<and> Q v s"

  definition EQ :: "(int \<Rightarrow> val) \<Rightarrow> ('a \<Rightarrow> int \<Rightarrow> val) \<Rightarrow> 'a \<Rightarrow> bool" where
    "EQ k ty v \<equiv> k = ty v"

  definition VAR_BIND_FINAL :: "bool \<Rightarrow> assn" where "VAR_BIND_FINAL x _ = x"
    (* Required for protection against eta-contraction on printing,
      and ensuring that final predicate does not depend on state *)

  text \<open>Variable bindings in assumptions\<close>

  lemma imapD[vcg_vars_mksimps]: "imap x ty a s \<Longrightarrow> s x = ty a" by (auto simp: imap_def)

  lemma imap_subst[simp]:
    "x\<noteq>y \<Longrightarrow> imap x ty v (s(y:=b)) \<longleftrightarrow> imap x ty v s"
    "imap x ty v (s(x:=b)) \<longleftrightarrow> b = ty v"
    unfolding imap_def by auto

  lemma VAR_BIND_elim[elim!]:
    assumes "VAR_BIND x ty (\<lambda>v. Q v) s"
    obtains v where "imap x ty v s" "Q v s"
    using assms unfolding VAR_BIND_def by auto

  lemma VAR_BIND_FINAL_elim[elim!]:
    assumes "VAR_BIND_FINAL Q s"
    obtains Q using assms unfolding VAR_BIND_FINAL_def by auto

  text \<open>Variable Bindings in Conclusion\<close>
  text \<open>Handle substitutions\<close>

  lemma var_bind_simp1: "x\<noteq>y \<Longrightarrow> VAR_BIND x ty Q (s(y:=v)) \<longleftrightarrow> VAR_BIND x ty (\<lambda>w s. Q w (s(y:=v))) s"
    unfolding VAR_BIND_def imap_def by auto

  lemma var_bind_simp2: "VAR_BIND x ty Q (s(x:=v)) \<longleftrightarrow> VAR_CHANGED v ty (\<lambda>w s. Q w (s(x:=v))) s"
    unfolding VAR_BIND_def VAR_CHANGED_def imap_def by auto

  lemma var_bind_simp3: "VAR_CHANGED k ty Q (s(x:=v)) \<longleftrightarrow> VAR_CHANGED k ty (\<lambda>w s. Q w (s(x:=v))) s"
    unfolding VAR_CHANGED_def by auto

  lemma var_bind_simp4: "VAR_BIND_FINAL Q (s(x:=v)) = VAR_BIND_FINAL Q s"
    by (auto simp: VAR_BIND_FINAL_def)

  lemmas var_bind_simps = var_bind_simp1 var_bind_simp2 var_bind_simp3
    var_bind_simp4

  text \<open>Resolve Conditionals\<close>
  lemma CONDI:
    assumes "b \<Longrightarrow> P" "\<not>b \<Longrightarrow> Q"
    shows "COND b P Q"
    using assms by (auto simp: COND_def)

  text \<open>Instantiate\<close>

  lemma VAR_BINDI:
    assumes "imap x ty v s" "Q v s"
    shows "VAR_BIND x ty Q s"
    using assms
    unfolding VAR_BIND_def VAR_CHANGED_def by auto

  lemma VAR_CHANGEDI:
    assumes "EQ k ty v" "Q v s"
    shows "VAR_CHANGED k ty Q s"
    using assms
    unfolding VAR_CHANGED_def EQ_def by auto

  lemma VAR_BIND_FINALI:
    assumes "Q"
    shows "VAR_BIND_FINAL Q s"
    using assms
    by (auto simp: VAR_BIND_FINAL_def)

  lemma EQIs:
    "EQ a id a"
    "EQ (ty v) ty v"
    unfolding EQ_def by auto

  method vcg_resolve_binding =
    rule VAR_BINDI, assumption
  | rule VAR_CHANGEDI, rule EQIs

  method vcg_try_resolve_bindings =
    (imp_basic_simp add: var_bind_simps)?;
    (intro CONDI)?;
    (vcg_resolve_binding+)?

  method vcg_resolve_bindings =
    vcg_try_resolve_bindings; rule VAR_BIND_FINALI

subsubsection \<open>Syntax\<close>

(* TODO: How to activate this syntax only in bundle? *)
nonterminal var_bind and var_binds

syntax
  "_var_block" :: "var_binds \<Rightarrow> 'a" ("vars _" [12] 10)
  "_var_final" :: "var_bind \<Rightarrow> 'a \<Rightarrow> var_binds" ("_ in _" [13,12] 12)
  "_var_cons" :: "var_bind \<Rightarrow> var_binds \<Rightarrow> var_binds" ("_/ _" [13,12] 12)
  "_var_bind_nvt" :: "'a \<Rightarrow> idt \<Rightarrow> 'a \<Rightarrow> var_bind" ("'(_ as _ : _')" [14,14,14] 14)
  "_var_bind_nt" :: "idt \<Rightarrow> 'a \<Rightarrow> var_bind" ("'(_ : _')" [14,14] 14)
  "_var_bind_nv" :: "'a \<Rightarrow> idt \<Rightarrow> var_bind" ("'(_ as _')" [14,14] 14)
  "_var_bind_n" :: "idt \<Rightarrow> var_bind" ("_" [14] 14)

(*syntax
  "_var_block" :: "var_binds \<Rightarrow> 'a" ("vars _" [12] 10)
  "_var_final" :: "var_bind \<Rightarrow> 'a \<Rightarrow> var_binds" ("_ in _" [13,12] 12)
  "_var_cons" :: "var_bind \<Rightarrow> var_binds \<Rightarrow> var_binds" ("_,/ _" [13,12] 12)
  "_var_bind_nvt" :: "'a \<Rightarrow> idt \<Rightarrow> 'a \<Rightarrow> var_bind" ("_ as _ : _" [14,14,14] 14)
  "_var_bind_nt" :: "idt \<Rightarrow> 'a \<Rightarrow> var_bind" ("_ : _" [14,14] 14)
  "_var_bind_nv" :: "'a \<Rightarrow> idt \<Rightarrow> var_bind" ("_ as _" [14,14] 14)
  "_var_bind_n" :: "idt \<Rightarrow> var_bind" ("_" [14] 14)
*)

syntax
  "_var_app" :: "var_bind \<Rightarrow> 'a \<Rightarrow> 'a"
  "_var_bind_s" :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a"

translations
  "_var_block (_var_final b Q)" \<rightleftharpoons> "_var_app b (CONST VAR_BIND_FINAL Q)"
  "_var_block (_var_cons b bs)" \<rightleftharpoons> "_var_app b (_var_block bs)"
  "_var_app (_var_bind_nvt x v ty) bs" \<rightleftharpoons> "_var_bind_s x ty (\<lambda>v. bs)"
  "_var_bind_nv x v" \<rightleftharpoons> "_var_bind_nvt x v (CONST var)"
  "_var_bind_nt x ty" \<rightharpoonup> "_var_bind_nvt (x) x ty"
  "_var_bind_n x" \<rightharpoonup> "_var_bind_nv (x) x"
  "_var_cons b c" \<leftharpoondown>  "_var_final b (_var_block c)"

ML \<open>
  local
    open IMP_Translation
  in
    fun xform_var_arg (Const (@{syntax_const "_constrain"}, _) $ t $ _) = xform_var_arg t
      | xform_var_arg (Free (str,_)) = SOME (HOLogic.mk_string str)
      | xform_var_arg _ = NONE

    fun
      var_bind_s_tr _ [x, ty, q] = let
        val x = the_default x (xform_var_arg x)
      in
        Syntax.const @{const_name VAR_BIND}$x$ty$q
      end
    | var_bind_s_tr _ ts = raise (TERM ("var_bind_s_tr",ts))

    fun
      var_bind_s_tr' _ (x::ts) = let
        val x = case try dest_var_syntax x of
          NONE => x
        | SOME s => Syntax.const s

      in
        list_comb (Syntax.const @{syntax_const "_var_bind_s"}, x::ts)
      end
    | var_bind_s_tr' _ _ = raise Match

    fun bound_eq (Ast.Appl [Ast.Constant @{syntax_const "_constrain"}, x, _]) y = bound_eq x y
      | bound_eq (Ast.Appl [Ast.Constant @{syntax_const "_bound"}, x]) y = bound_eq x y
      | bound_eq (Ast.Variable x) y = x = y
      | bound_eq _ _ = false

    fun var_same_ast_tr' [(Ast.Constant x), b] =
      if bound_eq b x then
        Ast.Appl [Ast.Constant @{syntax_const "_var_bind_n"}, b]
      else raise Match
    | var_same_ast_tr' [(Ast.Constant x), b, ty] =
      if bound_eq b x then
        Ast.Appl [Ast.Constant @{syntax_const "_var_bind_nt"}, b, ty]
      else raise Match
    | var_same_ast_tr' _ = raise Match

    val setup =
      Sign.parse_translation [
          (@{syntax_const "_var_bind_s"}, var_bind_s_tr)
        ]
      #>
      Sign.print_translation [
        (@{const_syntax VAR_BIND}, var_bind_s_tr')
      ]
      #>
    Sign.print_ast_translation
     [(@{syntax_const "_var_bind_nvt"}, K var_same_ast_tr'),
      (@{syntax_const "_var_bind_nv"}, K var_same_ast_tr')
     ];

    val _ = Theory.setup setup

  end
\<close>

term "vars a (b : var) c (x as xx) (''xx.d'' as xxx) (''__y'' as yy : id) in P a b c"

subsection \<open>Annotating While Loops\<close>
definition AWHILE :: "assn \<Rightarrow> bexp \<Rightarrow> com \<Rightarrow> com" ("(INVAR _ WHILE _/ DO _)"  [0, 0, 61] 61)
  where "INVAR I WHILE b DO c \<equiv> WHILE b DO c"

lemma annot_invar: "(WHILE b DO c) = (INVAR I WHILE b DO c)" by (simp add: AWHILE_def)

lemma awhile_rule:
  assumes "\<Turnstile> {R} c {P}"
  assumes "\<And>s. \<lbrakk>P s; bval b s\<rbrakk> \<Longrightarrow> R s"
  assumes "\<And>s. \<lbrakk>P s; \<not>bval b s\<rbrakk> \<Longrightarrow> Q s"
  shows "\<Turnstile> {P} INVAR P WHILE b DO c {Q}"
  unfolding AWHILE_def by (rule while_rule[OF assms])

definition AWHILET :: "(state\<times>state) set \<Rightarrow> assn \<Rightarrow> bexp \<Rightarrow> com \<Rightarrow> com" ("(VAR _ INVAR _ WHILE _/ DO _)"  [0, 0, 61] 61)
  where "VAR R INVAR I WHILE b DO c \<equiv> WHILE b DO c"

lemma annot_tinvar: "(WHILE b DO c) = (VAR R INVAR I WHILE b DO c)" by (simp add: AWHILET_def)

lemma awhile_trule:
  fixes R :: "(state \<times> state) set"
  assumes "wf R"
  assumes "\<And>s\<^sub>0. \<Turnstile>\<^sub>t {Ph s\<^sub>0} c {\<lambda>s. P s \<and> (s, s\<^sub>0) \<in> R}"
  assumes "\<And>s. \<lbrakk>P s; bval b s\<rbrakk> \<Longrightarrow> id (Ph s) s"
  assumes "\<And>s. \<lbrakk>P s; \<not>bval b s\<rbrakk> \<Longrightarrow> Q s"
  shows "\<Turnstile>\<^sub>t {P} VAR R INVAR P WHILE b DO c {Q}"
  unfolding AWHILET_def
  by (rule while_trule[OF assms])

subsection \<open>Basic VCG\<close>

lemmas vcg_rules = skip_rule assign_rule clear_rule seq_rule if_rule awhile_rule
lemmas vcg_trules = skip_trule assign_trule clear_trule seq_trule if_trule awhile_trule conjI

method vcg_is_no_hoare_triple = match conclusion in
    "\<Turnstile> {_} _ {_}" \<Rightarrow> fail
  \<bar> "\<Turnstile>\<^sub>t {_} _ {_}" \<Rightarrow> fail
  \<bar> _ \<Rightarrow> succeed

definition VERIFICATION_CONDITION :: "bool \<Rightarrow> bool" where
  "VERIFICATION_CONDITION P = P"

lemma VC_I: "P \<Longrightarrow> VERIFICATION_CONDITION P" by (simp add: VERIFICATION_CONDITION_def)
lemma VC_D: "VERIFICATION_CONDITION P \<Longrightarrow> P" by (simp add: VERIFICATION_CONDITION_def)

method rule_wrapper methods m = m; (vcg_is_no_hoare_triple, rule VC_D)?

method vcg_rule (* Apply Hoare-rule and tag side conditions *)
  = rule_wrapper\<open>rule vcg_rules vcg_trules (*| (rule assign_trule_workaround, (simp;fail))*)\<close>

method vcg_prepare_goal -- \<open>Applied before processing any goal\<close>
  = vars_clarsimp?

method vcg_remove_binding_assms = ((thin_tac "imap _ _ _ _")+)?

method vcg_prepare_vc -- \<open>Applied to prepare verification condition. May solve it.\<close>
  = rule VC_I; (vcg_resolve_bindings; vcg_remove_binding_assms | vcg_try_resolve_bindings)

method vcg_step_solver methods solver
  = vcg_prepare_goal; ( vcg_rule | vcg_prepare_vc;solver )
method vcg_default_solver = clarsimp?; (safe?;clarsimp?;fail)?

method vcg_step = vcg_step_solver\<open>vcg_default_solver\<close>
method vcg_ctd = (vcg_step)+

method vcg_init = rule_wrapper\<open>rule conseq_pre_rule conseq_pre_trule\<close>

method vcg = vcg_init, vcg_ctd

method vcg_ctd_raw = (vcg_step_solver\<open>succeed\<close>)+
method vcg_raw = vcg_init, vcg_ctd_raw

subsection \<open>Deferred VCs\<close>

definition DEFERRED :: "bool \<Rightarrow> bool" where "DEFERRED P = P"
lemma DEFERREDD: "DEFERRED P \<Longrightarrow> P" by (auto simp: DEFERRED_def)

method vcg_can_defer =
  (
    match conclusion
      in "DEFERRED _" \<Rightarrow> fail -- \<open>Refuse to defer already deferred goals\<close>
    \<bar> "\<Turnstile> {_} _ {_}" \<Rightarrow> fail  -- \<open>Refuse to defer Hoare triples (They are no VCs!)\<close>
    \<bar> "\<Turnstile>\<^sub>t {_} _ {_}" \<Rightarrow> fail  -- \<open>Refuse to defer Hoare triples (They are no VCs!)\<close>
    \<bar> _ \<Rightarrow> succeed)

method vcg_defer =
  vcg_can_defer, rule DEFERREDD, tactic \<open>FIRSTGOAL defer_tac\<close>

method vcg_all =
  (vcg_init, (vcg_ctd, vcg_defer? | vcg_defer)+, (unfold DEFERRED_def)?)

end