theory Print
  imports Show.Show HOL.Rat
begin

subsection \<open>Instances of the Show-class\<close>

text \<open>We do not import "Show.Show_Instances", because we provide a different, more efficient
  instantiation for @{typ rat}.
  The other instances (for @{typ unit}, @{typ nat}, etc.) are copied from "Show.Show_Instances".\<close>

definition showsp_unit :: "unit showsp"
where
  "showsp_unit p x = shows_string ''()''"

lemma show_law_unit [show_law_intros]:
  "show_law showsp_unit x"
  by (rule show_lawI) (simp add: showsp_unit_def show_law_simps)

abbreviation showsp_char :: "char showsp"
where
  "showsp_char \<equiv> shows_prec"

lemma show_law_char [show_law_intros]:
  "show_law showsp_char x"
  by (rule show_lawI) (simp add: show_law_simps)

primrec showsp_bool :: "bool showsp"
where
  "showsp_bool p True = shows_string ''True''" |
  "showsp_bool p False = shows_string ''False''"

lemma show_law_bool [show_law_intros]:
  "show_law showsp_bool x"
  by (rule show_lawI, cases x) (simp_all add: show_law_simps)

primrec pshowsp_prod :: "(shows \<times> shows) showsp"
where
  "pshowsp_prod p (x, y) = shows_string ''('' o x o shows_string '', '' o y o shows_string '')''"

definition showsp_prod :: "'a showsp \<Rightarrow> 'b showsp \<Rightarrow> ('a \<times> 'b) showsp"
where
  [code del]: "showsp_prod s1 s2 p = pshowsp_prod p o map_prod (s1 1) (s2 1)"

lemma showsp_prod_simps [simp, code]:
  "showsp_prod s1 s2 p (x, y) =
    shows_string ''('' o s1 1 x o shows_string '', '' o s2 1 y o shows_string '')''"
  by (simp add: showsp_prod_def)

fun string_of_digit :: "nat \<Rightarrow> string"
where
  "string_of_digit n =
    (if n = 0 then ''0''
    else if n = 1 then ''1''
    else if n = 2 then ''2''
    else if n = 3 then ''3''
    else if n = 4 then ''4''
    else if n = 5 then ''5''
    else if n = 6 then ''6''
    else if n = 7 then ''7''
    else if n = 8 then ''8''
    else ''9'')"

fun showsp_nat :: "nat showsp"
where
  "showsp_nat p n =
    (if n < 10 then shows_string (string_of_digit n)
    else showsp_nat p (n div 10) o shows_string (string_of_digit (n mod 10)))"
declare showsp_nat.simps [simp del]

lemma show_law_nat [show_law_intros]:
  "show_law showsp_nat n"
  by (rule show_lawI, induct n rule: nat_less_induct) (simp add: show_law_simps showsp_nat.simps)

lemma showsp_nat_append [show_law_simps]:
  "showsp_nat p n (x @ y) = showsp_nat p n x @ y"
  by (intro show_lawD show_law_intros)

definition showsp_int :: "int showsp"
where
  "showsp_int p i =
    (if i < 0 then shows_string ''-'' o showsp_nat p (nat (- i)) else showsp_nat p (nat i))"

lemma show_law_int [show_law_intros]:
  "show_law showsp_int i"
  by (rule show_lawI, cases "i < 0") (simp_all add: showsp_int_def show_law_simps)

lemma showsp_int_append [show_law_simps]:
  "showsp_int p i (x @ y) = showsp_int p i x @ y"
  by (intro show_lawD show_law_intros)

fun showsp_natural :: "natural showsp"
where
  "showsp_natural p n =
    (if n < 10 then shows_string (string_of_digit (nat_of_natural n))
    else showsp_natural p (n div 10) o shows_string (string_of_digit (nat_of_natural (n mod 10))))"
declare showsp_natural.simps [simp del]

lemma showsp_nat_showsp_natural: "showsp_nat p n = showsp_natural p (natural_of_nat n)"
proof (induct n rule: nat_less_induct)
  case (1 n)
  show ?case
    by (subst showsp_nat.simps, subst showsp_natural.simps)
       (smt 1 div_less_dividend divide_natural.rep_eq less_natural.rep_eq modulo_natural.rep_eq
        nat_of_natural_inverse nat_of_natural_numeral nat_of_natural_of_nat_inverse not_gr_zero
        one_less_numeral_iff semiring_norm(76) zero_less_numeral)
qed

corollary showsp_natural_showsp_nat: "showsp_natural p n = showsp_nat p (nat_of_natural n)"
  by (simp add: showsp_nat_showsp_natural)

lemma show_law_natural [show_law_intros]: "show_law showsp_natural n"
  by (rule show_lawI, simp add: showsp_natural_showsp_nat showsp_nat_append)

lemma showsp_natural_append [show_law_simps]:
  "showsp_natural p n (x @ y) = showsp_natural p n x @ y"
  by (intro show_lawD show_law_intros)

definition showsp_integer :: "integer showsp"
where
  "showsp_integer p i =
    (if i < 0 then shows_string ''-'' o showsp_natural p (natural_of_integer (- i)) else showsp_natural p (natural_of_integer i))"

lemma show_law_integer [show_law_intros]: "show_law showsp_integer i"
  by (rule show_lawI, cases "i < 0", simp_all add: showsp_integer_def show_law_simps)

lemma showsp_integer_append [show_law_simps]:
  "showsp_integer p i (x @ y) = showsp_integer p i x @ y"
  by (intro show_lawD show_law_intros)

definition showsp_rat :: "rat showsp"
where
  "showsp_rat p x =
    (case quotient_of x of (d, n) \<Rightarrow>
      if n = 1 then
        showsp_integer p (integer_of_int d) else
        showsp_integer p (integer_of_int d) o shows_string ''/'' o showsp_integer p (integer_of_int n))"

lemma show_law_rat [show_law_intros]:
  "show_law showsp_rat r"
  by (rule show_lawI, cases "quotient_of r") (simp add: showsp_rat_def show_law_simps)

lemma showsp_rat_append [show_law_simps]:
  "showsp_rat p r (x @ y) = showsp_rat p r x @ y"
  by (intro show_lawD show_law_intros)

local_setup {*
  Show_Generator.register_foreign_partial_and_full_showsp @{type_name prod} 0
       @{term "pshowsp_prod"}
       @{term "showsp_prod"} (SOME @{thm showsp_prod_def})
       @{term "map_prod"} (SOME @{thm prod.map_comp}) [true, true]
       @{thm show_law_prod}
  #> Show_Generator.register_foreign_showsp @{typ unit} @{term "showsp_unit"} @{thm show_law_unit}
  #> Show_Generator.register_foreign_showsp @{typ bool} @{term "showsp_bool"} @{thm show_law_bool}
  #> Show_Generator.register_foreign_showsp @{typ char} @{term "showsp_char"} @{thm show_law_char}
  #> Show_Generator.register_foreign_showsp @{typ nat} @{term "showsp_nat"} @{thm show_law_nat}
  #> Show_Generator.register_foreign_showsp @{typ int} @{term "showsp_int"} @{thm show_law_int}
  #> Show_Generator.register_foreign_showsp @{typ rat} @{term "showsp_rat"} @{thm show_law_rat}
  #> Show_Generator.register_foreign_showsp @{typ natural} @{term "showsp_natural"} @{thm show_law_natural}
  #> Show_Generator.register_foreign_showsp @{typ integer} @{term "showsp_integer"} @{thm show_law_integer}
*}

derive "show" option sum prod unit bool nat int rat natural integer

subsection \<open>Printing\<close>

text \<open>Taken from AFP-entry "Affine-Arithmetic".\<close>

definition print_raw :: "String.literal \<Rightarrow> unit" where "print_raw x = ()"

abbreviation "print \<equiv> (\<lambda>a b. let _ = print_raw (String.implode (show a)) in b)"

definition echo :: "'a \<Rightarrow> 'a::show" where "echo x = print x x"

code_printing constant print_raw \<rightharpoonup> (SML) "writeln"

lemma echo_id: "echo = (\<lambda>x. x)"
  by (rule, simp add: echo_def)

subsection \<open>File Output\<close>

definition file_output :: "String.literal \<Rightarrow> ((String.literal \<Rightarrow> unit) \<Rightarrow> 'a) \<Rightarrow> 'a" where
  "file_output _ f = f (\<lambda>_. ())"

code_printing constant file_output \<rightharpoonup> (SML) "(fn s => fn f => File.open'_output (fn os => f (File.output os)) (Path.explode s))"

subsection \<open>Timing\<close>

typedecl ('a, 'b) cpu_timer
typedecl time

consts start_cpu_timer :: "unit \<Rightarrow> ('a, 'b) cpu_timer"
consts check_cpu_timer :: "('a, 'b) cpu_timer \<Rightarrow> (time \<times> time)"
consts time_to_string :: "time \<Rightarrow> String.literal"

definition check_cpu_timer_string :: "('a, 'b) cpu_timer \<Rightarrow> String.literal"
  where "check_cpu_timer_string t =
    (let (usr, sys) = check_cpu_timer t in (STR ''User: '' + time_to_string usr) + STR ''  System: '' + time_to_string sys)"

definition timing_raw :: "String.literal \<Rightarrow> (unit \<Rightarrow> 'a) \<Rightarrow> 'a"
  where "timing_raw s f = (let tmr = (start_cpu_timer ())::(nat, nat) cpu_timer;
                         res = f ();
                         _ = print_raw (s + check_cpu_timer_string tmr) in res)"

definition timing_raw_nores :: "String.literal \<Rightarrow> (unit \<Rightarrow> 'a) \<Rightarrow> unit"
  where "timing_raw_nores s f = (let tmr = (start_cpu_timer ())::(nat, nat) cpu_timer;
                         res = f ();
                         _ = print_raw (s + check_cpu_timer_string tmr) in ())"

abbreviation "timing \<equiv> (\<lambda>v. timing_raw (STR '''') (\<lambda>_. v))"
abbreviation "timing_nores \<equiv> (\<lambda>v. timing_raw_nores (STR '''') (\<lambda>_. v))"
abbreviation "timing_lbl \<equiv> (\<lambda>s v. timing_raw (String.implode s + STR '': '') (\<lambda>_. v))"

lemma timing_raw_id: "timing_raw s f = f ()"
  by (simp add: timing_raw_def)

code_printing
type_constructor cpu_timer \<rightharpoonup>
    (SML) "_ Timer.cpu_timer"
| type_constructor time \<rightharpoonup>
    (SML) "Time.time"
| constant start_cpu_timer \<rightharpoonup>
    (SML) "Timer.startCPUTimer"
| constant check_cpu_timer \<rightharpoonup>
    (SML) "(fn ct => (let val {usr, sys} = Timer.checkCPUTimer ct in (usr, sys) end))"
