theory Closure_Mumble
  imports Language
begin

inductive_set mumble :: "('a \<times> 'a) llist \<Rightarrow> ('a \<times> 'a) lan" for xs where
  self [simp, intro!]: "xs \<in> mumble xs"
| mumble [dest]: "ys \<frown> LCons (\<sigma>, \<sigma>') (LCons (\<sigma>', \<sigma>'') zs) \<in> mumble xs \<Longrightarrow> ys \<frown> LCons (\<sigma>, \<sigma>'') zs \<in> mumble xs"

definition Mumble :: "('a \<times> 'a) lan \<Rightarrow> ('a \<times> 'a) lan" ("_\<^sup>\<dagger>" [1000] 1000) where
  "X\<^sup>\<dagger> = \<Union>{mumble xs |xs. xs \<in> X}"

lemma env_mumble: "lfinite ys  \<Longrightarrow> R \<subseteq> S \<Longrightarrow> env R (ys \<frown> LCons (\<sigma>, \<sigma>') (LCons (\<sigma>'', \<sigma>''') xs)) \<Longrightarrow> env S (ys \<frown> LCons (\<sigma>, \<sigma>''') xs)"
proof (induct ys rule: lfinite.induct)
  case lfinite_LNil
  thus ?case
    apply (cases xs)
    apply (metis EqSingle lappend_code(1))
    by (metis (no_types, hide_lams) env_LCons env_iso lappend_code(1) prod.collapse)
