(*  Title:      JinjaThreads/Basic/Aux.thy
    Author:     Andreas Lochbihler, David von Oheimb, Tobias Nipkow

    Based on the Jinja theory Common/Aux.thy by David von Oheimb and Tobias Nipkow
*)

header {*
  \isaheader{Auxiliary Definitions and Lemmata}
*}

theory Auxiliary
imports
  Main
  "~~/src/HOL/Library/FinFun_Syntax"
  "~~/src/HOL/Library/Transitive_Closure_Table"
  "~~/src/HOL/Library/Predicate_Compile_Alternative_Defs"
  "~~/src/HOL/Library/Code_Char"
  "~~/src/HOL/Library/Monad_Syntax"
  "~~/src/HOL/Library/Infinite_Set"
begin

(* FIXME move and possibly turn into a general simproc *)
lemma nat_add_max_le[simp]:
  "((n::nat) + max i j \<le> m) = (n + i \<le> m \<and> n + j \<le> m)"
 (*<*)by arith(*>*)

lemma Suc_add_max_le[simp]:
  "(Suc(n + max i j) \<le> m) = (Suc(n + i) \<le> m \<and> Suc(n + j) \<le> m)"
(*<*)by arith(*>*)

lemma less_min_eq1:
  "(a :: 'a :: order) < b \<Longrightarrow> min a b = a"
by(auto simp add: min_def order_less_imp_le)

lemma less_min_eq2:
  "(a :: 'a :: order) > b \<Longrightarrow> min a b = b"
by(auto simp add: min_def order_less_imp_le)

notation Some ("(\<lfloor>_\<rfloor>)")

(*<*)
declare
 option.splits[split]
 Let_def[simp]
 subset_insertI2 [simp]
(*>*)

declare not_Cons_self [no_atp]

lemma Option_bind_eq_None_conv:
  "x \<guillemotright>= y = None \<longleftrightarrow> x = None \<or> (\<exists>x'. x = Some x' \<and> y x' = None)"
by(cases x) simp_all

lemma Option_bind_eq_Some_conv:
  "x \<guillemotright>= y = Some z \<longleftrightarrow> (\<exists>x'. x = Some x' \<and> y x' = Some z)"
by(cases x) simp_all

lemma map_upds_xchg_snd:
  "\<lbrakk> length xs \<le> length ys; length xs \<le> length zs; \<forall>i. i < length xs \<longrightarrow> ys ! i = zs ! i \<rbrakk>
  \<Longrightarrow> f(xs [\<mapsto>] ys) = f(xs [\<mapsto>] zs)"
proof(induct xs arbitrary: ys zs f)
  case Nil thus ?case by simp
next
  case (Cons x xs)
  note IH = `\<And>f ys zs. \<lbrakk> length xs \<le> length ys; length xs \<le> length zs; \<forall>i<length xs. ys ! i = zs ! i\<rbrakk>
             \<Longrightarrow> f(xs [\<mapsto>] ys) = f(xs [\<mapsto>] zs)`
  note leny = `length (x # xs) \<le> length ys`
  note lenz = `length (x # xs) \<le> length zs`
  note nth = `\<forall>i<length (x # xs). ys ! i = zs ! i`
  from lenz obtain z zs' where zs [simp]: "zs = z # zs'" by(cases zs, auto)
  from leny obtain y ys' where ys [simp]: "ys = y # ys'" by(cases ys, auto)
  from lenz leny nth have "(f(x \<mapsto> y))(xs [\<mapsto>] ys') = (f(x \<mapsto> y))(xs [\<mapsto>] zs')"
    by-(rule IH, auto)
  moreover from nth have "y = z" by auto
  ultimately show ?case by(simp add: map_upds_def)
qed

subsection {*@{text distinct_fst}*}

definition
  distinct_fst  :: "('a \<times> 'b) list \<Rightarrow> bool"
where
  "distinct_fst  \<equiv>  distinct \<circ> map fst"

lemma distinct_fst_Nil [simp]:
  "distinct_fst []"
 (*<*)
apply (unfold distinct_fst_def)
apply (simp (no_asm))
done
(*>*)

lemma distinct_fst_Cons [simp]:
  "distinct_fst ((k,x)#kxs) = (distinct_fst kxs \<and> (\<forall>y. (k,y) \<notin> set kxs))"
(*<*)
apply (unfold distinct_fst_def)
apply (auto simp:image_def)
done
(*>*)

lemma distinct_fstD: "\<lbrakk> distinct_fst xs; (x, y) \<in> set xs; (x, z) \<in> set xs \<rbrakk> \<Longrightarrow> y = z"
by(induct xs) auto

lemma map_of_SomeI:
  "\<lbrakk> distinct_fst kxs; (k,x) \<in> set kxs \<rbrakk> \<Longrightarrow> map_of kxs k = Some x"
(*<*)by (induct kxs) (auto simp:fun_upd_apply)(*>*)

lemma rel_option_Some1:
  "rel_option R (Some x) y \<longleftrightarrow> (\<exists>y'. y = Some y' \<and> R x y')"
by(cases y) simp_all

lemma rel_option_Some2:
  "rel_option R x (Some y) \<longleftrightarrow> (\<exists>x'. x = Some x' \<and> R x' y)"
by(cases x) simp_all

subsection {* Using @{term list_all2} for relations *}

definition
  fun_of :: "('a \<times> 'b) set \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> bool"
where
  "fun_of S \<equiv> \<lambda>x y. (x,y) \<in> S"

text {* Convenience lemmas *}
(*<*)
declare fun_of_def [simp]
(*>*)
lemma rel_list_all2_Cons [iff]:
  "list_all2 (fun_of S) (x#xs) (y#ys) =
   ((x,y) \<in> S \<and> list_all2 (fun_of S) xs ys)"
  (*<*)by simp(*>*)