| constant time_to_string \<rightharpoonup>
    (SML) "Time.toString"

end (* theory *)


theory CoCallsFuture
imports CoCallGraph CallFutures
begin

inductive_set any_future :: "var set \<Rightarrow> future set" for S
  where "domF f \<subseteq> S \<Longrightarrow> f \<in> any_future S"

definition conformsToCC :: "future \<Rightarrow> CoCalls \<Rightarrow> bool"
  where "conformsToCC f G \<longleftrightarrow> (\<forall>x y. (x--y\<notin>G) \<longrightarrow> possible x f \<longrightarrow>  \<not> possible y (after x f))"

definition ccFilterFuture  :: "future set \<Rightarrow> CoCalls \<Rightarrow> future set"
  where "ccFilterFuture S G = {f \<in> S . conformsToCC f G}"

lemma no_future_conforms[simp]:  "conformsToCC no_future G"
  unfolding conformsToCC_def by simp

end


theory BDD_union
  imports Main BDD_basic BDD_dedup BDD_select
begin

fun union :: "BDD \<Rightarrow> BDD \<Rightarrow> BDD" where
  "union Nothing b = b" |
  "union Top _ = Top" |
  "union a Nothing = a" |
  "union a Top = Top" |
  "union (Select a at ae) (Select b bt be) =
    (if a > b then select a (union at (Select b bt be)) (union ae (Select b bt be))
     else if a = b then  select a (union at bt) (union ae be)
     else select b (union (Select a at ae) bt) (union (Select a at ae) be))"

lemma union_simp_nothing [simp]: "union a Nothing = a"
  apply (induction a)
  by auto

lemma union_simp_top [simp]: "union a Top = Top"
  apply (induction a)
  by auto

theorem ordered_union [simp]: "ordered n a \<Longrightarrow> ordered n b \<Longrightarrow> ordered n (union a b)"
  apply (induction a b arbitrary: n rule: union.induct)
  apply simp_all
  apply auto
  apply (metis BDD.inject BDD.simps(5) BDD.simps(7) ordered.simps ordered_select)
  apply (metis BDD.inject BDD.simps(5) BDD.simps(7) ordered.simps ordered_select)
  by (metis BDD.inject BDD.simps(5) BDD.simps(7) linorder_cases ordered.simps ordered_select)

lemma dup_free_union [simp]: "norm n a \<Longrightarrow> norm n b \<Longrightarrow> norm n (union a b)"
  apply (induction a b rule: union.induct)
  apply simp_all
  apply auto
  apply (metis BDD.distinct(3) BDD.distinct(6) BDD.inject elim_dup_dedups elim_dup_noop norm.simps norm_ord norm_select norm_widen ordered.simps ordered_union)
  apply (metis BDD.distinct(6) BDD.inject BDD.simps(5) elim_dup_dedups elim_dup_noop norm.cases norm_ord norm_select norm_widen ordered.simps ordered_union)
  by (smt (verit, best) BDD.distinct(6) BDD.inject select_def BDD.simps(5) antisym_conv3 elim_dup_dedups elim_dup_noop norm.simps norm_ord norm_widen ordered_union)

theorem union_correct [simp]: "contains (union a b) p = (contains a p \<or> contains b p)"
  apply (induction a b rule: union.induct)
  apply (simp add: contains_p_correct)
  apply fastforce
  apply fastforce
  apply fastforce
  apply (metis contains_p.simps(3) contains_p_correct select_correct union.simps(5))
  done

end