next
  case (lfinite_LConsI xs' x')
  thus ?case
    apply simp
    apply (cases xs')
    apply auto
    by (metis env_split2 lappend_assoc lappend_code(1) lappend_snocL1_conv_LCons2 lfinite_LCons lfinite_LConsI.hyps(2) lfinite_code(1))
qed

lemma env_mumble2: "lfinite ws \<Longrightarrow> env (R\<^sup>*) (ws \<frown> ((\<sigma>, \<sigma>'') # vs)) \<Longrightarrow> env (R\<^sup>*) (ws \<frown> ((\<sigma>, \<sigma>') # (\<sigma>', \<sigma>'') # vs))"
proof (induct ws rule: lfinite.induct)
  case lfinite_LNil
  thus ?case
    by (cases vs) auto
next
  case (lfinite_LConsI xs' x)
  thus ?case
    apply simp
    apply (cases xs')
    apply auto
    by (metis env_split2 lappend_assoc lappend_code(1) lappend_snocL1_conv_LCons2 lfinite_LCons lfinite_LConsI.hyps(2) lfinite_code(1))
qed

lemma mumble_preserves_env: "xs \<in> mumble ys \<Longrightarrow> env R ys \<Longrightarrow> env R xs"
proof (induct xs rule: mumble.induct)
  case self thus ?case by simp
next
  case (mumble ws \<sigma> \<sigma>' \<sigma>'' vs)
  thus ?case
    by (metis env_mumble lappend_inf subset_iff)
qed

lemma mumble_preserves_env2: "xs \<in> mumble ys \<Longrightarrow> env (R\<^sup>*) xs \<Longrightarrow> env (R\<^sup>*) ys"
proof (induct xs rule: mumble.induct)
  case self thus ?case by simp
next
  case (mumble ws \<sigma> \<sigma>' \<sigma>'' vs)
  thus ?case
    by (metis env_mumble2 lappend_inf)
qed

lemma mumble_preserves_env_var [dest]: "xs \<in> mumble ys \<Longrightarrow> R \<subseteq> S \<Longrightarrow> env R ys \<Longrightarrow> env S xs"
proof (induct xs rule: mumble.induct)
  case self thus ?case
    by (metis env_iso)
next
  case (mumble ws \<sigma> \<sigma>' \<sigma>'' vs)
  thus ?case
    by (metis env_mumble lappend_inf order_refl)
qed

lemma mumble_rely: "xs \<in> mumble ys \<Longrightarrow> rely R ys ys' \<Longrightarrow> (\<exists>xs'. xs' \<in> mumble ys' \<and> rely R xs xs')"
proof (induct xs rule: mumble.induct)
  case self
  thus ?case
    by (metis mumble.self)
next
  case (mumble ws \<sigma> \<sigma>' \<sigma>'' vs)

  from mumble(2)[OF mumble(3)]
  obtain xs'
  where "xs' \<in> mumble ys'" and "rely R (ws \<frown> ((\<sigma>, \<sigma>') # (\<sigma>', \<sigma>'') # vs)) xs'"
    by metis

  thus ?case
    sorry
qed

lemma mumble_rely': "xs \<in> mumble ys \<Longrightarrow> rely R xs xs' \<Longrightarrow> (\<exists>ys'. xs' \<in> mumble ys' \<and> rely R ys ys')"
  sorry

lemma mumble_Rely_1: "R \<rhd> (X\<^sup>\<dagger>) \<subseteq> (R \<rhd> X)\<^sup>\<dagger>"
  apply (simp add: Rely_def Mumble_def subset_iff)
  apply clarify
  by (metis mumble_rely')

lemma mumble_Rely_2: "(R \<rhd> X)\<^sup>\<dagger> \<subseteq> R \<rhd> (X\<^sup>\<dagger>)"
  apply (simp add: Rely_def Mumble_def subset_iff)
  apply clarify
  by (metis mumble_rely rely_sym)

lemma mumble_Rely: "(R \<rhd> X)\<^sup>\<dagger> = R \<rhd> (X\<^sup>\<dagger>)"
  by (metis mumble_Rely_1 mumble_Rely_2 subset_antisym)

lemma mumble_trans: "xs \<in> mumble ys \<Longrightarrow> ys \<in> mumble zs \<Longrightarrow> xs \<in> mumble zs"
proof (induct xs rule: mumble.induct)
  case self
  thus ?case .
next
  case (mumble ws \<sigma> \<sigma>' \<sigma>'' vs)
  from mumble(2)[OF mumble(3)]
  show ?case
    by (rule mumble.mumble)
qed

lemma mumble_lappend: "xs \<in> mumble xs' \<Longrightarrow> ys \<in> mumble ys' \<Longrightarrow> (xs \<frown> ys) \<in> mumble (xs' \<frown> ys')"
proof (induct xs rule: mumble.induct)
  case self
  thus ?case
  proof (induct ys rule: mumble.induct)
    case self
    show ?case
      by (metis mumble.self)
  next
    case (mumble ws \<sigma> \<sigma>' \<sigma>'' vs)
    thus ?case
      by (metis lappend_assoc mumble.mumble)
  qed
next
  case (mumble ws \<sigma> \<sigma>' \<sigma>'' vs)
  thus ?case
    by (metis lappend_assoc lappend_code(2) mumble.mumble)
qed

lemma Mumble_iso: "X \<subseteq> Y \<Longrightarrow> X\<^sup>\<dagger> \<subseteq> Y\<^sup>\<dagger>"
  by (auto simp add: Mumble_def)

lemma Mumble_ext: "X \<subseteq> X\<^sup>\<dagger>"
  by (auto simp add: Mumble_def)

lemma Mumble_idem [simp]: "X\<^sup>\<dagger>\<^sup>\<dagger> = X\<^sup>\<dagger>"
proof -
  have "X\<^sup>\<dagger>  \<subseteq> X\<^sup>\<dagger>\<^sup>\<dagger>"
    by (metis Mumble_ext)
  thus "X\<^sup>\<dagger>\<^sup>\<dagger> = X\<^sup>\<dagger>"
    by (auto dest: mumble_trans simp add: Mumble_def)
qed

lemma Mumble_union [simp]: "(X \<union> Y)\<^sup>\<dagger> = X\<^sup>\<dagger> \<union> Y\<^sup>\<dagger>"
  by (auto simp add: Mumble_def)

lemma Mumble_continuous: "(\<Union>\<XX>)\<^sup>\<dagger> = \<Union>{X\<^sup>\<dagger> |X. X \<in> \<XX>}"
  by (auto simp add: Mumble_def)

lemma Mumble_Env_l [simp]: "(R \<Colon> S)\<^sup>\<dagger> \<subseteq> R \<Colon> (S\<^sup>\<dagger>)"
  by (auto simp add: Mumble_def Env_def)

lemma Mumble_Env_r [simp]: "R \<Colon> (S\<^sup>\<dagger>) \<subseteq> (R \<Colon> S)\<^sup>\<dagger>"
  apply (auto simp add: Env_def)
  apply (simp add: Mumble_def)
  apply (erule exE)
  apply (erule conjE)
  apply (erule exE)+
  apply (erule conjE)
  apply (rule_tac x = xa in exI)
  apply simp
  apply (rule_tac x = xs in exI)
  apply simp
  by (metis mumble_preserves_env2)

lemma Mumble_Env: "(R \<Colon> S)\<^sup>\<dagger> = R \<Colon> (S\<^sup>\<dagger>)"
  by (metis Mumble_Env_l Mumble_Env_r subset_antisym)

lemma Mumble_meet [simp]: "(X\<^sup>\<dagger> \<inter> Y\<^sup>\<dagger>)\<^sup>\<dagger> = X\<^sup>\<dagger> \<inter> Y\<^sup>\<dagger>"
  by (auto dest: mumble_trans simp add: Mumble_def)

lemma mumble_infinite [dest]: "ys \<in> mumble xs \<Longrightarrow> \<not> lfinite xs \<Longrightarrow> \<not> lfinite ys"
  by (induct ys rule: mumble.induct) auto

lemma "mumble xs \<cdot> mumble ys \<subseteq> mumble (xs \<frown> ys)"
  apply (simp add: l_prod_def)
  apply safe
  apply (metis lappend_inf mumble.self mumble_lappend)
  by (metis mumble_lappend)

lemma [dest!]: "llength xs = \<infinity> \<Longrightarrow> LNil \<in> xs \<sha> ys \<Longrightarrow> False"
  by (auto simp add: tshuffle_words_def)

notation ltake ("\<up>")
  and ldrop ("\<down>")

lemma LCons_lappend_LNil: "LCons y ys = LCons y LNil \<frown> ys"
  by (metis lappend_code(1) lappend_code(2))

lemma interleave_ldropWhile: "(\<exists>t'\<in>lset t. \<exists>a. t' = Inl a) \<Longrightarrow> ldropWhile is_right (traj t) = LCons (Inl ()) (ltl (ldropWhile is_right (traj t)))"
  by (metis interleave_ltakeWhile_is_right is_right.simps(2) lappend_LNil2 lappend_ltakeWhile_ldropWhile ldropWhile_rights_not_LNil reinterleave split_llist)

lemma shuffle_lset: "t \<in> xs \<sha> ys \<Longrightarrow> lset t = Inl ` (lset xs) \<union> Inr ` (lset ys)"
  apply (auto simp add: tshuffle_words_def lefts_def rights_def image_def)
  sorry

lemma lappend_not_LNil_iff [simp]: "xs \<frown> ys \<noteq> LNil \<longleftrightarrow> xs \<noteq> LNil \<or> ys \<noteq> LNil"
  by (metis LNil_eq_lappend_iff)

(* Lemmas for simplifying trajectory based goals *)

lemma traj_not_LNil: "traj t \<noteq> LNil \<longleftrightarrow> t \<noteq> LNil"
  by (metis reinterleave traj_LNil traj_interleave)

lemma ltakeWhile_right_traj [simp]: "ltakeWhile is_right (traj t) = traj (ltakeWhile is_right t)"
  by (simp add: traj_def ltakeWhile_lmap)

lemma ltakeWhile_left_traj [simp]: "ltakeWhile is_left (traj t) = traj (ltakeWhile is_left t)"
  by (simp add: traj_def ltakeWhile_lmap)

lemma ltl_traj [simp]: "ltl (traj t) = traj (ltl t)"
  by (simp add: traj_def)

lemma ldropWhile_right_traj [simp]: "ldropWhile is_right (traj t) = traj (ldropWhile is_right t)"
  by (simp add: traj_def ldropWhile_lmap)

lemma ldropWhile_left_traj [simp]: "ldropWhile is_left (traj t) = traj (ldropWhile is_left t)"
  by (simp add: traj_def ldropWhile_lmap)

lemma traj_LCons: "traj (LCons x xs) = LCons (\<langle>\<lambda>x. Inl (),\<lambda>x. Inr ()\<rangle> x) (traj xs)"
  by (simp add: traj_def)

lemma traj_llist_Case [simp]:
  fixes ys :: "('a + 'b) llist"
  shows "llist_Case LNil (\<lambda>x xs. xs) (traj ys) = traj (llist_Case LNil (\<lambda>x xs. xs) ys)"
  by (cases ys) (simp_all add: llist_Case_def traj_LCons)

lemma llength_traj [simp]: "llength (traj xs) = llength xs"
  by (simp add: traj_def)

lemma lfilter_right_traj [simp]: "lfilter is_right (traj xs) = traj (lfilter is_right xs)"
  by (auto simp add: traj_def lfilter_lmap)

lemma ldeleteLeft_nat_traj [simp]: "ldeleteLeft_nat n (traj t) = traj (ldeleteLeft_nat n t)"
proof (induct n arbitrary: t)
  case 0 show ?case by simp
next
  case (Suc n)
  thus ?case
    apply auto
    apply (rule arg_cong) back
    apply (simp add: llist_Case_def)
    apply (cases "ldropWhile is_right t")
    by (simp_all add: traj_LCons del: ldropWhile_eq_LNil_iff)
qed

lemma [simp]: "traj (ltakeWhile is_right t) \<frown> traj (ldropWhile is_right t) = traj t"
  by (metis lappend_ltakeWhile_ldropWhile traj_lappend)

lemma [simp]: "lfilter is_left (ltakeWhile is_right t) = LNil"
  by (metis Not_is_left lfilter_ltakeWhile)

lemma "lfilter is_right (ltakeWhile is_right t) = ltakeWhile is_right t"
  by (metis Not_is_left lfilter_left_right lfilter_ltakeWhile)

lemma [simp]: "ldeleteLeft n (traj t) = traj (ldeleteLeft n t)"
  by (cases n) simp_all

lemma tshuffle_left_LCons: "xs \<in> LCons y ys \<sha> zs \<Longrightarrow> ldeleteLeft_nat 0 xs \<in> ys \<sha> zs"
  apply simp
  apply (auto simp add: tshuffle_words_def lefts_def rights_def)
  apply (subst lfilter_lappend_lfinite)
  apply (metis Not_is_left lappend_inf lappend_ltakeWhile_ldropWhile lfilter_ltakeWhile llength_LCons llength_LNil zero_ne_eSuc)
  apply simp
  apply (metis Not_is_left ltl_lfilter ltl_simps(2))
  apply (subst lfilter_lappend_lfinite)
  apply (metis Not_is_left lappend_inf lappend_ltakeWhile_ldropWhile lfilter_ltakeWhile llength_LCons llength_LNil zero_ne_eSuc)
  apply simp
  apply (subst lfilter_lappend_lfinite[symmetric])
  apply (metis Not_is_left lappend_inf lappend_ltakeWhile_ldropWhile lfilter_ltakeWhile llength_LCons llength_LNil zero_ne_eSuc)
  apply (cases "ldropWhile is_right xs")
  apply simp
  apply (metis lappend_LNil2 lappend_ltakeWhile_ldropWhile)
  apply simp
  by (metis lappend_ltakeWhile_ldropWhile)

lemma [simp]: "traj (lmap Inl xs) = lmap (\<lambda>x. Inl ()) xs"
  by (simp add: traj_def)

lemma [simp]: "ltakeWhile is_right (lmap (\<lambda>x. Inl ()) xs) = LNil"
  by (auto simp add: ltakeWhile_lmap)

lemma [simp]: "ldropWhile is_right (lmap (\<lambda>x. Inl ()) xs) = lmap (\<lambda>x. Inl ()) xs"
  by (cases xs) simp_all

lemma interleave_only_left_var: "llength t = llength xs \<Longrightarrow> xs \<triangleright> lmap (\<lambda>x. Inl ()) t \<triangleleft> zs = lmap Inl xs"
  by (metis (full_types) interleave_only_left lmap_const_llength)

lemma [simp]: "lfilter is_right (ltakeWhile is_right xs) = ltakeWhile is_right xs"
  by (metis Not_is_left lfilter_left_right lfilter_ltakeWhile)

lemma llength_enat_0 [dest!]: "llength xs = enat 0 \<Longrightarrow> xs = LNil"
  by (metis enat_0 llength_eq_0 lnull_def)

lemma lmap_unl_Inl: "(\<forall>x\<in>lset xs. is_left x) \<Longrightarrow> lmap unl xs = ys \<longleftrightarrow> xs = lmap Inl ys"
  apply (auto simp del: lmap.compositionality)
  apply (rule sym)
  apply (rule lmap2_id_var)
  apply auto
  by (metis is_left.simps(2) obj_sumE unl.simps(1))

lemma lmap_unr_Inr: "(\<forall>x\<in>lset xs. is_right x) \<Longrightarrow> lmap unr xs = ys \<longleftrightarrow> xs = lmap Inr ys"
  apply (auto simp del: lmap.compositionality)
  apply (rule sym)
  apply (rule lmap2_id_var)
  apply auto
  by (metis is_right.simps(2) obj_sumE unr.simps(1))

lemma [simp]: "\<forall>x\<in>lset xs. is_right x \<Longrightarrow> lfinite xs \<Longrightarrow> ldropWhile is_right (xs \<frown> ys) = ldropWhile is_right ys"
  by (simp add: ldropWhile_lappend)

lemma lefts_LCons_lfinite_rights: "\<ll> xs = LCons y ys \<Longrightarrow> lfinite (ltakeWhile is_right xs)"
  by (metis lefts_ltake_right lfinite_ltakeWhile llist.distinct(1) ltakeWhile_all)

lemma lfilter_lefts_LCons_lfinite_rights: "lfilter is_left xs = LCons (Inl y) (lmap Inl ys) \<Longrightarrow> lfinite (ltakeWhile is_right xs)"
  by (metis lefts_LCons_lfinite_rights lefts_LConsl lefts_def_var lfilter_idem)

primrec ldelete_nat :: "nat \<Rightarrow> 'a llist \<Rightarrow> 'a llist" where
  "ldelete_nat 0 xs = llist_Case LNil (\<lambda>x' xs'. xs') xs"
| "ldelete_nat (Suc n) xs = llist_Case LNil (\<lambda>x' xs'. LCons x' (ldelete_nat n xs')) xs"

primrec ldelete :: "enat \<Rightarrow> 'a llist \<Rightarrow> 'a llist" where
  "ldelete (enat n) xs = ldelete_nat n xs"
| "ldelete \<infinity> xs = xs"

lemma ldropWhile_lfilter_rl_LNil: "ldropWhile is_right xs = LNil \<longleftrightarrow> lfilter is_left xs = LNil"
  apply auto
  apply (metis diverge_lfilter_LNil ldropWhile_eq_LNil_iff not_is_left)
  by (metis ldropWhile_eq_LNil_iff lfilter_empty_conv not_is_right)

lemma ldropWhile_lfilter_LConsD: "ldropWhile P xs = LCons y ys \<Longrightarrow> lfilter (Not \<circ> P) xs = LCons y (lfilter (Not \<circ> P) ys)"
  by auto

lemma [simp]: "\<not> lfinite (ltakeWhile is_right xs) \<Longrightarrow> lfilter is_left xs = LNil"
  by (metis diverge_lfilter_LNil lfinite_ltakeWhile not_is_right)

lemma lfilter_ldeleteLeft_nat: "lfilter is_left (ldeleteLeft_nat n xs) = ldelete_nat n (lfilter is_left xs)"
proof (induct n arbitrary: xs)
  case 0
  show ?case
    apply simp
    apply (cases "lfinite (ltakeWhile is_right xs)")
    apply (simp_all add: llist_Case_def)
    apply (metis Not_is_left ltl_def ltl_lfilter)
    by (simp add: lappend_inf)
next
  case (Suc n)
  thus ?case
    apply simp
    apply (cases "lfinite (ltakeWhile is_right xs)")
    apply (subst lfilter_lappend_lfinite)
    apply assumption
    apply (simp add: llist_Case_def)
    apply (cases "ldropWhile is_right xs")
    apply (frule ldropWhile_lfilter_rl_LNil[THEN iffD1])
    apply simp
    apply (frule ldropWhile_lfilter_LConsD)
    apply (frule ldropWhile_LConsD)
    apply (simp only: Not_is_right[symmetric])
    apply simp
    apply (metis not_is_right)
    by (simp add: lappend_inf llist_Case_def)
qed

lemma lfilter_ldeleteLeft: "lfilter is_left (ldeleteLeft n xs) = ldelete n (lfilter is_left xs)"
  by (metis enat.exhaust ldelete.simps(1) ldelete.simps(2) ldeleteLeft.simps(1) ldeleteLeft.simps(2) lfilter_ldeleteLeft_nat)

lemma lfilter_lefts_LCons:
  assumes "lfilter is_left xs = LCons (Inl y) (lmap Inl ys)"
  shows "lfilter is_left (ltakeWhile is_right xs \<frown> ltl (ldropWhile is_right xs)) = lmap Inl ys"
  using assms
  apply -
  apply (frule lfilter_lefts_LCons_lfinite_rights)
  apply (subst lfilter_lappend_lfinite)
  apply assumption
  apply simp
  apply (drule lfilter_eq_LCons)
  apply (erule exE)
  by (metis Not_is_left ltl_simps(2))

lemma ldelete_nat_lappend [simp]: "llength xs = enat n \<Longrightarrow> ldelete_nat n (xs \<frown> LCons y ys) = xs \<frown> ys"
proof (induct n arbitrary: xs)
  case 0 thus ?case
    by - (drule llength_enat_0, auto simp add: llist_Case_def)
next
  case (Suc n)

  from Suc(2)
  have "\<exists>x' xs'. xs = LCons x' xs'"
    by (metis Zero_not_Suc enat.inject llength_LNil llist.exhaust zero_enat_def)
  then obtain x' xs' where xs_def: "xs = LCons x' xs'" by blast

  from Suc(2)
  have "llength xs' = enat n"
    by (simp add: xs_def eSuc_enat[symmetric])

  hence [simp]: "ldelete_nat n (xs' \<frown> LCons y ys) = xs' \<frown> ys"
    by (metis Suc.hyps)

  thus ?case
    by (auto simp add: llist_Case_def xs_def)
qed

lemma ldelete_llength_lappend: "\<exists>y. zs = xs \<frown> LCons y ys \<Longrightarrow> ldelete (llength xs) zs = xs \<frown> ys"
  by (cases "llength xs") auto

lemma lfilter_ltl: "(P (lhd xs) \<Longrightarrow> lfilter P xs = LCons (lhd xs) ys) \<Longrightarrow> (\<not> P (lhd xs) \<Longrightarrow> lfilter P xs = ys) \<Longrightarrow> lfilter P (ltl xs) = ys"
  by (simp add: ltl_def, cases xs, auto)

lemma [simp]: "lfilter is_left (ldropWhile is_right t) = lfilter is_left t"
proof -
  {
    assume case1: "lfinite (ltakeWhile is_right t)"

    have "lfilter is_left t = lfilter is_left (ltakeWhile is_right t \<frown> ldropWhile is_right t)"
      by (metis lappend_ltakeWhile_ldropWhile)
    also have "... = lfilter is_left (ldropWhile is_right t)"
      by (metis Not_is_left case1 lappend_code(1) lfilter_lappend_lfinite lfilter_ltakeWhile)
    finally have "lfilter is_left (ldropWhile is_right t) = lfilter is_left t"
      by auto
  }
  moreover
  {
    assume case2: "\<not> lfinite (ltakeWhile is_right t)"
    hence "ldropWhile is_right t = LNil"
      by (metis ldropWhile_eq_LNil_iff lfinite_ltakeWhile)
    moreover from case2 have "lfilter is_left t = LNil"
      by (metis calculation ldropWhile_lfilter_rl_LNil)
    ultimately have "lfilter is_left (ldropWhile is_right t) = lfilter is_left t"
      by auto
  }
  ultimately show ?thesis by blast
qed

lemma lefts_LCons_deleteLeft:
  assumes "\<ll> t = LCons x (xs \<frown> LCons y ys)"
  shows "\<ll> (ldeleteLeft (llength xs) (ltl (ldropWhile is_right t))) = xs \<frown> ys"
  using assms
  apply -
  apply (erule rev_mp)
  apply (simp add: lefts_def)
  apply (simp add: lfilter_ldeleteLeft)
  apply (cases "llength xs")
  apply (subgoal_tac "lfinite xs")
  apply (rule impI)
  apply (subst lmap_lappend_distrib)
  apply (subgoal_tac "llength xs = llength (lmap Inl xs)")
  apply (rotate_tac 3)
  apply (erule ssubst)
  apply (rule ldelete_llength_lappend)
  apply (rule_tac x = "Inl y" in exI)
  defer
  apply force
  apply (metis enat.distinct(1) not_lfinite_llength)
  apply (subgoal_tac "\<not> lfinite xs")
  apply (erule ssubst)
  apply (simp add: lappend_inf)
  apply (metis Not_is_left ltl_lfilter ltl_simps(2))
  apply (metis llength_eq_infty_conv_lfinite)
  apply (rule lfilter_ltl)
  apply simp
  apply (intro conjI)
  apply (metis Not_is_left lhd_LCons lhd_lfilter)
  apply (metis llist.simps(13) lmap_lappend_distrib)
  by (metis Not_is_left is_left.simps(1) lhd_LCons lhd_lfilter)

lemma [simp]: "\<down> (llength xs) xs = LNil"
  by (metis ldrop_eq_LNil order_refl)

lemma lfilter_ldropn: "lfilter P (ldropn n xs) = \<down> (llength (lfilter P (\<up> (enat n) xs))) (lfilter P xs)"
proof (induct n arbitrary: xs)
  case 0
  show ?case
    by (simp add: enat_0)
next
  case (Suc n)
  thus ?case
    by (cases xs) (simp_all add: eSuc_enat[symmetric])
qed

lemma lfilter_ldrop: "lfilter P (\<down> n xs) = \<down> (llength (lfilter P (\<up> n xs))) (lfilter P xs)"
  apply (cases n)
  apply (simp_all add: lfilter_ldropn)
  apply (metis ldrop_enat lfilter_ldropn)
  by (metis enat_ord_simps(3) ldrop_eq_LNil ltake_all order_refl)

lemma [simp]: "\<rr> (ltl (ldropWhile is_right t)) = \<rr> (ldropWhile is_right t)"
  by (simp add: rights_def)

lemma mumble_LCons: "ys \<in> mumble xs \<Longrightarrow> LCons x ys \<in> mumble (LCons x xs)"
  apply (subst LCons_lappend_LNil[where ys = xs])
  apply (subst LCons_lappend_LNil[where ys = ys])
  apply (rule mumble_lappend)
  apply (rule mumble.self)
  by assumption

lemma lset_lfilter_var: "x \<in> lset (lfilter P xs) \<Longrightarrow> x \<in> lset xs"
  by (metis (lifting) lset_lfilter mem_Collect_eq)

lemma llength_lefts_lappend [simp]: "lfinite xs \<Longrightarrow> llength (\<ll> (xs \<frown> ys)) = llength (\<ll> xs) + llength (\<ll> ys)"
  by (simp add: lefts_def)

lemma llength_rights_lappend [simp]: "lfinite xs \<Longrightarrow> llength (\<rr> (xs \<frown> ys)) = llength (\<rr> xs) + llength (\<rr> ys)"
  by (simp add: rights_def)

lemma [simp]: "lfilter is_right (ldeleteLeft_nat n xs) = lfilter is_right xs"
proof (induct n arbitrary: xs)
  case 0 show ?case
    apply (auto simp add: rights_def)
    apply (cases "llength (ltakeWhile is_right xs)")
    apply (subst lappend_ltakeWhile_ldropWhile[symmetric, of xs is_right]) back back
    apply (subst lfilter_lappend_lfinite)
    apply (metis lfinite_conv_llength_enat)
    apply (subst lfilter_lappend_lfinite)
    apply (metis lfinite_conv_llength_enat)
    apply simp
    apply simp
    by (metis enat_ord_code(3) ldropWhile_eq_ldrop ldropWhile_lfilter_rl_LNil ldrop_eq_LNil lfilter_left_right llength_ltakeWhile_eq_infinity)
next
  case (Suc n)
  thus ?case
    apply simp
    apply (cases "llength (ltakeWhile is_right xs)")
    apply (subst lappend_ltakeWhile_ldropWhile[symmetric, of xs is_right]) back back
    apply (subst lfilter_lappend_lfinite)
    apply (metis lfinite_conv_llength_enat)
    apply (subst lfilter_lappend_lfinite)
    apply (metis lfinite_conv_llength_enat)
    apply (rule arg_cong) back
    apply (simp add: llist_Case_def)
    apply (cases "ldropWhile is_right xs")
    apply simp
    apply simp
    apply (metis not_is_right)
    apply simp
    by (metis enat_ord_code(3) ldropWhile_eq_ldrop ldropWhile_lfilter_rl_LNil ldrop_eq_LNil lfilter_left_right llength_ltakeWhile_eq_infinity)
qed

lemma [simp]: "\<rr> (ldeleteLeft_nat n xs) = \<rr> xs"
  by (simp add: rights_def)

lemma eSuc_move: "y \<noteq> 0 \<Longrightarrow> eSuc x = y \<longleftrightarrow> x = y - 1"
  apply default
  apply auto
  by (metis co.enat.collapse epred_conv_minus)

lemma llength_ldelete_nat: "enat n < llength xs \<Longrightarrow> llength (ldelete_nat n xs) = llength xs - 1"
proof (induct n arbitrary: xs)
  case 0 thus ?case
    by (cases xs) (simp_all add: llist_Case_def)
next
  case (Suc n) thus ?case
    apply simp
    apply (cases xs)
    apply simp
    apply (simp add: llist_Case_def)
    by (metis Suc_ile_eq eSuc_move not_iless0)
qed

lemma lmap_LConsl: "lmap \<langle>id,id\<rangle> (LCons (Inl x) xs) = LCons x (lmap \<langle>id,id\<rangle> xs)"
  by auto

lemma [simp]: "llength (\<ll> (ldropWhile is_right t)) = llength (\<ll> t)"
  by (auto simp add: lefts_def)

lemma [simp]: "lfilter is_right (linsertLeft_nat n x xs) = lfilter is_right xs"
proof (induct n arbitrary: xs)
  case 0 thus ?case
    apply auto
    apply (cases "lfinite (ltakeWhile is_right xs)")
    apply (subst lfilter_lappend_lfinite)
    apply assumption
    apply simp
    apply (subst lappend_ltakeWhile_ldropWhile[symmetric, of xs is_right]) back back
    apply (subst lfilter_lappend_lfinite)
    apply assumption
    apply simp
    apply (simp add: lappend_inf)
    by (metis diverge_lfilter_LNil lappend_inf lappend_ltakeWhile_ldropWhile lfilter_left_right lfinite_ltakeWhile not_is_right)
next
  case (Suc n)
  thus ?case
    apply simp
    apply (cases "lfinite (ltakeWhile is_right xs)")
    apply (subst lappend_ltakeWhile_ldropWhile[symmetric, of xs is_right]) back back
    apply (subst lfilter_lappend_lfinite) back
    apply simp_all
    apply (rule arg_cong) back
    apply (simp add: llist_Case_def)
    apply (cases "ldropWhile is_right xs")
    apply simp
    apply simp
    apply (metis not_is_right)
    apply (simp add: lappend_inf)
    by (metis diverge_lfilter_LNil lappend_inf lappend_ltakeWhile_ldropWhile lfilter_left_right lfinite_ltakeWhile not_is_right)
qed

lemma [simp]: "lfilter is_left (ltl (ldropWhile is_right xs)) = ltl (lfilter is_left (ldropWhile is_right xs))"
proof -
  have "lfilter is_left (ltl (ldropWhile is_right xs)) = ltl (lfilter is_left xs)"
    by (metis Not_is_left ltl_lfilter)
  also have "... = ltl (lfilter is_left (ldropWhile is_right xs))"
    by simp
  finally show ?thesis .
qed

lemma llength_ltl_not_LNil: "xs \<noteq> LNil \<Longrightarrow> llength (ltl xs) = llength xs - 1"
  by (metis epred_conv_minus epred_llength)

lemma eSuc_move2: "y \<noteq> 0 \<Longrightarrow> eSuc x < y \<longleftrightarrow> x < y - 1"
  apply default
  apply (metis Extended_Nat.eSuc_mono co.enat.collapse epred_conv_minus)
  by (metis eSuc_minus_1 enat_minus_mono1 not_less)

lemma eSuc_minus_1_var: "n \<noteq> 0 \<Longrightarrow> eSuc (n - 1) = n"
  by (metis eSuc_move)

lemma llength_linsertLeft_nat:
  "enat n < llength (lfilter is_left xs) \<Longrightarrow> llength (lfilter is_left (linsertLeft_nat n x xs)) = eSuc (llength (lfilter is_left xs))"
proof (induct n arbitrary: xs)
  case 0
  thus ?case
    by (cases "lfinite (ltakeWhile is_right xs)") simp_all
next
  case (Suc n)

  from Suc(2)
  have "enat n < llength (lfilter is_left (ltl (ldropWhile is_right xs)))"
    apply simp
    apply (subst llength_ltl_not_LNil)
    apply (metis llength_LNil not_iless0)
    apply (simp add: eSuc_enat[symmetric])
    apply (subst eSuc_move2[symmetric])
    apply (metis not_iless0)
    by assumption
  hence "llength (lfilter is_left (linsertLeft_nat n x (ltl (ldropWhile is_right xs)))) = eSuc (llength (lfilter is_left (ltl (ldropWhile is_right xs))))"
    by (metis Suc.hyps)

  from this and Suc(2)
  show ?case
    apply simp
    apply (cases "lfinite (ltakeWhile is_right xs)")
    apply (simp add: llist_Case_def)
    apply (cases "ldropWhile is_right xs")
    apply simp
    apply (metis ldropWhile_lfilter_rl_LNil llength_LNil not_iless0)
    apply (drule ldropWhile_right_LCons)
    apply (erule exE)
    apply simp
    apply (subst llength_ltl_not_LNil)
    apply (metis llength_LNil not_iless0)
    apply (subst eSuc_minus_1_var)
    apply (metis not_iless0)
    apply (rule refl)
    by (simp add: lappend_inf)
qed

lemma [simp]: "\<rr> (linsertLeft_nat n x xs) = \<rr> xs"
  by (simp add: rights_def)

lemma [simp]: "\<rr> (linsertLeft n x xs) = \<rr> xs"
  by (cases n) simp_all

lemma [simp]: "lfilter is_left (traj xs) = traj (lfilter is_left xs)"
  by (auto simp add: traj_def lfilter_lmap)

lemma [simp]: "llength (lfilter is_left (traj xs)) = llength (lfilter is_left xs)"
  by simp

lemma lfilter_all [intro]: "(\<forall>x\<in>lset xs. P x) \<Longrightarrow> lfilter P xs = xs"
proof -
  assume "\<forall>x\<in>lset xs. P x"
  hence "lfilter P xs = lfilter (\<lambda>x. True) xs"
    by (auto intro: lfilter_cong)
  also have "... = xs"
    by (metis lfilter_K_True)
  finally show ?thesis .
qed

lemma [simp]: "lfilter P (ltakeWhile P xs) = ltakeWhile P xs"
  by (auto dest: lset_ltakeWhileD)

lemma [simp]: "ltakeWhile P xs \<frown> lfilter P (ldropWhile P xs) = lfilter P xs"
  apply (subgoal_tac "ltakeWhile P xs = lfilter P (ltakeWhile P xs)")
  apply (erule ssubst)
  apply (cases "lfinite (ltakeWhile P xs)")
  apply (subst lfilter_lappend_lfinite[symmetric])
  apply assumption
  apply simp
  apply (metis (hide_lams, full_types) lappend_LNil2 lappend_ltakeWhile_ldropWhile ldropWhile_eq_LNil_iff lfilter_LNil lfinite_ltakeWhile)
  by simp

lemma mumble_in_left:
  assumes "t \<in> (xs \<frown> LCons (\<sigma>, \<sigma>'') ys) \<sha> zs"
  shows "lmap \<langle>id,id\<rangle> (xs \<frown> LCons (\<sigma>, \<sigma>'') ys \<triangleright> traj t \<triangleleft> zs) \<in> mumble (lmap \<langle>id,id\<rangle> (xs \<frown> LCons (\<sigma>,\<sigma>') (LCons (\<sigma>',\<sigma>'') ys) \<triangleright> linsertLeft (llength xs) () (traj t) \<triangleleft> zs))"
proof (cases "llength xs")
  assume "llength xs = \<infinity>"
  from this and assms show ?thesis
    by (auto intro: sumlist_cases[of t] simp add: traj_def interleave_left interleave_right)
next
  let ?TR = "ltakeWhile is_right"
  let ?DR = "ldropWhile is_right"

  fix n
  assume "llength xs = enat n"
  moreover hence "lmap \<langle>id,id\<rangle> (xs \<frown> LCons (\<sigma>, \<sigma>'') ys \<triangleright> traj t \<triangleleft> zs) \<in> mumble (lmap \<langle>id,id\<rangle> (xs \<frown> LCons (\<sigma>,\<sigma>') (LCons (\<sigma>',\<sigma>'') ys) \<triangleright> linsertLeft_nat n () (traj t) \<triangleleft> zs))"
    using assms
  proof (induct n arbitrary: xs t zs)
    case 0 note zero = this
    {
      assume zs_not_LNil: "zs \<noteq> LNil"

      from zero have [simp]: "xs = LNil"
        by (metis llength_enat_0)
      hence t_shuffle: "t \<in> LCons (\<sigma>, \<sigma>'') ys \<sha> zs"
        by (metis zero(2) lappend_code(1))
      from t_shuffle have t_not_LNil: "t \<noteq> LNil"
        by (auto simp add: tshuffle_words_def)
      from t_shuffle and zs_not_LNil have ltl_t_not_LNil: "ltl t \<noteq> LNil"
        apply (auto simp add: tshuffle_words_def rights_def lefts_def)
        by (metis LNil_eq_lmap lfilter_LCons lfilter_LNil llist.distinct(1) llist.sel_exhaust not_is_right)

      from t_shuffle
      have "?DR t = LCons (Inl (\<sigma>,\<sigma>'')) (ltl (?DR t))"
        by (auto dest: lfilter_eq_LCons simp add: tshuffle_words_def lefts_def lmap_unl_Inl)

      hence traj_DR: "?DR (traj t) = LCons (Inl ()) (ltl (ldropWhile is_right (traj t)))"
        by - (drule arg_cong[where f = traj], simp)

      have [intro]: "lfinite (traj (ltakeWhile is_right t))"
        by (metis ldropWhile_eq_LNil_iff lfinite_ltakeWhile llist.distinct(1) ltakeWhile_right_traj traj_DR)

      have "lmap \<langle>id,id\<rangle> (LCons (\<sigma>, \<sigma>'') ys \<triangleright> traj t \<triangleleft> zs) = lmap \<langle>id,id\<rangle> (LCons (\<sigma>,\<sigma>'') ys \<triangleright> ?TR (traj t) \<frown> ?DR (traj t) \<triangleleft> zs)"
        by (metis lappend_ltakeWhile_ldropWhile)
      also have "... = lmap \<langle>id,id\<rangle> ((LNil \<triangleright> ?TR (traj t) \<triangleleft> \<up> (llength (\<rr> (?TR (traj t)))) zs) \<frown>
                                    (LCons (\<sigma>,\<sigma>'') ys \<triangleright> ?DR (traj t) \<triangleleft> \<down> (llength (\<rr> (?TR (traj t)))) zs))"
        apply (subst intro_traj)
        apply (subst traj_lappend)
        apply (subst interleave_append[OF t_shuffle])
        apply (metis intro_traj lappend_ltakeWhile_ldropWhile traj_interleave)
        by simp
      also have "... = lmap \<langle>id,id\<rangle> ((LNil \<triangleright> ?TR (traj t) \<triangleleft> \<up> (llength (\<rr> (?TR (traj t)))) zs) \<frown>
                                     LCons (Inl (\<sigma>,\<sigma>'')) (ys \<triangleright> ltl (?DR (traj t)) \<triangleleft> \<down> (llength (\<rr> (?TR (traj t)))) zs))"
        apply (subst interleave_ldropWhile)
        apply (subst shuffle_lset[OF t_shuffle])
        by (simp_all add: interleave_left)
      also have "... = lmap \<langle>id,id\<rangle> (LNil \<triangleright> ?TR (traj t) \<triangleleft> \<up> (llength (\<rr> (?TR (traj t)))) zs) \<frown>
                       LCons (\<sigma>,\<sigma>'') (lmap \<langle>id,id\<rangle> (ys \<triangleright> ltl (?DR (traj t)) \<triangleleft> \<down> (llength (\<rr> (?TR (traj t)))) zs))"
        by (simp add: lmap_lappend_distrib)
      also have "... \<in> mumble (lmap \<langle>id,id\<rangle> (LCons (\<sigma>, \<sigma>') (LCons (\<sigma>', \<sigma>'') ys) \<triangleright> linsertLeft_nat 0 () (traj t) \<triangleleft> zs))"
        apply (rule mumble[where \<sigma>' = \<sigma>'])
        apply (simp only: linsertLeft_nat.simps)
        apply (subst interleave_append_llength)
        prefer 3
        apply (subst traj_DR) back
        apply (simp only: lefts_ltake_right llength_LNil ltake_0 ldrop_0 lmap_lappend_distrib interleave_left lhd_LCons lmap_LConsl ltl_simps)
        apply (rule mumble.self)
        apply simp
        using t_shuffle
        apply (auto simp add: tshuffle_words_def)
        apply (subst llength_lefts_lappend)
        apply auto
        apply (subst llength_rights_lappend)
        apply auto
        by (metis lappend_ltakeWhile_ldropWhile lefts_LCons_lfinite_rights llength_lappend rights_append)
      finally have ?case
          by auto
    }
    moreover
    {
      assume zs_LNil: "zs = LNil"
      from zero have [simp]: "xs = LNil"
        by (metis llength_enat_0)
      from zs_LNil and zero have ?case
        apply (auto simp add: interleave_left interleave_only_left)
        apply (rule mumble.mumble[where ys = LNil and \<sigma>' = \<sigma>', simplified])
        by (rule mumble.self)
    }
    ultimately show ?case
      by (cases zs) simp_all
  next
    case (Suc n)

    from Suc(2) have xs_lfinite: "lfinite xs"
      by (metis lfinite_conv_llength_enat)

    from Suc obtain x' and xs' where xs_def: "xs = LCons x' xs'"
      by (cases xs) (auto simp add: eSuc_enat[symmetric])
    hence xs'_len: "llength xs' = enat n"
      by (metis Suc.prems(1) co.enat.inject eSuc_enat llength_LCons)

    from Suc(3)
    have prem_lhd [simp]: "lhd (ldropWhile is_right t) = Inl x'"
      apply (auto simp add: tshuffle_words_def lefts_def xs_def)
      apply (erule rev_mp)
      by (metis (mono_tags) Not_is_left lhd_LCons lhd_lfilter)

    from Suc(3)
    have [simp]: "lhd (ldropWhile is_right (traj t)) = Inl ()"
      apply (auto simp add: tshuffle_words_def lefts_def xs_def)
      apply (erule rev_mp)
      by (metis (no_types) Not_is_left lappend_LNil2 lappend_ltakeWhile_ldropWhile ldropWhile_right_traj ldropWhile_rights_not_LNil lfilter_ltakeWhile lhd_LCons llist.distinct(2) llist.exhaust llist.simps(13) traj_def)

    from Suc(3)
    have "ldropWhile is_right (traj t) \<noteq> LNil"
      apply (auto simp add: tshuffle_words_def xs_def traj_not_LNil)
      by (metis lappend_LNil2 lappend_ltakeWhile_ldropWhile lefts_ltake_right llist.distinct(2))

    from Suc(3)
    have ind_shuffle: "ltl (ldropWhile is_right t) \<in> (xs' \<frown> LCons (\<sigma>, \<sigma>'') ys) \<sha> \<down> (llength (\<rr> (?TR (traj t)))) zs"
      apply (auto simp add: lefts_def tshuffle_words_def xs_def rights_def)
      sorry (* This used to work... *)

    from Suc(1)[OF xs'_len ind_shuffle]
    have ih: "lmap \<langle>id,id\<rangle> (xs' \<frown> LCons (\<sigma>, \<sigma>'') ys \<triangleright> ltl (?DR (traj t)) \<triangleleft> \<down> (llength (\<rr> (?TR (traj t)))) zs)
             \<in> mumble (lmap \<langle>id,id\<rangle> (xs' \<frown> LCons (\<sigma>, \<sigma>') (LCons (\<sigma>', \<sigma>'') ys) \<triangleright> linsertLeft_nat n () (ltl (?DR (traj t))) \<triangleleft> \<down> (llength (\<rr> (?TR (traj t)))) zs))"
      by simp

    hence ih_var: "ltakeWhile is_right (traj t) = LNil \<Longrightarrow>
      lmap \<langle>id,id\<rangle> (xs' \<frown> LCons (\<sigma>, \<sigma>'') ys \<triangleright> ltl (?DR (traj t)) \<triangleleft> zs)
      \<in> mumble (lmap \<langle>id,id\<rangle> (xs' \<frown> LCons (\<sigma>, \<sigma>') (LCons (\<sigma>', \<sigma>'') ys) \<triangleright> linsertLeft_nat n () (ltl (?DR (traj t))) \<triangleleft> zs))"
      by auto

    have "lmap \<langle>id,id\<rangle> (xs \<frown> LCons (\<sigma>,\<sigma>'') ys \<triangleright> traj t \<triangleleft> zs) = lmap \<langle>id,id\<rangle> (xs \<frown> LCons (\<sigma>,\<sigma>'') ys \<triangleright> ?TR (traj t) \<frown> ?DR (traj t) \<triangleleft> zs)"
      by (metis lappend_ltakeWhile_ldropWhile)
    also have "... = lmap \<langle>id,id\<rangle> ((LNil \<triangleright> ?TR (traj t) \<triangleleft> \<up> (llength (\<rr> (?TR (traj t)))) zs) \<frown>
                                  (xs \<frown> LCons (\<sigma>, \<sigma>'') ys \<triangleright> ?DR (traj t) \<triangleleft> \<down> (llength (\<rr> (?TR (traj t)))) zs))"
      by (subst interleave_append[OF Suc(3)]) simp_all
    also have "... = lmap \<langle>id,id\<rangle> ((LNil \<triangleright> ?TR (traj t) \<triangleleft> \<up> (llength (\<rr> (?TR (traj t)))) zs) \<frown>
                                  (xs \<frown> LCons (\<sigma>, \<sigma>'') ys \<triangleright> LCons (Inl ()) (ltl (?DR (traj t))) \<triangleleft> \<down> (llength (\<rr> (?TR (traj t)))) zs))"
        apply (subst interleave_ldropWhile)
        apply (subst shuffle_lset[OF Suc(3)])
        apply auto
        apply (rule_tac x = "Inl (\<sigma>,\<sigma>'')" in bexI)
        apply auto
        apply (subgoal_tac "lfinite xs")
        apply (metis imageI in_lset_lappend_iff lset_intros(1))
        by (metis xs_lfinite)
    also have "... = lmap \<langle>id,id\<rangle> ((LNil \<triangleright> ?TR (traj t) \<triangleleft> \<up> (llength (\<rr> (?TR (traj t)))) zs) \<frown>
                                  LCons (Inl x') (xs' \<frown> LCons (\<sigma>, \<sigma>'') ys \<triangleright> ltl (?DR (traj t)) \<triangleleft> \<down> (llength (\<rr> (?TR (traj t)))) zs))"
      by (metis (hide_lams, no_types) calculation interleave_left lappend_code(2) lhd_LCons ltl_simps(2) xs_def)
    also have "... = lmap \<langle>id,id\<rangle> (LNil \<triangleright> ?TR (traj t) \<triangleleft> \<up> (llength (\<rr> (?TR (traj t)))) zs) \<frown>
                     LCons x' (lmap \<langle>id,id\<rangle> (xs' \<frown> LCons (\<sigma>, \<sigma>'') ys \<triangleright> ltl (?DR (traj t)) \<triangleleft> \<down> (llength (\<rr> (?TR (traj t)))) zs))"
      by (simp add: lmap_lappend_distrib)
    also have "... \<in> mumble (lmap \<langle>id,id\<rangle> (xs \<frown> LCons (\<sigma>, \<sigma>') (LCons (\<sigma>', \<sigma>'') ys) \<triangleright> linsertLeft_nat (Suc n) () (traj t) \<triangleleft> zs))" (is ?goal)
    proof (cases "ltakeWhile is_right (traj t) = LNil")
      case True
      moreover have "traj (?DR t) = LCons (Inl ()) (traj (ltl (?DR t)))"
        by (metis (full_types) `ldropWhile is_right (traj t) \<noteq> LNil` ldropWhile_right_traj ldropWhile_rights_not_LNil ltl_traj)
      ultimately show ?goal
        by (auto intro!: ih_var[simplified] mumble_LCons simp add: xs_def llist_Case_def interleave_left)
    next
      case False
      from Suc(3)
      have "?DR t = LCons (Inl x') (ltl (?DR t))"
        by (auto dest: lfilter_eq_LCons simp add: tshuffle_words_def lefts_def lmap_unl_Inl xs_def)

      hence traj_DR: "?DR (traj t) = LCons (Inl ()) (ltl (ldropWhile is_right (traj t)))"
        by - (drule arg_cong[where f = traj], simp)

      hence DR_traj: "traj (?DR t) = LCons (Inl ()) (ltl (ldropWhile is_right (traj t)))"
        by simp

      from Suc(3)
      have [simp]: "lfilter is_left (ltl (ldropWhile is_right t)) = lmap Inl (xs' \<frown> LCons (\<sigma>, \<sigma>'') ys)"
        by (auto simp add: tshuffle_words_def lefts_def lmap_unl_Inl xs_def)

      show ?goal
        apply (simp only: linsertLeft_nat.simps)
        apply (subst interleave_append_llength)
        prefer 3
        apply (subst lmap_lappend_distrib)
        apply (rule mumble_lappend)
        apply simp
        apply (subst traj_DR) back
        apply (simp add: llist_Case_def xs_def interleave_left)
        apply (rule mumble_LCons)
        apply (rule ih[simplified])
        using Suc(3)
        apply (auto simp add: tshuffle_words_def traj_DR llist_Case_def)
        apply (subst llength_lefts_lappend)
        apply (simp add: traj_def)
        apply (metis lappend_not_LNil_iff lefts_LCons_lfinite_rights neq_LNil_conv)
        apply (subst DR_traj)
        apply auto
        apply (subst iadd_Suc_right)
        apply (rule arg_cong) back
        apply (simp add: lefts_def lmap_unl_Inl)
        apply (subst llength_linsertLeft_nat)
        apply (subst xs'_len[symmetric])
        prefer 2
        apply (subst iadd_Suc_right)
        apply (rule arg_cong) back
        apply (simp add: xs_def iadd_Suc_right eSuc_plus)
        apply (simp add: xs_def)
        apply (metis xs'_len)
        apply (subst DR_traj)
        apply simp
        apply (subst llength_rights_lappend)
        apply (simp add: traj_def)
        apply (metis lappend_not_LNil_iff lefts_LCons_lfinite_rights neq_LNil_conv)
        apply simp
        by (metis lappend_ltakeWhile_ldropWhile lappend_not_LNil_iff lefts_LCons_lfinite_rights llength_lappend llist.sel_exhaust rights_append)
    qed
    finally show ?case
      by simp
  qed
  ultimately show ?thesis
    by simp
qed

lemma tshuffle_mumble: "\<Union>{lmap \<langle>id,id\<rangle> ` (xs' \<sha> ys)|xs'. xs' \<in> mumble xs} \<subseteq> (lmap \<langle>id,id\<rangle> ` (xs \<sha> ys))\<^sup>\<dagger>"
proof -
  {
  fix xs' zs'

  assume "xs' \<in> mumble xs" and "zs' \<in> xs' \<sha> ys"

  hence "\<exists>zs\<in>xs \<sha> ys. lmap \<langle>id,id\<rangle> zs' \<in> mumble (lmap \<langle>id,id\<rangle> zs)"
  proof (induct xs' arbitrary: zs' rule: mumble.induct)
    case (self zs')
    thus ?case
      by (rule_tac x = zs' in bexI, auto)
  next
    case (mumble ws \<sigma> \<sigma>' \<sigma>'' vs zs')

    hence zs'_interleave: "zs' = (ws \<frown> LCons (\<sigma>, \<sigma>'') vs) \<triangleright> traj zs' \<triangleleft> ys"
      by (simp add: tshuffle_words_def) (metis reinterleave)

    from mumble(3)
    have "(ws \<frown> LCons (\<sigma>,\<sigma>') (LCons (\<sigma>',\<sigma>'') vs) \<triangleright> linsertLeft (llength ws) () (traj zs') \<triangleleft> ys) \<in> (ws \<frown> LCons (\<sigma>, \<sigma>') (LCons (\<sigma>', \<sigma>'') vs)) \<sha> ys"
      apply (auto simp add: tshuffle_words_def)
      apply (subgoal_tac "linsertLeft (llength ws) () (traj zs') = traj (linsertLeft (llength ws) () (traj zs'))")
      apply (rotate_tac 2)
      apply (erule ssubst)
      apply (subst lefts_interleave_llength)
      apply simp_all
      defer
      apply (subgoal_tac "linsertLeft (llength ws) () (traj zs') = traj (linsertLeft (llength ws) () (traj zs'))")
      apply (rotate_tac 2)
      apply (erule ssubst)
      apply (subst rights_interleave_llength)
      apply simp_all
      apply (simp add: lefts_def lmap_unl_Inl)
      apply (cases "llength ws")
      apply simp_all
      apply (subst llength_linsertLeft_nat)
      by (simp_all add: iadd_Suc_right)

    from this and mumble(2) obtain zs where "zs \<in> xs \<sha> ys"
    and "lmap \<langle>id,id\<rangle> (ws \<frown> LCons (\<sigma>,\<sigma>') (LCons (\<sigma>',\<sigma>'') vs) \<triangleright> linsertLeft (llength ws) () (traj zs') \<triangleleft> ys) \<in> mumble (lmap \<langle>id,id\<rangle> zs)"
      by blast

    moreover have "lmap \<langle>id,id\<rangle> zs' \<in> mumble (lmap \<langle>id,id\<rangle> (ws \<frown> LCons (\<sigma>,\<sigma>') (LCons (\<sigma>',\<sigma>'') vs) \<triangleright> linsertLeft (llength ws) () (traj zs') \<triangleleft> ys))"
      by (subst zs'_interleave) (metis (full_types) mumble.prems mumble_in_left)

    ultimately show ?case
      by (metis (hide_lams, no_types) mumble_trans)
  qed
  }
  thus ?thesis
    apply (simp add: Mumble_def)
    apply safe
    apply simp_all
    by (metis imageI)
qed

lemma set_cong2: "(\<And>xs ys. f xs ys \<subseteq> g xs ys) \<Longrightarrow> \<Union>{f xs ys |xs ys. P xs ys} \<subseteq> \<Union>{g xs ys |xs ys. P xs ys}"
  by auto

lemma shuffle_mumble1: "X\<^sup>\<dagger> \<parallel> Y \<subseteq> (X \<parallel> Y)\<^sup>\<dagger>"
proof -
  have "X\<^sup>\<dagger> \<parallel> Y = \<Union>(mumble ` X) \<parallel> Y"
    by (rule arg_cong, auto simp add: Mumble_def image_def)
  also have "... = \<Union>{mumble xs \<parallel> Y|xs. xs \<in> X}"
    by (subst trans[OF shuffle_comm shuffle_inf_dist], subst shuffle_comm, auto)
  also have "... = \<Union>{\<Union>{lmap \<langle>id,id\<rangle> ` (xs' \<sha> ys) |xs' ys. xs' \<in> mumble xs \<and> ys \<in> Y}|xs. xs \<in> X}"
    by (simp add: shuffle_def)
  also have "... = \<Union>{\<Union>{lmap \<langle>id,id\<rangle> ` (xs' \<sha> ys) |xs'. xs' \<in> mumble xs}|xs ys. xs \<in> X \<and> ys \<in> Y}"
    by blast
  also have "... \<subseteq> \<Union>{(lmap \<langle>id,id\<rangle> ` (xs \<sha> ys))\<^sup>\<dagger>|xs ys. xs \<in> X \<and> ys \<in> Y}"
    apply (insert tshuffle_mumble)
    apply (rule set_cong2)
    by assumption
  also have "... = \<Union>{\<Union>zs\<in>xs \<sha> ys. mumble (lmap \<langle>id,id\<rangle> zs)|xs ys. xs \<in> X \<and> ys \<in> Y}"
    by (auto simp add: Mumble_def)
  also have "... = (X \<parallel> Y)\<^sup>\<dagger>"
    apply (simp add: shuffle_def Mumble_def)
    apply safe
    apply simp_all
    apply (metis imageI)
    by (metis UN_I)
  finally show ?thesis .
qed

lemma mumble_LNil_lfinite: "ys \<in> mumble LNil \<Longrightarrow> lfinite ys"
  by (induct ys rule: mumble.induct) auto

lemma mumble_member: "xs \<in> X \<Longrightarrow> mumble xs \<subseteq> X\<^sup>\<dagger>"
  by (auto simp add: Mumble_def)

lemma set_comp_fun_sub1: "(\<And>x. x \<in> X \<Longrightarrow> f x \<subseteq> g x) \<Longrightarrow> \<Union>{f x |x. x \<in> X} \<subseteq> \<Union>{g x |x. x \<in> X}"
  by auto

lemma Mumble_shuffle_left [simp]: "(X\<^sup>\<dagger> \<parallel> Y)\<^sup>\<dagger> = (X \<parallel> Y)\<^sup>\<dagger>"
  apply (rule antisym)
  apply (metis (full_types) Mumble_idem Mumble_iso shuffle_comm shuffle_mumble1)
  by (metis Mumble_ext Mumble_iso par.mult_isor)

lemma Mumble_shuffle_right [simp]: "(X \<parallel> Y\<^sup>\<dagger>)\<^sup>\<dagger> = (X \<parallel> Y)\<^sup>\<dagger>"
  by (metis Mumble_shuffle_left shuffle_comm)

lemma mumble_infinite2: "xs \<in> mumble ys \<Longrightarrow> \<not> lfinite xs \<Longrightarrow> \<not> lfinite ys"
  by (induct xs rule: mumble.induct) auto

lemma mumble_preserves_finiteness [dest]: "xs \<in> mumble ys \<Longrightarrow> lfinite xs \<longleftrightarrow> lfinite ys"
  by (metis mumble_infinite mumble_infinite2)

lemma Mumble_l_prod [simp]: "(X\<^sup>\<dagger> \<cdot> Y\<^sup>\<dagger>)\<^sup>\<dagger> = (X \<cdot> Y)\<^sup>\<dagger>"
proof (rule antisym)
  show "(X\<^sup>\<dagger> \<cdot> Y\<^sup>\<dagger>)\<^sup>\<dagger> \<subseteq> (X \<cdot> Y)\<^sup>\<dagger>"
    apply (simp add: l_prod_def)
    apply (intro conjI)
    apply (rule le_supI1)
    defer
    apply (rule le_supI2)
    apply (simp_all add: Mumble_def)
    apply safe
    apply simp_all
    apply (rename_tac z xs' ys' xs ys)
    apply (rule_tac x = "mumble (xs \<frown> ys)" in exI)
    apply (intro conjI)
    apply (rule_tac x = "xs \<frown> ys" in exI)
    apply simp
    apply (rule_tac x = "xs" in exI)
    apply (rule_tac x = "ys" in exI)
    apply simp
    apply (metis mumble_infinite)
    apply (metis mumble_lappend mumble_trans)
    apply (rename_tac xs xs' xs'')
    apply (rule_tac x = "mumble xs''" in exI)
    apply (intro conjI)
    apply (rule_tac x = "xs''" in exI)
    apply simp_all
    apply safe
    apply (metis mumble_infinite2)
    by (metis mumble_trans)
  show "(X \<cdot> Y)\<^sup>\<dagger> \<subseteq> (X\<^sup>\<dagger> \<cdot> Y\<^sup>\<dagger>)\<^sup>\<dagger>"
    by (metis Mumble_ext Mumble_iso seq.mult_isol_var)
qed

lemma Mumble_l_prod1 [simp]: "(X \<cdot> Y\<^sup>\<dagger>)\<^sup>\<dagger> = (X \<cdot> Y)\<^sup>\<dagger>"
  by (metis Mumble_idem Mumble_l_prod)

lemma Mumble_l_prod2 [simp]: "(X\<^sup>\<dagger> \<cdot> Y)\<^sup>\<dagger> = (X \<cdot> Y)\<^sup>\<dagger>"
  by (metis Mumble_idem Mumble_l_prod)

lemma Mumble_empty [simp]: "{}\<^sup>\<dagger> = {}"
  by (simp add: Mumble_def)

lemma mumble_LNil: "xs \<in> mumble LNil \<Longrightarrow> xs = LNil"
  apply (induct rule: mumble.induct)
  apply auto
  by (metis lappend_not_LNil_iff llist.distinct(1))

lemma Mumble_LNil [simp]: "{LNil}\<^sup>\<dagger> = {LNil}"
  by (simp add: Mumble_def) (metis Set.set_insert ex_in_conv insertI2 mumble.self mumble_LNil)

lemma Mumble_star_lfp: "(\<mu> y. {LNil} \<union> x \<cdot> y)\<^sup>\<dagger> = (\<mu> y. {LNil} \<union> (x \<cdot> y)\<^sup>\<dagger>)"
  apply (rule fixpoint_fusion)
  apply (subst lower_is_jp)
  apply (simp add: join_preserving_def Mumble_continuous)
  apply blast
  apply (metis iso_Un1 monoI seq.mult_isol)
  apply (rule monoI)
  apply (rule par.add_iso_var[rule_format])
  apply simp
  apply (metis Mumble_iso l_prod_isor)
  apply (simp add: o_def)
  apply (rule ext)
  by (metis Mumble_LNil Mumble_union insert_is_Un)

lemma Mumble_star1: "(x\<^sup>\<dagger>\<^sup>\<star>)\<^sup>\<dagger> \<subseteq> (x\<^sup>\<star>)\<^sup>\<dagger>"
  by (simp only: star_def Mumble_star_lfp Mumble_l_prod2)

lemma Mumble_star [simp]: "((x\<^sup>\<dagger>)\<^sup>\<star>)\<^sup>\<dagger> = (x\<^sup>\<star>)\<^sup>\<dagger>"
  by (rule antisym, metis Mumble_star1, metis Mumble_ext Mumble_iso seq.star_iso)

lemma Mumble_Inter [simp]: "(\<Inter>(Mumble ` A))\<^sup>\<dagger> = \<Inter>(Mumble ` A)"
  apply (rule antisym)
  defer
  apply (metis Mumble_ext)
  apply (simp add: Mumble_def image_def)
  apply safe
  apply simp
  apply (erule_tac x = "xa\<^sup>\<dagger>" in allE)
  apply safe
  apply (simp_all add: Mumble_def)
  apply metis
  by (metis mumble_trans)

lemma Mumble_FIN [simp]: "(x \<inter> FIN)\<^sup>\<dagger> = (x\<^sup>\<dagger>) \<inter> FIN"
  by (auto simp add: Mumble_def FIN_def)

lemma empty_Mumble_FIN [simp]: "{}\<^sup>\<dagger> \<inter> FIN = {}\<^sup>\<dagger>"
  by (auto simp add: Mumble_def FIN_def)

definition fmumble :: "('a \<times> 'a) lan \<Rightarrow> ('a \<times> 'a) lan" ("_\<^sup>\<ddagger>" [1000] 1000) where
  "fmumble x = x\<^sup>\<dagger> \<inter> FIN"

lemma fmumble_empty [simp]: "{}\<^sup>\<ddagger> = {}"
  by (simp add: fmumble_def)

lemma fmumble_l_prod1 [simp]: "(X\<^sup>\<ddagger> \<cdot> Y)\<^sup>\<ddagger> = (X \<cdot> Y)\<^sup>\<ddagger>"
  by (metis Mumble_FIN Mumble_l_prod2 fmumble_def l_prod_FIN_simp1)

lemma fmumble_l_prod2 [simp]: "(X \<cdot> Y\<^sup>\<ddagger>)\<^sup>\<ddagger> = (X \<cdot> Y)\<^sup>\<ddagger>"
  by (metis Mumble_FIN Mumble_l_prod1 fmumble_def l_prod_FIN_simp2)

lemma fmumble_union [simp]: "(X \<union> Y)\<^sup>\<ddagger> = X\<^sup>\<ddagger> \<union> Y\<^sup>\<ddagger>"
  by (simp add: fmumble_def)

lemma fmumble_one [simp]: "{LNil}\<^sup>\<ddagger> = {LNil}"
  by (auto simp add: fmumble_def FIN_def)

lemma fmumble_idem [simp]: "X\<^sup>\<ddagger>\<^sup>\<ddagger> = X\<^sup>\<ddagger>"
  by (simp add: fmumble_def)

lemma fmumble_shuffle_left [simp]: "(X\<^sup>\<ddagger> \<parallel> Y)\<^sup>\<ddagger> = (X \<parallel> Y)\<^sup>\<ddagger>"
  by (simp add: fmumble_def) (metis Mumble_FIN Mumble_shuffle_right shuffle_FIN_simp2 shuffle_comm)

lemma fmumble_shuffle_right [simp]: "(X \<parallel> Y\<^sup>\<ddagger>)\<^sup>\<ddagger> = (X \<parallel> Y)\<^sup>\<ddagger>"
  by (metis fmumble_shuffle_left shuffle_comm)

lemma fmumble_meet [simp]: "(X\<^sup>\<ddagger> \<inter> Y\<^sup>\<ddagger>)\<^sup>\<ddagger> = X\<^sup>\<ddagger> \<inter> Y\<^sup>\<ddagger>"
  by (simp add: fmumble_def) (metis (hide_lams, no_types) Int_left_commute Mumble_FIN Mumble_meet inf_commute inf_left_idem)

lemma fmumble_star [simp]: "(X\<^sup>\<ddagger>\<^sup>\<star>)\<^sup>\<ddagger> = (X\<^sup>\<star>)\<^sup>\<ddagger>"
  apply (simp add: fmumble_def)
  by (metis Mumble_FIN Mumble_star inf_commute inf_left_idem star_FIN)

lemma fmumble_iso [intro]: "X \<subseteq> Y \<Longrightarrow> X\<^sup>\<ddagger> \<subseteq> Y\<^sup>\<ddagger>"
  by (metis fmumble_union le_iff_sup)

lemma fmumble_ext: "X \<inter> FIN \<subseteq> X\<^sup>\<ddagger>"
  by (metis Mumble_FIN Mumble_ext fmumble_def)

lemma fmumble_continuous: "(\<Union>\<XX>)\<^sup>\<ddagger> = \<Union>{X\<^sup>\<ddagger> |X. X \<in> \<XX>}"
  by (auto simp add: fmumble_def Mumble_continuous)

lemma fmumble_star_power: "Z\<^sup>\<ddagger> \<subseteq> Y\<^sup>\<ddagger> \<Longrightarrow> (X \<cdot> Y)\<^sup>\<ddagger> \<subseteq> Y\<^sup>\<ddagger> \<Longrightarrow> (power X i \<cdot> Z)\<^sup>\<ddagger> \<subseteq> Y\<^sup>\<ddagger>"
  apply (induct i)
  apply simp_all
proof -
  fix ia :: nat
  assume a1: "(Language.power X ia \<cdot> Z)\<^sup>\<ddagger> \<subseteq> Y\<^sup>\<ddagger>"
  assume a2: "(X \<cdot> Y)\<^sup>\<ddagger> \<subseteq> Y\<^sup>\<ddagger>"
  have "Y\<^sup>\<ddagger> = Y\<^sup>\<ddagger> \<union> (Language.power X ia \<cdot> Z)\<^sup>\<ddagger>"
    using a1 by fastforce
  hence "\<exists>x\<^sub>0. X \<cdot> (Language.power X ia \<cdot> Z) \<subseteq> x\<^sub>0 \<and> x\<^sub>0\<^sup>\<ddagger> \<subseteq> Y\<^sup>\<ddagger>"
    using a2 by (metis fmumble_l_prod2 fmumble_union l_prod_isor par.add_ub2)
  hence "\<exists>x\<^sub>0. (X \<cdot> (Language.power X ia \<cdot> Z))\<^sup>\<ddagger> \<subseteq> x\<^sub>0 \<and> x\<^sub>0 \<subseteq> Y\<^sup>\<ddagger>"
    by (metis fmumble_iso)
  thus "(X \<cdot> Language.power X ia \<cdot> Z)\<^sup>\<ddagger> \<subseteq> Y\<^sup>\<ddagger>"
    by (metis order.trans seq.mult_assoc)
qed

lemma fmumble_star_inductl: "(Z \<union> X \<cdot> Y)\<^sup>\<ddagger> \<subseteq> Y\<^sup>\<ddagger> \<Longrightarrow> (X\<^sup>\<star> \<cdot> Z)\<^sup>\<ddagger> \<subseteq> Y\<^sup>\<ddagger>"
  apply (simp add: star_power l_prod_inf_distr fmumble_continuous Sup_le_iff)
  apply (intro allI impI)
  apply (erule exE)
  apply simp
  apply (erule conjE)+
  apply (erule exE)
  apply (erule conjE)
  apply simp
  apply (rename_tac A B C)
  apply (thin_tac "A = (C \<cdot> Z)\<^sup>\<ddagger>")
  apply (thin_tac "B = C \<cdot> Z")
  apply (rename_tac X')
  apply (simp add: powers_def)
  apply (erule exE)
  apply simp
  apply (thin_tac "X' = Language.power X i")
  apply (rule fmumble_star_power)
  by assumption+

end


theory Syntax
  imports Main Push_State
begin

chapter \<open>While Language Syntax\<close>

(* a basic step is an action, a verification condition, and a behaviour set.  *)
(* note that iterated product types are right-associated. *)
type_synonym ('a,'b) basic = "('a \<times> 'b set \<times> 'b rel)"
type_synonym ('a,'b) eff = "('b set \<times> 'b rel)"
type_synonym ('a,'b) seq = "('a,'b) basic list"
type_synonym ('a,'b) wmm = "('a,'b) basic \<Rightarrow> ('a,'b) basic \<Rightarrow> ('a,'b) basic \<Rightarrow> bool"

abbreviation tag :: "('a,'b) basic \<Rightarrow> 'a"
  where "tag \<equiv> fst"

abbreviation vc :: "('a,'b) basic \<Rightarrow> 'b set"
  where "vc \<alpha> \<equiv> fst (snd \<alpha>)"

abbreviation beh :: "('a,'b) basic \<Rightarrow> 'b rel"
  where "beh \<alpha> \<equiv> snd (snd \<alpha>)"

abbreviation pushbasic where
  "pushbasic s s' \<alpha> \<equiv> (tag \<alpha>, pushpred s (vc \<alpha>), pushrel s s' (beh \<alpha>))"

abbreviation popbasic where
  "popbasic s s' \<alpha> \<equiv> (tag \<alpha>, poppred' s (vc \<alpha>), poprel' s s' (beh \<alpha>))"

text \<open>
A While language with non-deterministic choice, iteration and parallel composition.
Choice is intended to select from an arbitrary set of commands, however, this cannot
be expressed as an Isabelle datatype. To mimic a set, choice takes a function from
'labels' to arbitrary commands, where it may select any command in the function's range.
The state encoding is reused to express the notion of a label (but maybe this is a bad idea).
\<close>
datatype ('a,'b) com =
  Nil
  | Basic "('a,'b) basic"
  | Seq "('a,'b) com" "('a,'b) wmm" "('a,'b) com" ("_ ;\<^sub>_ _ " [90,0,90] 80)
  | Choice "'b \<Rightarrow> ('a,'b) com"                    (binder "\<Sqinter>" 10)
  | Loop "('a,'b) com" "('a,'b) wmm"              ("_*\<^sub>_" [90,90] 90)
  | Parallel "('a,'b) com" "('a,'b) com"          (infixr "||" 150)
  | Thread "('a,'b) com"
  | Capture 'b "('a,'b) com"

abbreviation univ_stack ("\<forall>\<^sub>c _" 100)
  where "univ_stack c \<equiv> \<Sqinter>s. Capture s c"

subsection \<open>Local Command\<close>

text \<open>
Identify if a command consists of only thread local constructs.
\<close>

inductive local :: "('a,'b) com \<Rightarrow> bool"
  where
    "local Nil" |
    "local (Basic \<alpha>)" |
    "local c\<^sub>1 \<Longrightarrow> local c\<^sub>2  \<Longrightarrow> local (c\<^sub>1 ;\<^sub>r c\<^sub>2)" |
    "\<forall>s. local (f s) \<Longrightarrow> local (Choice f)" |
    "local c \<Longrightarrow> local (c*\<^sub>w)" |
    "local c \<Longrightarrow> local (Capture k c)"

lemma local_simps [simp]:
  "local Nil = True"
  "local (Basic \<alpha>) = True"
  "local (c\<^sub>1 ;\<^sub>r c\<^sub>2) = (local c\<^sub>1 \<and> local c\<^sub>2)"
  "local (Choice f) = (\<forall>s. local (f s))"
  "local (c*\<^sub>w) = local c"
  "local (Capture k c) = local c"
  "local (c\<^sub>1 || c\<^sub>2) = False"
  "local (Thread c) = False"
  by (auto intro: local.intros elim: local.cases)

end


(*  Author:  Gertrud Bauer, Tobias Nipkow  *)

theory Plane1Props
imports Plane1 PlaneProps Tame
begin

lemma next_plane_subset:
  "\<forall>f \<in> \<F> g. vertices f \<noteq> [] \<Longrightarrow>
   set (next_plane\<^bsub>p\<^esub> g) \<subseteq> set (next_plane0\<^bsub>p\<^esub> g)"
apply(clarsimp simp:next_plane0_def next_plane_def minimalFace_def finalGraph_def)
apply(rule_tac x = "minimal (size \<circ> vertices) (nonFinals g)" in bexI)
 apply(rule_tac x = "minimalVertex g (minimal (size \<circ> vertices) (nonFinals g))" in bexI)
  apply blast
 apply(subgoal_tac "\<forall>f\<in>set (nonFinals g). vertices f \<noteq> []")
  apply(simp add:minimalVertex_def)
 apply(simp add:nonFinals_def)
apply simp
done

lemma mgp_next_plane0_if_next_plane:
  "minGraphProps g \<Longrightarrow> g [next_plane\<^bsub>p\<^esub>]\<rightarrow> g' \<Longrightarrow> g [next_plane0\<^bsub>p\<^esub>]\<rightarrow> g'"
using next_plane_subset by(blast dest: mgp_vertices_nonempty)

lemma inv_inv_next_plane: "invariant inv next_plane\<^bsub>p\<^esub>"
apply(rule inv_subset[OF inv_inv_next_plane0])
apply(blast dest: mgp_next_plane0_if_next_plane[OF inv_mgp])
done

end


(*
    This file is a part of IsarMathLib -
    a library of formalized mathematics written for Isabelle/Isar.

    Copyright (C) 2020,2021 Slawomir Kolodynski

    This program is free software; Redistribution and use in source and binary forms,
    with or without modification, are permitted provided that the following conditions are met:

   1. Redistributions of source code must retain the above copyright notice,
   this list of conditions and the following disclaimer.
   2. Redistributions in binary form must reproduce the above copyright notice,
   this list of conditions and the following disclaimer in the documentation and/or
   other materials provided with the distribution.
   3. The name of the author may not be used to endorse or promote products
   derived from this software without specific prior written permission.

THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR IMPLIED
WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE,
EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. *)

section \<open> Basic properties of real numbers \<close>

theory Real_ZF_2 imports OrderedField_ZF MetricSpace_ZF
begin

text\<open> Isabelle/ZF and IsarMathLib do not have a set of real numbers built-in.
  The \<open>Real_ZF\<close> and \<open>Real_ZF_1\<close> theories provide a construction but here we do not use it in any way
  and we just assume that we have a model of real numbers (i.e. a completely ordered field)
  as defined in the \<open>Ordered_Field\<close> theory. The construction only assures us that objects with
  the desired properties exist in the ZF world. \<close>

subsection\<open>Basic notation for real numbers\<close>

text\<open> In this section we define notation that we will use whenever real numbers play a role, i.e.
  most of mathematics.\<close>

text\<open> The next locale sets up notation for contexts where real numbers are used. \<close>

locale reals =
  fixes Reals("\<real>") and Add and Mul and ROrd
  assumes R_are_reals: "IsAmodelOfReals(\<real>,Add,Mul, ROrd)"

  fixes zero ("\<zero>")
  defines zero_def[simp]: "\<zero> \<equiv> TheNeutralElement(\<real>,Add)"

  fixes one ("\<one>")
  defines one_def[simp]: "\<one> \<equiv> TheNeutralElement(\<real>,Mul)"

  fixes realmul (infixl "\<rmu>" 71)
  defines realmul_def[simp]: "x \<rmu> y \<equiv> Mul`\<langle>x,y\<rangle>"

  fixes realadd (infixl "\<ra>" 69)
  defines realadd_def[simp]: "x \<ra> y \<equiv> Add`\<langle>x,y\<rangle>"

  fixes realminus("\<rm> _" 89)
  defines realminus_def[simp]: "(\<rm>x) \<equiv> GroupInv(\<real>,Add)`(x)"

  fixes realsub (infixl "\<rs>" 90)
  defines realsub_def [simp]: "x\<rs>y \<equiv> x\<ra>(\<rm>y)"

  fixes lesseq (infix "\<lsq>" 68)
  defines lesseq_def [simp]: "x \<lsq> y \<equiv> \<langle>x,y\<rangle> \<in>  ROrd"

  fixes sless (infix "\<ls>" 68)
  defines sless_def [simp]: "x \<ls> y \<equiv> x\<lsq>y \<and> x\<noteq>y"

  fixes nonnegative ("\<real>\<^sup>+")
  defines nonnegative_def[simp]: "\<real>\<^sup>+ \<equiv> Nonnegative(\<real>,Add, ROrd)"

  fixes positiveset ("\<real>\<^sub>+")
  defines positiveset_def[simp]: "\<real>\<^sub>+ \<equiv> PositiveSet(\<real>,Add, ROrd)"

  fixes setinv ("\<sm> _" 72)
  defines setninv_def [simp]: "\<sm>A \<equiv> GroupInv(\<real>,Add)``(A)"

  fixes non_zero ("\<real>\<^sub>0")
  defines non_zero_def[simp]: "\<real>\<^sub>0 \<equiv> \<real>-{\<zero>}"

  fixes abs ("\<bar> _ \<bar>")
  defines abs_def [simp]: "\<bar>x\<bar> \<equiv> AbsoluteValue(\<real>,Add,ROrd)`(x)"

  fixes dist
  defines dist_def[simp]: "dist \<equiv> {\<langle>p,\<bar>fst(p) \<rs> snd(p)\<bar>\<rangle> . p \<in> \<real>\<times>\<real>}"

  fixes two ("\<two>")
  defines two_def[simp]: "\<two> \<equiv> \<one> \<ra> \<one>"

  fixes inv ("_\<inverse> " [96] 97)
  defines inv_def[simp]:
    "x\<inverse> \<equiv> GroupInv(\<real>\<^sub>0,restrict(Mul,\<real>\<^sub>0\<times>\<real>\<^sub>0))`(x)"

  fixes realsq ("_\<^sup>2" [96] 97)
  defines realsq_def [simp]: "x\<^sup>2 \<equiv> x\<rmu>x"

  fixes oddext ("_ \<degree>")
  defines oddext_def [simp]: "f\<degree> \<equiv> OddExtension(\<real>,Add,ROrd,f)"

  fixes disk
  defines disk_def [simp]: "disk(c,r) \<equiv> Disk(\<real>,dist,ROrd,c,r)"

text\<open> The assumtions of the \<open>field1\<close> locale (that sets the context for ordered fields)
  hold in the \<open>reals\<close> locale \<close>

lemma (in reals) field1_is_valid: shows "field1(\<real>, Add, Mul,ROrd)"
proof
  from R_are_reals show "IsAring(\<real>, Add, Mul)" and "Mul {is commutative on} \<real>"
    and "ROrd \<subseteq> \<real> \<times> \<real>" and "IsLinOrder(\<real>,  ROrd)"
    and "\<forall>x y. \<forall>z\<in>\<real>. \<langle>x, y\<rangle> \<in> ROrd \<longrightarrow> \<langle>Add`\<langle>x, z\<rangle>, Add`\<langle>y, z\<rangle>\<rangle> \<in> ROrd"
    and "Nonnegative(\<real>, Add, ROrd) {is closed under} Mul"
    and "TheNeutralElement(\<real>, Add) \<noteq> TheNeutralElement(\<real>, Mul)"
    and "\<forall>x\<in>\<real>. x \<noteq> TheNeutralElement(\<real>,Add) \<longrightarrow> (\<exists>y\<in>\<real>. Mul`\<langle>x, y\<rangle> = TheNeutralElement(\<real>,Mul))"
    using IsAmodelOfReals_def IsAnOrdField_def IsAnOrdRing_def by auto
qed

text\<open> We can use theorems proven in the  \<open>field1\<close> locale in the \<open>reals\<close> locale.
  Note that since the the \<open>field1\<close> locale is an extension of the \<open>ring1\<close> locale, which is an
  extension of \<open>ring0\<close> locale , this makes available also the theorems proven in
  the \<open>ring1\<close> and \<open>ring0\<close> locales. \<close>

sublocale reals < field1 Reals Add Mul realadd realminus realsub realmul zero one two realsq ROrd
  using field1_is_valid by auto

text\<open> The \<open>group3\<close> locale from the \<open>OrderedGroup_ZF\<close> theory defines context for theorems about
  ordered groups. We can use theorems proven in there in the \<open>reals\<close> locale as real numbers
  with addition form an ordered group. \<close>

sublocale reals < group3 Reals Add ROrd zero realadd realminus lesseq sless nonnegative positiveset
  unfolding group3_def using OrdRing_ZF_1_L4 by auto

text\<open>Since real numbers with addition form a group we can use the theorems proven in the  \<open>group0\<close>
  locale defined in the \<open>Group_ZF\<close> theory in the \<open>reals\<close> locale. \<close>

sublocale reals < group0 Reals Add zero realadd realminus
  unfolding group3_def using OrderedGroup_ZF_1_L1 by auto

text\<open>Let's recall basic properties of the real line. \<close>

lemma (in reals) basic_props: shows  "ROrd {is total on} \<real>" and "Add {is commutative on} \<real>"
  using OrdRing_ZF_1_L4(2,3) by auto

text\<open> The distance function \<open>dist\<close> defined in the \<open>reals\<close> locale is a metric. \<close>

lemma (in reals) dist_is_metric: shows
  "dist : \<real>\<times>\<real> \<rightarrow> \<real>\<^sup>+"
  "\<forall>x\<in>\<real>.\<forall>y\<in>\<real>. dist`\<langle>x,y\<rangle> = \<bar>x \<rs> y\<bar>"
  "\<forall>x\<in>\<real>.dist`\<langle>x,x\<rangle> = \<zero>"
  "\<forall>x\<in>\<real>.\<forall>y\<in>\<real>. dist`\<langle>x,y\<rangle> = dist`\<langle>y,x\<rangle>"
  "\<forall>x\<in>\<real>.\<forall>y\<in>\<real>.\<forall>z\<in>\<real>. \<bar>x \<rs> z\<bar> \<lsq> \<bar>x \<rs> y\<bar> \<ra> \<bar>y \<rs> z\<bar>"
  "\<forall>x\<in>\<real>.\<forall>y\<in>\<real>.\<forall>z\<in>\<real>. dist`\<langle>x,z\<rangle> \<lsq> dist`\<langle>x, y\<rangle> \<ra> dist`\<langle>y,z\<rangle>"
  "\<forall>x\<in>\<real>.\<forall>y\<in>\<real>. dist`\<langle>x,y\<rangle> = \<zero> \<longrightarrow> x=y"
  "IsApseudoMetric(dist,\<real>,\<real>,Add,ROrd)"
  "IsAmetric(dist,\<real>,\<real>,Add,ROrd)"
proof -
  show I: "dist : \<real>\<times>\<real> \<rightarrow> \<real>\<^sup>+" using add_group.group_op_closed add_group.inverse_in_group OrdRing_ZF_1_L4
      OrderedGroup_ZF_3_L3B  ZF_fun_from_total by simp
  then show II:"\<forall>x\<in>\<real>.\<forall>y\<in>\<real>. dist`\<langle>x,y\<rangle> = \<bar>x\<rs>y\<bar>" using ZF_fun_from_tot_val0 by auto
  then show III: "\<forall>x\<in>\<real>.dist`\<langle>x,x\<rangle> = \<zero>" using add_group.group0_2_L6 OrderedGroup_ZF_3_L2A by simp
  { fix x y
    assume "x\<in>\<real>" "y\<in>\<real>"
    then have "(\<rm>(x\<rs>y)) = y\<rs>x" using add_group.group0_2_L12 by simp
    moreover from \<open>x\<in>\<real>\<close> \<open>y\<in>\<real>\<close> have "\<bar>\<rm>(x\<rs>y)\<bar> =\<bar>x\<rs>y\<bar>"
      using add_group.group_op_closed add_group.inverse_in_group basic_props(1) OrderedGroup_ZF_3_L7A
      by simp
    ultimately have "\<bar>y\<rs>x\<bar> = \<bar>x\<rs>y\<bar>" by simp
    with \<open>x\<in>\<real>\<close> \<open>y\<in>\<real>\<close> II have "dist`\<langle>x,y\<rangle> = dist`\<langle>y,x\<rangle>" by simp
  } thus IV: "\<forall>x\<in>\<real>.\<forall>y\<in>\<real>. dist`\<langle>x,y\<rangle> = dist`\<langle>y,x\<rangle>" by simp
  { fix x y
    assume "x\<in>\<real>" "y\<in>\<real>" "dist`\<langle>x,y\<rangle> = \<zero>"
    with II have "\<bar>x\<rs>y\<bar> = \<zero>" by simp
    with \<open>x\<in>\<real>\<close> \<open>y\<in>\<real>\<close> have "x\<rs>y = \<zero>"
      using add_group.group_op_closed add_group.inverse_in_group OrderedGroup_ZF_3_L3D by auto
    with \<open>x\<in>\<real>\<close> \<open>y\<in>\<real>\<close> have"x=y" using add_group.group0_2_L11A by simp
  } thus V: "\<forall>x\<in>\<real>.\<forall>y\<in>\<real>. dist`\<langle>x,y\<rangle> = \<zero> \<longrightarrow> x=y" by auto
  { fix x y z
    assume "x\<in>\<real>" "y\<in>\<real>" "z\<in>\<real>"
    then have "\<bar>x\<rs>z\<bar> = \<bar>(x\<rs>y)\<ra>(y \<rs> z)\<bar>" using add_group.cancel_middle(5) by simp
    with \<open>x\<in>\<real>\<close> \<open>y\<in>\<real>\<close> \<open>z\<in>\<real>\<close> have "\<bar>x\<rs>z\<bar>  \<lsq> \<bar>x\<rs>y\<bar> \<ra> \<bar>y \<rs> z\<bar>"
      using add_group.group_op_closed add_group.inverse_in_group OrdRing_ZF_1_L4(2,3) OrdGroup_triangle_ineq
      by simp
  } thus  "\<forall>x\<in>\<real>.\<forall>y\<in>\<real>.\<forall>z\<in>\<real>. \<bar>x \<rs> z\<bar> \<lsq> \<bar>x \<rs> y\<bar> \<ra> \<bar>y \<rs> z\<bar>" by simp
  with II show "\<forall>x\<in>\<real>.\<forall>y\<in>\<real>.\<forall>z\<in>\<real>. dist`\<langle>x,z\<rangle> \<lsq> dist`\<langle>x, y\<rangle> \<ra> dist`\<langle>y,z\<rangle>" by auto
  with I III IV V show "IsApseudoMetric(dist,\<real>,\<real>,Add,ROrd)" and "IsAmetric(dist,\<real>,\<real>,Add,ROrd)"
    unfolding IsApseudoMetric_def IsAmetric_def by auto
qed

text\<open>Real numbers form an ordered loop.\<close>

lemma (in reals) reals_loop: shows "IsAnOrdLoop(\<real>,Add,ROrd)"
proof -
  have "IsAloop(\<real>,Add)" using add_group.group_is_loop by simp
  moreover from R_are_reals have "ROrd \<subseteq> \<real> \<times> \<real>" and "IsPartOrder(\<real>,ROrd)"
    using IsAmodelOfReals_def IsAnOrdField_def IsAnOrdRing_def Order_ZF_1_L2
    by auto
  moreover
  { fix x y z assume A: "x\<in>\<real>" "y\<in>\<real>"  "z\<in>\<real>"
    then have "x\<lsq>y \<longleftrightarrow> x\<ra>z \<lsq> y\<ra>z"
      using ord_transl_inv ineq_cancel_right by blast
    moreover from A have "x\<lsq>y \<longleftrightarrow> z\<ra>x \<lsq> z\<ra>y"
      using ord_transl_inv OrderedGroup_ZF_1_L5AE by blast
    ultimately have "(x\<lsq>y \<longleftrightarrow> x\<ra>z \<lsq> y\<ra>z) \<and> (x\<lsq>y \<longleftrightarrow> z\<ra>x \<lsq> z\<ra>y)"
      by simp
  }
  ultimately show "IsAnOrdLoop(\<real>,Add,ROrd)" unfolding IsAnOrdLoop_def by auto
qed

text\<open> The assumptions of the  \<open>pmetric_space\<close> locale hold in the \<open>reals\<close> locale. \<close>

lemma (in reals) pmetric_space_valid: shows "pmetric_space(\<real>,Add, ROrd,dist,\<real>)"
  unfolding pmetric_space_def pmetric_space_axioms_def loop1_def
  using reals_loop dist_is_metric(8)
  by blast

text\<open> The assumptions of the  \<open>metric_space\<close> locale hold in the \<open>reals\<close> locale. \<close>

lemma (in reals) metric_space_valid: shows "metric_space(\<real>,Add, ROrd,dist,\<real>)"
proof -
  have "\<forall>x\<in>\<real>. \<forall>y\<in>\<real>. dist`\<langle>x,y\<rangle>=\<zero> \<longrightarrow> x=y"
    using dist_is_metric(9) unfolding IsAmetric_def by auto
  then show ?thesis unfolding metric_space_def metric_space_axioms_def
    using pmetric_space_valid by simp
qed

text\<open>Some properties of the order relation on reals: \<close>

lemma (in reals) pos_is_lattice: shows
  "IsLinOrder(\<real>,ROrd)"
  "IsLinOrder(\<real>\<^sub>+,ROrd \<inter> \<real>\<^sub>+\<times>\<real>\<^sub>+)"
  "(ROrd \<inter> \<real>\<^sub>+\<times>\<real>\<^sub>+) {is a lattice on} \<real>\<^sub>+"
proof -
  show "IsLinOrder(\<real>,ROrd)" using OrdRing_ZF_1_L1 unfolding IsAnOrdRing_def by simp
  moreover have "\<real>\<^sub>+ \<subseteq> \<real>" using pos_set_in_gr by simp
  ultimately show "IsLinOrder(\<real>\<^sub>+,ROrd \<inter> \<real>\<^sub>+\<times>\<real>\<^sub>+)" using ord_linear_subset(2) by simp
  moreover have "(ROrd \<inter> \<real>\<^sub>+\<times>\<real>\<^sub>+) \<subseteq> \<real>\<^sub>+\<times>\<real>\<^sub>+" by auto
  ultimately show "(ROrd \<inter> \<real>\<^sub>+\<times>\<real>\<^sub>+) {is a lattice on} \<real>\<^sub>+" using lin_is_latt by simp
qed

text\<open>Of course the set of positive real numbers is nonempty as one is there.\<close>

lemma (in reals) pos_non_empty: shows "\<real>\<^sub>+\<noteq>0"
  using R_are_reals ordring_one_is_pos
  unfolding IsAmodelOfReals_def IsAnOrdField_def by auto

text\<open> We define the topology on reals as one consisting of the unions of open disks. \<close>

definition (in reals) RealTopology ("\<tau>\<^sub>\<real>")
  where "\<tau>\<^sub>\<real> \<equiv> {\<Union>A. A \<in> Pow(\<Union>c\<in>\<real>.{disk(c,r). r \<in> \<real>\<^sub>+})}"

text\<open>Real numbers form a Hausdorff topological space with topology generated by open disks. \<close>

theorem (in reals) reals_is_top:
  shows "\<tau>\<^sub>\<real> {is a topology}" "\<Union>\<tau>\<^sub>\<real> = \<real>" "\<tau>\<^sub>\<real> {is T\<^sub>2}"
proof -
  let ?B = "\<Union>c\<in>\<real>.{disk(c,r). r \<in> \<real>\<^sub>+}"
  have "pmetric_space(\<real>,Add, ROrd,dist,\<real>)" using pmetric_space_valid by simp
  moreover have "metric_space(\<real>,Add, ROrd,dist,\<real>)" using metric_space_valid by simp
  moreover have "ROrd {down-directs} \<real>\<^sub>+"
    using pos_is_lattice(3) pos_non_empty meet_down_directs down_dir_mono
    unfolding IsAlattice_def by blast
  moreover have "?B = (\<Union>c\<in>\<real>.{disk(c,r). r \<in> \<real>\<^sub>+})" by simp
  moreover have "\<tau>\<^sub>\<real> =  {\<Union>A. A \<in> Pow(?B)}" unfolding RealTopology_def by simp
  ultimately show "\<tau>\<^sub>\<real> {is a topology}"  "\<Union>\<tau>\<^sub>\<real> = \<real>"  "\<tau>\<^sub>\<real> {is T\<^sub>2}"
    using pmetric_space.pmetric_is_top metric_space.metric_space_T2
    by auto
qed

end


(*  Title:      HOL/MicroJava/BV/Typing_Framework_err.thy
    Author:     Gerwin Klein
    Copyright   2000 TUM
*)

section \<open>Lifting the Typing Framework to err, app, and eff\<close>

theory Typing_Framework_err
imports
  Typing_Framework
  SemilatAlg
begin

definition wt_err_step :: "'s ord \<Rightarrow> 's err step_type \<Rightarrow> 's err list \<Rightarrow> bool"
where
  "wt_err_step r step \<tau>s \<longleftrightarrow> wt_step (Err.le r) Err step \<tau>s"

definition wt_app_eff :: "'s ord \<Rightarrow> (nat \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> 's step_type \<Rightarrow> 's list \<Rightarrow> bool"
where
  "wt_app_eff r app step \<tau>s \<longleftrightarrow>
    (\<forall>p < size \<tau>s. app p (\<tau>s!p) \<and> (\<forall>(q,\<tau>) \<in> set (step p (\<tau>s!p)). \<tau> <=_r \<tau>s!q))"

definition map_snd :: "('b \<Rightarrow> 'c) \<Rightarrow> ('a \<times> 'b) list \<Rightarrow> ('a \<times> 'c) list"
where
  "map_snd f = map (\<lambda>(x,y). (x, f y))"

definition error :: "nat \<Rightarrow> (nat \<times> 'a err) list"
where
  "error n = map (\<lambda>x. (x,Err)) [0..<n]"

definition err_step :: "nat \<Rightarrow> (nat \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> 's step_type \<Rightarrow> 's err step_type"
where
  "err_step n app step p t =
  (case t of
    Err   \<Rightarrow> error n
  | OK \<tau> \<Rightarrow> if app p \<tau> then map_snd OK (step p \<tau>) else error n)"

definition app_mono :: "'s ord \<Rightarrow> (nat \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> nat \<Rightarrow> 's set \<Rightarrow> bool"
where
  "app_mono r app n A \<longleftrightarrow>
    (\<forall>s p t. s \<in> A \<and> p < n \<and> s \<sqsubseteq>\<^sub>r t \<longrightarrow> app p t \<longrightarrow> app p s)"

lemmas err_step_defs = err_step_def map_snd_def error_def

lemma bounded_err_stepD:
  "\<lbrakk> bounded (err_step n app step) n;
     p < n; app p a; (q,b) \<in> set (step p a) \<rbrakk> \<Longrightarrow> q < n"
(*<*)
  apply (simp add: bounded_def err_step_def)
  apply (erule allE, erule impE, assumption)
  apply (erule_tac x = "OK a" in allE, drule bspec)
   apply (simp add: map_snd_def)
   apply fast
  apply simp
  done
(*>*)

lemma in_map_sndD: "(a,b) \<in> set (map_snd f xs) \<Longrightarrow> \<exists>b'. (a,b') \<in> set xs"
(*<*)
  apply (induct xs)
  apply (auto simp add: map_snd_def)
  done
(*>*)

lemma bounded_err_stepI:
  "\<forall>p. p < n \<longrightarrow> (\<forall>s. ap p s \<longrightarrow> (\<forall>(q,s') \<in> set (step p s). q < n))
  \<Longrightarrow> bounded (err_step n ap step) n"
(*<*)
apply (clarsimp simp: bounded_def err_step_def split: err.splits)
apply (simp add: error_def image_def)
apply (blast dest: in_map_sndD)
done
(*>*)

lemma bounded_lift:
  "bounded step n \<Longrightarrow> bounded (err_step n app step) n"
(*<*)
  apply (unfold bounded_def err_step_def error_def)
  apply clarify
  apply (erule allE, erule impE, assumption)
  apply (case_tac \<tau>)
  apply (auto simp add: map_snd_def split: if_split_asm)
  done
(*>*)

lemma le_list_map_OK [simp]:
  "\<And>b. (map OK a [\<sqsubseteq>\<^bsub>Err.le r\<^esub>] map OK b) = (a [\<sqsubseteq>\<^sub>r] b)"
(*<*)
  apply (induct a)
   apply simp
  apply simp
  apply (case_tac b)
   apply simp
  apply simp
  done
(*>*)

lemma map_snd_lessI:
  "set xs {\<sqsubseteq>\<^bsub>r\<^esub>} set ys \<Longrightarrow> set (map_snd OK xs) {\<sqsubseteq>\<^bsub>Err.le r\<^esub>} set (map_snd OK ys)"
(*<*)
  apply (induct xs)
  apply (unfold lesubstep_type_def map_snd_def)
  apply auto
  done
(*>*)

lemma mono_lift:
  "\<lbrakk> order r; app_mono r app n A; bounded (err_step n app step) n;
    \<forall>s p t. s \<in> A \<and> p < n \<and> s \<sqsubseteq>\<^sub>r t \<longrightarrow> app p t \<longrightarrow> set (step p s) {\<sqsubseteq>\<^bsub>r\<^esub>} set (step p t) \<rbrakk>
  \<Longrightarrow>  mono (Err.le r) (err_step n app step) n (err A)"
(*<*)
apply (simp only: app_mono_def SemilatAlg.mono_def err_step_def)
apply clarify
apply (case_tac \<tau>)
 apply simp
apply simp
apply (case_tac \<tau>')
 apply simp
 apply clarify
 apply (simp add: lesubstep_type_def error_def)
 apply clarify
 apply (drule in_map_sndD)
 apply clarify
 apply (drule bounded_err_stepD, assumption+)
 apply (rule exI [of _ Err])
 apply simp
apply simp
apply (erule allE, erule allE, erule allE, erule impE)
 apply (rule conjI, assumption)
 apply (rule conjI, assumption)
 apply assumption
apply (rule conjI)
apply clarify
apply (erule allE, erule allE, erule allE, erule impE)
 apply (rule conjI, assumption)
 apply (rule conjI, assumption)
 apply assumption
apply (erule impE, assumption)
apply (rule map_snd_lessI, assumption)
apply clarify
apply (simp add: lesubstep_type_def error_def)
apply clarify
apply (drule in_map_sndD)
apply clarify
apply (drule bounded_err_stepD, assumption+)
apply (rule exI [of _ Err])
apply simp
done
(*>*)

lemma in_errorD: "(x,y) \<in> set (error n) \<Longrightarrow> y = Err"
(*<*) by (auto simp add: error_def) (*>*)

lemma pres_type_lift:
  "\<forall>s\<in>A. \<forall>p. p < n \<longrightarrow> app p s \<longrightarrow> (\<forall>(q, s')\<in>set (step p s). s' \<in> A)
  \<Longrightarrow> pres_type (err_step n app step) n (err A)"
(*<*)
apply (unfold pres_type_def err_step_def)
apply clarify
apply (case_tac b)
 apply simp
apply (case_tac \<tau>)
 apply simp
 apply (drule in_errorD)
 apply simp
apply (simp add: map_snd_def split: if_split_asm)
 apply fast
apply (drule in_errorD)
apply simp
done
(*>*)

lemma wt_err_imp_wt_app_eff:
  assumes wt: "wt_err_step r (err_step (size ts) app step) ts"
  assumes b:  "bounded (err_step (size ts) app step) (size ts)"
  shows "wt_app_eff r app step (map ok_val ts)"
(*<*)
proof (unfold wt_app_eff_def, intro strip, rule conjI)
  fix p assume "p < size (map ok_val ts)"
  hence lp: "p < size ts" by simp
  hence ts: "0 < size ts" by (cases p) auto
  hence err: "(0,Err) \<in> set (error (size ts))" by (simp add: error_def)

  from wt lp
  have [intro?]: "\<And>p. p < size ts \<Longrightarrow> ts ! p \<noteq> Err"
    by (unfold wt_err_step_def wt_step_def) simp

  show app: "app p (map ok_val ts ! p)"
  proof (rule ccontr)
    from wt lp obtain s where
      OKp:  "ts ! p = OK s" and
      less: "\<forall>(q,t) \<in> set (err_step (size ts) app step p (ts!p)). t <=_(Err.le r) ts!q"
      by (unfold wt_err_step_def wt_step_def stable_def)
         (auto iff: not_Err_eq)
    assume "\<not> app p (map ok_val ts ! p)"
    with OKp lp have "\<not> app p s" by simp
    with OKp have "err_step (size ts) app step p (ts!p) = error (size ts)"
      by (simp add: err_step_def)
    with err ts obtain q where
      "(q,Err) \<in> set (err_step (size ts) app step p (ts!p))" and
      q: "q < size ts" by auto
    with less have "ts!q = Err" by auto
    moreover from q have "ts!q \<noteq> Err" ..
    ultimately show False by blast
  qed

  show "\<forall>(q,t)\<in>set(step p (map ok_val ts ! p)). t \<sqsubseteq>\<^sub>r map ok_val ts ! q"
  proof clarify
    fix q t assume q: "(q,t) \<in> set (step p (map ok_val ts ! p))"

    from wt lp q
    obtain s where
      OKp:  "ts ! p = OK s" and
      less: "\<forall>(q,t) \<in> set (err_step (size ts) app step p (ts!p)). t <=_(Err.le r) ts!q"
      by (unfold wt_err_step_def wt_step_def stable_def)
         (auto iff: not_Err_eq)

    from b lp app q have lq: "q < size ts" by (rule bounded_err_stepD)
    hence "ts!q \<noteq> Err" ..
    then obtain s' where OKq: "ts ! q = OK s'" by (auto iff: not_Err_eq)

    from lp lq OKp OKq app less q
    show "t \<sqsubseteq>\<^sub>r map ok_val ts ! q"
      by (auto simp add: err_step_def map_snd_def)
  qed
qed
(*>*)

lemma wt_app_eff_imp_wt_err:
  assumes app_eff: "wt_app_eff r app step ts"
  assumes bounded: "bounded (err_step (size ts) app step) (size ts)"
  shows "wt_err_step r (err_step (size ts) app step) (map OK ts)"
(*<*)
proof (unfold wt_err_step_def wt_step_def, intro strip, rule conjI)
  fix p assume "p < size (map OK ts)"
  hence p: "p < size ts" by simp
  thus "map OK ts ! p \<noteq> Err" by simp
  { fix q t
    assume q: "(q,t) \<in> set (err_step (size ts) app step p (map OK ts ! p))"
    with p app_eff obtain
      "app p (ts ! p)" "\<forall>(q,t) \<in> set (step p (ts!p)). t \<sqsubseteq>\<^sub>r ts!q"
      by (unfold wt_app_eff_def) blast
    moreover
    from q p bounded have "q < size ts"
      by - (rule boundedD)
    hence "map OK ts ! q = OK (ts!q)" by simp
    moreover
    have "p < size ts" by (rule p)
    moreover note q
    ultimately
    have "t \<sqsubseteq>\<^bsub>Err.le r\<^esub> map OK ts ! q"
      by (auto simp add: err_step_def map_snd_def)
  }
  thus "stable (Err.le r) (err_step (size ts) app step) (map OK ts) p"
    by (unfold stable_def) blast
qed
(*>*)

end


(*  Title:      statecharts/DataSpace/Data.thy

    Author:     Steffen Helke, Software Engineering Group
    Copyright   2010 Technische Universitaet Berlin
*)

section \<open>Data Space Assignments\<close>
theory Data
imports DataSpace
begin

subsection \<open>Total data space assignments\<close>

definition
  Data :: "['d list, 'd dataspace]
                => bool" where
  "Data L D = (((length L) = (PartNum D)) \<and>
               (\<forall> i \<in> {n. n < (PartNum D)}. (L!i) \<in> (PartDom D i)))"

lemma Data_EmptySet:
    "([@ t. True], Abs_dataspace [UNIV])\<in> { (L,D) | L D. Data L D }"
apply (unfold Data_def PartDom_def)
apply auto
apply (subst Abs_dataspace_inverse)
apply auto
done

definition
  "data =
    { (L,D) |
             (L::('d list))
             (D::('d dataspace)).
              Data L D }"

typedef 'd data = "data :: ('d list * 'd dataspace) set"
  unfolding data_def
  apply (rule exI)
  apply (rule Data_EmptySet)
  done

definition
 DataValue :: "('d data) => ('d list)" where
 "DataValue = fst o Rep_data"

definition
 DataSpace :: "('d data) => ('d dataspace)" where
 "DataSpace = snd o Rep_data"

definition
 DataPart :: "['d data, nat] => 'd" ("(_ !P!/ _)" [10,11]10) where
 "DataPart d n = (DataValue d) ! n"

lemma Rep_data_tuple:
  "Rep_data D = (DataValue D, DataSpace D)"
by (unfold DataValue_def DataSpace_def, simp)

lemma Rep_data_select:
  "(DataValue D, DataSpace D) \<in> data"
apply (subst Rep_data_tuple [THEN sym])
apply (rule Rep_data)
done

lemma Data_select:
  "Data (DataValue D) (DataSpace D)"
apply (cut_tac D=D in Rep_data_select)
apply (unfold data_def)
apply auto
done

lemma length_DataValue_PartNum [simp]:
  "length (DataValue D) = PartNum (Data.DataSpace D)"
apply (cut_tac D=D in Data_select)
apply (unfold Data_def)
apply auto
done

lemma DataValue_PartDom [simp]:
  "i < PartNum (Data.DataSpace D) \<Longrightarrow>
   DataValue D ! i \<in> PartDom (Data.DataSpace D) i"
apply (cut_tac D=D in Data_select)
apply (unfold Data_def)
apply auto
done

lemma DataPart_PartDom [simp]:
  "i < PartNum (Data.DataSpace d) \<longrightarrow> (d !P! i) \<in> ((Data.DataSpace d) !D! i)"
apply (unfold DataPart_def)
apply auto
done

subsection \<open>Partial data space assignments\<close>

definition
  PData :: "['d option list, 'd dataspace] => bool" where
  "PData L D == ((length L) = (PartNum D)) \<and>
                (\<forall> i \<in> {n. n < (PartNum D)}.
                    (L!i) \<noteq> None \<longrightarrow> the (L!i) \<in> (PartDom D i))"

lemma PData_EmptySet:
    "([Some (@ t. True)], Abs_dataspace [UNIV]) \<in> { (L,D) | L D. PData L D }"
apply (unfold PData_def PartDom_def)
apply auto
apply (subst Abs_dataspace_inverse)
apply auto
done

definition
  "pdata =
    { (L,D) |
             (L::('d option list))
             (D::('d dataspace)).
              PData L D }"

typedef 'd pdata = "pdata :: ('d option list * 'd dataspace) set"
  unfolding pdata_def
  apply (rule exI)
  apply (rule PData_EmptySet)
  done

definition
  PDataValue :: "('d pdata) => ('d option list)" where
 "PDataValue = fst o Rep_pdata"

definition
  PDataSpace :: "('d pdata) => ('d dataspace)" where
 "PDataSpace = snd o Rep_pdata"

definition
  Data2PData :: "('d data) => ('d pdata)" where
 "Data2PData D = (let
                      (L,DP) = Rep_data D;
                      OL     = map Some L
                  in
                      Abs_pdata (OL,DP))"

definition
  PData2Data :: "('d pdata) => ('d data)" where
 "PData2Data D = (let
                      (OL,DP) = Rep_pdata D;
                       L      = map the OL
                  in
                      Abs_data (L,DP))"

definition
  DefaultPData :: "('d dataspace) => ('d pdata)" where
 "DefaultPData D = Abs_pdata (replicate (PartNum D) None, D)"

definition
  OptionOverride :: "('d option * 'd) => 'd" where
 "OptionOverride P = (if (fst P) = None then (snd P) else (the (fst P)))"

definition
  DataOverride :: "['d pdata, 'd data] => 'd data" ("(_ [D+]/ _)" [10,11]10) where
 "DataOverride D1 D2 =
                (let
                    (L1,DP1) = Rep_pdata D1;
                    (L2,DP2) = Rep_data D2;
                    L        = map OptionOverride (zip L1 L2)
                 in
                    Abs_data (L,DP2))"

lemma Rep_pdata_tuple:
  "Rep_pdata D = (PDataValue D, PDataSpace D)"
apply (unfold PDataValue_def PDataSpace_def)
apply (simp)
done

lemma Rep_pdata_select:
  "(PDataValue D, PDataSpace D) \<in> pdata"
apply (subst Rep_pdata_tuple [THEN sym])
apply (rule Rep_pdata)
done

lemma PData_select:
  "PData (PDataValue D) (PDataSpace D)"
apply (cut_tac D=D in Rep_pdata_select)
apply (unfold pdata_def)
apply auto
done

subsubsection \<open>\<open>DefaultPData\<close>\<close>

lemma PData_DefaultPData [simp]:
   "PData (replicate (PartNum D) None) D"
apply (unfold PData_def)
apply auto
done

lemma pdata_DefaultPData [simp]:
   "(replicate (PartNum D) None, D) \<in> pdata "
apply (unfold pdata_def)
apply auto
done

lemma PDataSpace_DefaultPData [simp]:
   "PDataSpace (DefaultPData D) = D"
apply (unfold DataSpace_def PDataSpace_def DefaultPData_def)
apply auto
apply (subst Abs_pdata_inverse)
apply auto
done

lemma length_PartNum_PData [simp]:
  "length (PDataValue P) = PartNum (PDataSpace P)"
apply (cut_tac D=P in Rep_pdata_select)
apply (unfold pdata_def PData_def)
apply auto
done

subsubsection \<open>\<open>Data2PData\<close>\<close>

lemma PData_Data2PData [simp]:
  "PData (map Some (DataValue D)) (Data.DataSpace D)"
apply (unfold PData_def)
apply auto
done

lemma pdata_Data2PData [simp]:
  "(map Some (DataValue D), Data.DataSpace D) \<in> pdata"
apply (unfold pdata_def)
apply auto
done

lemma DataSpace_Data2PData [simp]:
  "(PDataSpace (Data2PData D)) = (Data.DataSpace D)"
apply (unfold DataSpace_def PDataSpace_def Data2PData_def Let_def)
apply auto
apply (cut_tac D=D in Rep_data_tuple)
apply auto
apply (subst Abs_pdata_inverse)
apply auto
done

lemma PDataValue_Data2PData_DataValue [simp]:
     "(map the (PDataValue (Data2PData D))) = DataValue D"
apply (unfold DataValue_def PDataValue_def Data2PData_def Let_def)
apply auto
apply (cut_tac D=D in Rep_data_tuple)
apply auto
apply (subst Abs_pdata_inverse)
apply simp
apply (simp del: map_map)
done

lemma DataSpace_PData2Data:
   "Data (map the (PDataValue D)) (PDataSpace D) \<Longrightarrow>
   (Data.DataSpace (PData2Data D) = (PDataSpace D))"
apply (unfold DataSpace_def PDataSpace_def PData2Data_def Let_def)
apply auto
apply (cut_tac D=D in Rep_pdata_tuple)
apply auto
apply (subst Abs_data_inverse)
apply (unfold data_def)
apply auto
done

lemma PartNum_PDataValue_PartDom [simp]:
   "\<lbrakk> i < PartNum (PDataSpace Q);
      PDataValue Q ! i = Some y \<rbrakk> \<Longrightarrow>
      y \<in> PartDom (PDataSpace Q) i"
apply (cut_tac D=Q in Rep_pdata_select)
apply (unfold pdata_def PData_def)
apply auto
done

subsubsection \<open>\<open>DataOverride\<close>\<close>

lemma Data_DataOverride:
 "((PDataSpace P) = (Data.DataSpace Q)) \<Longrightarrow>
  Data (map OptionOverride (zip (PDataValue P) (Data.DataValue Q))) (Data.DataSpace Q)"
apply (unfold Data_def)
apply auto
apply (unfold OptionOverride_def)
apply auto
apply (rename_tac i D)
apply (case_tac "PDataValue P ! i = None")
apply auto
apply (drule sym)
apply auto
done

lemma data_DataOverride:
 "((PDataSpace P) = (Data.DataSpace Q)) \<Longrightarrow>
   (map OptionOverride (zip (PDataValue P) (Data.DataValue Q)), Data.DataSpace Q) \<in> data"
apply (unfold data_def)
apply auto
apply (rule Data_DataOverride)
apply fast
done

lemma DataSpace_DataOverride [simp]:
 "((Data.DataSpace D) = (PDataSpace E)) \<Longrightarrow>
   Data.DataSpace (E [D+] D) = (Data.DataSpace D)"
apply (unfold DataSpace_def DataOverride_def Let_def)
apply auto
apply (cut_tac D=D in Rep_data_tuple)
apply (cut_tac D=E in Rep_pdata_tuple)
apply auto
apply (subst Abs_data_inverse)
apply auto
apply (drule sym)
apply simp
apply (rule data_DataOverride)
apply auto
done

lemma DataValue_DataOverride [simp]:
 "((PDataSpace P) = (Data.DataSpace Q)) \<Longrightarrow>
  (DataValue (P [D+] Q)) = (map OptionOverride (zip (PDataValue P) (Data.DataValue Q)))"
apply (unfold DataValue_def DataOverride_def Let_def)
apply auto
apply (cut_tac D=P in Rep_pdata_tuple)
apply (cut_tac D=Q in Rep_data_tuple)
apply auto
apply (subst Abs_data_inverse)
apply auto
apply (rule data_DataOverride)
apply auto
done

subsubsection \<open>\<open>OptionOverride\<close>\<close>

lemma DataValue_OptionOverride_nth:
 "\<lbrakk> ((PDataSpace P) = (DataSpace Q));
    i < PartNum (DataSpace Q) \<rbrakk> \<Longrightarrow>
    (DataValue (P [D+] Q) ! i) =
    OptionOverride (PDataValue P ! i, DataValue Q ! i)"
apply auto
done

lemma None_OptionOverride [simp]:
   "(fst P) = None \<Longrightarrow> OptionOverride P = (snd P)"
apply (unfold OptionOverride_def)
apply auto
done

lemma Some_OptionOverride [simp]:
   "(fst P) \<noteq> None \<Longrightarrow> OptionOverride P = the (fst P)"
apply (unfold OptionOverride_def)
apply auto
done

end


(*
 * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)

theory Time_Methods_Cmd_Test imports
  Lib.Time_Methods_Cmd
  Lib.Eisbach_Methods
  "HOL-Library.Sublist"
begin

text \<open>
  @{method time_methods} is a utility that runs several methods on the same
  proof goal, printing the running time of each one.

  Usage:

    apply (time_methods [(no_check)] [(skip_fail)]
        [name1:] \<open>method1\<close>
        [name2:] \<open>method2\<close>
        ...)

  Options:

    no_check: Don't check that the outputs of each method match.

    skip_fail: Don't print anything for failed methods.
\<close>

experiment begin
  section \<open>Basic examples\<close>

  lemma
    "A \<Longrightarrow> B \<Longrightarrow> A \<or> B"
    apply (time_methods
            \<open>erule disjI1\<close>
            \<open>erule disjI2\<close>)
    done

  text \<open>Give labels to methods:\<close>
  lemma
    "A \<Longrightarrow> B \<Longrightarrow> A \<or> B"
    apply (time_methods
            label: \<open>erule disjI1\<close>
            "another label": \<open>erule disjI2\<close>)
    done

  text \<open>no_check prevents failing even if the method results differ.\<close>
  lemma
    "A \<Longrightarrow> B \<Longrightarrow> A \<or> B"
    apply (time_methods (no_check)
            \<open>rule disjI1\<close>
            \<open>rule disjI2\<close>)
    apply assumption
    done

  text \<open>
    Fast and slow list reversals.
  \<close>
  lemma list_eval_rev_append:
    "rev xs = rev xs @ []"
    "rev [] @ ys = ys"
    "rev (x # xs) @ ys = rev xs @ (x # ys)"
    by auto

  lemma "rev [0..100] = map ((-) 100) [0..100]"
        "rev [0..200] = map ((-) 200) [0..200]"
    text \<open>evaluate everything but @{term rev}\<close>
    apply (all \<open>match conclusion in "rev x = y" for x y \<Rightarrow>
                  \<open>rule subst[where t = x], simp add: upto.simps\<close>\<close>)
    apply (all \<open>match conclusion in "rev x = y" for x y \<Rightarrow>
                  \<open>rule subst[where t = y], simp add: upto.simps\<close>\<close>)

    text \<open>evaluate @{term rev}\<close>
    apply (time_methods
            naive100: \<open>simp\<close>
            slow100: \<open>simp only: rev.simps append.simps\<close>
            fast100: \<open>subst list_eval_rev_append(1), simp only: list_eval_rev_append(2-3)\<close>
          )
    apply (time_methods
            naive200: \<open>simp\<close>
            slow200: \<open>simp only: rev.simps append.simps\<close>
            fast200: \<open>subst list_eval_rev_append(1), simp only: list_eval_rev_append(2-3)\<close>
          )
    done

  text \<open>
    Fast and slow subsequence testing.
  \<close>
  lemma
    "subseq (map ((*) 2) [1 ..  5]) [1 .. 10]"
    "subseq (map ((*) 2) [1 ..  6]) [1 .. 12]"
    "subseq (map ((*) 2) [1 ..  7]) [1 .. 14]"
    "subseq (map ((*) 2) [1 ..  8]) [1 .. 16]"
    apply (all \<open>match conclusion in "subseq x y" for x y \<Rightarrow>
                  \<open>rule subst[where t = x], simp add: upto.simps,
                   rule subst[where t = y], simp add: upto.simps\<close>\<close>)

    apply (time_methods
      "HOL simp": \<open>simp\<close>

      "l4v simp": \<open>simp cong: if_cong cong del: if_weak_cong\<close>
        \<comment> \<open>exponential time!\<close>
      )+
    done

  text \<open>
    Which method is a better SAT solver?
    Instance 01 from the uf20-91 dataset at http://www.cs.ubc.ca/~hoos/SATLIB/benchm.html
  \<close>
  lemma "\<exists>x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20.
          (~x4 & x18 & ~x19) | (~x3 & ~x18 & x5) | (x5 & x8 & x15) | (x20 & ~x7 & x16) |
          (~x10 & x13 & x7) | (x12 & x9 & ~x17) | (~x17 & ~x19 & ~x5) | (x16 & ~x9 & ~x15) |
          (~x11 & x5 & x14) | (~x18 & x10 & ~x13) | (x3 & ~x11 & ~x12) | (x6 & x17 & x8) |
          (x18 & ~x14 & ~x1) | (x19 & x15 & ~x10) | (~x12 & ~x18 & x19) | (x8 & ~x4 & ~x7) |
          (x8 & x9 & ~x4) | (~x7 & ~x17 & x15) | (~x12 & x7 & x14) | (x10 & x11 & ~x8) |
          (~x2 & x15 & x11) | (~x9 & ~x6 & ~x1) | (x11 & ~x20 & x17) | (~x9 & x15 & ~x13) |
          (~x12 & x7 & x17) | (x18 & x2 & ~x20) | (~x20 & ~x12 & ~x4) | (~x19 & ~x11 & ~x14) |
          (x16 & ~x18 & x4) | (x1 & x17 & x19) | (x13 & ~x15 & ~x10) | (x12 & x14 & x13) |
          (~x12 & x14 & x7) | (x7 & ~x16 & ~x10) | (~x6 & ~x10 & ~x7) | (~x20 & ~x14 & x16) |
          (x19 & ~x17 & ~x11) | (x7 & ~x1 & x20) | (x5 & ~x12 & ~x15) | (x4 & x9 & x13) |
          (~x12 & x11 & x7) | (x5 & ~x19 & x8) | (~x1 & ~x16 & ~x17) | (~x20 & x14 & x15) |
          (~x13 & x4 & ~x10) | (~x14 & ~x7 & ~x10) | (x5 & ~x9 & ~x20) | (~x10 & ~x1 & x19) |
          (x16 & x15 & x1) | (~x16 & ~x3 & x11) | (x15 & x10 & ~x4) | (~x4 & x15 & x3) |
          (x10 & x16 & ~x11) | (x8 & ~x12 & x5) | (~x14 & x6 & ~x12) | (~x1 & ~x6 & ~x11) |
          (x13 & x5 & x1) | (x7 & x2 & ~x12) | (~x1 & x20 & ~x19) | (x2 & x13 & x8) |
          (~x15 & ~x18 & ~x4) | (x11 & ~x14 & ~x9) | (x6 & x15 & x2) | (~x5 & x12 & x15) |
          (x6 & ~x17 & ~x5) | (x13 & ~x5 & x19) | (~x20 & x1 & ~x14) | (~x9 & x17 & ~x15) |
          (x5 & ~x19 & x18) | (x12 & ~x8 & x10) | (x18 & ~x14 & x4) | (~x15 & x9 & ~x13) |
          (~x9 & x5 & x1) | (~x10 & x19 & x14) | (~x20 & ~x9 & ~x4) | (x9 & x2 & ~x19) |
          (x5 & ~x13 & x17) | (~x2 & x10 & x18) | (x18 & ~x3 & ~x11) | (~x7 & x9 & ~x17) |
          (x15 & x6 & x3) | (x2 & ~x3 & x13) | (~x12 & ~x3 & x2) | (x2 & x3 & ~x17) |
          (~x20 & x15 & x16) | (x5 & x17 & x19) | (x20 & x18 & ~x11) | (x9 & ~x1 & x5) |
          (x19 & ~x9 & ~x17) | (~x12 & x2 & ~x17)"
    using [[meson_max_clauses=99]]
    apply (time_methods
              blast: \<open>blast\<close>
              metis: \<open>metis\<close>
              meson: \<open>meson\<close>
              smt:   \<open>smt\<close>
              force: \<open>force\<close>
              fastforce: \<open>fastforce intro: ex_bool_eq[THEN iffD2]\<close>
              fastforce: \<open>fastforce simp: ex_bool_eq\<close>
              presburger: \<open>use ex_bool_eq[simp] in presburger\<close>
          )
    done

  section \<open>Other tests\<close>

  text \<open>Test ML interface\<close>
  lemma "True"
    apply (tactic \<open>
            let val method = SIMPLE_METHOD (simp_tac @{context} 1)
                fun dummy_callback _ _ = ()
            in (fn st => Time_Methods.time_methods false false dummy_callback [(NONE, method)] [] st
                      |> (fn ([timing], st') => (tracing (Timing.message timing); st')))
               |> Method.NO_CONTEXT_TACTIC @{context}
            end\<close>)
    done

  text \<open>Check that we fail when the methods give different results\<close>
  lemma
    "A \<or> B"
    apply (tactic \<open>
      let
        fun skip_dummy_state tac = fn st =>
            case Thm.prop_of st of
                Const ("Pure.prop", _) $ (Const ("Pure.term", _) $ Const ("Pure.dummy_pattern", _)) =>
                  Seq.succeed st
              | _ => tac st;
        val methods = @{thms disjI1 disjI2}
              |> map (fn rule => (NONE, SIMPLE_METHOD (resolve_tac @{context} [rule] 1)))
        fun dummy_callback _ _ = ()
      in (fn st => Time_Methods.time_methods false false dummy_callback methods [] st
                   |> (fn (timing, st') => error "test failed: shouldn't reach here")
                   handle THM _ => Seq.succeed (Seq.Result st)) (* should reach here *)
         |> Method.NO_CONTEXT_TACTIC @{context}
         |> skip_dummy_state
      end\<close>)
    oops

  text \<open>Check that we propagate failures from the input methods\<close>
  lemma "A"
    apply (fails \<open>time_methods \<open>simp\<close>\<close>)
    oops

  text \<open>Check that we skip failing methods when skip_fail set\<close>
  lemma "A \<and> B \<Longrightarrow> A"
    apply (
        ( \<comment> \<open>roughly corresponds to "time_methods (skip_fail) \<open>fail\<close>",
              but errors if it calls the output callback\<close>
          tactic \<open>
            let
              fun timing_callback _ _ = error "test failed: shouldn't reach here"
              val methods = [(NONE, SIMPLE_METHOD no_tac)]
            in
              (fn st =>
                #2 (Time_Methods.time_methods false true timing_callback methods [] st))
              |> Method.NO_CONTEXT_TACTIC @{context}
            end\<close>)
      | time_methods (skip_fail) good_simp: \<open>simp\<close>)
    done
end

end