lemma rel_list_all2_Cons1:
  "list_all2 (fun_of S) (x#xs) ys =
  (\<exists>z zs. ys = z#zs \<and> (x,z) \<in> S \<and> list_all2 (fun_of S) xs zs)"
  (*<*)by (cases ys) auto(*>*)

lemma rel_list_all2_Cons2:
  "list_all2 (fun_of S) xs (y#ys) =
  (\<exists>z zs. xs = z#zs \<and> (z,y) \<in> S \<and> list_all2 (fun_of S) zs ys)"
  (*<*)by (cases xs) auto(*>*)

lemma rel_list_all2_refl:
  "(\<And>x. (x,x) \<in> S) \<Longrightarrow> list_all2 (fun_of S) xs xs"
  (*<*)by (simp add: list_all2_refl)(*>*)

lemma rel_list_all2_antisym:
  "\<lbrakk> (\<And>x y. \<lbrakk>(x,y) \<in> S; (y,x) \<in> T\<rbrakk> \<Longrightarrow> x = y);
     list_all2 (fun_of S) xs ys; list_all2 (fun_of T) ys xs \<rbrakk> \<Longrightarrow> xs = ys"
  (*<*)by (rule list_all2_antisym) auto(*>*)

lemma rel_list_all2_trans:
  "\<lbrakk> \<And>a b c. \<lbrakk>(a,b) \<in> R; (b,c) \<in> S\<rbrakk> \<Longrightarrow> (a,c) \<in> T;
    list_all2 (fun_of R) as bs; list_all2 (fun_of S) bs cs\<rbrakk>
  \<Longrightarrow> list_all2 (fun_of T) as cs"
  (*<*)by (rule list_all2_trans) auto(*>*)

lemma rel_list_all2_update_cong:
  "\<lbrakk> i<size xs; list_all2 (fun_of S) xs ys; (x,y) \<in> S \<rbrakk>
  \<Longrightarrow> list_all2 (fun_of S) (xs[i:=x]) (ys[i:=y])"
  (*<*)by (simp add: list_all2_update_cong)(*>*)

lemma rel_list_all2_nthD:
  "\<lbrakk> list_all2 (fun_of S) xs ys; p < size xs \<rbrakk> \<Longrightarrow> (xs!p,ys!p) \<in> S"
  (*<*)by (drule list_all2_nthD) auto(*>*)

lemma rel_list_all2I:
  "\<lbrakk> length a = length b; \<And>n. n < length a \<Longrightarrow> (a!n,b!n) \<in> S \<rbrakk> \<Longrightarrow> list_all2 (fun_of S) a b"
  (*<*)by (erule list_all2_all_nthI) simp(*>*)

(*<*)declare fun_of_def [simp del](*>*)

lemma list_all2_induct[consumes 1, case_names Nil Cons]:
  assumes major: "list_all2 P xs ys"
  and Nil: "Q [] []"
  and Cons: "\<And>x xs y ys. \<lbrakk> P x y; list_all2 P xs ys; Q xs ys \<rbrakk> \<Longrightarrow> Q (x # xs) (y # ys)"
  shows "Q xs ys"
using major
by(induct xs arbitrary: ys)(auto simp add: list_all2_Cons1 Nil intro!: Cons)

lemma list_all2_split:
  assumes major: "list_all2 P xs ys"
  and split: "\<And>x y. P x y \<Longrightarrow> \<exists>z. Q x z \<and> R z y"
  shows "\<exists>zs. list_all2 Q xs zs \<and> list_all2 R zs ys"
using major
by(induct rule: list_all2_induct)(auto dest: split)

lemma list_all2_refl_conv:
  "list_all2 P xs xs \<longleftrightarrow> (\<forall>x\<in>set xs. P x x)"
unfolding list_all2_conv_all_nth Ball_def in_set_conv_nth
by auto

lemma list_all2_op_eq [simp]:
  "list_all2 op = xs ys \<longleftrightarrow> xs = ys"
by(induct xs arbitrary: ys)(auto simp add: list_all2_Cons1)

lemmas filter_replicate_conv = filter_replicate

lemma length_greater_Suc_0_conv: "Suc 0 < length xs \<longleftrightarrow> (\<exists>x x' xs'. xs = x # x' # xs')"
by(cases xs, auto simp add: neq_Nil_conv)

lemmas zip_same_conv = zip_same_conv_map

lemma nth_Cons_subtract: "0 < n \<Longrightarrow> (x # xs) ! n = xs ! (n - 1)"
by(auto simp add: nth_Cons split: nat.split)

lemma f_nth_set:
  "\<lbrakk> f (xs ! n) = v; n < length xs \<rbrakk> \<Longrightarrow> v \<in> f ` set xs"
unfolding set_conv_nth by auto

lemma nth_concat_eqI:
  "\<lbrakk> n = listsum (map length (take i xss)) + k; i < length xss; k < length (xss ! i); x = xss ! i ! k \<rbrakk>
  \<Longrightarrow> concat xss ! n = x"
apply(induct xss arbitrary: n i k)
 apply simp
apply simp
apply(case_tac i)
 apply(simp add: nth_append)
apply(simp add: nth_append)
done

lemma replicate_eq_append_conv:
  "(replicate n x = xs @ ys) = (\<exists>m\<le>n. xs = replicate m x \<and> ys = replicate (n-m) x)"
proof(induct n arbitrary: xs ys)
  case 0 thus ?case by simp
next
  case (Suc n xs ys)
  have IH: "\<And>xs ys. (replicate n x = xs @ ys) = (\<exists>m\<le>n. xs = replicate m x \<and> ys = replicate (n - m) x)" by fact
  show ?case
  proof(unfold replicate_Suc, rule iffI)
    assume a: "x # replicate n x = xs @ ys"
    show "\<exists>m\<le>Suc n. xs = replicate m x \<and> ys = replicate (Suc n - m) x"
    proof(cases xs)
      case Nil
      thus ?thesis using a
        by(auto)
    next
      case (Cons X XS)
      with a have x: "x = X" and "replicate n x = XS @ ys" by auto
      hence "\<exists>m\<le>n. XS = replicate m x \<and> ys = replicate (n - m) x"
        by -(rule IH[THEN iffD1])
      then obtain m where "m \<le> n" and XS: "XS = replicate m x" and ys: "ys = replicate (n - m) x" by blast
      with x Cons show ?thesis
        by(fastforce)
    qed
  next
    assume "\<exists>m\<le>Suc n. xs = replicate m x \<and> ys = replicate (Suc n - m) x"
    then obtain m where m: "m \<le> Suc n" and xs: "xs = replicate m x" and ys: "ys = replicate (Suc n - m) x" by blast
    thus "x # replicate n x = xs @ ys"
      by(simp add: replicate_add[THEN sym])
  qed
qed

lemma replicate_Suc_snoc:
  "replicate (Suc n) x = replicate n x @ [x]"
by (metis replicate_Suc replicate_append_same)

lemma map_eq_append_conv:
  "map f xs = ys @ zs \<longleftrightarrow> (\<exists>ys' zs'. map f ys' = ys \<and> map f zs' = zs \<and> xs = ys' @ zs')"
apply(rule iffI)
 apply(metis append_eq_conv_conj append_take_drop_id assms drop_map take_map)
by(clarsimp)

lemma append_eq_map_conv:
  "ys @ zs = map f xs \<longleftrightarrow> (\<exists>ys' zs'. map f ys' = ys \<and> map f zs' = zs \<and> xs = ys' @ zs')"
unfolding map_eq_append_conv[symmetric]
by auto

lemma map_eq_map_conv:
  "map f xs = map g ys \<longleftrightarrow> list_all2 (\<lambda>x y. f x = g y) xs ys"
apply(induct xs arbitrary: ys)
apply(auto simp add: list_all2_Cons1 Cons_eq_map_conv)
done

lemma map_eq_all_nth_conv:
  "map f xs = ys \<longleftrightarrow> length xs = length ys \<and> (\<forall>n < length xs. f (xs ! n) = ys ! n)"
apply(induct xs arbitrary: ys)
apply(fastforce simp add: nth_Cons Suc_length_conv split: nat.splits)+
done

lemma take_eq_take_le_eq:
  "\<lbrakk> take n xs = take n ys; m \<le> n \<rbrakk> \<Longrightarrow> take m xs = take m ys"
by(metis min.absorb_iff1 take_take)

lemma take_list_update_beyond:
  "n \<le> m \<Longrightarrow> take n (xs[m := x]) = take n xs"
by(cases "n \<le> length xs")(rule nth_take_lemma, simp_all)

lemma hd_drop_conv_nth:
  "n < length xs \<Longrightarrow> hd (drop n xs) = xs ! n"
by(rule hd_drop_conv_nth) (metis list.size(3) not_less0)

lemma set_tl_subset: "set (tl xs) \<subseteq> set xs"
by(cases xs) auto

lemma tl_conv_drop: "tl xs = drop 1 xs"
by(cases xs) simp_all

lemma takeWhile_eq_Nil_dropWhile_eq_Nil_imp_Nil:
  "\<lbrakk> takeWhile P xs = []; dropWhile P xs = [] \<rbrakk> \<Longrightarrow> xs = []"
by (metis dropWhile_eq_drop drop_0 list.size(3))

lemma takeWhile_eq_Nil_conv:
  "takeWhile P xs = [] \<longleftrightarrow> (xs = [] \<or> \<not> P (hd xs))"
by(cases xs) simp_all

lemma dropWhile_append1': "dropWhile P xs \<noteq> [] \<Longrightarrow> dropWhile P (xs @ ys) = dropWhile P xs @ ys"
by(cases xs) auto

lemma dropWhile_append2': "dropWhile P xs = [] \<Longrightarrow> dropWhile P (xs @ ys) = dropWhile P ys"
by(simp)

lemma takeWhile_append1': "dropWhile P xs \<noteq> [] \<Longrightarrow> takeWhile P (xs @ ys) = takeWhile P xs"
by auto

lemma takeWhile_takeWhile: "takeWhile P (takeWhile Q xs) = takeWhile (\<lambda>x. P x \<and> Q x) xs"
by(induct xs) simp_all

lemma dropWhile_eq_ConsD:
  "dropWhile P xs = y # ys \<Longrightarrow> y \<in> set xs \<and> \<not> P y"
by(induct xs)(auto split: split_if_asm)

lemma dropWhile_eq_hd_conv: "dropWhile P xs = hd xs # rest \<longleftrightarrow> xs \<noteq> [] \<and> rest = tl xs \<and> \<not> P (hd xs)"
by (metis append_Nil append_is_Nil_conv dropWhile_eq_Cons_conv list.sel(1) neq_Nil_conv takeWhile_dropWhile_id takeWhile_eq_Nil_conv list.sel(3))

lemma dropWhile_eq_same_conv: "dropWhile P xs = xs \<longleftrightarrow> (xs = [] \<or> \<not> P (hd xs))"
by (metis dropWhile.simps(1) eq_Nil_appendI hd_dropWhile takeWhile_dropWhile_id takeWhile_eq_Nil_conv)

lemma subset_code [code_unfold]:
  "set xs \<subseteq> set ys \<longleftrightarrow> (\<forall>x \<in> set xs. x \<in> set ys)"
by(rule Set.subset_eq)

lemma eval_bot [simp]:
  "Predicate.eval bot = (\<lambda>_. False)"
by(auto simp add: fun_eq_iff)

lemma not_is_emptyE:
  assumes "\<not> Predicate.is_empty P"
  obtains x where "Predicate.eval P x"
using assms
by(fastforce simp add: Predicate.is_empty_def bot_pred_def intro!: pred_iffI)

lemma is_emptyD:
  assumes "Predicate.is_empty P"
  shows "Predicate.eval P x \<Longrightarrow> False"
using assms
by(simp add: Predicate.is_empty_def bot_pred_def bot_apply Set.empty_def)

lemma eval_bind_conv:
  "Predicate.eval (P \<guillemotright>= R) y = (\<exists>x. Predicate.eval P x \<and> Predicate.eval (R x) y)"
by(blast elim: bindE intro: bindI)

lemma eval_single_conv: "Predicate.eval (Predicate.single a) b \<longleftrightarrow> a = b"
by(blast intro: singleI elim: singleE)

lemma conj_asm_conv_imp:
  "(A \<and> B \<Longrightarrow> PROP C) \<equiv> (A \<Longrightarrow> B \<Longrightarrow> PROP C)"
apply(rule equal_intr_rule)
 apply(erule meta_mp)
 apply(erule (1) conjI)
apply(erule meta_impE)
 apply(erule conjunct1)
apply(erule meta_mp)
apply(erule conjunct2)
done

lemma meta_all_eq_conv: "(\<And>a. a = b \<Longrightarrow> PROP P a) \<equiv> PROP P b"
apply(rule equal_intr_rule)
 apply(erule meta_allE)
 apply(erule meta_mp)
 apply(rule refl)
apply(hypsubst)
apply assumption
done

lemma meta_all_eq_conv2: "(\<And>a. b = a \<Longrightarrow> PROP P a) \<equiv> PROP P b"
apply(rule equal_intr_rule)
 apply(erule meta_allE)
 apply(erule meta_mp)
 apply(rule refl)
apply(hypsubst)
apply assumption
done

lemma disj_split:
  "P (a \<or> b) \<longleftrightarrow> (a \<longrightarrow> P True) \<and> (b \<longrightarrow> P True) \<and> (\<not> a \<and> \<not> b \<longrightarrow> P False)"
apply(cases a)
apply(case_tac [!] b)
apply auto
done

lemma disj_split_asm:
  "P (a \<or> b) \<longleftrightarrow> \<not> (a \<and> \<not> P True \<or> b \<and> \<not> P True \<or> \<not> a \<and> \<not> b \<and> \<not> P False)"
apply(auto simp add: disj_split[of P])
done

lemma disjCE:
  assumes "P \<or> Q"
  obtains P | "Q" "\<not> P"
using assms by blast

lemma case_option_conv_if:
  "(case v of None \<Rightarrow> f | Some x \<Rightarrow> g x) = (if \<exists>a. v = Some a then g (the v) else f)"
by(simp)

lemma LetI: "(\<And>x. x = t \<Longrightarrow> P x) \<Longrightarrow> let x = t in P x"
by(simp)

(* rearrange parameters and premises to allow application of one-point-rules *)
(* adapted from Tools/induct.ML and Isabelle Developer Workshop 2010 *)

simproc_setup rearrange_eqs ("Pure.all t") = {*
let
  fun swap_params_conv ctxt i j cv =
    let
      fun conv1 0 ctxt = Conv.forall_conv (cv o snd) ctxt
        | conv1 k ctxt =
            Conv.rewr_conv @{thm swap_params} then_conv
            Conv.forall_conv (conv1 (k - 1) o snd) ctxt
      fun conv2 0 ctxt = conv1 j ctxt
        | conv2 k ctxt = Conv.forall_conv (conv2 (k - 1) o snd) ctxt
    in conv2 i ctxt end;

  fun swap_prems_conv 0 = Conv.all_conv
    | swap_prems_conv i =
        Conv.implies_concl_conv (swap_prems_conv (i - 1)) then_conv
        Conv.rewr_conv Drule.swap_prems_eq;

  fun drop_judgment ctxt = Object_Logic.drop_judgment (Proof_Context.theory_of ctxt);

  fun find_eq ctxt t =
    let
      val l = length (Logic.strip_params t);
      val Hs = Logic.strip_assums_hyp t;
      fun find (i, (_ $ (Const ("HOL.eq", _) $ Bound j $ _))) = SOME (i, j)
        | find (i, (_ $ (Const ("HOL.eq", _) $ _ $ Bound j))) = SOME (i, j)
        | find _ = NONE
    in
      (case get_first find (map_index I Hs) of
        NONE => NONE
      | SOME (0, 0) => NONE
      | SOME (i, j) => SOME (i, l - j - 1, j))
    end;

  fun mk_swap_rrule ctxt ct =
    (case find_eq ctxt (term_of ct) of
      NONE => NONE
    | SOME (i, k, j) => SOME (swap_params_conv ctxt k j (K (swap_prems_conv i)) ct))
in
  fn _ => mk_swap_rrule
end
*}
declare [[simproc del: rearrange_eqs]]
lemmas meta_onepoint = meta_all_eq_conv meta_all_eq_conv2

lemma meta_all2_eq_conv: "(\<And>a b. a = c \<Longrightarrow> PROP P a b) \<equiv> (\<And>b. PROP P c b)"
apply(rule equal_intr_rule)
 apply(erule meta_allE)+
 apply(erule meta_mp)
 apply(rule refl)
apply(erule meta_allE)
apply simp
done

lemma meta_all3_eq_conv: "(\<And>a b c. a = d \<Longrightarrow> PROP P a b c) \<equiv> (\<And>b c. PROP P d b c)"
apply(rule equal_intr_rule)
 apply(erule meta_allE)+
 apply(erule meta_mp)
 apply(rule refl)
apply(erule meta_allE)+
apply simp
done

lemma meta_all4_eq_conv: "(\<And>a b c d. a = e \<Longrightarrow> PROP P a b c d) \<equiv> (\<And>b c d. PROP P e b c d)"
apply(rule equal_intr_rule)
 apply(erule meta_allE)+
 apply(erule meta_mp)
 apply(rule refl)
apply(erule meta_allE)+
apply simp
done

lemma meta_all5_eq_conv: "(\<And>a b c d e. a = f \<Longrightarrow> PROP P a b c d e) \<equiv> (\<And>b c d e. PROP P f b c d e)"
apply(rule equal_intr_rule)
 apply(erule meta_allE)+
 apply(erule meta_mp)
 apply(rule refl)
apply(erule meta_allE)+
apply simp
done

lemma inj_on_image_mem_iff:
  "\<lbrakk> inj_on f A; B \<subseteq> A; a \<in> A \<rbrakk> \<Longrightarrow> f a \<in> f ` B \<longleftrightarrow> a \<in> B"
by(metis inv_into_f_eq inv_into_image_cancel rev_image_eqI)

lemma setsum_hom:
  assumes hom_add [simp]: "\<And>a b. f (a + b) = f a + f b"
  and hom_0 [simp]: "f 0 = 0"
  shows "setsum (f \<circ> h) A = f (setsum h A)"
proof(cases "finite A")
  case False thus ?thesis by simp
next
  case True thus ?thesis
    by(induct) simp_all
qed

lemma setsum_upto_add_nat:
  "a \<le> b \<Longrightarrow> setsum f {..<(a :: nat)} + setsum f {a..<b} = setsum f {..<b}"
by (metis atLeast0LessThan le0 setsum_add_nat_ivl)

lemma nat_fun_sum_eq_conv:
  fixes f :: "'a \<Rightarrow> nat"
  shows "(\<lambda>a. f a + g a) = (\<lambda>a. 0) \<longleftrightarrow> f = (\<lambda>a .0) \<and> g = (\<lambda>a. 0)"
by(auto simp add: fun_eq_iff)

lemma in_ran_conv: "v \<in> ran m \<longleftrightarrow> (\<exists>k. m k = Some v)"
by(simp add: ran_def)

lemma map_le_dom_eq_conv_eq:
  "\<lbrakk> m \<subseteq>\<^sub>m m'; dom m = dom m' \<rbrakk> \<Longrightarrow> m = m'"
by (metis map_le_antisym map_le_def)

lemma map_leI:
  "(\<And>k v. f k = Some v \<Longrightarrow> g k = Some v) \<Longrightarrow> f \<subseteq>\<^sub>m g"
unfolding map_le_def by auto

lemma map_le_SomeD: "\<lbrakk> m \<subseteq>\<^sub>m m'; m x = \<lfloor>y\<rfloor> \<rbrakk> \<Longrightarrow> m' x = \<lfloor>y\<rfloor>"
by(auto simp add: map_le_def dest: bspec)

lemma map_le_same_upd:
  "f x = None \<Longrightarrow> f \<subseteq>\<^sub>m f(x \<mapsto> y)"
by(auto simp add: map_le_def)

lemma map_upd_map_add: "X(V \<mapsto> v) = (X ++ [V \<mapsto> v])"
by(simp)

lemma foldr_filter_conv:
  "foldr f (filter P xs) = foldr (\<lambda>x s. if P x then f x s else s) xs"
by(induct xs)(auto intro: ext)

lemma foldr_insert_conv_set:
  "foldr insert xs A = A \<union> set xs"
by(induct xs arbitrary: A) auto

lemma snd_o_Pair_conv_id: "snd o Pair a = id"
by(simp add: o_def id_def)

lemma if_split:
  "\<lbrakk> P \<Longrightarrow> A; \<not> P \<Longrightarrow> B \<rbrakk> \<Longrightarrow> if P then A else B"
by(auto)

lemma ex_set_conv: "(\<exists>x. x \<in> set xs) \<longleftrightarrow> xs \<noteq> []"
apply(auto)
apply(auto simp add: neq_Nil_conv)
done

lemma subset_Un1: "A \<subseteq> B \<Longrightarrow> A \<subseteq> B \<union> C" by blast
lemma subset_Un2: "A \<subseteq> C \<Longrightarrow> A \<subseteq> B \<union> C" by blast
lemma subset_insert: "A \<subseteq> B \<Longrightarrow> A \<subseteq> insert a B" by blast
lemma UNION_subsetD: "\<lbrakk> (\<Union>x\<in>A. f x) \<subseteq> B; a \<in> A \<rbrakk> \<Longrightarrow> f a \<subseteq> B" by blast

lemma Collect_eq_singleton_conv:
  "{a. P a} = {a} \<longleftrightarrow> P a \<and> (\<forall>a'. P a' \<longrightarrow> a = a')"
by(auto)

lemma Collect_conv_UN_singleton: "{f x|x. x \<in> P} = (\<Union>x\<in>P. {f x})"
by blast

lemma if_else_if_else_eq_if_else [simp]:
  "(if b then x else if b then y else z) = (if b then x else z)"
by(simp)

lemma rec_prod_split [simp]: "old.rec_prod = split"
by(simp add: fun_eq_iff)

lemma inj_Pair_snd [simp]: "inj (Pair x)"
by(rule injI) auto

lemma rtranclp_False [simp]: "(\<lambda>a b. False)\<^sup>*\<^sup>* = op ="
by(auto simp add: fun_eq_iff elim: rtranclp_induct)

lemmas rtranclp_induct3 =
  rtranclp_induct[where a="(ax, ay, az)" and b="(bx, by, bz)", split_rule, consumes 1, case_names refl step]

lemmas tranclp_induct3 =
  tranclp_induct[where a="(ax, ay, az)" and b="(bx, by, bz)", split_rule, consumes 1, case_names refl step]

lemmas rtranclp_induct4 =
  rtranclp_induct[where a="(ax, ay, az, aw)" and b="(bx, by, bz, bw)", split_rule, consumes 1, case_names refl step]

lemmas tranclp_induct4 =
  tranclp_induct[where a="(ax, ay, az, aw)" and b="(bx, by, bz, bw)", split_rule, consumes 1, case_names refl step]

lemmas converse_tranclp_induct2 =
  converse_tranclp_induct [of _ "(ax,ay)" "(bx,by)", split_rule,
                 consumes 1, case_names base step]

lemma wfP_induct' [consumes 1, case_names wfP]:
  "\<lbrakk>wfP r; \<And>x. (\<And>y. r y x \<Longrightarrow> P y) \<Longrightarrow> P x\<rbrakk> \<Longrightarrow> P a"
by(blast intro: wfP_induct)

lemma wfP_induct2 [consumes 1, case_names wfP]:
  "\<lbrakk>wfP r; \<And>x x'. (\<And>y y'. r (y, y') (x, x') \<Longrightarrow> P y y') \<Longrightarrow> P x x' \<rbrakk> \<Longrightarrow> P x x'"
by(drule wfP_induct'[where P="\<lambda>(x, y). P x y"]) blast+

lemma wfP_minimalE:
  assumes "wfP r"
  and "P x"
  obtains z where "P z" "r^** z x" "\<And>y. r y z \<Longrightarrow> \<not> P y"
proof -
  let ?Q = "\<lambda>x'. P x' \<and> r^** x' x"
  from `P x` have "?Q x" by blast
  from `wfP r` have "\<And>Q. x \<in> Q \<longrightarrow> (\<exists>z\<in>Q. \<forall>y. r y z \<longrightarrow> y \<notin> Q)"
    unfolding wfP_eq_minimal by blast
  from this[rule_format, of "Collect ?Q"] `?Q x`
  obtain z where "?Q z" and min: "\<And>y. r y z \<Longrightarrow> \<not> ?Q y" by auto
  from `?Q z` have "P z" "r^** z x" by auto
  moreover
  { fix y
    assume "r y z"
    hence "\<not> ?Q y" by(rule min)
    moreover from `r y z` `r^** z x` have "r^** y x"
      by(rule converse_rtranclp_into_rtranclp)
    ultimately have "\<not> P y" by blast }
  ultimately show thesis ..
qed

lemma coinduct_set_wf [consumes 3, case_names coinduct, case_conclusion coinduct wait step]:
  assumes "mono f" "wf r" "(a, b) \<in> X"
  and step: "\<And>x b. (x, b) \<in> X \<Longrightarrow> (\<exists>b'. (b', b) \<in> r \<and> (x, b') \<in> X) \<or> (x \<in> f (fst ` X \<union> gfp f))"
  shows "a \<in> gfp f"
proof -
  from `(a, b) \<in> X` have "a \<in> fst ` X" by(auto intro: rev_image_eqI)
  moreover
  { fix a b
    assume "(a, b) \<in> X"
    with `wf r` have "a \<in> f (fst ` X \<union> gfp f)"
      by(induct)(blast dest: step) }
  hence "fst ` X \<subseteq> f (fst ` X \<union> gfp f)" by(auto)
  ultimately show ?thesis by(rule coinduct_set[OF `mono f`])
qed

subsection {* reflexive transitive closure for label relations *}

inductive converse3p :: "('a \<Rightarrow> 'b \<Rightarrow> 'c \<Rightarrow> bool) \<Rightarrow> 'c \<Rightarrow> 'b \<Rightarrow> 'a \<Rightarrow> bool"
  for r :: "'a \<Rightarrow> 'b \<Rightarrow> 'c \<Rightarrow> bool"
where
  converse3pI: "r a b c \<Longrightarrow> converse3p r c b a"

lemma converse3p_converse3p: "converse3p (converse3p r) = r"
by(auto intro: converse3pI intro!: ext elim: converse3p.cases)

lemma converse3pD: "converse3p r c b a \<Longrightarrow> r a b c"
by(auto elim: converse3p.cases)

inductive rtrancl3p :: "('a \<Rightarrow> 'b \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'b list \<Rightarrow> 'a \<Rightarrow> bool"
  for r :: "'a \<Rightarrow> 'b \<Rightarrow> 'a \<Rightarrow> bool"
  where
  rtrancl3p_refl [intro!, simp]: "rtrancl3p r a [] a"
| rtrancl3p_step: "\<lbrakk> rtrancl3p r a bs a'; r a' b a'' \<rbrakk> \<Longrightarrow> rtrancl3p r a (bs @ [b]) a''"

lemmas rtrancl3p_induct3 =
  rtrancl3p.induct[of _ "(ax,ay,az)" _ "(cx,cy,cz)", split_format (complete),
                 consumes 1, case_names refl step]

lemmas rtrancl3p_induct4 =
  rtrancl3p.induct[of _ "(ax,ay,az,aw)" _ "(cx,cy,cz,cw)", split_format (complete),
                 consumes 1, case_names refl step]

lemma rtrancl3p_induct4' [consumes 1, case_names refl step]:
  assumes major: "rtrancl3p r (ax, (ay, az), aw) bs (cx, (cy, cz), cw)"
  and refl: "\<And>a aa b ba. P a aa b ba [] a aa b ba"
  and step: "\<And>a aa b ba bs ab ac bb bc bd ad ae be bf.
       \<lbrakk> rtrancl3p r (a, (aa, b), ba) bs (ab, (ac, bb), bc);
         P a aa b ba bs ab ac bb bc; r (ab, (ac, bb), bc) bd (ad, (ae, be), bf) \<rbrakk>
       \<Longrightarrow> P a aa b ba (bs @ [bd]) ad ae be bf"
  shows "P ax ay az aw bs cx cy cz cw"
using major
apply -
apply(drule_tac P="\<lambda>(a, (aa, b), ba) bs (cx, (cy, cz), cw). P a aa b ba bs cx cy cz cw" in rtrancl3p.induct)
by(auto intro: refl step)

lemma rtrancl3p_induct1:
  "\<lbrakk> rtrancl3p r a bs c; P a; \<And>bs c b d. \<lbrakk> rtrancl3p r a bs c; r c b d; P c \<rbrakk> \<Longrightarrow> P d \<rbrakk> \<Longrightarrow> P c"
apply(induct rule: rtrancl3p.induct)
apply(auto)
done

inductive_cases rtrancl3p_cases:
  "rtrancl3p r x [] y"
  "rtrancl3p r x (b # bs) y"

lemma rtrancl3p_trans [trans]:
  assumes one: "rtrancl3p r a bs a'"
  and two: "rtrancl3p r a' bs' a''"
  shows "rtrancl3p r a (bs @ bs') a''"
using two one
proof(induct rule: rtrancl3p.induct)
  case rtrancl3p_refl thus ?case by simp
next
  case rtrancl3p_step thus ?case
    by(auto simp only: append_assoc[symmetric] intro: rtrancl3p.rtrancl3p_step)
qed

lemma rtrancl3p_step_converse:
  assumes step: "r a b a'"
  and stepify: "rtrancl3p r a' bs a''"
  shows "rtrancl3p r a (b # bs) a''"
using stepify step
proof(induct rule: rtrancl3p.induct)
  case rtrancl3p_refl
  with rtrancl3p.rtrancl3p_refl[where r=r and a=a] show ?case
    by(auto dest: rtrancl3p.rtrancl3p_step simp del: rtrancl3p.rtrancl3p_refl)
next
  case rtrancl3p_step thus ?case
    unfolding append_Cons[symmetric]
    by -(rule rtrancl3p.rtrancl3p_step)
qed

lemma converse_rtrancl3p_step:
  "rtrancl3p r a (b # bs) a'' \<Longrightarrow> \<exists>a'. r a b a' \<and> rtrancl3p r a' bs a''"
apply(induct bs arbitrary: a'' rule: rev_induct)
 apply(erule rtrancl3p.cases)
  apply(clarsimp)+
 apply(erule rtrancl3p.cases)
  apply(clarsimp)
  apply(rule_tac x="a''a" in exI)
  apply(clarsimp)
 apply(clarsimp)
apply(erule rtrancl3p.cases)
 apply(clarsimp)
apply(clarsimp)
by(fastforce intro: rtrancl3p_step)

lemma converse_rtrancl3pD:
  "rtrancl3p (converse3p r) a' bs a \<Longrightarrow> rtrancl3p r a (rev bs) a'"
apply(induct rule: rtrancl3p.induct)
 apply(fastforce intro: rtrancl3p.intros)
apply(auto dest: converse3pD intro: rtrancl3p_step_converse)
done

lemma rtrancl3p_converse_induct [consumes 1, case_names refl step]:
  assumes ih: "rtrancl3p r a bs a''"
  and refl: "\<And>a. P a [] a"
  and step: "\<And>a b a' bs a''. \<lbrakk> rtrancl3p r a' bs a''; r a b a'; P a' bs a'' \<rbrakk> \<Longrightarrow> P a (b # bs) a''"
  shows "P a bs a''"
  using ih
proof(induct bs arbitrary: a a'')
  case Nil thus ?case
    by(auto elim: rtrancl3p.cases intro: refl)
next
  case Cons thus ?case
    by(auto dest!: converse_rtrancl3p_step intro: step)
qed

lemma rtrancl3p_converse_induct' [consumes 1, case_names refl step]:
  assumes ih: "rtrancl3p r a bs a''"
  and refl: "P a'' []"
  and step: "\<And>a b a' bs. \<lbrakk> rtrancl3p r a' bs a''; r a b a'; P a' bs \<rbrakk> \<Longrightarrow> P a (b # bs)"
  shows "P a bs"
using rtrancl3p_converse_induct[OF ih, where P="\<lambda>a bs a'. a' = a'' \<longrightarrow> P a bs"]
by(auto intro: refl step)

lemma rtrancl3p_converseE[consumes 1, case_names refl step]:
  "\<lbrakk> rtrancl3p r a bs a'';
     \<lbrakk> a = a''; bs = [] \<rbrakk> \<Longrightarrow> thesis;
     \<And>bs' b a'. \<lbrakk> bs = b # bs'; r a b a'; rtrancl3p r a' bs' a'' \<rbrakk> \<Longrightarrow> thesis \<rbrakk>
  \<Longrightarrow> thesis"
by(induct rule: rtrancl3p_converse_induct)(auto)

lemma rtrancl3p_induct' [consumes 1, case_names refl step]:
  assumes major: "rtrancl3p r a bs c"
  and refl: "P a [] a"
  and step: "\<And>bs a' b a''. \<lbrakk> rtrancl3p r a bs a'; P a bs a'; r a' b a'' \<rbrakk>
             \<Longrightarrow> P a (bs @ [b]) a''"
  shows "P a bs c"
proof -
  from major have "(P a [] a \<and> (\<forall>bs a' b a''. rtrancl3p r a bs a' \<and> P a bs a' \<and> r a' b a'' \<longrightarrow> P a (bs @ [b]) a'')) \<longrightarrow> P a bs c"
    by-(erule rtrancl3p.induct, blast+)
  with refl step show ?thesis by blast
qed

lemma r_into_rtrancl3p:
  "r a b a' \<Longrightarrow> rtrancl3p r a [b] a'"
by(rule rtrancl3p_step_converse) auto

lemma rtrancl3p_appendE:
  assumes "rtrancl3p r a (bs @ bs') a''"
  obtains a' where "rtrancl3p r a bs a'" "rtrancl3p r a' bs' a''"
using assms
apply(induct a "bs @ bs'" arbitrary: bs rule: rtrancl3p_converse_induct')
apply(fastforce intro: rtrancl3p_step_converse simp add: Cons_eq_append_conv)+
done

lemma rtrancl3p_Cons:
  "rtrancl3p r a (b # bs) a' \<longleftrightarrow> (\<exists>a''. r a b a'' \<and> rtrancl3p r a'' bs a')"
by(auto intro: rtrancl3p_step_converse converse_rtrancl3p_step)

lemma rtrancl3p_Nil:
  "rtrancl3p r a [] a' \<longleftrightarrow> a = a'"
by(auto elim: rtrancl3p_cases)

definition invariant3p :: "('a \<Rightarrow> 'b \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a set \<Rightarrow> bool"
where "invariant3p r I \<longleftrightarrow> (\<forall>s tl s'. s \<in> I \<longrightarrow> r s tl s' \<longrightarrow> s' \<in> I)"

lemma invariant3pI: "(\<And>s tl s'. \<lbrakk> s \<in> I; r s tl s' \<rbrakk> \<Longrightarrow> s' \<in> I) \<Longrightarrow> invariant3p r I"
unfolding invariant3p_def by blast

lemma invariant3pD: "\<And>tl. \<lbrakk> invariant3p r I; r s tl s'; s \<in> I \<rbrakk> \<Longrightarrow> s' \<in> I"
unfolding invariant3p_def by(blast)

lemma invariant3p_rtrancl3p:
  assumes inv: "invariant3p r I"
  and rtrancl: "rtrancl3p r a bs a'"
  and start: "a \<in> I"
  shows "a' \<in> I"
using rtrancl start by(induct)(auto dest: invariant3pD[OF inv])

lemma invariant3p_UNIV [simp, intro!]:
  "invariant3p r UNIV"
by(blast intro: invariant3pI)

lemma invarinat3p_empty [simp, intro!]:
  "invariant3p r {}"
by(blast intro: invariant3pI)

lemma invariant3p_IntI [simp, intro]:
  "\<lbrakk> invariant3p r I; invariant3p r J \<rbrakk> \<Longrightarrow> invariant3p r (I \<inter> J)"
by(blast dest: invariant3pD intro: invariant3pI)

subsection {* Concatenation for @{typ String.literal} *}

definition concat :: "String.literal list \<Rightarrow> String.literal"
where [code del]: "concat xs = String.implode (List.concat (map String.explode xs))"

code_printing
  constant concat \<rightharpoonup>
    (SML) "String.concat"
    and (Haskell) "concat"
    and (OCaml) "String.concat \"\""

hide_const (open) concat

end


section "Implementing Labelled Transition Systems by Maps"
theory DLTSByMap
imports LTSSpec LTSGA
begin

locale dltsbm_defs =
  m1: StdMap m1_ops +
  m2: StdMap m2_ops
  for m1_ops::"('V,'m2,'m1,_) map_ops_scheme"
  and m2_ops::"('W,'V,'m2,_) map_ops_scheme"
begin
  definition dltsbm_\<alpha> :: "('V,'W,'m1) lts_\<alpha>" where
    "dltsbm_\<alpha> m1 \<equiv> {(v,w,v').
      \<exists>m2. m1.\<alpha> m1 v = Some m2  \<and> m2.\<alpha> m2 w = Some v'}"

  definition "dltsbm_invar m1 \<equiv>
    m1.invar m1 \<and> (\<forall>m2 \<in> ran (m1.\<alpha> m1). m2.invar m2)"

  lemma dltsbm_invar_alt_def :
    "dltsbm_invar m1 =
     (m1.invar m1 \<and>
      (\<forall>v m2. m1.\<alpha> m1 v = Some m2 \<longrightarrow> (
         m2.invar m2)))"
  unfolding dltsbm_invar_def
  by (auto simp add: ran_def)

  lemma dltsbm_invar_alt_def2 :
    "dltsbm_invar m1 =
     (m1.invar m1 \<and>
      (\<forall>v m2. m1.lookup v m1 = Some m2 \<longrightarrow> (
         m2.invar m2)))"
  unfolding dltsbm_invar_alt_def
  by (auto simp add: m1.correct m2.correct)

  lemma dlts_correct : "dlts dltsbm_\<alpha> dltsbm_invar"
    unfolding dlts_def dltsbm_\<alpha>_def dltsbm_invar_alt_def
    by auto

  definition dltsbm_empty :: "('V,'W,'m1) lts_empty" where
    "dltsbm_empty \<equiv> m1.empty"

  lemma dltsbm_empty_correct:
    "lts_empty dltsbm_\<alpha> dltsbm_invar dltsbm_empty"
    unfolding lts_empty_def dltsbm_empty_def dltsbm_\<alpha>_def dltsbm_invar_def
    by (simp add: m1.correct)

  definition dltsbm_succ :: "('V,'W,'m1) lts_succ" where
    "dltsbm_succ l v e \<equiv>
     case m1.lookup v l of
        None \<Rightarrow> None |
        Some m2 \<Rightarrow> m2.lookup e m2"

  lemma dltsbm_succ_correct :
     "dlts_succ dltsbm_\<alpha> dltsbm_invar dltsbm_succ"
   unfolding dlts_succ_def dltsbm_invar_alt_def dltsbm_\<alpha>_def dltsbm_succ_def
   by (simp add: m1.correct m2.correct split: option.split)

  definition dltsbm_memb :: "('V,'W,'m1) lts_memb" where
    "dltsbm_memb l v e v' \<equiv>
     case m1.lookup v l of
        None \<Rightarrow> False |
        Some m2 \<Rightarrow> m2.lookup e m2 = Some v'"

  lemma dltsbm_memb_correct :
     "lts_memb dltsbm_\<alpha> dltsbm_invar dltsbm_memb"
   unfolding lts_memb_def dltsbm_invar_alt_def dltsbm_\<alpha>_def dltsbm_memb_def
   by (simp add: m1.correct m2.correct split: option.split)

  definition dltsbm_add :: "('V,'W,'m1) lts_add" where
    "dltsbm_add v w v' l \<equiv>
     case m1.lookup v l of
        None \<Rightarrow> (m1.update v (m2.sng w v') l) |
        Some m2 \<Rightarrow> m1.update v (m2.update w v' m2) l"

  lemma dltsbm_add_correct:
    "dlts_add dltsbm_\<alpha> dltsbm_invar dltsbm_add"
  proof
    fix l v w v'
    assume invar: "dltsbm_invar l"

    from invar
    show "dltsbm_invar (dltsbm_add v w v' l)"
      unfolding dltsbm_invar_alt_def dltsbm_add_def
      by (simp add: m1.correct m2.correct split: option.split if_split)

    assume "\<And>v''. v'' \<noteq> v' \<Longrightarrow> (v, w, v'') \<notin> dltsbm_\<alpha> l"
    with invar show "dltsbm_\<alpha> (dltsbm_add v w v' l) = insert (v, w, v') (dltsbm_\<alpha> l)"
      unfolding dltsbm_invar_alt_def dltsbm_\<alpha>_def dltsbm_add_def
      apply (simp add: m1.correct m2.correct set_eq_iff
               split: option.split if_split)
      apply auto
      apply metis
    done
  qed

  definition dltsbm_add_succs :: "('V,'W,'m1) lts_add_succs" where
    "dltsbm_add_succs v w vs l \<equiv> (case vs of [] \<Rightarrow> l | (v'#vs') \<Rightarrow> dltsbm_add v w v' l)"

  lemma dltsbm_add_succs_correct:
    "dlts_add_succs dltsbm_\<alpha> dltsbm_invar dltsbm_add_succs"
  proof
    fix l :: "'m1" and v :: 'V and w :: 'W and vs :: "'V list"
    assume invar: "dltsbm_invar l"

    note add_OK = dlts_add.dlts_add_correct [OF dltsbm_add_correct, OF invar]
    assume len_vs: "length vs < 2"
    assume l_OK: "\<And>v'. v' \<notin> set vs \<Longrightarrow> (v, w, v') \<notin> dltsbm_\<alpha> l"

    have "dltsbm_invar (dltsbm_add_succs v w vs l) \<and>
          dltsbm_\<alpha> (dltsbm_add_succs v w vs l) = dltsbm_\<alpha> l \<union> {(v, w, v') |v'. v' \<in> set vs}"
    proof (cases vs)
      case Nil thus ?thesis by (simp add: dltsbm_add_succs_def invar)
    next
      case (Cons v' vs')
      with len_vs have vs_eq[simp]:"vs = [v']" by auto
      with l_OK add_OK show ?thesis
        by (simp add: dltsbm_add_succs_def)
    qed
    thus "dltsbm_invar (dltsbm_add_succs v w vs l)"
         "dltsbm_\<alpha> (dltsbm_add_succs v w vs l) = dltsbm_\<alpha> l \<union> {(v, w, v') |v'. v' \<in> set vs}"
      by simp_all
  qed

  definition dltsbm_delete :: "('V,'W,'m1) lts_delete" where
    "dltsbm_delete v w v' m1 \<equiv>
     case m1.lookup v m1 of
        None \<Rightarrow> m1 |
        Some m2 \<Rightarrow> (case m2.lookup w m2 of
          None \<Rightarrow> m1 |
          Some v'' \<Rightarrow> if (v' = v'') then m1.update v (m2.delete w m2) m1 else m1)"

  lemma dltsbm_delete_correct:
    "lts_delete dltsbm_\<alpha> dltsbm_invar dltsbm_delete"
  proof
    fix l v w v'
    assume invar: "dltsbm_invar l"

    from invar
    show "dltsbm_invar (dltsbm_delete v w v' l)"
      unfolding dltsbm_invar_alt_def dltsbm_delete_def
      by (simp add: m1.correct m2.correct split: option.split if_split)

    from invar
    show "dltsbm_\<alpha> (dltsbm_delete v w v' l) = (dltsbm_\<alpha> l) - {(v, w, v')}"
      unfolding dltsbm_invar_alt_def dltsbm_\<alpha>_def dltsbm_delete_def
      apply (simp add: m1.correct m2.correct set_eq_iff restrict_map_def
               split: option.split if_split)
      apply auto
    done
  qed

  definition dltsbm_succ_it where
    "dltsbm_succ_it m1 v e =
     (case m1.lookup v m1 of
         None \<Rightarrow> set_iterator_emp
       | Some m2 \<Rightarrow>
           (case m2.lookup e m2 of
               None \<Rightarrow> set_iterator_emp
             | Some v' \<Rightarrow> set_iterator_sng v'))"

  lemma dltsbm_succ_it_correct :
    shows "lts_succ_it dltsbm_\<alpha> dltsbm_invar dltsbm_succ_it"
  unfolding lts_succ_it_def
  proof (intro allI impI)
    fix l v e
    assume invar_l: "dltsbm_invar l"
    from invar_l have invar_m1: "m1.invar l"
      unfolding dltsbm_invar_def by simp

    show "set_iterator (dltsbm_succ_it l v e)
             {v' . (v, e, v') \<in> dltsbm_\<alpha> l}"
    proof (cases "m1.lookup v l")
      case None note m1_v_eq = this
      with invar_m1 have "{v' |v'. (v, e, v') \<in> dltsbm_\<alpha> l} = {}"
        unfolding dltsbm_\<alpha>_def
         by (simp add: m1.correct)
      thus ?thesis
        unfolding dltsbm_succ_it_def
        by (simp add: m1_v_eq set_iterator_emp_correct)
    next
      case (Some m2) note m1_v_eq = this
      with invar_l have invar_m2: "m2.invar m2"
        unfolding dltsbm_invar_alt_def
        by (simp add: m1.correct)

      show ?thesis
      proof (cases "m2.lookup e m2")
        case None note m2_e_eq = this
        with invar_m1 invar_m2 m1_v_eq have "{v' |v'. (v, e, v') \<in> dltsbm_\<alpha> l} = {}"
          unfolding dltsbm_\<alpha>_def
           by (simp add: m1.correct m2.correct)
        thus ?thesis
          unfolding dltsbm_succ_it_def
          by (simp add: m1_v_eq m2_e_eq set_iterator_emp_correct)
      next
        case (Some v') note m2_e_eq = this
        with invar_m1 invar_m2 m1_v_eq have "{v' |v'. (v, e, v') \<in> dltsbm_\<alpha> l} = {v'}"
          unfolding dltsbm_\<alpha>_def
           by (simp add: m1.correct m2.correct)
        thus ?thesis
          unfolding dltsbm_succ_it_def
          by (simp add: m1_v_eq m2_e_eq set_iterator_sng_correct)
      qed
    qed
  qed

  definition dltsbm_succ_label_it where
    "dltsbm_succ_label_it it2 m1 v =
     (case m1.lookup v m1 of
         None \<Rightarrow> set_iterator_emp
       | Some m2 \<Rightarrow> it2 m2)"

  lemma dltsbm_succ_label_it_alt_def :
    "dltsbm_succ_label_it = (\<lambda>it2 m1 v.
      (case m1.lookup v m1 of
          None \<Rightarrow> \<lambda>c f \<sigma>0. \<sigma>0
        | Some m2 \<Rightarrow> it2 m2))"
    unfolding dltsbm_succ_label_it_def[abs_def]
              curry_def set_iterator_emp_def[abs_def] fst_conv snd_conv
    by simp

  lemma dltsbm_succ_label_it_correct :
    assumes it2_OK: "map_iteratei m2.\<alpha> m2.invar it2"
    shows "lts_succ_label_it dltsbm_\<alpha> dltsbm_invar (dltsbm_succ_label_it it2)"
  unfolding lts_succ_label_it_def
  proof (intro allI impI)
    fix l v
    assume invar_l: "dltsbm_invar l"
    from invar_l have invar_m1: "m1.invar l"
      unfolding dltsbm_invar_def by simp

    show "set_iterator (dltsbm_succ_label_it it2 l v)
             {(e, v') . (v, e, v') \<in> dltsbm_\<alpha> l}"
    proof (cases "m1.lookup v l")
      case None note m1_v_eq = this
      with invar_m1 have "{(e, v') |e v'. (v, e, v') \<in> dltsbm_\<alpha> l} = {}"
        unfolding dltsbm_\<alpha>_def
         by (simp add: m1.correct)
      thus ?thesis
        unfolding dltsbm_succ_label_it_def
        by (simp add: m1_v_eq set_iterator_emp_correct)
    next
      case (Some m2) note m1_v_eq = this
      with invar_l have invar_m2: "m2.invar m2"
        unfolding dltsbm_invar_alt_def
        by (simp add: m1.correct)

      have it2_OK': "map_iterator (it2 m2) (m2.\<alpha> m2)"
        using map_iteratei.iteratei_rule[OF it2_OK, OF invar_m2] by simp

      from m1_v_eq invar_m1 have "{(e, v') |e v'. (v, e, v') \<in> dltsbm_\<alpha> l} = map_to_set (m2.\<alpha> m2)"
        unfolding dltsbm_\<alpha>_def
        by (simp add: m1.correct map_to_set_def)

      with it2_OK' show ?thesis
        unfolding dltsbm_succ_label_it_def
        by (simp add: m1_v_eq set_iterator_emp_correct)
    qed
  qed

  definition dltsbm_filter_it where
    "dltsbm_filter_it it1 it2 P_v1 P_e P_v2 P m1 =
        set_iterator_filter (\<lambda>vev'. P_v2 (snd (snd vev')) \<and> P_e (fst (snd vev')) \<and> P vev')
        (map_iterator_product
           (map_iterator_key_filter P_v1 (it1 m1))
           it2)"

  lemma dltsbm_filter_it_alt_def :
     "dltsbm_filter_it = (\<lambda>it1 it2 P_v1 P_e P_v2 P m1 c f.
        it1 m1 c
         (\<lambda>(v1, m2) \<sigma>. if P_v1 v1
                then it2 m2 c
                      (\<lambda>(e, v2) \<sigma>. if P_v2 v2 \<and>
                                P_e e \<and> P (v1, (e, v2))
                             then f (v1, (e, v2)) \<sigma> else \<sigma>)
                      \<sigma>
                else \<sigma>))"
     unfolding dltsbm_filter_it_def[abs_def] map_iterator_product_alt_def split_def prod.collapse
               fst_conv snd_conv set_iterator_filter_alt_def map_iterator_key_filter_alt_def

     by simp

  lemma dltsbm_filter_it_correct :
    assumes it1_OK: "map_iteratei m1.\<alpha> m1.invar it1"
    assumes it2_OK: "map_iteratei m2.\<alpha> m2.invar it2"
    shows "lts_filter_it dltsbm_\<alpha> dltsbm_invar (dltsbm_filter_it it1 it2)"
  unfolding lts_filter_it_def
  proof (intro allI impI)
    fix l P_v1 P_e P_v2 P
    assume invar_l: "dltsbm_invar l"
    from invar_l have invar_m1: "m1.invar l"
      unfolding dltsbm_invar_def by simp

    let ?S_2'' = "\<lambda>m2. {(e, v'). m2.\<alpha> m2 e = Some v'}"

    { fix v m2
      assume l_v_eq:"(m1.\<alpha> l |` {v. P_v1 v}) v = Some m2"

      from invar_l l_v_eq have invar_m2: "m2.invar m2"
        unfolding dltsbm_invar_alt_def
        by (auto simp add: m1.correct restrict_map_eq)

      note it2_OK' = map_iteratei.iteratei_rule [OF it2_OK, OF invar_m2]
      hence "set_iterator (it2 m2) (?S_2'' m2)" unfolding map_to_set_def by simp
    } note it2_OK'' = this

    note it1_OK' = map_iteratei.iteratei_rule [OF it1_OK, OF invar_m1]
    note it1_OK'' = map_iterator_key_filter_correct [OF it1_OK', of P_v1]

    let ?it1'' = "map_iterator_product
      (map_iterator_key_filter P_v1 (it1 l)) it2"
    let ?S_1'' = "{(k, e). \<exists>v. m1.\<alpha> l k = Some v \<and> P_v1 k \<and>
           (case e of (e, v') \<Rightarrow> m2.\<alpha> v e = Some v')}"

    have S_1''_eq: "?S_1'' = {(v, e, v'). (v, e, v') \<in> dltsbm_\<alpha> l \<and> P_v1 v}"
      unfolding dltsbm_\<alpha>_def by auto

    from map_iterator_product_correct [OF it1_OK'', of it2 ?S_2''] it2_OK''
    have it1_OK'': "set_iterator ?it1''
       {(v, e, v'). (v, e, v') \<in> dltsbm_\<alpha> l \<and> P_v1 v}"
      by (simp add: restrict_map_eq S_1''_eq)

    from set_iterator_filter_correct [OF it1_OK'', of "\<lambda>vev'. P_v2 (snd (snd vev')) \<and> P_e (fst (snd vev')) \<and> P vev'"]
    show "set_iterator (dltsbm_filter_it it1 it2 P_v1 P_e P_v2 P l)
           {(v1, e, v2). (v1, e, v2) \<in> dltsbm_\<alpha> l \<and> P_v1 v1 \<and> P_e e \<and> P_v2 v2 \<and> P (v1, e, v2)}"
      unfolding dltsbm_filter_it_def[symmetric]
      apply simp
      apply (rule subst [where P = "set_iterator (dltsbm_filter_it it1 it2 P_v1 P_e P_v2 P l)"])
      apply auto
    done
  qed

  definition dltsbm_it where
    "dltsbm_it it1 it2 = ltsga_iterator (dltsbm_filter_it it1 it2)"

  lemma dltsbm_it_alt_def :
     "dltsbm_it = (\<lambda>it1 it2 m1 c f. it1 m1 c (\<lambda>(v1, m2). it2 m2 c (\<lambda>(e, v2). f (v1, e, v2))))"
     unfolding dltsbm_it_def[abs_def] ltsga_iterator_def dltsbm_filter_it_alt_def
     by simp

  lemma dltsbm_it_correct :
    assumes it1_OK: "map_iteratei m1.\<alpha> m1.invar it1"
    assumes it2_OK: "map_iteratei m2.\<alpha> m2.invar it2"
    shows "lts_iterator dltsbm_\<alpha> dltsbm_invar (dltsbm_it it1 it2)"
  unfolding dltsbm_it_def
  apply (rule ltsga_iterator_correct)
    apply (rule dltsbm_filter_it_correct)
    apply fact+
  done

  definition dltsbm_pre_it where
   "dltsbm_pre_it it1 (l::'m1) (v'::'V) (e::'W) =
    map_iterator_dom_filter (\<lambda>vm2.
      case m2.lookup e (snd vm2) of
         None \<Rightarrow> False
       | Some v'' \<Rightarrow> (v' = v'')) (it1 l)"

  lemma dltsbm_pre_it_alt_def :
    "dltsbm_pre_it =
     (\<lambda>it1 l v' e c f.
        it1 l c
         (\<lambda>kv \<sigma>.
             if case_option False ((=) v')
                 (map_op_lookup m2_ops e (snd kv))
             then f (fst kv) \<sigma> else \<sigma>))"
    unfolding dltsbm_pre_it_def[abs_def] map_iterator_dom_filter_alt_def curry_def
              fst_conv snd_conv by simp

  lemma dltsbm_pre_it_correct :
    assumes it1_OK: "map_iteratei m1.\<alpha> m1.invar it1"
    shows "lts_pre_it dltsbm_\<alpha> dltsbm_invar (dltsbm_pre_it it1)"
  unfolding lts_pre_it_def
  proof (intro allI impI)
    fix l v' e
    assume invar_l: "dltsbm_invar l"
    from invar_l have invar_m1: "m1.invar l"
      unfolding dltsbm_invar_def by simp

    from map_iteratei.iteratei_rule [OF it1_OK, OF invar_m1] have
      step1: "set_iterator (it1 l) (map_to_set (map_op_\<alpha> m1_ops l))" .

    from map_iterator_dom_filter_correct [OF step1,
      of "\<lambda>vm2. case m2.lookup e (snd vm2) of None \<Rightarrow> False | Some v'' \<Rightarrow> v'=v''"]
    have step2: "set_iterator (dltsbm_pre_it it1 l v' e)
          {k. \<exists>v. m1.\<alpha> l k = Some v \<and>
             (case m2.lookup e v of None \<Rightarrow> False
              | Some v'' \<Rightarrow> v'= v'')}"
      by (simp add: dltsbm_pre_it_def[symmetric])

   from invar_l
   have step3: "{k. \<exists>v. m1.\<alpha> l k = Some v \<and> (case m2.lookup e v of None \<Rightarrow> False
                                  | Some v'' \<Rightarrow> v' = v'')} =
                {v |v. (v, e, v') \<in> dltsbm_\<alpha> l}"
     unfolding dltsbm_\<alpha>_def dltsbm_invar_alt_def
     by (auto simp add: map_to_set_def m1.correct m2.correct split: option.splits)
        (metis m2.lookup_correct map_upd_eqD1)

   from step2 step3
   show "set_iterator (dltsbm_pre_it it1 l v' e) {v . (v, e, v') \<in> dltsbm_\<alpha> l}"
     unfolding dltsbm_pre_it_def by simp
  qed

  definition dltsbm_pre_label_it where
    "dltsbm_pre_label_it it1 it2 m1 v' =
        map_iterator_product (it1 m1)
           (\<lambda>m2. map_iterator_dom_filter ((=) v' \<circ> snd)
              (it2 m2))"

  lemma dltsbm_pre_label_it_alt_def :
     "dltsbm_pre_label_it =
      (\<lambda>it1 it2 m1 v' c f.
        it1 m1 c
         (\<lambda>a. it2 (snd a) c
               (\<lambda>kv \<sigma>.
                   if v' = snd kv then f (fst a, fst kv) \<sigma>
                   else \<sigma>)))"
     unfolding dltsbm_pre_label_it_def[abs_def] map_iterator_product_alt_def
               curry_def map_iterator_dom_filter_alt_def
               fst_conv snd_conv by simp

  lemma dltsbm_pre_label_it_correct :
    assumes it1_OK: "map_iteratei m1.\<alpha> m1.invar it1"
    assumes it2_OK: "map_iteratei m2.\<alpha> m2.invar it2"
    shows "lts_pre_label_it dltsbm_\<alpha> dltsbm_invar (dltsbm_pre_label_it it1 it2)"
  unfolding lts_pre_label_it_def
  proof (intro allI impI)
    fix l v'
    assume invar_l: "dltsbm_invar l"
    from invar_l have invar_m1: "m1.invar l"
      unfolding dltsbm_invar_def by simp

    let ?it_b = "\<lambda>m2. map_iterator_dom_filter ((=) v' \<circ> snd) (it2 m2)"
    let ?S_b = "\<lambda>m2. {e . m2.\<alpha> m2 e = Some v'}"

    { fix v m2
      assume l_v_eq: "m1.\<alpha> l v = Some m2"

      from invar_l l_v_eq have invar_m2: "m2.invar m2"
        unfolding dltsbm_invar_alt_def
        by (simp add: m1.correct)

      note it2_OK' = map_iteratei.iteratei_rule [OF it2_OK, OF invar_m2]
      from map_iterator_dom_filter_correct [OF it2_OK', of "(=) v' \<circ> snd"]
      have "set_iterator (?it_b m2) (?S_b m2)"
        by simp
    } note it_b_aux = this

    from invar_l
    have S_b_aux: "{(k, e). \<exists>v. m1.\<alpha> l k = Some v \<and> e \<in> ?S_b v} =
                   {(v, e) |v e. (v, e, v') \<in> dltsbm_\<alpha> l}"
      unfolding dltsbm_invar_alt_def dltsbm_\<alpha>_def
      by (auto simp add: m1.correct m2.correct)

    note it1_OK' = map_iteratei.iteratei_rule [OF it1_OK, OF invar_m1]
    from map_iterator_product_correct [OF it1_OK', of ?it_b ?S_b] S_b_aux it_b_aux
    show "set_iterator (dltsbm_pre_label_it it1 it2 l v')
             {(v, e) . (v, e, v') \<in> dltsbm_\<alpha> l} "
      by (simp add: dltsbm_pre_label_it_def[symmetric])
  qed
end

end


(******************************************************************************)
(* External Algorithm for Calculating the Transitive Closure in Isabelle/HOL  *)
(* Author: Frank Zeyda, University of York (UK)                               *)
(* Email: frank.zeyda@york.ac.uk                                              *)
(******************************************************************************)

section {* Efficiency Issue *}

theory transcl_issue
imports transcl "~~/src/HOL/Library/Code_Target_Numeral"
begin

subsection {* Comparison with a priori @{method eval} *}

text \<open>Let us define a graph with 80 edges.\<close>

definition myrel :: "nat rel" where
"myrel = {
( 1,  2), ( 2,  3), ( 3,  4), ( 4,  5), ( 5,  6), ( 6,  7), ( 7,  8), ( 8,  9),
(11, 12), (12, 13), (13, 14), (14, 15), (15, 16), (16, 17), (17, 18), (18, 19),
(21, 22), (22, 23), (23, 24), (24, 25), (25, 26), (26, 27), (27, 28), (28, 29),
(31, 32), (32, 33), (33, 34), (34, 35), (35, 36), (36, 37), (37, 38), (38, 39),
(41, 42), (42, 43), (43, 44), (44, 45), (45, 46), (46, 47), (47, 48), (48, 49),
(51, 52), (52, 53), (53, 54), (54, 55), (55, 56), (56, 57), (57, 58), (58, 59),
(61, 62), (62, 63), (63, 64), (64, 65), (65, 66), (66, 67), (67, 68), (68, 69),
(71, 72), (72, 73), (73, 74), (74, 75), (75, 76), (76, 77), (77, 78), (78, 79),
(81, 82), (82, 83), (83, 84), (84, 85), (85, 86), (86, 87), (87, 88), (88, 89),
(91, 92), (92, 93), (93, 94), (94, 95), (95, 96), (96, 97), (97, 98), (98, 99)}"

definition myrel_tc:
"myrel_tc = transcl(myrel)"

text \<open>The following actually performs fairly efficient (about 1s).\<close>

lemma "acyclic myrel"
(* apply (code_simp) *)
apply (eval)
done

text \<open>That is because it directly invokes the SML code below.\<close>

export_code acyclic in SML

text \<open>We trade the above for a supposedly more efficient program.\<close>

export_code acyclic_witness in SML

text \<open>The price to pay is defining and exporting code for @{const myrel_tc}.\<close>

export_code myrel_tc in SML

lemma "acyclic myrel"
apply (rule acyclic_witnessI)
apply (rule_tac x = "transcl(myrel)" in exI)
apply (eval)
done

text \<open>
  It turns out that the algorithm is overall still slightly slower than using
  the @{method eval} method a priori on @{term "acyclic R"}. I wonder if there
  could be an efficiency gain when we operate on larger relations. I believe
  the primary reason for the algorithmic solution being slower is related to
  parsing and perhaps the code generation of the closure term. Using the HOL
  theory \<open>Code_Target_Numeral\<close> improves matters reasonably. Perhaps we have
  to consider further tricks and tweaks to speed up code generation. I guess
  that symbolic evaluation (via @{method simp}) is not giving us any reward.
\<close>

subsection {* Symbolic Evaluation *}

text \<open>Let us check whether we can proof the proviso by simplification.\<close>

text \<open>Additional simplification laws for proving @{term "acyclic_witness R"}.\<close>

lemma empty_subset:
"({} \<subseteq> A) = True"
apply (simp)
done

lemma irrefl_empty:
"irrefl {} = True"
apply (unfold irrefl_def)
apply (clarsimp)
done

lemma irrefl_insert:
"irrefl (insert (x, y) r) = ((x \<noteq> y) \<and> irrefl r)"
apply (unfold irrefl_def)
apply (clarsimp)
apply (blast)
done

lemmas relcomp_empty =
  relcomp_empty1
  relcomp_empty2

lemma relcomp_insert:
"(insert (a, b) R) O (insert (c, d) S) =
  (if b = c then {(a, d)} else {}) \<union>
    ((insert (a, b) R) O S) \<union> (R O (insert (c, d) S))"
apply (auto)
done

text \<open>Relevant laws for simplifying equalities on @{type nat} values.\<close>

lemmas nat_eq_simps =
  Num.eq_numeral_simps
  Num.pred_numeral_simps
  Num.num.distinct
  Num.num.inject
  Num.eq_numeral_Suc
  Num.Suc_eq_numeral
  Nat.nat.distinct
  Nat.nat.inject
  Nat.One_nat_def

text \<open>Relevant laws to simplify subset and membership expressions.\<close>

lemmas mem_subset_simps =
  insert_iff empty_iff insert_subset empty_subset HOL.simp_thms

text \<open>Unfortunately, simplification proofs are not as efficiently as I hoped.\<close>

text \<open>Irreflexivity is not too bad...\<close>

lemma "irrefl transcl(myrel)"
apply (unfold irrefl_insert irrefl_empty)
apply (simp only: nat_eq_simps simp_thms)
oops

text \<open>
  But subset proofs already become perceivably slower. We could perhaps make
  them faster again by letting the algorithm produce a relation whose initial
  maplets precisely correspond to that of the input relation.
\<close>

lemma "myrel \<subseteq> transcl(myrel)"
apply (unfold myrel_def)
apply (simp only: mem_subset_simps nat_eq_simps)
oops

-- \<open>It gets really tricky when trying to prove the closure property.\<close>

lemma "myrel_tc O myrel \<subseteq> myrel_tc"
apply (unfold myrel_def myrel_tc)
-- \<open>Due to the size of the relation, @{method eval} seems to struggle too...\<close>
(* apply (eval) *)
-- \<open>But the below is much much slower, and in fact not practical...\<close>
(* apply (simp only: mem_subset_simps relcomp_insert relcomp_empty nat_eq_simps) *)
oops

text \<open>
  In conclusion, simplification to discharge the proviso might be difficult,
  unless we devise and implement a clever way to do it! Code evaluation may
  actually be the best method, despite having to trust the evaluator.
\<close>

subsection {* Evaluation Experiments *}

value "acyclic {(a, b), (c, d), (e, f), (g, h)}"
value "{(a, b), (c, d)} \<subseteq> {(e, f), (g, h), (i, j)}"
value "({a, b} O {c, d}) \<subseteq> {e, f}"

text \<open>
  Note that slow-down is also down to an expansion of numbers into chained
  applications of @{const Suc}. This can be alleviated by changing the way
  numbers are translated into code include the theory \<open>Code_Target_Numberal\<close>
  from the HOL library. The effort here btw is not generating the code but
  translating it back into a HOL term.
\<close>

value myrel

text \<open>
  The difference in efficiency between the two evaluations below is explained
  through the effort of encoding @{const myrel_tc} before the code evaluation
  can be executed. (There is no effort in translating the result back here.)
  The question is whether the efficiency gained by executing our external C++
  algorithm dominates the efficiency lost by having to encode @{const myrel_tc}
  rather than @{const myrel}. I suppose this will be the case for relations
  larger than a certain size, but those might in any case be too big in order
  to process within Isabelle... :-(. The only thing we could do is to somewhat
  try and reduce the effort in code translation of large relations. Perhaps
  the problem is less pronounced if we used strings rather than numbers.
\<close>

value "irrefl (ntrancl 100 myrel)"
value "irrefl transcl(myrel)"

text \<open>
  Another pitfall to look out for is to avoid large expanded terms in favour
  of encapsulating them into local variables via `\<open>let x = _ in _\<close>' or global
  constants. This makes the code translation more efficient as a side-effect,
  approximately by a factor of 1.5 below.
\<close>

value "myrel_tc O myrel \<subseteq> myrel_tc"

value "transcl(myrel) O myrel \<subseteq> transcl(myrel)"

text \<open>
  Let us try to customise code generation to discharge the closure proviso.
\<close>

definition cl_proviso :: "'a rel \<Rightarrow> 'a rel \<Rightarrow> bool" where
[code del]: "cl_proviso C R = (C O R \<subseteq> C)"

lemma cl_proviso_set [code]:
"cl_proviso C (set []) = True"
"cl_proviso C (set [y]) = (\<forall>x\<in>C. (snd x) = (fst y) \<longrightarrow> (fst x, snd y) \<in> C)"
"cl_proviso C (set (x # y # t)) =
  (cl_proviso C (set [x]) \<and> cl_proviso C (set (y # t)))"
apply (unfold cl_proviso_def)
apply (fastforce)+
done

export_code cl_proviso in SML

text \<open>In terms of speed, there is, however, no discernible difference.\<close>

value "cl_proviso myrel_tc myrel"
value "myrel_tc O myrel \<subseteq> myrel_tc"

lemma "cl_proviso transcl(myrel) myrel"
apply (eval)
oops

lemma "myrel_tc O myrel \<subseteq> myrel_tc"
apply (eval)
oops

subsection {* Conclusion *}

text \<open>
  The investigation revealed that the approach using an external algorithm and
  certifying the result might not universally faster than an immediate attack
  on @{term "acyclic R"} with the @{method eval} method. The reason is that we
  need cannot discharge the proviso @{const acyclic_witness} of the respective
  theorem @{thm [source] acyclic_witnessI} efficiently by simplification, and
  evaluation likewise incurs an overhead of encoding the (larger) relation that
  is to be certified. Direct proof of @{term "acyclic R"}, on the other hand,
  profits from a smaller relation to encode as part of code generation, and I
  presume for the external algorithm to dominate the naive one carried out by
  @{const acyclic} using @{const ntrancl} we need to consider much larger sets
  whose processing in Isabelle will already pose challenges.
\<close>

text \<open>
  All this is a bit disheartening, bearing in mind the effort that went into
  developing the tool chain. I still believe that for larger relations, it is
  faster than plain @{method eval} but this requires some more investigation.
  If time, it would be interesting to see if code generation of larger sets
  can somewhat be improved. Alternatively, one could write a (more) efficient
  algorithm for the transitive closure in ML and verify it in Isabelle/HOL.
  Lastly, the perhaps the C++ tool could be invoked after code generation has
  taken place. In that case, \<open>transcl(_)\<close> will actually be a function whose
  sole purpose is to be expanded during code generation (it does not have a
  HOL semantics). This might solve the efficiency trade-off (point 2 below).

  The two bottle-necks seem to be
    1. Declaring and Processing constants of large relations \<open>R\<close> and \<open>C\<close>.
    2. Code generation that discharges the proviso @{term "acyclic_witness C"}.

  The bottle-neck is not executing the algorithm per se --- this, at least,
  seems indeed to take place very efficiently. A side issue is whether the
  @{method eval} tactic results in a trusted proof. The link

  \url{https://lists.cam.ac.uk/pipermail/cl-isabelle-users/2013-September/msg00014.html}

  to the Isabelle mailing list seems quite instructive. There seem to be three
  tactics: @{method code_simp}, @{method normalization}, and @{method eval}.
  The first one is fully trusted, the second and third one are not, using code
  evaluation and execution as an oracle.
\<close>
end