theory SimpleVariant imports HOML MFilter BaseDefs
begin
(*Axiom's of new, simplified variant*)
axiomatization where
 A1': "\<lfloor>\<^bold>\<not>(\<P>(\<lambda>x.(x\<^bold>\<noteq>x)))\<rfloor>" and
 A2': "\<lfloor>\<^bold>\<forall>X Y.(((\<P> X) \<^bold>\<and> ((X\<^bold>\<sqsubseteq>Y) \<^bold>\<or> (X\<Rrightarrow>Y))) \<^bold>\<rightarrow> (\<P> Y))\<rfloor>" and
 A3:  "\<lfloor>\<^bold>\<forall>\<Z>.((\<P>\<o>\<s> \<Z>) \<^bold>\<rightarrow> (\<^bold>\<forall>X.((X\<Sqinter>\<Z>) \<^bold>\<rightarrow> (\<P> X))))\<rfloor>"

lemma T2: "\<lfloor>\<P> \<G>\<rfloor>" by (metis A3 G_def) (*From A3*)
lemma L1: "\<lfloor>\<P>(\<lambda>x.(x\<^bold>=x))\<rfloor>" by (metis A2' A3)

(*Necessary existence of a Godlike entity*)
theorem T6: "\<lfloor>\<^bold>\<box>(\<^bold>\<exists>\<^sup>E \<G>)\<rfloor>" sledgehammer (*Proof found*)
proof -
 have T1: "\<lfloor>\<^bold>\<forall>X.((\<P> X) \<^bold>\<rightarrow> \<^bold>\<diamond>(\<^bold>\<exists>\<^sup>E X))\<rfloor>" by (metis A1' A2')
 have T3: "\<lfloor>\<^bold>\<diamond>(\<^bold>\<exists>\<^sup>E \<G>)\<rfloor>" using T1 T2 by simp
 have T5: "\<lfloor>(\<^bold>\<diamond>(\<^bold>\<exists>\<^sup>E \<G>)) \<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>\<exists>\<^sup>E \<G>)\<rfloor>" by (metis A1' A2' T2)
  thus ?thesis using T3 by blast qed

lemma True nitpick[satisfy] oops (*Consistency: model found*)

(*Modal collapse and monotheism: not implied*)
lemma MC: "\<lfloor>\<^bold>\<forall>\<Phi>.(\<Phi> \<^bold>\<rightarrow> \<^bold>\<box>\<Phi>)\<rfloor>" nitpick oops (*Countermodel*)
lemma MT: "\<lfloor>\<^bold>\<forall>x y.(((\<G> x) \<^bold>\<and> (\<G> y)) \<^bold>\<rightarrow> (x\<^bold>=y))\<rfloor>"
          nitpick oops (*Countermodel*)

(*Gödel's A1, A4, A5: not implied anymore*)

(*Checking filter and ultrafilter properties*)
theorem F1: "\<lfloor>Filter \<P>\<rfloor>" sledgehammer oops (*Proof found*)
theorem U1: "\<lfloor>UFilter \<P>\<rfloor>" nitpick oops (*Countermodel*)
end

(*
(*More detailed proof for T5*)
theorem T5again: "\<lfloor>(\<^bold>\<diamond>(\<^bold>\<exists>\<^sup>E \<G>)) \<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>\<exists>\<^sup>E \<G>)\<rfloor>"
 proof -
 have L1: "\<lfloor>(\<^bold>\<exists>X.((\<P> X)\<^bold>\<and>\<^bold>\<not>(\<^bold>\<exists>\<^sup>EX)))\<^bold>\<rightarrow>(\<P>(\<lambda>x.(x\<^bold>\<noteq>x)))\<rfloor>" by (smt A2')
 have L2: "\<lfloor>\<^bold>\<not>(\<^bold>\<exists>X.((\<P> X) \<^bold>\<and> \<^bold>\<not>(\<^bold>\<exists>\<^sup>E X)))\<rfloor>" by (metis L1 A1')
 have T1': "\<lfloor>\<^bold>\<forall>X.((\<P> X) \<^bold>\<rightarrow> (\<^bold>\<exists>\<^sup>E X))\<rfloor>" by (metis L2)
 have T2': "\<lfloor>\<P> \<G>\<rfloor>" by (metis A3 G_def)
 have T3': "\<lfloor>\<^bold>\<exists>\<^sup>E \<G>\<rfloor>" by (metis T1' T2')
 have L3: "\<lfloor>\<^bold>\<box>(\<^bold>\<exists>\<^sup>E \<G>)\<rfloor>" using T3' by auto
 have L4: "\<lfloor>(\<^bold>\<diamond>(\<^bold>\<exists>\<^sup>E \<G>)) \<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>\<exists>\<^sup>E \<G>)\<rfloor>" using L3 by blast
   thus ?thesis by blast qed
end
*)

(*
lemma T: "\<lfloor>\<^bold>\<forall>\<phi>. \<^bold>\<box>\<phi> \<^bold>\<rightarrow> \<phi>\<rfloor>" sledgehammer nitpick oops
abbreviation h1 (infix"\<^bold>=\<^bold>="90) where "x\<^bold>=\<^bold>=y \<equiv> \<lambda>w.(x=y)"
abbreviation h2 (infix"\<^bold>\<noteq>\<^bold>\<noteq>"90) where "x\<^bold>\<noteq>\<^bold>\<noteq>y \<equiv> \<lambda>w.(x\<noteq>y)"

consts GG::\<gamma>
axiomatization where GG: "GG = \<G>"

(*Definition Schnitt aller positiven Eigenschaften*)
abbreviation schnittPos::"\<gamma>\<Rightarrow>\<sigma>" ("SchnittPos") where "SchnittPos X \<equiv> X\<Sqinter>\<P>"

theorem  "\<lfloor>\<^bold>\<forall>X. (SchnittPos X) \<^bold>\<rightarrow> (X \<^bold>=\<^bold>= \<G>)\<rfloor>" nitpick[show_all,format=4] oops (*Countermodel*)

(*Definition of Hauptfilter for X*)
abbreviation hf::"\<gamma>\<Rightarrow>(\<gamma>\<Rightarrow>\<sigma>)" ("Hauptfilter")
  where "Hauptfilter X \<equiv> \<lambda>Y. (X\<^bold>\<subseteq>Y)"

abbreviation hf2::"\<gamma>\<Rightarrow>(\<gamma>\<Rightarrow>\<sigma>)" ("Hauptfilter2")
  where "Hauptfilter2 X \<equiv> \<lambda>Y. X\<^bold>\<sqsubseteq>Y"

abbreviation hf3::"\<gamma>\<Rightarrow>(\<gamma>\<Rightarrow>\<sigma>)" ("Hauptfilter3")
  where "Hauptfilter3 X \<equiv> \<lambda>Y. X\<Rrightarrow>Y"

abbreviation hf4::"\<gamma>\<Rightarrow>(\<gamma>\<Rightarrow>\<sigma>)" ("Hauptfilter4")
  where "Hauptfilter4 X \<equiv> \<lambda>Y. X\<^bold>\<sqsubseteq>Y \<^bold>\<or> X\<Rrightarrow>Y"

axiomatization where OneWorld: "\<exists>w::i. \<forall>v. w = v"

theorem H1: "\<lfloor>\<^bold>\<forall>X. (SchnittPos X) \<^bold>\<rightarrow> Filter (Hauptfilter X)\<rfloor>"
  by (metis A1' A2' G_def T2)

theorem H2: "\<lfloor>\<^bold>\<forall>X. (SchnittPos X) \<^bold>\<rightarrow> Filter (Hauptfilter2 X)\<rfloor>"
  by (metis A1' A2' G_def T2)

theorem H3: "\<lfloor>\<^bold>\<forall>X. (SchnittPos X) \<^bold>\<rightarrow> Filter (Hauptfilter3 X)\<rfloor>"
  sledgehammer (A1' A2' G_def T2 OneWorld)
  by (smt A1' A2' G_def OneWorld T2)  nitpick oops (*Countermodel*)

theorem H4: "\<lfloor>\<^bold>\<forall>X. (SchnittPos X) \<^bold>\<rightarrow> Filter (Hauptfilter4 X)\<rfloor>"
  proof - {fix X
  have 1: "\<lfloor>(SchnittPos X) \<^bold>\<rightarrow> (\<^bold>U\<^bold>\<in>(Hauptfilter4 X) \<^bold>\<and> \<^bold>\<not>(\<^bold>\<emptyset>\<^bold>\<in>(Hauptfilter4 X)))\<rfloor>"
    by (metis A1' A2' G_def T2 T6)
  have 2: "\<lfloor>(SchnittPos X) \<^bold>\<rightarrow> (\<^bold>\<forall>\<phi> \<psi>.((\<phi>\<^bold>\<in>(Hauptfilter4 X) \<^bold>\<and> (\<phi>\<^bold>\<subseteq>\<psi>)) \<^bold>\<rightarrow> \<psi>\<^bold>\<in>(Hauptfilter4 X)))\<rfloor>"
    sledgehammer nitpick sorry
  have 3: "\<lfloor>(SchnittPos X) \<^bold>\<rightarrow> (\<^bold>\<forall>\<phi> \<psi>.((\<phi>\<^bold>\<in>(Hauptfilter4 X) \<^bold>\<and> \<psi>\<^bold>\<in>(Hauptfilter4 X)) \<^bold>\<rightarrow> (\<phi>\<^bold>\<sqinter>\<psi>)\<^bold>\<in>(Hauptfilter4 X)))\<rfloor>"
     sorry
  have 4: "\<lfloor>(SchnittPos X) \<^bold>\<rightarrow> Filter (Hauptfilter4 X)\<rfloor>"
    using 1 2 3 sorry
}
  thus ?thesis sorry qed

consts HF1::"\<gamma>\<Rightarrow>(\<gamma>\<Rightarrow>\<sigma>)" HF2::"\<gamma>\<Rightarrow>(\<gamma>\<Rightarrow>\<sigma>)" HF3::"\<gamma>\<Rightarrow>(\<gamma>\<Rightarrow>\<sigma>)" HF4::"\<gamma>\<Rightarrow>(\<gamma>\<Rightarrow>\<sigma>)"

axiomatization where
 AA1:  "HF1 = Hauptfilter" and
 AA2:  "HF2 = Hauptfilter2" and
 AA3:  "HF3 = Hauptfilter3" and
 AA4:  "HF4 = Hauptfilter4"

theorem  "\<lfloor>\<^bold>\<forall>X. (SchnittPos X) \<^bold>\<rightarrow> ((HF1 X) \<^bold>=\<^bold>= (HF2 X))\<rfloor>" sledgehammer nitpick[show_all,format=4] oops
theorem  "\<lfloor>\<^bold>\<forall>X. (SchnittPos X) \<^bold>\<rightarrow> ((HF1 X) \<^bold>=\<^bold>= (HF3 X))\<rfloor>" sledgehammer nitpick[show_all,format=4] oops
theorem  "\<lfloor>\<^bold>\<forall>X. (SchnittPos X) \<^bold>\<rightarrow> ((HF2 X) \<^bold>=\<^bold>= (HF3 X))\<rfloor>" sledgehammer nitpick[show_all,format=4] oops
theorem  "\<lfloor>\<^bold>\<forall>X. (SchnittPos X) \<^bold>\<rightarrow> ((HF3 X) \<^bold>=\<^bold>= (HF4 X))\<rfloor>" sledgehammer nitpick[show_all,format=4] oops

(*Necessary existence of a Godlike entity*)
theorem T6':  "\<lfloor>\<^bold>\<box>(\<^bold>\<exists>\<^sup>E \<G>)\<rfloor>" sledgehammer (*Proof found*)
 proof -
  have T1: "\<lfloor>\<^bold>\<forall>X. \<P> X \<^bold>\<rightarrow> \<^bold>\<diamond>(\<^bold>\<exists>\<^sup>E X)\<rfloor>" by (metis A1' A2')
  have T2: "\<lfloor>\<P> \<G>\<rfloor>" by (metis A3 G_def)
  have T3: "\<lfloor>\<^bold>\<diamond>(\<^bold>\<exists>\<^sup>E \<G>)\<rfloor>" using T1 T2 by simp
  have T5: "\<lfloor>\<^bold>\<diamond>(\<^bold>\<exists>\<^sup>E \<G>) \<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>\<exists>\<^sup>E \<G>)\<rfloor>" by (metis A1' A2' T2)
  thus ?thesis using T3 by blast qed

end
*)

(*
(*Further Tests*)
 lemma A3': "\<lfloor>\<^bold>\<forall>X Y.((\<P> X) \<^bold>\<and> (\<P> Y)) \<^bold>\<rightarrow> \<P> (\<lambda>z. X z  \<^bold>\<and> Y z)\<rfloor>" sledgehammer(A3) nitpick oops

 lemma "\<lfloor>(X\<^bold>\<sqsubseteq>Y)\<^bold>\<rightarrow>(X\<Rrightarrow>Y)\<rfloor>" nitpick oops (*Countermodel*)
 lemma "\<lfloor>(X\<Rrightarrow>Y)\<^bold>\<rightarrow>(X\<^bold>\<sqsubseteq>Y)\<rfloor>" sledgehammer nitpick oops (*Countermodel*)
 lemma "(\<lfloor>(X\<^bold>\<sqsubseteq>Y)\<rfloor>)\<longrightarrow>(\<lfloor>(X\<Rrightarrow>Y)\<rfloor>)" nitpick oops (*Countermodel*)
 lemma "(\<lfloor>(X\<Rrightarrow>Y)\<rfloor>)\<longrightarrow>(\<lfloor>(X\<^bold>\<sqsubseteq>Y)\<rfloor>)" nitpick oops (*Countermodel*)
*)

(*
lemma T2: "\<lfloor>\<P> \<G>\<rfloor>" by (metis A3 G_def)
theorem F1: "\<lfloor>Filter \<P>\<rfloor>" sledgehammer (*Proof found*)
proof -
 have 1: "\<lfloor>\<^bold>U\<^bold>\<in>\<P> \<^bold>\<and> \<^bold>\<not>(\<^bold>\<emptyset>\<^bold>\<in>\<P>)\<rfloor>" using A1' by auto
 have 2: "\<lfloor>\<^bold>\<forall>\<phi> \<psi>.((\<phi>\<^bold>\<in>\<P> \<^bold>\<and> (\<phi>\<^bold>\<subseteq>\<psi>)) \<^bold>\<rightarrow> \<psi>\<^bold>\<in>\<P>)\<rfloor>" by (metis A2')
 have 3: "\<lfloor>\<^bold>\<forall>\<phi> \<psi>.((\<phi>\<^bold>\<in>\<P> \<^bold>\<and> \<psi>\<^bold>\<in>\<P>) \<^bold>\<rightarrow> (\<phi>\<^bold>\<sqinter>\<psi>)\<^bold>\<in>\<P>)\<rfloor>" by (metis (no_types, lifting) A2' G_def A3)
 thus ?thesis using 1 2 3 by simp qed

theorem U1: "\<lfloor>Ultrafilter \<P>\<rfloor>" nitpick oops (*Countermodel*)
*)

(*
abbreviation a2::"\<gamma>\<Rightarrow>(\<gamma>\<Rightarrow>\<sigma>)\<Rightarrow>\<sigma>" (infix"\<^bold>\<in>"81) where "x\<^bold>\<in>S \<equiv> S x"
abbreviation b2::\<gamma> ("\<^bold>\<emptyset>") where "\<^bold>\<emptyset> \<equiv> \<lambda>x. \<^bold>\<bottom>"
abbreviation c2::\<gamma> ("\<^bold>U") where "\<^bold>U \<equiv> \<lambda>x. \<^bold>\<top>"
abbreviation d2::"\<gamma>\<Rightarrow>\<gamma>\<Rightarrow>\<sigma>" ("_\<^bold>\<subseteq>_") where "\<phi>\<^bold>\<subseteq>\<psi> \<equiv> \<^bold>\<forall>x. \<phi> x \<^bold>\<rightarrow> \<psi> x"
abbreviation e2::"\<gamma>\<Rightarrow>\<gamma>\<Rightarrow>\<gamma>" ("_\<^bold>\<sqinter>_") where "\<phi>\<^bold>\<sqinter>\<psi> \<equiv> \<lambda>x. \<phi> x \<^bold>\<and> \<psi> x"
abbreviation f2::"\<gamma>\<Rightarrow>\<gamma>" ("\<inverse>_") where "\<inverse>\<psi> \<equiv> \<lambda>x. \<^bold>\<not>(\<psi> x)"

(*Definition of modal filter*)
abbreviation g::"(\<gamma>\<Rightarrow>\<sigma>)\<Rightarrow>\<sigma>" ("Filter")
  where "Filter \<Phi> \<equiv> \<^bold>U\<^bold>\<in>\<Phi> \<^bold>\<and> \<^bold>\<not>(\<^bold>\<emptyset>\<^bold>\<in>\<Phi>)
                     \<^bold>\<and> (\<^bold>\<forall>\<phi> \<psi>. (\<phi>\<^bold>\<in>\<Phi> \<^bold>\<and> (\<phi>\<^bold>\<subseteq>\<psi>)) \<^bold>\<rightarrow> \<psi>\<^bold>\<in>\<Phi>)
                     \<^bold>\<and> (\<^bold>\<forall>\<phi> \<psi>. (\<phi>\<^bold>\<in>\<Phi> \<^bold>\<and> \<psi>\<^bold>\<in>\<Phi>) \<^bold>\<rightarrow> (\<phi>\<^bold>\<sqinter>\<psi>)\<^bold>\<in>\<Phi>)"

(*Definition of modal ultrafilter *)
abbreviation h::"(\<gamma>\<Rightarrow>\<sigma>)\<Rightarrow>\<sigma>" ("Ultrafilter")
  where "Ultrafilter \<Phi> \<equiv> Filter \<Phi> \<^bold>\<and> (\<^bold>\<forall>\<phi>. (\<phi>\<^bold>\<in>\<Phi>) \<^bold>\<or> ((\<inverse>\<phi>)\<^bold>\<in>\<Phi>))"

theorem U1: "\<lfloor>Ultrafilter \<P>\<rfloor>"
proof -
 have 1: "\<lfloor>\<^bold>U\<^bold>\<in>\<P> \<^bold>\<and> \<^bold>\<not>(\<^bold>\<emptyset>\<^bold>\<in>\<P>)\<rfloor>" using A1' by auto
 have 2: "\<lfloor>\<^bold>\<forall>\<phi> \<psi>.((\<phi>\<^bold>\<in>\<P> \<^bold>\<and> (\<phi>\<^bold>\<subseteq>\<psi>)) \<^bold>\<rightarrow> \<psi>\<^bold>\<in>\<P>)\<rfloor>" by (metis A2')
 have 3: "\<lfloor>\<^bold>\<forall>\<phi> \<psi>.((\<phi>\<^bold>\<in>\<P> \<^bold>\<and> \<psi>\<^bold>\<in>\<P>) \<^bold>\<rightarrow> (\<phi>\<^bold>\<sqinter>\<psi>)\<^bold>\<in>\<P>)\<rfloor>" using A3 sledgehammer [remote_satallax remote_leo2 remote_leo3]  nitpick sorry
 have 4: "\<lfloor>\<^bold>\<forall>\<phi>.(\<phi>\<^bold>\<in>\<P> \<^bold>\<or> (\<inverse>\<phi>)\<^bold>\<in>\<P>)\<rfloor>" nitpick oops
 thus ?thesis using 1 2 3 4 by simp qed

 lemma "\<lfloor>Filter \<P> \<rfloor>" sledgehammer nitpick oops (*Counterm*)
 lemma "\<lfloor>Ultrafilter \<P> \<rfloor>" sledgehammer nitpick oops (*Counterm*)

(*Filter and ultrafilter are consistent*)

 consts Godlike::\<gamma>  NeEx::\<gamma>
 axiomatization where
  1: "Godlike = \<G>" and
  2: "NeEx = \<N>\<E>" and
  3: "\<exists>e1::e. \<exists>e2::e. \<not> e1 = e2"

 lemma True nitpick[satisfy] oops
 lemma MT: "\<lfloor>\<^bold>\<forall>x y. \<G> x \<^bold>\<and> \<G> y \<^bold>\<rightarrow> x \<^bold>= y\<rfloor>" nitpick oops (*Cntm.*)
 lemma MT: "\<lfloor>\<^bold>\<forall>\<^sup>Ex y. \<G> x \<^bold>\<and> \<G> y \<^bold>\<rightarrow> x \<^bold>= y\<rfloor>" sledgehammer nitpick [format=2] oops
 lemma MT': "\<G> x w \<and> \<G> y w \<and> \<not>\<G> z w \<longrightarrow> x = y" sledgehammer nitpick [format=2] oops
 lemma MT'': "\<lfloor>\<^bold>\<forall>\<^sup>Ex y. \<G> x \<^bold>\<and> \<G> y \<^bold>\<rightarrow> (\<^bold>\<forall>P. P x \<^bold>\<rightarrow> P y)\<rfloor>" sledgehammer nitpick [format=2] oops
 lemma MC: "\<lfloor>\<^bold>\<forall>\<Phi>.(\<Phi> \<^bold>\<rightarrow> (\<^bold>\<box> \<Phi>))\<rfloor>" nitpick[timeout = 10000] nunchaku oops (*Countermodel*)
 lemma A1: "\<lfloor>\<^bold>\<forall>X.(\<^bold>\<not>(\<P> X) \<^bold>\<leftrightarrow> \<P>(\<^bold>\<rightharpoondown>X))\<rfloor>" nitpick[format=4] oops (*Countermodel*)
 lemma A4: "\<lfloor>\<^bold>\<forall>X.(\<P> X \<^bold>\<rightarrow> \<^bold>\<box>(\<P> X))\<rfloor>" nitpick[format=4] oops (*Countermodel*)
 lemma A5: "\<lfloor>\<P> \<N>\<E>\<rfloor>" nitpick oops (*Countermodel*)
*)


section \<open>The algorithm\<close>

theory Generic_Join
  imports MFOTL_Monitor_Devel.Table
begin

type_synonym 'a atable = "nat set \<times> 'a table"
type_synonym 'a query = "'a atable set"
type_synonym vertices = "nat set"

type_synonym 'a satable = "nat set \<times> ('a tuple \<Rightarrow> 'a tuple set)"
type_synonym 'a squery = "nat set \<times> nat set \<times> 'a satable set"

subsection \<open>Generic algorithm\<close>

locale getIJ =
  fixes getIJ :: "'a query \<Rightarrow> 'a query \<Rightarrow> vertices \<Rightarrow> vertices \<times> vertices"
  assumes coreProperties: "card V \<ge> 2 \<Longrightarrow> getIJ Q_pos Q_neg V = (I, J) \<Longrightarrow>
    card I \<ge> 1 \<and> card J \<ge> 1 \<and> V = I \<union> J \<and> I \<inter> J = {}"
begin

lemma getIJProperties:
  assumes "card V \<ge> 2"
  assumes "(I, J) = getIJ Q_pos Q_neg V"
  shows "card I \<ge> 1" and "card J \<ge> 1" and "card I < card V" and "card J < card V"
    and "V = I \<union> J" and "I \<inter> J = {}"
proof -
  show "1 \<le> card I" using coreProperties[of V Q_pos Q_neg I J] assms by auto
  show "1 \<le> card J" using coreProperties[of V Q_pos Q_neg I J] assms by auto
  show "card I < card V" by (metis (no_types, lifting) Int_ac(3) One_nat_def Suc_le_lessD assms(1)
        assms(2) card_gt_0_iff card_seteq dual_order.trans getIJ.coreProperties getIJ_axioms leI
        le_iff_inf one_le_numeral sup_ge1 sup_ge2)
  show "card J < card V" by (metis One_nat_def Suc_1 assms(1) assms(2) card_gt_0_iff card_seteq
        getIJ.coreProperties getIJ_axioms leI le_0_eq le_iff_inf nat.simps(3) sup_ge1 sup_ge2)
  show "V = I \<union> J" by (metis assms(1) assms(2) getIJ.coreProperties getIJ_axioms)
  show "I \<inter> J = {}" by (metis assms(1) assms(2) getIJ_axioms getIJ_def)
qed

fun projectTable :: "vertices \<Rightarrow> 'a atable \<Rightarrow> 'a atable" where
  "projectTable V (s, t) = (s \<inter> V, Set.image (restrict V) t)"

fun filterQuery :: "vertices \<Rightarrow> 'a query \<Rightarrow> 'a query" where
  "filterQuery V Q = Set.filter (\<lambda>(s, _). \<not> Set.is_empty (s \<inter> V)) Q"

fun filterQueryNeg :: "vertices \<Rightarrow> 'a query \<Rightarrow> 'a query" where
  "filterQueryNeg V Q = Set.filter (\<lambda>(A, _). A \<subseteq> V) Q"

fun projectQuery :: "vertices \<Rightarrow> 'a query \<Rightarrow> 'a query" where
  "projectQuery V s = Set.image (projectTable V) s"

fun isSameIntersection :: "'a tuple \<Rightarrow> nat set \<Rightarrow> 'a tuple \<Rightarrow> bool" where
  "isSameIntersection t1 s t2 = (restrict s t1 = restrict s t2)"

fun semiJoin :: "'a atable \<Rightarrow> (nat set \<times> 'a tuple) \<Rightarrow> 'a atable" where
  "semiJoin (s, tab) (st, tup) = (s, Set.filter (isSameIntersection tup (s \<inter> st)) tab)"

fun newQuery :: "vertices \<Rightarrow> 'a query \<Rightarrow> (nat set \<times> 'a tuple) \<Rightarrow> 'a query" where
  "newQuery V Q (st, t) = Set.image (\<lambda>tab. projectTable V (semiJoin tab (st, t))) Q"

fun merge_option :: "'a option \<times> 'a option \<Rightarrow> 'a option" where
  "merge_option (None, None) = None"
| "merge_option (Some x, None) = Some x"
| "merge_option (None, Some x) = Some x"
| "merge_option (Some a, Some b) = Some a"
(* Last case shouldn't happen but useful for proof *)

fun merge :: "'a tuple \<Rightarrow> 'a tuple \<Rightarrow> 'a tuple" where
  "merge t1 t2 = map merge_option (zip t1 t2)"

function (sequential) genericJoin :: "vertices \<Rightarrow> 'a query \<Rightarrow> 'a query \<Rightarrow> 'a table" where
  "genericJoin V Q_pos Q_neg =
    (if card V \<le> 1 then
      (\<Inter>(_, x) \<in> Q_pos. x) - (\<Union>(_, x) \<in> Q_neg. x)
    else
      let (I, J) = getIJ Q_pos Q_neg V in
      let Q_I_pos = projectQuery I (filterQuery I Q_pos) in
      let Q_I_neg = filterQueryNeg I Q_neg in
      let R_I = genericJoin I Q_I_pos Q_I_neg in
      let Q_J_neg = Q_neg - Q_I_neg in
      let Q_J_pos = filterQuery J Q_pos in
      let X = {(t, genericJoin J (newQuery J Q_J_pos (I, t)) (newQuery J Q_J_neg (I, t)))
        | t . t \<in> R_I} in
      (\<Union>(t, x) \<in> X. {merge xx t | xx . xx \<in> x}))"
by pat_completeness auto
termination
  by (relation "measure (\<lambda>(V, Q_pos, Q_neg). card V)") (auto simp add: getIJProperties)

fun squery_of_query :: "vertices \<Rightarrow> vertices \<Rightarrow> 'a query \<Rightarrow> 'a squery" where
  "squery_of_query I J Q = (I, J, Set.image (\<lambda>(V, T).
    (V, Equiv_Relations.proj (Set.image (\<lambda>t. (restrict (V \<inter> I) t, restrict J t)) T))) Q)"

fun query_of_squery :: "'a squery \<Rightarrow> 'a tuple \<Rightarrow> 'a query" where
  "query_of_squery (I, J, SQ) t = Set.image (\<lambda>(V, f). (V \<inter> J, f (restrict (V \<inter> I) t))) SQ"

lemma squery_correct: "t \<in> R \<Longrightarrow> newQuery J Q (I, t) = query_of_squery (squery_of_query I J
  (Set.image (\<lambda>(V, T). let R' = restrict (V \<inter> I) ` R in
    (V, Set.filter (\<lambda>t. restrict (V \<inter> I) t \<in> R') T)) Q)) t"
  by (auto simp: Equiv_Relations.proj_def image_image intro!: image_cong rev_image_eqI) simp+

lemma genericJoin_code[code]:
  "genericJoin V Q_pos Q_neg =
    (if card V \<le> 1 then
      (\<Inter>(_, x) \<in> Q_pos. x) - (\<Union>(_, x) \<in> Q_neg. x)
    else
      let (I, J) = getIJ Q_pos Q_neg V in
      let Q_I_pos = projectQuery I (filterQuery I Q_pos) in
      let Q_I_neg = filterQueryNeg I Q_neg in
      let R_I = genericJoin I Q_I_pos Q_I_neg in
      (if Set.is_empty R_I then {} else
        let Q_J_neg = Q_neg - Q_I_neg in
        let Q_J_pos = filterQuery J Q_pos in
        let SQ_J_pos = squery_of_query I J (Set.image (\<lambda>(V, T).
          let V' = V \<inter> I; R' = restrict V' ` R_I in
          (V, Set.filter (\<lambda>t. restrict V' t \<in> R') T)) Q_J_pos) in
        let SQ_J_neg = squery_of_query I J (Set.image (\<lambda>(V, T).
          let V' = V \<inter> I; R' = restrict V' ` R_I in
          (V, Set.filter (\<lambda>t. restrict V' t \<in> R') T)) Q_J_neg) in
        let X = {(t, genericJoin J (query_of_squery SQ_J_pos t) (query_of_squery SQ_J_neg t))
          | t . t \<in> R_I} in
        (\<Union>(t, x) \<in> X. {merge xx t | xx . xx \<in> x})))"
  by (subst genericJoin.simps)
     (fastforce simp only: Let_def Set.is_empty_def squery_correct split: if_splits)

fun wrapperGenericJoin :: "'a query \<Rightarrow> 'a query \<Rightarrow> 'a table" where
  "wrapperGenericJoin Q_pos Q_neg =
    (if ((\<exists>(A, X)\<in>Q_pos. Set.is_empty X) \<or> (\<exists>(A, X)\<in>Q_neg. Set.is_empty A \<and> \<not> Set.is_empty X)) then
      {}
    else
      let Q = Set.filter (\<lambda>(A, _). \<not> Set.is_empty A) Q_pos in
      if Set.is_empty Q then
        (\<Inter>(A, X)\<in>Q_pos. X) -  (\<Union>(A, X)\<in>Q_neg. X)
      else
        let V = (\<Union>(A, X)\<in>Q. A) in
        let Qn = Set.filter (\<lambda>(A, _). A \<subseteq> V \<and> card A \<ge> 1) Q_neg in
        genericJoin V Q Qn)"

end

subsection \<open>An instantation\<close>

fun score :: "'a query \<Rightarrow> nat \<Rightarrow> nat" where
  "score Q i = sum (\<lambda>(_, x). card x) (Set.filter (\<lambda>(sign, _). i \<in> sign) Q)"

fun arg_max_list :: "('a \<Rightarrow> ('b::linorder)) \<Rightarrow> 'a list \<Rightarrow> 'a" where
  "arg_max_list f [x] = x"
| "arg_max_list f (x#y#zs) = (let m = arg_max_list f (y#zs) in if f m \<le> f x then x else m)"

lemma arg_max_list_element:
  assumes "length l \<ge> 1" shows "arg_max_list f l \<in> set l"
  using assms
  by (induction l rule: induct_list012) (auto simp: Let_def)

fun max_getIJ :: "'a query \<Rightarrow> 'a query \<Rightarrow> vertices \<Rightarrow> vertices \<times> vertices" where
  "max_getIJ Q_pos Q_neg V = (
  let l = sorted_list_of_set V in
  if Set.is_empty Q_neg then
    let x = arg_max_list (score Q_pos) l in
    ({x}, V - {x})
  else
    let x = arg_max_list (score Q_neg) l in
    (V - {x}, {x}))"

lemma max_getIJ_coreProperties:
  assumes "card V \<ge> 2"
  assumes "(I, J) = max_getIJ Q_pos Q_neg V"
  shows "card I \<ge> 1 \<and> card J \<ge> 1 \<and> V = I \<union> J \<and> I \<inter> J = {}"
proof -
  have "finite V" using assms(1) card.infinite by force
  define l where "l = sorted_list_of_set V"
  then have "length l \<ge> 1" by (metis Suc_1 Suc_le_lessD \<open>finite V\<close> assms(1) distinct_card
        distinct_sorted_list_of_set less_imp_le set_sorted_list_of_set)
  show ?thesis
  proof (cases "Set.is_empty Q_neg")
    case True
    define x where "x = arg_max_list (score Q_pos) l"
    then have "x \<in> (set l)" using \<open>1 \<le> length l\<close> arg_max_list_element by blast
    then have "x \<in> V" by (simp add: \<open>finite V\<close> l_def)
    moreover have "(I, J) = ({x}, V - {x})"
    proof -
      have "(I, J) =  (let l = sorted_list_of_set V in
    let x = arg_max_list (score Q_pos) l in
    ({x}, V - {x}))" by (simp add: True assms(2))
      then show ?thesis by (metis l_def x_def)
    qed
    then show ?thesis using Pair_inject \<open>finite V\<close> assms(1) calculation by auto
  next
    case False
    define x where "x = arg_max_list (score Q_neg) l"
    then have "x \<in> (set l)" using \<open>1 \<le> length l\<close> arg_max_list_element by blast
    then have "x \<in> V" by (simp add: \<open>finite V\<close> l_def)
    moreover have "(I, J) = (V - {x}, {x})"
    proof -
      have "(I, J) = (let l = sorted_list_of_set V in
  let x = arg_max_list (score Q_neg) l in (V - {x}, {x}))" by (simp add: False assms(2))
      then show ?thesis by (metis l_def x_def)
    qed
    then show ?thesis using Pair_inject \<open>finite V\<close> assms(1) calculation by auto
  qed
qed

global_interpretation New_max: getIJ max_getIJ
  defines New_max_getIJ_genericJoin = "New_max.genericJoin"
  and New_max_getIJ_wrapperGenericJoin = "New_max.wrapperGenericJoin"
  by standard (metis max_getIJ_coreProperties)

end


section {*I\_kparser\_FS\_HFS*}
theory
  I_kparser_FS_HFS

imports
  I_kparser_FS
  I_kparser_HFS

begin

definition parserHFS_to_parserFS_derivation :: "
  (('stack, 'event) parser_step_label, ('stack, 'event) parserHFS_conf)derivation
  \<Rightarrow> (('stack, 'event) parser_step_label, ('stack, 'event) parserFS_conf)derivation"
  where
    "parserHFS_to_parserFS_derivation d \<equiv>
  \<lambda>n. case d n of
  None \<Rightarrow> None
  | Some (pair e c) \<Rightarrow>
      Some (pair e
        \<lparr>parserFS_conf_fixed = parserHFS_conf_fixed c,
        parserFS_conf_stack = parserHFS_conf_stack c,
        parserFS_conf_scheduler = drop (length(parserHFS_conf_fixed c))(parserHFS_conf_scheduler c)\<rparr>)"

lemma parserHFS_to_parserFS_derivation_preserves_derivation_initial: "
  valid_parser P
  \<Longrightarrow> parserHFS.derivation_initial P d
  \<Longrightarrow> parserFS.derivation_initial P (parserHFS_to_parserFS_derivation d)"
  apply(simp add: parserHFS_to_parserFS_derivation_def)
  apply(simp add: parserFS.derivation_initial_def)
  apply(rule conjI)
   prefer 2
   apply(simp add: parserHFS.derivation_initial_def)
   apply(clarsimp)
   apply(case_tac "d 0")
    apply(clarsimp)
   apply(rename_tac a)(*strict*)
   apply(clarsimp)
   apply(case_tac a)
   apply(rename_tac a option b)(*strict*)
   apply(clarsimp)
   apply(rename_tac b)(*strict*)
   apply(simp add: parserFS_initial_configurations_def parserHFS_initial_configurations_def)
   apply(clarsimp)
   apply(simp add: parserFS_configurations_def parserHFS_configurations_def)
   apply(clarsimp)
   apply(rename_tac w)(*strict*)
   apply(simp add: parser_fixed_schedulers_def parser_schedulers_def parser_unfixed_schedulers_def prefix_closure_def suffix_closure_def)
   apply(rule conjI)
    apply(rename_tac w)(*strict*)
    apply(rule_tac x="[parser_bottom P]" in exI)
    apply(simp add: prefix_def)
   apply(rename_tac w)(*strict*)
   apply(rule_tac x="(w @ [parser_bottom P])" in exI)
   apply(simp add: suffix_def)
  apply(simp add: parserFS.derivation_def)
  apply(clarsimp)
  apply(rename_tac i)(*strict*)
  apply(case_tac "i")
   apply(rename_tac i)(*strict*)
   apply(clarsimp)
   apply(simp add: parserHFS.derivation_initial_def)
   apply(clarsimp)
   apply(case_tac "d 0")
    apply(clarsimp)
   apply(rename_tac a)(*strict*)
   apply(clarsimp)
   apply(case_tac a)
   apply(rename_tac a option b)(*strict*)
   apply(clarsimp)
  apply(rename_tac i nat)(*strict*)
  apply(clarsimp)
  apply(rename_tac nat)(*strict*)
  apply(case_tac "d (Suc nat)")
   apply(rename_tac nat)(*strict*)
   apply(clarsimp)
  apply(rename_tac nat a)(*strict*)
  apply(subgoal_tac "\<exists>e1 e2 c1 c2. d nat = Some (pair e1 c1) \<and> d (Suc nat) = Some (pair (Some e2) c2) \<and> parserHFS_step_relation P c1 e2 c2")
   apply(rename_tac nat a)(*strict*)
   prefer 2
   apply(rule_tac
      m="Suc nat"
      in parserHFS.step_detail_before_some_position)
     apply(rename_tac nat a)(*strict*)
     apply(simp add: parserHFS.derivation_initial_def)
    apply(rename_tac nat a)(*strict*)
    apply(force)
   apply(rename_tac nat a)(*strict*)
   apply(force)
  apply(rename_tac nat a)(*strict*)
  apply(clarsimp)
  apply(rename_tac nat e1 e2 c1 c2)(*strict*)
  apply(subgoal_tac "c1 \<in> parserHFS_configurations P")
   apply(rename_tac nat e1 e2 c1 c2)(*strict*)
   prefer 2
   apply(rule parserHFS.belongs_configurations)
    apply(rename_tac nat e1 e2 c1 c2)(*strict*)
    apply(rule parserHFS.derivation_initial_belongs)
     apply(rename_tac nat e1 e2 c1 c2)(*strict*)
     apply(force)
    apply(rename_tac nat e1 e2 c1 c2)(*strict*)
    apply(force)
   apply(rename_tac nat e1 e2 c1 c2)(*strict*)
   apply(force)
  apply(rename_tac nat e1 e2 c1 c2)(*strict*)
  apply(subgoal_tac "valid_parser_step_label P e2")
   apply(rename_tac nat e1 e2 c1 c2)(*strict*)
   prefer 2
   apply(simp add: valid_parser_def)
   apply(simp add: parserFS_step_relation_def parserHFS_step_relation_def)
  apply(rename_tac nat e1 e2 c1 c2)(*strict*)
  apply(simp add: parserFS_step_relation_def parserHFS_step_relation_def valid_parser_step_label_def parserHFS_configurations_def)
  apply(clarsimp)
  apply(rename_tac nat e1 e2 c2 f h k w xa xb y xc wa)(*strict*)
  apply(case_tac e2)
  apply(rename_tac nat e1 e2 c2 f h k w xa xb y xc wa rule_lpopa rule_rpopa rule_lpusha rule_rpusha)(*strict*)
  apply(case_tac c2)
  apply(rename_tac nat e1 e2 c2 f h k w xa xb y xc wa rule_lpopa rule_rpopa rule_lpusha rule_rpusha parserHFS_conf_fixeda parserHFS_conf_historya parserHFS_conf_stacka parserHFS_conf_schedulera)(*strict*)
  apply(clarsimp)
  apply(rename_tac nat e1 f h k w xa xb y xc wa rule_lpop rule_lpush rule_rpush)(*strict*)
  apply(rename_tac lpo lpu rpu)
  apply(rename_tac nat e1 f h k w xa xb y xc wa lpo lpu rpu)(*strict*)
  apply(rule_tac conjI)
   apply(rename_tac nat e1 f h k w xa xb y xc wa lpo lpu rpu)(*strict*)
   apply(rule_tac x="xc" in exI)
   apply(force)
  apply(rename_tac nat e1 f h k w xa xb y xc wa lpo lpu rpu)(*strict*)
  apply(simp add: prefix_def)
  apply(clarsimp)
  apply(rename_tac nat e1 f h k w xa xb y xc wa lpo lpu rpu c)(*strict*)
  apply(subgoal_tac "prefix f (kPrefix k (w @ [parser_bottom P])) \<or> prefix (kPrefix k (w @ [parser_bottom P])) f")
   apply(rename_tac nat e1 f h k w xa xb y xc wa lpo lpu rpu c)(*strict*)
   prefer 2
   apply(rule mutual_prefix_prefix)
   apply(force)
  apply(rename_tac nat e1 f h k w xa xb y xc wa lpo lpu rpu c)(*strict*)
  apply(erule disjE)
   apply(rename_tac nat e1 f h k w xa xb y xc wa lpo lpu rpu c)(*strict*)
   apply(simp add: prefix_def)
   apply(clarsimp)
   apply(rename_tac nat e1 f h k w xa xb y xc wa lpo lpu rpu c ca)(*strict*)
   apply(rule conjI)
    apply(rename_tac nat e1 f h k w xa xb y xc wa lpo lpu rpu c ca)(*strict*)
    apply (metis drop_append)
   apply(rename_tac nat e1 f h k w xa xb y xc wa lpo lpu rpu c ca)(*strict*)
   apply (metis drop_length_append)
  apply(rename_tac nat e1 f h k w xa xb y xc wa lpo lpu rpu c)(*strict*)
  apply(simp add: prefix_def)
  apply(clarsimp)
  done

lemma parserHFS_to_parserFS_derivation_preserves_parser_fixed_input_length_recN: "
  valid_parser G
  \<Longrightarrow> parserHFS.derivation G d
  \<Longrightarrow> parser_fixed_input_length_recN d n = parser_fixed_input_length_recN (parserHFS_to_parserFS_derivation d) n"
  apply(induct n)
   apply(clarsimp)
  apply(rename_tac n)(*strict*)
  apply(clarsimp)
  apply(case_tac "d(Suc n)")
   apply(rename_tac n)(*strict*)
   apply(clarsimp)
   apply(simp add: parserHFS_to_parserFS_derivation_def)
  apply(rename_tac n a)(*strict*)
  apply(clarsimp)
  apply(subgoal_tac "\<exists>e c. d (Suc n) = Some (pair (Some e) c)")
   apply(rename_tac n a)(*strict*)
   apply(clarsimp)
   apply(rename_tac n e c)(*strict*)
   apply(simp add: parserHFS_to_parserFS_derivation_def)
  apply(rename_tac n a)(*strict*)
  apply(rule parserHFS.pre_some_position_is_some_position_prime)
     apply(rename_tac n a)(*strict*)
     apply(force)
    apply(rename_tac n a)(*strict*)
    apply(force)
   apply(rename_tac n a)(*strict*)
   apply(force)
  apply(rename_tac n a)(*strict*)
  apply(force)
  done

lemma parserHFS_to_parserFS_derivation_preserves_step_labels: "
  valid_parser G
  \<Longrightarrow> parserHFS.derivation G d
  \<Longrightarrow> d n = Some (pair e c)
  \<Longrightarrow> \<exists>c. (parserHFS_to_parserFS_derivation d) n = Some (pair e c)"
  apply(induct n arbitrary: e c)
   apply(rename_tac e c)(*strict*)
   apply(simp add: parserHFS_to_parserFS_derivation_def)
  apply(rename_tac n e c)(*strict*)
  apply(clarsimp)
  apply(subgoal_tac "\<exists>e1 e2 c1 c2. d n = Some (pair e1 c1) \<and> d (Suc n) = Some (pair (Some e2) c2) \<and> parserHFS_step_relation G c1 e2 c2")
   apply(rename_tac n e c)(*strict*)
   prefer 2
   apply(rule_tac
      m="Suc n"
      in parserHFS.step_detail_before_some_position)
     apply(rename_tac n e c)(*strict*)
     apply(force)
    apply(rename_tac n e c)(*strict*)
    apply(force)
   apply(rename_tac n e c)(*strict*)
   apply(force)
  apply(rename_tac n e c)(*strict*)
  apply(clarsimp)
  apply(rename_tac n c e1 e2 c1)(*strict*)
  apply(erule_tac
      x="e1"
      in meta_allE)
  apply(erule_tac
      x="c1"
      in meta_allE)
  apply(clarsimp)
  apply(rename_tac n c e1 e2 c1 ca)(*strict*)
  apply(simp add: parserHFS_to_parserFS_derivation_def)
  done

lemma parserHFS_to_parserFS_derivation_preserves_maximum_of_domain: "
  valid_parser G
  \<Longrightarrow> maximum_of_domain d n
  \<Longrightarrow> maximum_of_domain (parserHFS_to_parserFS_derivation d) n"
  apply(simp add: maximum_of_domain_def parserHFS_to_parserFS_derivation_def)
  apply(clarsimp)
  apply(rename_tac y)(*strict*)
  apply(case_tac y)
  apply(rename_tac y option b)(*strict*)
  apply(clarsimp)
  done

definition parserFS_to_parserHFS_derivation :: "
  ('stack, 'event, 'marker) parser
  \<Rightarrow> (('stack, 'event) parser_step_label, ('stack, 'event) parserFS_conf) derivation
  \<Rightarrow> (('stack, 'event) parser_step_label, ('stack, 'event) parserHFS_conf)derivation"
  where
    "parserFS_to_parserHFS_derivation G d \<equiv>
  \<lambda>n.
  case d n of
  None \<Rightarrow> None
  | Some (pair e c) \<Rightarrow>
      Some (pair e
        \<lparr>parserHFS_conf_fixed
          = parserFS_conf_fixed c,
        parserHFS_conf_history
          = butlast_if_match ((the (right_quotient_word
                    (parserFS_conf_scheduler
                      (the (get_configuration (d 0))))
                    (parserFS_conf_scheduler c)))) (parser_bottom G),
        parserHFS_conf_stack = parserFS_conf_stack c,
        parserHFS_conf_scheduler = parserFS_conf_fixed c @ parserFS_conf_scheduler c\<rparr>)"

lemma parserFS_to_parserHFS_derivation_preserves_derivation_initial: "
  valid_parser P
  \<Longrightarrow> parserFS.derivation_initial P d
  \<Longrightarrow> parserHFS.derivation_initial P (parserFS_to_parserHFS_derivation P d)"
  apply(simp add: parserFS_to_parserHFS_derivation_def)
  apply(simp add: parserHFS.derivation_initial_def)
  apply(rule conjI)
   prefer 2
   apply(simp add: parserFS.derivation_initial_def)
   apply(clarsimp)
   apply(case_tac "d 0")
    apply(clarsimp)
   apply(rename_tac a)(*strict*)
   apply(clarsimp)
   apply(case_tac a)
   apply(rename_tac a option b)(*strict*)
   apply(clarsimp)
   apply(rename_tac b)(*strict*)
   apply(simp add: parserFS_initial_configurations_def parserHFS_initial_configurations_def)
   apply(clarsimp)
   apply(simp add: parserFS_configurations_def parserHFS_configurations_def)
   apply(clarsimp)
   apply(rename_tac w)(*strict*)
   apply(simp add: get_configuration_def)
   apply(simp add: right_quotient_word_def)
   apply(simp add: prefix_def)
   apply(simp add: suffix_def butlast_if_match_def parser_schedulers_def parser_unfixed_schedulers_def valid_parser_def)
   apply(clarsimp)
  apply(simp add: parserHFS.derivation_def)
  apply(clarsimp)
  apply(rename_tac i)(*strict*)
  apply(case_tac "i")
   apply(rename_tac i)(*strict*)
   apply(clarsimp)
   apply(simp add: parserFS.derivation_initial_def)
   apply(clarsimp)
   apply(case_tac "d 0")
    apply(clarsimp)
   apply(rename_tac a)(*strict*)
   apply(clarsimp)
   apply(case_tac a)
   apply(rename_tac a option b)(*strict*)
   apply(clarsimp)
  apply(rename_tac i nat)(*strict*)
  apply(clarsimp)
  apply(rename_tac nat)(*strict*)
  apply(case_tac "d (Suc nat)")
   apply(rename_tac nat)(*strict*)
   apply(clarsimp)
  apply(rename_tac nat a)(*strict*)
  apply(subgoal_tac "\<exists>e1 e2 c1 c2. d nat = Some (pair e1 c1) \<and> d (Suc nat) = Some (pair (Some e2) c2) \<and> parserFS_step_relation P c1 e2 c2")
   apply(rename_tac nat a)(*strict*)
   prefer 2
   apply(rule_tac
      m="Suc nat"
      in parserFS.step_detail_before_some_position)
     apply(rename_tac nat a)(*strict*)
     apply(simp add: parserFS.derivation_initial_def)
    apply(rename_tac nat a)(*strict*)
    apply(force)
   apply(rename_tac nat a)(*strict*)
   apply(force)
  apply(rename_tac nat a)(*strict*)
  apply(clarsimp)
  apply(rename_tac nat e1 e2 c1 c2)(*strict*)
  apply(simp add: parserFS_step_relation_def parserHFS_step_relation_def)
  apply(clarsimp)
  apply(rename_tac nat e1 e2 c1 c2 x xa)(*strict*)
  apply(subgoal_tac "\<exists>c. d 0 = Some (pair None c)")
   apply(rename_tac nat e1 e2 c1 c2 x xa)(*strict*)
   prefer 2
   apply(rule parserFS.some_position_has_details_at_0)
   apply(simp add: parserFS.derivation_initial_def)
   apply(force)
  apply(rename_tac nat e1 e2 c1 c2 x xa)(*strict*)
  apply(simp add: get_configuration_def)
  apply(clarsimp)
  apply(rename_tac nat e1 e2 c1 c2 x xa c)(*strict*)
  apply(subgoal_tac "valid_parser_step_label P e2")
   apply(rename_tac nat e1 e2 c1 c2 x xa c)(*strict*)
   prefer 2
   apply(simp add: valid_parser_def)
  apply(rename_tac nat e1 e2 c1 c2 x xa c)(*strict*)
  apply(simp add: valid_parser_step_label_def)
  apply(clarsimp)
  apply(rename_tac nat e1 e2 c1 c2 x xa c k w)(*strict*)
  apply(subgoal_tac "c1 \<in> parserFS_configurations P")
   apply(rename_tac nat e1 e2 c1 c2 x xa c k w)(*strict*)
   prefer 2
   apply(rule parserFS.belongs_configurations)
    apply(rename_tac nat e1 e2 c1 c2 x xa c)(*strict*)
    apply(rule parserFS.derivation_initial_belongs)
     apply(rename_tac nat e1 e2 c1 c2 x xa c)(*strict*)
     apply(force)
    apply(rename_tac nat e1 e2 c1 c2 x xa c)(*strict*)
    apply(force)
   apply(rename_tac nat e1 e2 c1 c2 x xa c)(*strict*)
   apply(force)
  apply(rename_tac nat e1 e2 c1 c2 x xa c k w)(*strict*)
  apply(subgoal_tac "\<exists>w. parserFS_string_state c = w @ (parserFS_string_state c1)")
   apply(rename_tac nat e1 e2 c1 c2 x xa c k w)(*strict*)
   prefer 2
   apply(rule_tac
      j="nat"
      in parserFS.derivation_monotonically_dec)
        apply(rename_tac nat e1 e2 c1 c2 x xa c k w)(*strict*)
        apply(force)
       apply(rename_tac nat e1 e2 c1 c2 x xa c k w)(*strict*)
       apply(force)
      apply(rename_tac nat e1 e2 c1 c2 x xa c k w)(*strict*)
      apply(rule parserFS.derivation_initial_belongs)
       apply(rename_tac nat e1 e2 c1 c2 x xa c k w)(*strict*)
       apply(force)
      apply(rename_tac nat e1 e2 c1 c2 x xa c k w)(*strict*)
      apply(force)
     apply(rename_tac nat e1 e2 c1 c2 x xa c k w)(*strict*)
     apply(simp add: parserFS.derivation_initial_def)
    apply(rename_tac nat e1 e2 c1 c2 x xa c k w)(*strict*)
    apply(force)
   apply(rename_tac nat e1 e2 c1 c2 x xa c k w)(*strict*)
   apply(force)
  apply(rename_tac nat e1 e2 c1 c2 x xa c k w)(*strict*)
  apply(subgoal_tac "parserFS_conf_fixed c = []")
   apply(rename_tac nat e1 e2 c1 c2 x xa c k w)(*strict*)
   prefer 2
   apply(simp add: parserFS.derivation_initial_def parserFS_initial_configurations_def)
  apply(rename_tac nat e1 e2 c1 c2 x xa c k w)(*strict*)
  apply(simp add: parserFS_string_state_def)
  apply(clarsimp)
  apply(rename_tac nat e1 e2 c1 c2 x xa c k w wa)(*strict*)
  apply(subgoal_tac "\<exists>w. parserFS_string_state c1 = w @ (parserFS_string_state c2)")
   apply(rename_tac nat e1 e2 c1 c2 x xa c k w wa)(*strict*)
   prefer 2
   apply(rule_tac
      j="Suc 0"
      in parserFS.derivation_monotonically_dec)
        apply(rename_tac nat e1 e2 c1 c2 x xa c k w wa)(*strict*)
        apply(force)
       apply(rename_tac nat e1 e2 c1 c2 x xa c k w wa)(*strict*)
       apply(force)
      apply(rename_tac nat e1 e2 c1 c2 x xa c k w wa)(*strict*)
      apply(rule parserFS.derivation_initial_belongs)
       apply(rename_tac nat e1 e2 c1 c2 x xa c k w wa)(*strict*)
       apply(force)
      apply(rename_tac nat e1 e2 c1 c2 x xa c k w wa)(*strict*)
      apply(force)
     apply(rename_tac nat e1 e2 c1 c2 x xa c k w wa)(*strict*)
     apply(simp add: parserFS.derivation_initial_def)
    apply(rename_tac nat e1 e2 c1 c2 x xa c k w wa)(*strict*)
    apply(force)
   apply(rename_tac nat e1 e2 c1 c2 x xa c k w wa)(*strict*)
   apply(force)
  apply(rename_tac nat e1 e2 c1 c2 x xa c k w wa)(*strict*)
  apply(subgoal_tac "c \<in> parserFS_configurations P")
   apply(rename_tac nat e1 e2 c1 c2 x xa c k w wa)(*strict*)
   prefer 2
   apply(rule parserFS.belongs_configurations)
    apply(rename_tac nat e1 e2 c1 c2 x xa c k w wa)(*strict*)
    apply(rule parserFS.derivation_initial_belongs)
     apply(rename_tac nat e1 e2 c1 c2 x xa c k w wa)(*strict*)
     apply(force)
    apply(rename_tac nat e1 e2 c1 c2 x xa c k w wa)(*strict*)
    apply(force)
   apply(rename_tac nat e1 e2 c1 c2 x xa c k w wa)(*strict*)
   apply(force)
  apply(rename_tac nat e1 e2 c1 c2 x xa c k w wa)(*strict*)
  apply(simp add: parserFS_string_state_def)
  apply(clarsimp)
  apply(rename_tac nat e1 e2 c1 c2 x xa c k w wa wb)(*strict*)
  apply(simp add: parserFS_configurations_def)
  apply(clarsimp)
  apply(rename_tac nat e1 e2 c2 x xa k w wa wb f la r)(*strict*)
  apply(case_tac c2)
  apply(rename_tac nat e1 e2 c2 x xa k w wa wb f la r parserFS_conf_fixeda parserFS_conf_stacka parserFS_conf_schedulera)(*strict*)
  apply(rename_tac f st sc)
  apply(rename_tac nat e1 e2 c2 x xa k w wa wb fa la r f st sc)(*strict*)
  apply(case_tac e2)
  apply(rename_tac nat e1 e2 c2 x xa k w wa wb fa la r f st sc rule_lpopa rule_rpopa rule_lpusha rule_rpusha)(*strict*)
  apply(rename_tac lpo lpu rpo rpu)
  apply(rename_tac nat e1 e2 c2 x xa k w wa wb fa la r f st sc lpo lpu rpo rpu)(*strict*)
  apply(clarsimp)
  apply(rename_tac nat e1 x xa k w wa wb fa la r f sc lpo rpo rpu)(*strict*)
  apply(thin_tac "parserFS.derivation_initial P d")
  apply(thin_tac "d (Suc nat) =
       Some (pair (Some \<lparr>rule_lpop = lpo, rule_rpop = kPrefix k (w @ [parser_bottom P]),
                           rule_lpush = rpo, rule_rpush = rpu\<rparr>)
              \<lparr>parserFS_conf_fixed = f, parserFS_conf_stack = x @ rpo,
                 parserFS_conf_scheduler = sc\<rparr>)")
  apply(thin_tac "d nat =
       Some (pair e1
              \<lparr>parserFS_conf_fixed = fa, parserFS_conf_stack = x @ lpo,
                 parserFS_conf_scheduler = r\<rparr>)")
  apply(thin_tac "\<lparr>rule_lpop = lpo, rule_rpop = kPrefix k (w @ [parser_bottom P]), rule_lpush = rpo,
          rule_rpush = rpu\<rparr>
       \<in> parser_rules P")
  apply(thin_tac "d 0 =
       Some (pair None
              \<lparr>parserFS_conf_fixed = [], parserFS_conf_stack = la,
                 parserFS_conf_scheduler = wa @ wb @ f @ sc\<rparr>)")
  apply(thin_tac "X \<noteq> []" for X)
  apply(thin_tac "X \<noteq> []"  for X)
  apply(thin_tac "set X \<subseteq> parser_nonterms P" for X)
  apply(thin_tac "set X \<subseteq> parser_nonterms P" for X)
  apply(thin_tac "set X \<subseteq> parser_nonterms P" for X)
  apply(thin_tac "set X \<subseteq> parser_nonterms P" for X)
  apply(thin_tac "set X \<subseteq> parser_events P" for X)
  apply(erule disjE)
   apply(rename_tac nat e1 x xa k w wa wb fa la r f sc lpo rpo rpu)(*strict*)
   apply(clarsimp)
   apply(rename_tac k w wa wb fa sc rpu popnew)(*strict*)
   apply(rule_tac t="right_quotient_word (wa @ wb @ rpu @ sc) sc" and s="Some (wa @ wb @ rpu)" in ssubst)
    apply(rename_tac k w wa wb fa sc rpu popnew)(*strict*)
    apply(rule right_quotient_word_Some_by_append)
    apply(force)
   apply(rename_tac k w wa wb fa sc rpu popnew)(*strict*)
   apply(clarsimp)
   apply(subgoal_tac "prefix fa wb \<or> prefix wb fa")
    apply(rename_tac k w wa wb fa sc rpu popnew)(*strict*)
    prefer 2
    apply(rule mutual_prefix_prefix)
    apply(force)
   apply(rename_tac k w wa wb fa sc rpu popnew)(*strict*)
   apply(erule disjE)
    apply(rename_tac k w wa wb fa sc rpu popnew)(*strict*)
    apply(simp add: prefix_def)
    apply(clarsimp)
    apply(rename_tac k w wa fa sc rpu c)(*strict*)
    apply(rule_tac t="right_quotient_word (wa @ fa @ c @ rpu @ sc) (c @ rpu @ sc)" and s="Some(wa@fa)" in ssubst)
     apply(rename_tac k w wa fa sc rpu c)(*strict*)
     apply(rule right_quotient_word_Some_by_append)
     apply(force)
    apply(rename_tac k w wa fa sc rpu c)(*strict*)
    apply(clarsimp)
    apply(rule_tac xs="sc" in rev_cases)
     apply(rename_tac k w wa fa sc rpu c)(*strict*)
     prefer 2
     apply(rename_tac k w wa fa sc rpu c ys y)(*strict*)
     apply(clarsimp)
     apply(rename_tac k w wa fa rpu c ys y)(*strict*)
     apply(simp add: parser_schedulers_def)
     apply(clarsimp)
     apply(rename_tac k w wa fa rpu c ys)(*strict*)
     apply (metis (no_types, hide_lams) append_Nil2 append_assoc butlast_if_match_pull_out butlast_if_match_reduces drop_butlast_if_match_distrib in_set_conv_decomp)
    apply(rename_tac k w wa fa sc rpu c)(*strict*)
    apply(clarsimp)
    apply(rename_tac k w wa fa rpu c)(*strict*)
    apply(rule_tac xs="rpu" in rev_cases)
     apply(rename_tac k w wa fa rpu c)(*strict*)
     prefer 2
     apply(rename_tac k w wa fa rpu c ys y)(*strict*)
     apply(clarsimp)
     apply(rename_tac k w wa fa c ys y)(*strict*)
     apply(simp add: parser_schedulers_def)
     apply(clarsimp)
     apply(rename_tac k w wa fa c ys)(*strict*)
     apply (metis append_Nil append_assoc butlast_if_match_pull_out butlast_if_match_reduces drop_butlast_if_match_distrib in_set_conv_decomp snoc_eq_iff_butlast)
    apply(rename_tac k w wa fa rpu c)(*strict*)
    apply(clarsimp)
    apply(rename_tac k w wa fa c)(*strict*)
    apply(rule_tac xs="c" in rev_cases)
     apply(rename_tac k w wa fa c)(*strict*)
     apply(clarsimp)
     apply(rename_tac k w wa)(*strict*)
     apply(simp add: kPrefix_def)
     apply(case_tac "k-length w")
      apply(rename_tac k w wa)(*strict*)
      prefer 2
      apply(rename_tac k w wa nat)(*strict*)
      apply(force)
     apply(rename_tac k w wa)(*strict*)
     apply(clarsimp)
     apply(simp add: parser_schedulers_def)
     apply(metis)
    apply(rename_tac k w wa fa c ys y)(*strict*)
    apply(clarsimp)
    apply(rename_tac k w wa fa ys y)(*strict*)
    apply(simp add: parser_schedulers_def)
   apply(rename_tac k w wa wb fa sc rpu popnew)(*strict*)
   apply(simp add: prefix_def)
   apply(clarsimp)
   apply(rename_tac k w wa wb sc popnew c)(*strict*)
   apply(rule_tac xs="sc" in rev_cases)
    apply(rename_tac k w wa wb sc popnew c)(*strict*)
    prefer 2
    apply(rename_tac k w wa wb sc popnew c ys y)(*strict*)
    apply(simp add: parser_schedulers_def)
    apply(clarsimp)
    apply(rename_tac k w wa wb popnew c ys)(*strict*)
    apply(rule_tac t="right_quotient_word (wa @ wb @ c @ popnew @ ys @ [parser_bottom P])
               (popnew @ ys @ [parser_bottom P])" and s="Some (wa@wb@c)" in ssubst)
     apply(rename_tac k w wa wb popnew c ys)(*strict*)
     apply(rule right_quotient_word_Some_by_append)
     apply(force)
    apply(rename_tac k w wa wb popnew c ys)(*strict*)
    apply(clarsimp)
    apply(subgoal_tac "butlast_if_match (wa @ wb @ c @ popnew) (parser_bottom P) = SSX" for SSX)
     apply(rename_tac k w wa wb popnew c ys)(*strict*)
     prefer 2
     apply(rule butlast_if_match_direct2_prime)
     apply(force)
    apply(rename_tac k w wa wb popnew c ys)(*strict*)
    apply(subgoal_tac "butlast_if_match (wa @ wb @ c) (parser_bottom P) = SSX" for SSX)
     apply(rename_tac k w wa wb popnew c ys)(*strict*)
     prefer 2
     apply(rule butlast_if_match_direct2_prime)
     apply(force)
    apply(rename_tac k w wa wb popnew c ys)(*strict*)
    apply(subgoal_tac "butlast_if_match (wb @ c @ popnew) (parser_bottom P) = SSX" for SSX)
     apply(rename_tac k w wa wb popnew c ys)(*strict*)
     prefer 2
     apply(rule butlast_if_match_direct2_prime)
     apply(force)
    apply(rename_tac k w wa wb popnew c ys)(*strict*)
    apply(force)
   apply(rename_tac k w wa wb sc popnew c)(*strict*)
   apply(clarsimp)
   apply(rename_tac k w wa wb popnew c)(*strict*)
   apply(rule_tac xs="popnew" in rev_cases)
    apply(rename_tac k w wa wb popnew c)(*strict*)
    prefer 2
    apply(rename_tac k w wa wb popnew c ys y)(*strict*)
    apply(simp add: parser_schedulers_def)
    apply(clarsimp)
    apply(rename_tac k w wa wb c ys)(*strict*)
    apply(rule_tac t="right_quotient_word (wa @ wb @ c @ ys @ [parser_bottom P])
               (ys @ [parser_bottom P])" and s="Some (wa@wb@c)" in ssubst)
     apply(rename_tac k w wa wb c ys)(*strict*)
     apply(rule right_quotient_word_Some_by_append)
     apply(force)
    apply(rename_tac k w wa wb c ys)(*strict*)
    apply(clarsimp)
    apply(subgoal_tac "butlast_if_match (wa @ wb @ c @ ys @ [parser_bottom P]) (parser_bottom P) = SSX" for SSX)
     apply(rename_tac k w wa wb c ys)(*strict*)
     prefer 2
     apply(rule butlast_if_match_direct)
     apply(force)
    apply(rename_tac k w wa wb c ys)(*strict*)
    apply(subgoal_tac "butlast_if_match (wa @ wb @ c) (parser_bottom P) = SSX" for SSX)
     apply(rename_tac k w wa wb c ys)(*strict*)
     prefer 2
     apply(rule butlast_if_match_direct2_prime)
     apply(force)
    apply(rename_tac k w wa wb c ys)(*strict*)
    apply(subgoal_tac "butlast_if_match (wb @ c @ ys @ [parser_bottom P]) (parser_bottom P) = SSX" for SSX)
     apply(rename_tac k w wa wb c ys)(*strict*)
     prefer 2
     apply(rule butlast_if_match_direct)
     apply(force)
    apply(rename_tac k w wa wb c ys)(*strict*)
    apply(force)
   apply(rename_tac k w wa wb popnew c)(*strict*)
   apply(clarsimp)
   apply(rename_tac k w wa wb c)(*strict*)
   apply(rule_tac xs="c" in rev_cases)
    apply(rename_tac k w wa wb c)(*strict*)
    prefer 2
    apply(rename_tac k w wa wb c ys y)(*strict*)
    apply(simp add: parser_schedulers_def)
    apply(clarsimp)
    apply(rename_tac k w wa wb ys)(*strict*)
    apply(rule_tac t="right_quotient_word (wa @ wb @ ys @ [parser_bottom P])
               []" and s="Some (X)" for X in ssubst)
     apply(rename_tac k w wa wb ys)(*strict*)
     apply(rule right_quotient_word_Some_by_append)
     apply(force)
    apply(rename_tac k w wa wb ys)(*strict*)
    apply(clarsimp)
    apply(subgoal_tac "butlast_if_match (wb @ ys @ [parser_bottom P]) (parser_bottom P) = SSX" for SSX)
     apply(rename_tac k w wa wb ys)(*strict*)
     prefer 2
     apply(rule butlast_if_match_direct)
     apply(force)
    apply(rename_tac k w wa wb ys)(*strict*)
    apply(force)
   apply(rename_tac k w wa wb c)(*strict*)
   apply(clarsimp)
   apply(rename_tac k w wa)(*strict*)
   apply(simp add: kPrefix_def parser_schedulers_def)
   apply(clarsimp)
  apply(rename_tac nat e1 x xa k w wa wb fa la r f sc lpo rpo rpu)(*strict*)
  apply(clarsimp)
  apply(rename_tac k w wa wb sc rpu remainder)(*strict*)
  apply(rule_tac xs="sc" in rev_cases)
   apply(rename_tac k w wa wb sc rpu remainder)(*strict*)
   prefer 2
   apply(rename_tac k w wa wb sc rpu remainder ys y)(*strict*)
   apply(simp add: parser_schedulers_def)
   apply(clarsimp)
   apply(rename_tac k w wa wb rpu remainder ys)(*strict*)
   apply (metis append_assoc butlast_if_match_reduces drop_length_append in_set_conv_decomp length_append)
  apply(rename_tac k w wa wb sc rpu remainder)(*strict*)
  apply(clarsimp)
  apply(rename_tac k w wa wb rpu remainder)(*strict*)
  apply(rule_tac xs="remainder" in rev_cases)
   apply(rename_tac k w wa wb rpu remainder)(*strict*)
   prefer 2
   apply(rename_tac k w wa wb rpu remainder ys y)(*strict*)
   apply(simp add: parser_schedulers_def)
   apply(clarsimp)
   apply(rename_tac k w wa wb rpu ys)(*strict*)
   apply (metis append_assoc butlast_if_match_reduces drop_length_append insert_subset le_SucI length_append set_append2 set_simps(2))
  apply(rename_tac k w wa wb rpu remainder)(*strict*)
  apply(clarsimp)
  apply(rename_tac k w wa wb rpu)(*strict*)
  apply(rule_tac xs="rpu" in rev_cases)
   apply(rename_tac k w wa wb rpu)(*strict*)
   prefer 2
   apply(rename_tac k w wa wb rpu ys y)(*strict*)
   apply(simp add: parser_schedulers_def)
   apply(clarsimp)
   apply(rename_tac k w wa wb ys)(*strict*)
   apply (metis add_Suc_right butlast_if_match_length_le length_append length_append_singleton)
  apply(rename_tac k w wa wb rpu)(*strict*)
  apply(clarsimp)
  apply(rename_tac k w wa)(*strict*)
  apply(simp add: kPrefix_def parser_schedulers_def)
  apply(clarsimp)
  done

lemma parserFS_to_parserHFS_derivation_preserves_maximum_of_domain: "
  valid_parser G
  \<Longrightarrow> maximum_of_domain d n
  \<Longrightarrow> maximum_of_domain (parserFS_to_parserHFS_derivation G d) n"
  apply(simp add: maximum_of_domain_def parserFS_to_parserHFS_derivation_def)
  apply(clarsimp)
  apply(rename_tac y)(*strict*)
  apply(case_tac y)
  apply(rename_tac y option b)(*strict*)
  apply(clarsimp)
  done

end