theory "Bound_Effect"
imports
  Ordinary_Differential_Equations.ODE_Analysis
  "Ids"
  "Lib"
  "Syntax"
  "Denotational_Semantics"
  "Frechet_Correctness"
  "Static_Semantics"
  "Coincidence"
begin
section \<open>Bound Effect Theorem\<close>
text \<open>The bound effect lemma says that a program can only modify its bound variables and nothing else.
  This is one of the major lemmas for showing correctness of uniform substitution. \<close>

context ids begin
lemma bound_effect:
  fixes I::"('sf,'sc,'sz) interp"
  assumes good_interp:"is_interp I"
  shows "\<And>\<nu> :: 'sz state. \<And>\<omega> ::'sz state. hpsafe \<alpha> \<Longrightarrow> (\<nu>, \<omega>) \<in> prog_sem I \<alpha> \<Longrightarrow> Vagree \<nu> \<omega> (- (BVP \<alpha>))"
proof (induct rule: hp_induct)
  case Var then show "?case"
    using agree_nil Compl_UNIV_eq BVP.simps(1) by fastforce
next
  case Test then show "?case"
    by auto(simp add: agree_refl Compl_UNIV_eq Vagree_def)
next
  case (Choice a b \<nu> \<omega>)
  assume IH1:"\<And>\<nu>'. \<And>\<omega>'. hpsafe a \<Longrightarrow>((\<nu>', \<omega>') \<in> prog_sem I a \<Longrightarrow> Vagree \<nu>' \<omega>' (- BVP a))"
  assume IH2:"\<And>\<nu>'. \<And>\<omega>'. hpsafe b \<Longrightarrow>((\<nu>', \<omega>') \<in> prog_sem I b \<Longrightarrow> Vagree \<nu>' \<omega>' (- BVP b))"
  assume sem:"(\<nu>, \<omega>) \<in> prog_sem I (a \<union>\<union> b)"
  assume safe:"hpsafe (Choice a b)"
  from safe have safes:"hpsafe a" "hpsafe b" by (auto dest: hpsafe.cases)
  have sems:"(\<nu>, \<omega>) \<in> prog_sem I (a) \<or> (\<nu>, \<omega>) \<in> prog_sem I (b)" using sem by auto
  have agrees:"Vagree \<nu> \<omega> (- BVP a) \<or> Vagree \<nu> \<omega> (- BVP b)" using IH1 IH2 sems safes by blast
  have sub1:"-(BVP a) \<supseteq> (- BVP a \<inter> - BVP b)" by auto
  have sub2:"-(BVP a) \<supseteq> (- BVP a \<inter> - BVP b)" by auto
  have res:"Vagree \<nu> \<omega> (- BVP a \<inter> - BVP b)" using agrees sub1 sub2 agree_supset by blast
  then show "?case" by auto
next
  case (Compose a b \<nu> \<omega>)
  assume IH1:"\<And>\<nu>'. \<And>\<omega>'. hpsafe a \<Longrightarrow> (\<nu>', \<omega>') \<in> prog_sem I a \<Longrightarrow> Vagree \<nu>' \<omega>' (- BVP a)"
  assume IH2:"\<And>\<nu>'. \<And>\<omega>'. hpsafe b \<Longrightarrow> (\<nu>', \<omega>') \<in> prog_sem I b \<Longrightarrow> Vagree \<nu>' \<omega>' (- BVP b)"
  assume sem:"(\<nu>, \<omega>) \<in> prog_sem I (a ;; b)"
  assume safe:"hpsafe (a ;; b)"
  from safe have safes:"hpsafe a" "hpsafe b" by (auto dest: hpsafe.cases)
  then show "?case"
    using agree_trans IH1 IH2 sem safes by fastforce
next
  fix ODE::"('sf,'sz) ODE" and P::"('sf,'sc,'sz) formula" and \<nu> \<omega>
  assume safe:"hpsafe (EvolveODE ODE P)"
  from safe have osafe:"osafe ODE" and fsafe:"fsafe P" by (auto dest: hpsafe.cases)
  show "(\<nu>, \<omega>) \<in> prog_sem I (EvolveODE ODE P) \<Longrightarrow> Vagree \<nu> \<omega> (- BVP (EvolveODE ODE P))"
  proof -
    assume sem:"(\<nu>, \<omega>) \<in> prog_sem I (EvolveODE ODE P)"
    from sem have agree:"Vagree \<nu> \<omega> (- BVO ODE)"
      apply(simp only: prog_sem.simps(8) mem_Collect_eq osafe fsafe)
      apply(erule exE)+
    proof -
      fix \<nu>' sol t
      assume assm:
        "(\<nu>, \<omega>) = (\<nu>', mk_v I ODE \<nu>' (sol t)) \<and>
         0 \<le> t \<and>
         (sol solves_ode (\<lambda>_. ODE_sem I ODE)) {0..t} {x. mk_v I ODE \<nu>' x \<in> fml_sem I P} \<and>  (sol 0) = (fst \<nu>')"
      have semBV:"-BVO ODE \<subseteq> -semBV I ODE"
        by(induction ODE, auto)
      from assm have "Vagree \<omega> \<nu> (- BVO ODE)" using mk_v_agree[of I ODE \<nu> "(sol t)"]
        using agree_sub[OF semBV] by auto
      thus  "Vagree \<nu> \<omega> (- BVO ODE)" by (rule agree_comm)
    qed
    thus "Vagree \<nu> \<omega> (- BVP (EvolveODE ODE P))" by auto
  qed
next
  case (Star a \<nu> \<omega>) then
  have IH:"(\<And>\<nu> \<omega>. hpsafe a \<Longrightarrow> (\<nu>, \<omega>) \<in> prog_sem I a \<Longrightarrow> Vagree \<nu> \<omega> (- BVP a))"
    and safe:"hpsafe a**"
    and sem:"(\<nu>, \<omega>) \<in> prog_sem I a**"
    by auto
  from safe have asafe:"hpsafe a" by (auto dest: hpsafe.cases)
  show "Vagree \<nu> \<omega> (- BVP a**)"
    using sem apply (simp only: prog_sem.simps)
    apply (erule converse_rtrancl_induct)
     subgoal by(rule agree_refl)
    subgoal for y z using IH[of y z, OF asafe] sem by (auto simp add: Vagree_def)
    done
qed (auto simp add: Vagree_def)
end end


theory PreferenceLogicTests1      (*** Benzmüller & Fuenmayor, 2020 ***)
   imports PreferenceLogicBasics
begin (*Tests for the SSE of van Benthem et al, JPL 2009, in HOL*)
(*Fact 1: definability of the principal operators and verification*)
lemma F1_9:  "(\<phi> \<^bold>\<preceq>\<^sub>E\<^sub>E \<psi>) u \<longleftrightarrow> (\<phi> \<preceq>\<^sub>E\<^sub>E \<psi>) u" by smt
lemma F1_10: "(\<phi> \<^bold>\<preceq>\<^sub>A\<^sub>E \<psi>) u \<longleftrightarrow> (\<phi> \<preceq>\<^sub>A\<^sub>E \<psi>) u" by smt
lemma F1_11: "(\<phi> \<^bold>\<prec>\<^sub>E\<^sub>E \<psi>) u \<longleftrightarrow> (\<phi> \<prec>\<^sub>E\<^sub>E \<psi>) u" by smt
lemma F1_12: "(\<phi> \<^bold>\<prec>\<^sub>A\<^sub>E \<psi>) u \<longleftrightarrow> (\<phi> \<prec>\<^sub>A\<^sub>E \<psi>) u" by smt
(*Fact 2: definability of remaining pref. operators and verification*)
lemma F2_13: "is_total SBR \<longrightarrow> ((\<phi> \<^bold>\<prec>\<^sub>A\<^sub>A \<psi>) u \<longleftrightarrow> (\<phi> \<prec>\<^sub>A\<^sub>A \<psi>) u)"  by smt
lemma F2_14: "is_total SBR \<longrightarrow> ((\<phi> \<^bold>\<succ>\<^sub>E\<^sub>A \<psi>) u \<longleftrightarrow> (\<phi> \<succ>\<^sub>E\<^sub>A \<psi>) u)"  by smt
lemma F2_15: "is_total SBR \<longrightarrow> ((\<phi> \<^bold>\<preceq>\<^sub>A\<^sub>A \<psi>) u \<longleftrightarrow> (\<phi> \<preceq>\<^sub>A\<^sub>A \<psi>) u)"  by smt
lemma F2_16: "is_total SBR \<longrightarrow> ((\<phi> \<^bold>\<succeq>\<^sub>E\<^sub>A \<psi>) u \<longleftrightarrow> (\<phi> \<succeq>\<^sub>E\<^sub>A \<psi>) u)"  by smt
(*Section 3.5 "Axiomatization" -- verify interaction axioms*)
lemma Incl_1:   "\<lfloor>(\<^bold>\<diamond>\<^sup>\<prec>\<phi>) \<^bold>\<rightarrow> (\<^bold>\<diamond>\<^sup>\<preceq>\<phi>)\<rfloor>"      by auto
lemma Inter_1:  "\<lfloor>(\<^bold>\<diamond>\<^sup>\<preceq>\<^bold>\<diamond>\<^sup>\<prec>\<phi>) \<^bold>\<rightarrow> (\<^bold>\<diamond>\<^sup>\<prec>\<phi>)\<rfloor>"   using tBR by blast
lemma Trans_le: "\<lfloor>(\<^bold>\<diamond>\<^sup>\<prec>\<^bold>\<diamond>\<^sup>\<prec>\<phi>) \<^bold>\<rightarrow> (\<^bold>\<diamond>\<^sup>\<prec>\<phi>)\<rfloor>"   using tBR by blast
lemma Inter_2:  "\<lfloor>(\<phi> \<^bold>\<and> \<^bold>\<diamond>\<^sup>\<preceq>\<psi>) \<^bold>\<rightarrow>  ((\<^bold>\<diamond>\<^sup>\<prec>\<psi>) \<^bold>\<or> \<^bold>\<diamond>\<^sup>\<preceq>(\<psi> \<^bold>\<and>  \<^bold>\<diamond>\<^sup>\<preceq>\<phi>))\<rfloor>" by blast
lemma F4: "\<lfloor>(\<phi> \<^bold>\<and> \<^bold>\<diamond>\<^sup>\<preceq>\<psi>) \<^bold>\<rightarrow> ((\<^bold>\<diamond>\<^sup>\<prec>\<psi>) \<^bold>\<or> \<^bold>\<diamond>\<^sup>\<preceq>(\<psi> \<^bold>\<and>  \<^bold>\<diamond>\<^sup>\<preceq>\<phi>))\<rfloor> \<longleftrightarrow>
            (\<forall>w. \<forall>v. (((w \<preceq> v) \<and> \<not>(v \<preceq> w)) \<longrightarrow> (w \<prec> v)))" by smt
lemma Inter_3: "\<lfloor>(\<^bold>\<diamond>\<^sup>\<prec>\<^bold>\<diamond>\<^sup>\<preceq>\<phi>) \<^bold>\<rightarrow> (\<^bold>\<diamond>\<^sup>\<prec>\<phi>)\<rfloor>" using tBR by blast
lemma Incl_2:  "\<lfloor>(\<^bold>\<diamond>\<^sup>\<preceq>\<phi>) \<^bold>\<rightarrow> (\<^bold>E\<phi>)\<rfloor>"      by blast
(*Section 3.6 "A binary preference fragment"*)
(* \<^bold>\<preceq>\<^sub>E\<^sub>E is the dual of \<^bold>\<prec>\<^sub>A\<^sub>A *)
lemma "\<lfloor>(\<phi> \<^bold>\<preceq>\<^sub>E\<^sub>E \<psi>) \<^bold>\<leftrightarrow> \<^bold>\<not>(\<psi> \<^bold>\<prec>\<^sub>A\<^sub>A \<phi>)\<rfloor> \<and> \<lfloor>(\<phi> \<^bold>\<prec>\<^sub>A\<^sub>A \<psi>) \<^bold>\<leftrightarrow> \<^bold>\<not>(\<psi> \<^bold>\<preceq>\<^sub>E\<^sub>E \<phi>)\<rfloor>" by simp
(* \<preceq>\<^sub>E\<^sub>E is the dual of \<prec>\<^sub>A\<^sub>A only if totality is assumed*)
lemma "\<lfloor>(\<phi> \<preceq>\<^sub>E\<^sub>E \<psi>) \<^bold>\<leftrightarrow> \<^bold>\<not>(\<psi> \<prec>\<^sub>A\<^sub>A \<phi>)\<rfloor>" nitpick oops (*countermodel*)
lemma "\<lfloor>(\<phi> \<preceq>\<^sub>E\<^sub>E \<psi>) \<^bold>\<rightarrow> \<^bold>\<not>(\<psi> \<prec>\<^sub>A\<^sub>A \<phi>)\<rfloor>" by blast (*this direction holds*)
lemma "is_total SBR \<longrightarrow> \<lfloor>(\<phi> \<preceq>\<^sub>E\<^sub>E \<psi>) \<^bold>\<leftrightarrow> \<^bold>\<not>(\<psi> \<prec>\<^sub>A\<^sub>A \<phi>)\<rfloor>"  by blast
lemma "\<lfloor>(\<phi> \<prec>\<^sub>A\<^sub>A \<psi>) \<^bold>\<leftrightarrow> \<^bold>\<not>(\<psi> \<preceq>\<^sub>E\<^sub>E \<phi>)\<rfloor>" nitpick oops (*countermodel*)
lemma "\<lfloor>(\<phi> \<prec>\<^sub>A\<^sub>A \<psi>) \<^bold>\<rightarrow> \<^bold>\<not>(\<psi> \<preceq>\<^sub>E\<^sub>E \<phi>)\<rfloor>" by blast (*this direction holds*)
lemma "is_total SBR \<longrightarrow> \<lfloor>(\<phi> \<prec>\<^sub>A\<^sub>A \<psi>) \<^bold>\<leftrightarrow> \<^bold>\<not>(\<psi> \<preceq>\<^sub>E\<^sub>E \<phi>)\<rfloor>"  by blast
(* verify p.97-98 *)
lemma monotonicity:  "\<lfloor>((\<phi> \<preceq>\<^sub>E\<^sub>E \<psi>) \<^bold>\<and> \<^bold>A(\<phi>\<^bold>\<rightarrow>\<xi>)) \<^bold>\<rightarrow> (\<xi> \<preceq>\<^sub>E\<^sub>E \<psi>)\<rfloor>" by blast
lemma reducibility:
        "\<lfloor>(((\<phi> \<preceq>\<^sub>E\<^sub>E \<psi>) \<^bold>\<and> \<alpha>) \<preceq>\<^sub>E\<^sub>E \<beta>) \<^bold>\<leftrightarrow> ((\<phi> \<preceq>\<^sub>E\<^sub>E \<psi>) \<^bold>\<and> (\<alpha> \<preceq>\<^sub>E\<^sub>E \<beta>))\<rfloor>" by blast
lemma reflexivity:   "\<lfloor>\<phi> \<^bold>\<rightarrow> (\<phi> \<preceq>\<^sub>E\<^sub>E \<phi>)\<rfloor>" using rBR by blast
(*The condition below is supposed to enforce totality of the preference
   relation. However there are countermodels. See p.98?*)
lemma "is_total SBR \<longrightarrow>
       \<lfloor>((\<phi> \<preceq>\<^sub>E\<^sub>E \<phi>)\<^bold>\<and>(\<psi> \<preceq>\<^sub>E\<^sub>E \<psi>)) \<^bold>\<rightarrow> ((\<phi> \<preceq>\<^sub>E\<^sub>E \<psi>)\<^bold>\<or>(\<psi> \<preceq>\<^sub>E\<^sub>E \<phi>))\<rfloor>"  by auto
lemma "\<lfloor>((\<phi> \<preceq>\<^sub>E\<^sub>E \<phi>) \<^bold>\<and> (\<psi> \<preceq>\<^sub>E\<^sub>E \<psi>)) \<^bold>\<rightarrow> ((\<phi> \<preceq>\<^sub>E\<^sub>E \<psi>) \<^bold>\<or> (\<psi> \<preceq>\<^sub>E\<^sub>E \<phi>))\<rfloor>
       \<longrightarrow> is_total SBR" nitpick oops (*countermodel - error in paper?*)
lemma "is_total SBR \<longrightarrow>
       \<lfloor>((\<phi> \<^bold>\<preceq>\<^sub>E\<^sub>E \<phi>) \<^bold>\<and> (\<psi> \<^bold>\<preceq>\<^sub>E\<^sub>E \<psi>)) \<^bold>\<rightarrow> ((\<phi> \<^bold>\<preceq>\<^sub>E\<^sub>E \<psi>) \<^bold>\<or> (\<psi> \<^bold>\<preceq>\<^sub>E\<^sub>E \<phi>))\<rfloor>" by auto
lemma "\<lfloor>((\<phi> \<^bold>\<preceq>\<^sub>E\<^sub>E \<phi>) \<^bold>\<and> (\<psi> \<^bold>\<preceq>\<^sub>E\<^sub>E \<psi>)) \<^bold>\<rightarrow> ((\<phi> \<^bold>\<preceq>\<^sub>E\<^sub>E \<psi>) \<^bold>\<or> (\<psi> \<^bold>\<preceq>\<^sub>E\<^sub>E \<phi>))\<rfloor>
       \<longrightarrow> is_total SBR" nitpick oops (*countermodel - error in paper?*)
end


theory ComparisonTheorem
  imports Main
         "HOL-Algebra.Group"
         HomologySModule
         ReducedHomology
         HFunctor
begin

context pointed_set
begin

section "Change of universe functors"

definition embed_functor :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a parr option \<Rightarrow> 'b parr option" where
  "embed_functor F = MkFunctor pointed_set_comp pointed_set_comp
                 (\<lambda>f. Some (MkArr
                 (pointed_image F (Dom' (the f)))
                 (pointed_image F (Cod' (the f)))
                  (\<lambda>x. F (fst (the f) (SOME a'. x = F a')))))"

interpretation P : category pointed_set_comp
  using is_category.

lemma arr_MkArr :
  assumes "Obj' A" "Obj' B" "f \<in> snd A \<rightarrow> snd B" "f (fst A) = fst B"
  shows "P.arr (Some (MkArr A B f))"
  unfolding P.arr_char
  apply simp
  apply (simp add: Arr'_def MkArr_def)
  using \<open>Obj' A\<close> unfolding Obj'_def apply simp
  unfolding setcat.Arr_def
  using assms
  unfolding Obj'_def by auto

lemma embed_functor :
  assumes F_inj : "\<And>x y. F x = F y \<Longrightarrow> x = y"
  shows "functor pointed_set_comp pointed_set_comp (embed_functor F)"
  unfolding functor_def
  apply (simp add: is_category)
  unfolding functor_axioms_def
  apply auto
      apply (simp add: embed_functor_def)
proof-
  have F_some : "\<And>x. (SOME a'. F x = F a') = x"
  proof
    show "\<And>x. F x = F x" using refl.
    show "\<And>x a'. F x = F a' \<Longrightarrow> a' = x" using F_inj by simp
  qed

  show arr: "\<And>f. P.arr f \<Longrightarrow> P.arr (embed_functor F f)"
    unfolding embed_functor_def
    apply simp
    apply (rule_tac arr_MkArr)
  proof-
    fix f :: "'a parr option"
    assume "P.arr f"
    then have arr_f: "Arr' (the f)"
      unfolding arr_char by simp
    show "Obj' (pointed_image F (fst (snd (the f))))"
      apply (rule_tac pointed_image_obj)
      using arr_f
      unfolding Arr'_def by simp
    show "Obj' (pointed_image F (snd (snd (the f))))"
      apply (rule_tac pointed_image_obj)
      using arr_f
      unfolding Arr'_def by simp
    show "(\<lambda>x. F (fst (the f) (SOME a'. x = F a')))
         \<in> snd (pointed_image F (fst (snd (the f)))) \<rightarrow> snd (pointed_image F (snd (snd (the f))))"
      unfolding pointed_image_simps
      apply auto
    proof-
      fix x
      assume x_in: "x \<in> snd (Dom' (the f))"
      have fx_in : "fst (the f) x \<in> snd (Cod' (the f))"
        using arr_f
        unfolding Arr'_def setcat.Arr_def
        using x_in by auto
      show "F (fst (the f) (SOME a'. F x = F a')) \<in> F ` snd (snd (snd (the f)))"
        unfolding F_some
        using fx_in by simp
    qed
    have some_fst : "(SOME a'. fst (pointed_image F (fst (snd (the f)))) = F a') =
                     fst (Dom' (the f))"
      unfolding pointed_image_simps
      apply simp
    proof
      show "F (fst (fst (snd (the f)))) = F (fst (fst (snd (the f))))" using refl.
      show "\<And>a'. F (fst (fst (snd (the f)))) = F a' \<Longrightarrow> a' = fst (fst (snd (the f)))"
        using F_inj by simp
    qed
    show "F (fst (the f) (SOME a'. fst (pointed_image F (fst (snd (the f)))) = F a')) =
         fst (pointed_image F (snd (snd (the f))))"
      unfolding pointed_image_simps
      apply simp
      unfolding F_some
      using arr_f
      unfolding Arr'_def
      by simp
  qed
  show dom : "\<And>f. P.arr f \<Longrightarrow> P.dom (embed_functor F f) = embed_functor F (P.dom f)"
    unfolding P.dom_char [OF arr]
    unfolding embed_functor_def
    apply (simp add: MkArr_def pointed_image_simps)
    unfolding P.dom_char
    apply (simp add: Id'_def)
    apply (rule_tac ext)
    apply auto
    unfolding F_some by simp_all
  show cod : "\<And>f. P.arr f \<Longrightarrow> P.cod (embed_functor F f) = embed_functor F (P.cod f)"
    unfolding P.cod_char [OF arr]
    unfolding embed_functor_def
    apply (simp add: MkArr_def pointed_image_simps)
    unfolding P.cod_char
    apply (simp add: Id'_def)
    apply (rule_tac ext)
    apply auto
    unfolding F_some by simp_all
  fix g f :: "'a parr option"
  assume arr_gf : "P.seq g f"
  have arr_egf : "P.seq (embed_functor F g) (embed_functor F f)"
    apply (rule_tac P.seqE [OF arr_gf])
    apply (rule_tac P.seqI)
    unfolding dom cod
    by (simp_all add: arr)
  show "embed_functor F (pointed_set_comp g f) =
           pointed_set_comp (embed_functor F g) (embed_functor F f)"
    apply (rule_tac P.seqE [OF arr_egf])
    apply (rule_tac P.seqE [OF arr_gf])
    using arr_egf arr_gf
    apply (rule_tac reverse_equality)
    apply (rule_tac P.comp_eq_char2)
    unfolding dom cod
        apply (simp_all add: arr)
  proof-
    fix x
    assume arr_f : "P.arr f"
    assume arr_g : "P.arr g"
    assume fx_in_g : "fst (the (embed_functor F f)) x \<in> snd (fst (snd (the (embed_functor F g))))"
    have g_eq : "snd (fst (snd (the (embed_functor F g)))) = F ` snd (fst (snd (the g)))"
      unfolding embed_functor_def
      by (simp add: MkArr_def pointed_image_simps arr_g)

    assume x_in_f : "x \<in> snd (fst (snd (the (embed_functor F f))))"
    have f_eq: "snd (fst (snd (the (embed_functor F f)))) = F ` snd (fst (snd (the f)))"
      unfolding embed_functor_def
      by (simp add: MkArr_def pointed_image_simps arr_f)
    assume x_in_gf : "x \<in> snd (fst (snd (the (embed_functor F (pointed_set_comp g f)))))"
    have gf_eq : "snd (fst (snd (the (embed_functor F (pointed_set_comp g f))))) =
                  F ` snd (fst (snd (the (pointed_set_comp g f))))"
      unfolding embed_functor_def
      by (simp add: MkArr_def pointed_image_simps arr_gf)

    show "P.arr f \<Longrightarrow> P.arr g \<Longrightarrow>
         fst (the (embed_functor F g)) (fst (the (embed_functor F f)) x) =
         fst (the (embed_functor F (pointed_set_comp g f))) x"
      using arr_gf
      apply (subst embed_functor_def)
      using fx_in_g
      unfolding g_eq
      apply (simp add: MkArr_def pointed_image_simps)
      apply (subst embed_functor_def)
      using x_in_f
      unfolding f_eq
      apply (simp add: MkArr_def pointed_image_simps)
      unfolding F_some
      apply (subst embed_functor_def)
      using x_in_gf
      unfolding gf_eq
      apply (simp add: MkArr_def pointed_image_simps)
      apply (subst fst_comp_char)
        apply simp_all
    proof-
      assume "x \<in> F ` snd (fst (snd (the f)))"
      then obtain a where a_def: "a \<in> snd (fst (snd (the f))) \<and> x = F a"
        by auto
      show "(SOME a'. x = F a') \<in> snd (fst (snd (the f)))"
        unfolding conjunct2 [OF a_def]
        unfolding F_some
        using conjunct1 [OF a_def].
    qed
  qed
qed

definition Inl_functor :: "'a parr option \<Rightarrow> ('a + 'b) parr option" where
  "Inl_functor = embed_functor Inl"

definition Inr_functor :: "'b parr option \<Rightarrow> ('a + 'b) parr option" where
  "Inr_functor = embed_functor Inr"

lemma Inl_functor : "functor pointed_set_comp pointed_set_comp Inl_functor"
  unfolding Inl_functor_def
  apply (rule_tac embed_functor)
  by simp

lemma Inr_functor : "functor pointed_set_comp pointed_set_comp Inr_functor"
  unfolding Inr_functor_def
  apply (rule_tac embed_functor)
  by simp

end

locale SphereCoeffHomologyWithUniverseChange =
  Coeff: "functor" pointed_fin_set.comp pointed_set.pointed_set_comp Coeff +
  Y : pointed_simplicial_set Y
  for Coeff :: "(nat \<times> nat list) option \<Rightarrow> ('a pointed_set.parr) option"
  and Y :: "(nat \<times> nat list) option \<Rightarrow> ('b pointed_set.parr) option"
begin
interpretation P: pointed_set.

interpretation SH : SphereCoeffHomology "(P.embed_functor P.Just) \<circ> P.Inr_functor \<circ> Coeff"
                                        "(P.embed_functor P.Just) \<circ> P.Inl_functor \<circ> Y"
  unfolding SphereCoeffHomology_def
  apply auto
   apply (rule_tac functor_comp)
    apply (rule_tac Coeff.functor_axioms)
   apply (rule_tac functor_comp)
    apply (rule_tac P.Inr_functor)
   apply (rule_tac P.embed_functor)
   apply simp
  unfolding pointed_simplicial_set_def
  apply (rule_tac functor_comp)
  using Y.pointed_simplicial_set_axioms
  unfolding pointed_simplicial_set_def apply simp
  apply (rule_tac functor_comp)
   apply (rule_tac P.Inl_functor)
  apply (rule_tac P.embed_functor)
  by simp

definition Homology where
  "Homology = SH.Homology"

lemma Homology_functor : "functor (subcategory.comp fin_set.comp pointed_fin_set.PointedArr')
                          pointed_set.pointed_set_comp (Homology n)"
  unfolding Homology_def
  using SH.Homology_functor.

end

locale comparison_theorem =
  A : comm_group A +
  Y : pointed_simplicial_set Y
  for A :: "('a, 'b) monoid_scheme"
  and Y :: "(nat \<times> nat list) option \<Rightarrow> ('a pointed_set.LC pointed_set.parr) option"
begin

interpretation P: pointed_set.

interpretation FunCat : functor_category pointed_fin_set.comp P.pointed_set_comp
  unfolding functor_category_def
  by (simp add: P.is_category pointed_fin_set.is_category)

interpretation SH : SphereCoeffHomologyWithUniverseChange
  "group_to_gammaset.HFunctor A" Y
  unfolding SphereCoeffHomologyWithUniverseChange_def
  apply (simp add: Y.pointed_simplicial_set_axioms)
  apply (rule_tac group_to_gammaset.is_functor)
  unfolding group_to_gammaset_def
  using A.comm_group_axioms.

interpretation RH : Reduced_Homology Y A
  unfolding Reduced_Homology_def
  by (simp add: Y.pointed_simplicial_set_axioms A.comm_group_axioms)

theorem "functor pointed_fin_set.comp P.pointed_set_comp
       (SH.Homology n)"
  unfolding pointed_fin_set.comp_def
  using SH.Homology_functor.

theorem "functor pointed_fin_set.comp P.pointed_set_comp
       (group_to_gammaset.HFunctor (RH.homology_group n))"
  apply (rule_tac group_to_gammaset.is_functor)
  unfolding group_to_gammaset_def
  using RH.is_comm_group.

theorem comparison :
   "FunCat.isomorphic
   (FunCat.mkIde (P.Inr_functor \<circ> SH.Homology n))
   (FunCat.mkIde (P.Inl_functor \<circ> group_to_gammaset.HFunctor (RH.homology_group n)))"
  oops
end

end


theory Cell
  imports "Deriving.Derive" Base
begin

datatype 'a::"countable" cell = Array "'a array" | Upd nat "'a" "'a cell ref"

derive countable cell

instance cell :: (heap) heap ..

datatype 'a::"countable" cell' = Array' "'a list" | Upd' nat "'a" "'a cell ref"

fun cell_assn where
  "cell_assn (Array' xs) (Array a) = a \<mapsto>\<^sub>a xs"
| "cell_assn (Upd' i' val' p') (Upd i val p) = \<up>(i = i' \<and> val = val' \<and> p = p')"
| "cell_assn _ _ = false"

lemma cell_assn_array [simp]: "cell_assn (Array' xs) c = (\<exists>\<^sub>Aa. \<up>(c = Array a) * a \<mapsto>\<^sub>a xs)"
  by(cases c)(auto simp: ent_iff entails_def)

lemma cell_assn_upd [simp]: "cell_assn (Upd' i x p) c = \<up>(c = Upd i x p)"
  by(cases c) auto

end


theory weird_nat_mul3acc_assoc1
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin

datatype Nat = Z | S "Nat"

fun add3acc :: "Nat => Nat => Nat => Nat" where
"add3acc (Z) (Z) z = z"
| "add3acc (Z) (S y2) z = add3acc Z y2 (S z)"
| "add3acc (S x2) y z = add3acc x2 (S y) z"

fun mul3acc :: "Nat => Nat => Nat => Nat" where
"mul3acc (Z) y z = Z"
| "mul3acc (S x2) (Z) z = Z"
| "mul3acc (S x2) (S x3) (Z) = Z"
| "mul3acc (S (Z)) (S (Z)) (S (Z)) = S Z"
| "mul3acc (S (Z)) (S (Z)) (S (S x5)) =
     S (add3acc
          (mul3acc Z Z (S x5))
          (add3acc
             (mul3acc (S Z) Z (S x5)) (mul3acc Z (S Z) (S x5))
             (mul3acc Z Z (S Z)))
          (add3acc Z Z (S x5)))"
| "mul3acc (S (Z)) (S (S x6)) (S x4) =
     S (add3acc
          (mul3acc Z (S x6) x4)
          (add3acc
             (mul3acc (S Z) (S x6) x4) (mul3acc Z (S Z) x4)
             (mul3acc Z (S x6) (S Z)))
          (add3acc Z (S x6) x4))"
| "mul3acc (S (S x7)) (S x3) (S x4) =
     S (add3acc
          (mul3acc (S x7) x3 x4)
          (add3acc
             (mul3acc (S Z) x3 x4) (mul3acc (S x7) (S Z) x4)
             (mul3acc (S x7) x3 (S Z)))
          (add3acc (S x7) x3 x4))"

(*hipster add3acc mul3acc *)

theorem x0 :
  "!!
     (x1 :: Nat) (x2 :: Nat) (x3acc :: Nat) (x4 :: Nat) (x5 :: Nat) .
     (mul3acc (mul3acc x1 x2 x3acc) x4 x5) =
       (mul3acc x1 x2 (mul3acc x3acc x4 x5))"
  by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)

end


section {*L\_ATS\_SchedUF\_Basic*}
theory
  L_ATS_SchedUF_Basic

imports
  L_ATS_Scheduler_Fragment

begin

locale ATS_SchedUF_Basic =
  ATS_Scheduler_Fragment
  "TSstructure :: 'TSstructure \<Rightarrow> bool"
  "configurations :: 'TSstructure \<Rightarrow> 'conf set"
  "initial_configurations :: 'TSstructure \<Rightarrow> 'conf set"
  "step_labels :: 'TSstructure \<Rightarrow> 'label set"
  "step_relation :: 'TSstructure \<Rightarrow> 'conf \<Rightarrow> 'label \<Rightarrow> 'conf \<Rightarrow> bool"
  "effects :: 'TSstructure \<Rightarrow> 'event set"
  "marking_condition :: 'TSstructure \<Rightarrow> ('label, 'conf) derivation \<Rightarrow> bool"
  "marked_effect :: 'TSstructure \<Rightarrow> ('label, 'conf) derivation \<Rightarrow> 'event set"
  "unmarked_effect :: 'TSstructure \<Rightarrow> ('label, 'conf) derivation \<Rightarrow> 'event set"
  "scheduler_fragments :: 'TSstructure \<Rightarrow> 'scheduler_fragment set"
  "empty_scheduler_fragment :: 'TSstructure \<Rightarrow> 'scheduler_fragment"
  "join_scheduler_fragments :: 'scheduler_fragment \<Rightarrow> 'scheduler_fragment \<Rightarrow> 'scheduler_fragment"
  for
    TSstructure configurations initial_configurations step_labels step_relation effects marking_condition marked_effect unmarked_effect scheduler_fragments empty_scheduler_fragment join_scheduler_fragments
    +

fixes unfixed_schedulers :: "'TSstructure \<Rightarrow> 'unfixed_scheduler set"
fixes empty_unfixed_scheduler :: "'TSstructure \<Rightarrow> 'unfixed_scheduler"
fixes unfixed_scheduler_right_quotient :: "'unfixed_scheduler \<Rightarrow> 'unfixed_scheduler \<Rightarrow> 'scheduler_fragment option"
fixes extend_unfixed_scheduler :: "'scheduler_fragment \<Rightarrow> 'unfixed_scheduler \<Rightarrow> 'unfixed_scheduler"
fixes unfixed_scheduler_extendable :: "'TSstructure \<Rightarrow> 'unfixed_scheduler \<Rightarrow> bool"

assumes AX_extend_unfixed_scheduler_preserves_unfixed_scheduler_extendable: "
  TSstructure G
  \<Longrightarrow> unfixed_scheduler_extendable G sUF
  \<Longrightarrow> unfixed_scheduler_extendable G (extend_unfixed_scheduler sE sUF)"

assumes AX_extend_unfixed_scheduler_unfixed_scheduler_right_quotient_empty: "
  TSstructure G
  \<Longrightarrow> sUF \<in> unfixed_schedulers G
  \<Longrightarrow> extend_unfixed_scheduler (the (unfixed_scheduler_right_quotient sUF (empty_unfixed_scheduler G))) (empty_unfixed_scheduler G) = sUF"

assumes AX_extend_unfixed_scheduler_left_neutral: "
  TSstructure G
  \<Longrightarrow> sUF \<in> unfixed_schedulers G
  \<Longrightarrow> extend_unfixed_scheduler (empty_scheduler_fragment G) sUF = sUF"

assumes AX_unfixed_scheduler_right_quotient_all: "
  TSstructure G
  \<Longrightarrow> sUF \<in> unfixed_schedulers G
  \<Longrightarrow> unfixed_scheduler_right_quotient sUF sUF = Some (empty_scheduler_fragment G)"

assumes AX_empty_unfixed_scheduler_in_unfixed_schedulers: "
  TSstructure G
  \<Longrightarrow> empty_unfixed_scheduler G \<in> unfixed_schedulers G"

assumes AX_extend_unfixed_scheduler_closed: "
  TSstructure G
  \<Longrightarrow> sE \<in> scheduler_fragments G
  \<Longrightarrow> sUF \<in> unfixed_schedulers G
  \<Longrightarrow> unfixed_scheduler_extendable G sUF
  \<Longrightarrow> extend_unfixed_scheduler sE sUF \<in> unfixed_schedulers G"

context ATS_SchedUF_Basic
begin

lemma AX_extend_unfixed_scheduler_closed_prime: "
  TSstructure G
  \<Longrightarrow> sE \<in> scheduler_fragments G
  \<Longrightarrow> sUF \<in> unfixed_schedulers G
  \<Longrightarrow> (unfixed_scheduler_extendable G sUF) \<or> (sE = empty_scheduler_fragment G)
  \<Longrightarrow> extend_unfixed_scheduler sE sUF \<in> unfixed_schedulers G"
  apply(erule disjE)
   apply (metis AX_extend_unfixed_scheduler_closed)
  apply (metis AX_extend_unfixed_scheduler_left_neutral)
  done

end

end


(*
    Authors:    Jose Divasón
                Sebastiaan Joosten
                René Thiemann
                Akihisa Yamada
    License:    BSD
*)

section \<open>Mistakes in the textbook Modern Computer Algebra (2nd edition)\<close>

theory Modern_Computer_Algebra_Problem
  imports Factorization_Algorithm_16_22
begin

fun max_degree_poly :: "int poly \<Rightarrow> int poly \<Rightarrow> int poly"
  where "max_degree_poly a b = (if degree a \<ge> degree b then a else b)"

fun choose_u :: "int poly list \<Rightarrow> int poly"
   where "choose_u [] = undefined"
 | "choose_u [gi] = gi"
 | "choose_u (gi # gj # gs) = max_degree_poly gi (choose_u (gj # gs))"

subsection \<open>A real problem of Algorithm 16.22\<close>

text \<open>Bogus example for Modern Computer Algebra (2nd edition), Algorithm 16.22, step 9:
  After having detected the factor @{term "[:1,1,0,1 :: int:]"}, the remaining polynomial
  $f^*$ will be 1, and the remaining list of modular factors will be empty.\<close>

lemma "let f = [:1,1:] * [:1,1,0,1:];
   p = suitable_prime_bz f;
   b = lead_coeff f;
   A = linf_norm_poly f; n = degree f; B = sqrt_int_ceiling (n+1) * 2^n * A;
   Bnd = 2^(n^2 div 2) * B^(2*n); l = log_ceiling p Bnd;
   (_, fs) = finite_field_factorization_int p f;
   gs = hensel_lifting p l f fs;
   u = choose_u gs;
   d = degree u;
   g_star = [:2,2,0,2 :: int :];
   (gs',hs') = List.partition (\<lambda>gi. poly_mod.dvdm p gi g_star) gs;
   h_star = smult b (prod_list hs');
   f_star = primitive_part h_star
  in (hs' = [] \<and> f_star = 1)" by eval

subsection \<open>Another potential problem of Algorithm 16.22\<close>

text \<open>
  Suppose that $g^*$ is $p^l$. (It is is not yet clear whether lattices exists
  where this $g^*$ is short enough).
  Then $pp(g^*) = 1$ is detected as \emph{irreducible} factor and the algorithm stops.
\<close>

definition "input_poly = [: 1,0,0,0,1,1,0,0,1,0,1,0,1 :: int :]"

text \<open>For @{const input_poly} the factorization will result in a lattice where
  each initial basis element has a Euclidean norm of at least $p^l$ (since the
  input polynomial $u$ has a norm larger than $p^l$.)
  So, just from the norm of the basis one cannot infer that the lattice contains small vectors.\<close>

lemma "let f = input_poly;
   p = suitable_prime_bz f;
   b = lead_coeff f;
   A = linf_norm_poly f; n = degree f; B = sqrt_int_ceiling (n+1) * 2^n * A;
   Bnd = 2^(n^2 div 2) * B^(2*n); l = log_ceiling p Bnd;
   (_, fs) = finite_field_factorization_int p f;
   gs = hensel_lifting p l f fs;
   u = choose_u gs;
   pl = p^l;
   pl2 = pl div 2;
   u' = poly_mod.inv_Mp2 pl pl2 (poly_mod.Mp pl (smult b u))
  in sqrt_int_floor (sq_norm u') > pl" by eval

text \<open>The following calculation will show that the norm of $g^*$ is not that much
  shorter than $p^l$ which is an indication that it is not obvious that in general
  $p^l$ cannot be chosen as short polynomial.\<close>

definition "compute_norms = (let f = input_poly;
   p = suitable_prime_bz f;
   b = lead_coeff f;
   A = linf_norm_poly f; n = degree f; B = sqrt_int_ceiling (n+1) * 2^n * A;
   Bnd = 2^(n^2 div 2) * B^(2*n); l = log_ceiling p Bnd;
   (_, fs) = finite_field_factorization_int p f;
   gs = hensel_lifting p l f fs;
   u = choose_u gs;
   pl = p^l;
   pl2 = pl div 2;
   u' = poly_mod.inv_Mp2 pl pl2 (poly_mod.Mp pl (smult b u));
   d = degree u;
   pl = p^l;
   L = factorization_lattice u' 1 pl;
   g_star = short_vector 2 L
  in (
     ''p^l:         '' @ show pl @ shows_nl [] @
     ''norm u:      '' @ show (sqrt_int_floor (sq_norm_poly u')) @ shows_nl [] @
     ''norm g_star: '' @ show (sqrt_int_floor (sq_norm_vec g_star)) @ shows_nl [] @ shows_nl []
))"

export_code compute_norms in Haskell

text \<open>
\<^item> @{term "p^l"}:         $\approx 6.61056 \cdot 10^{122}$, namely 661055968790248598951915308032771039828404682964281219284648795274405791236311345825189210439715284847591212025023358304256
\<^item> @{term "norm u"}:      $\approx 6.67555 \cdot 10^{122}$, namely 667555058938127908386141559707490406617756492853269306735125739182352318769782701477339940304992057299993307341153235059302
\<^item> @{term "norm g_star"}: $\approx 5.02568 \cdot 10^{110}$, namely 502567871888893789258107599397950338997348731386301514804539180088146716526330518979464688385872213886910747667
\<close>

subsection \<open>Verified wrong results\<close>

text \<open>An equality in example 16.24 of the textbook which is not valid.\<close>

lemma "let g2 = [:-984,1:];
           g3 = [:-72,1:];
           g4 = [:-6828,1:];
           rhs = [:-1728,-840,-420,6:]
  in \<not> poly_mod.eq_m (5^6) (smult 6 (g2*g3*g4)) (rhs)" by eval

end


theory Mumble_Language
  imports Aczel
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 consistent_mumble: "lfinite ys \<Longrightarrow> consistent (ys \<frown> LCons (\<sigma>, \<sigma>') (LCons (\<sigma>', \<sigma>'') xs)) \<Longrightarrow> consistent (ys \<frown> LCons (\<sigma>, \<sigma>'') xs)"
proof (induct ys rule: lfinite.induct)
  case lfinite_LNil
  thus ?case
    apply (cases xs)
    apply auto
    apply (drule consistent_LConsD)
    apply (drule consistent_LConsE)
    by auto
next
  case (lfinite_LConsI xs' x')
  thus ?case
    apply simp
    apply (cases xs')
    apply auto
    by (metis consistent_LConsE fst_conv)
qed

lemma inconsistent_mumble: "lfinite ys \<Longrightarrow> \<not> consistent (ys \<frown> LCons (\<sigma>, \<sigma>') (LCons (\<sigma>', \<sigma>'') xs)) \<Longrightarrow> \<not> consistent (ys \<frown> LCons (\<sigma>, \<sigma>'') xs)"
proof (induct ys rule: lfinite.induct)
  case lfinite_LNil
  thus ?case
    apply (cases xs)
    apply auto
    apply (drule consistent_LConsE)
    by auto
next
  case (lfinite_LConsI xs' x')
  thus ?case
    apply auto
    apply (cases xs')
    apply auto
    by (metis consistent_LConsE fst_conv)
qed

lemma mumble_preserves_consistent [dest]: "xs \<in> mumble ys \<Longrightarrow> consistent xs \<longleftrightarrow> consistent ys"
proof (induct xs rule: mumble.induct)
  case self thus ?case by simp
next
  case (mumble ws \<sigma> \<sigma>' \<sigma>'' vs)
  thus ?case
  proof auto
    assume "consistent (ws \<frown> LCons (\<sigma>, \<sigma>') (LCons (\<sigma>', \<sigma>'') vs))"
    thus "consistent (ws \<frown> LCons (\<sigma>, \<sigma>'') vs)"
      by (metis consistent_mumble lappend_inf)
  next
    assume "\<not> consistent (ws \<frown> LCons (\<sigma>, \<sigma>') (LCons (\<sigma>', \<sigma>'') vs))" and "consistent (ws \<frown> LCons (\<sigma>, \<sigma>'') vs)"
    thus "False"
      by (metis inconsistent_mumble lappend_inf)
  qed
qed

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_Con [simp]: "Con\<^sup>\<dagger> = Con"
  by (auto simp add: Mumble_def Con_def)

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

definition "llist_Case \<equiv> llist_case"

primrec ldeleteLeft_nat :: "nat \<Rightarrow> ('a + 'b) llist \<Rightarrow> ('a + 'b) llist" where
  "ldeleteLeft_nat 0 xs = ltakeWhile is_right xs \<frown> ltl (ldropWhile is_right xs)"
| "ldeleteLeft_nat (Suc n) xs = ltakeWhile is_right xs \<frown> llist_Case LNil (\<lambda>x' xs'. LCons x' (ldeleteLeft_nat n xs')) (ldropWhile is_right xs)"

primrec ldeleteLeft :: "enat \<Rightarrow> ('a + 'b) llist \<Rightarrow> ('a + 'b) llist" where
  "ldeleteLeft (enat n) xs = ldeleteLeft_nat n xs"
| "ldeleteLeft \<infinity> xs = xs"

primrec linsertLeft_nat :: "nat \<Rightarrow> 'a \<Rightarrow> ('a + 'b) llist \<Rightarrow> ('a + 'b) llist" where
  "linsertLeft_nat 0 x xs = ltakeWhile is_right xs \<frown> LCons (Inl x) (ldropWhile is_right xs)"
| "linsertLeft_nat (Suc n) x xs = ltakeWhile is_right xs \<frown> llist_Case LNil (\<lambda>x' xs'. LCons x' (linsertLeft_nat n x xs')) (ldropWhile is_right xs)"

primrec linsertLeft :: "enat \<Rightarrow> 'a \<Rightarrow> ('a + 'b) llist \<Rightarrow> ('a + 'b) llist" where
  "linsertLeft (enat n) x xs = linsertLeft_nat n x xs"
| "linsertLeft \<infinity> x xs = xs"

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

primrec linsert :: "enat \<Rightarrow> 'a \<Rightarrow> 'a llist \<Rightarrow> 'a llist" where
  "linsert (enat n) x xs = linsert_nat n x xs"
| "linsert \<infinity> x xs = xs"

lemma "mumble xs \<cdot> mumble ys \<subseteq> mumble (xs \<frown> ys)"
  apply (auto simp add: l_prod_def)
  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 [simp]: "\<up> (llength xs) xs = xs"
  by (metis ltake_all order_refl)

lemma [simp]: "traj LNil = LNil"
  by (metis traj_LNil traj_interleave)

lemma [simp]: "traj (LCons (Inl x) xs) = LCons (Inl ()) (traj xs)"
  by (simp add: traj_def)

lemma [simp]: "traj (LCons (Inr x) xs) = LCons (Inr ()) (traj xs)"
  by (simp add: traj_def)

lemma LConsl_in_shuffle [dest]: "LCons (Inl x) (xs \<frown> ys) \<in> xs' \<sha> ys' \<Longrightarrow> xs \<frown> ys \<in> ltl xs' \<sha> ys'"
  by (auto simp add: tshuffle_words_def)

lemma LConsr_in_shuffle [dest]: "LCons (Inr y) (xs \<frown> ys) \<in> xs' \<sha> ys' \<Longrightarrow> xs \<frown> ys \<in> xs' \<sha> ltl ys'"
  by (auto simp add: tshuffle_words_def)

lemma interleave_append:
  assumes "zs \<in> xs \<sha> ys"
  and "t \<frown> t' = traj zs"
  shows "xs \<triangleright> t \<frown> t' \<triangleleft> ys = (\<up> (llength (\<ll> t)) xs \<triangleright> t \<triangleleft> \<up> (llength (\<rr> t)) ys) \<frown> (\<down> (llength (\<ll> t)) xs \<triangleright> t' \<triangleleft> \<down> (llength (\<rr> t)) ys)"
proof -
  {
    assume "\<not> lfinite t"
    moreover have "\<And>xs ys. \<not> lfinite (xs \<triangleright> t \<triangleleft> ys)"
      by (metis calculation lfinite_traj)
    ultimately have ?thesis using assms
      apply (auto simp add: lappend_inf)
      apply (subst lappend_inf)
      apply (simp add: traj_def)
      apply blast
      by (metis (lifting, full_types) dual_order.refl ltake_all mem_Collect_eq tshuffle_words_def)
  }
  moreover
  {
    assume "lfinite t"
    hence "?thesis" using assms
    proof (induct t arbitrary: xs ys zs rule: lfinite_induct)
      case Nil thus ?case by simp
    next
      case (Cons w ws)
      thus ?case
        apply (cases w)
        apply (simp add: interleave_left)
        apply (subgoal_tac "ltl zs \<in> ltl xs \<sha> ys")
        apply (subgoal_tac "ws \<frown> t' = traj (ltl zs)")
        apply (metis (hide_lams, no_types) interleave_left ldrop_ltl ltake_ltl)
        apply (metis interleave_left ltl_simps(2) reinterleave traj_interleave)
        apply (simp add: tshuffle_words_def)
        apply (metis interleave_left lefts_LConsl ltl_simps(2) reinterleave rights_LConsl)
        apply (simp add: interleave_right)
        apply (subgoal_tac "ltl zs \<in> xs \<sha> ltl ys")
        apply (subgoal_tac "ws \<frown> t' = traj (ltl zs)")
        apply (metis (hide_lams, no_types) interleave_right ldrop_ltl ltake_ltl)
        apply (metis interleave_right ltl_simps(2) reinterleave traj_interleave)
        apply (simp add: tshuffle_words_def)
        by (metis interleave_right lefts_LConsr ltl_simps(2) reinterleave rights_LConsr)
    qed
  }
  ultimately show ?thesis by auto
qed

lemma traj_to_shuffle:
  assumes "llength (\<ll> t) = llength xs"
  and "llength (\<rr> t) = llength ys"
  shows "\<exists>zs. t = traj zs \<and> zs \<in> xs \<sha> ys"
  using assms
  apply (auto simp add: tshuffle_words_def)
  apply (rule_tac x = "xs \<triangleright> t \<triangleleft> ys" in exI)
  apply auto
  apply (metis lefts_interleave_llength traj_interleave)
  by (metis rights_interleave_llength traj_interleave)

lemma interleave_append_llength:
  assumes "llength (\<ll> (t \<frown> t')) = llength xs"
  and "llength (\<rr> (t \<frown> t')) = llength ys"
  shows "xs \<triangleright> t \<frown> t' \<triangleleft> ys = (\<up> (llength (\<ll> t)) xs \<triangleright> t \<triangleleft> \<up> (llength (\<rr> t)) ys) \<frown> (\<down> (llength (\<ll> t)) xs \<triangleright> t' \<triangleleft> \<down> (llength (\<rr> t)) ys)"
  by (metis (hide_lams, no_types) assms(1) assms(2) interleave_append traj_to_shuffle)

lemma lefts_ltake_right [simp]: "\<ll> (ltakeWhile is_right xs) = LNil"
  by (auto dest: lset_ltakeWhileD simp add: lefts_def)

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

lemma traj_lappend [simp]: "traj (xs \<frown> ys) = traj xs \<frown> traj ys"
  by (auto simp add: traj_def lmap_lappend_distrib)

lemma [simp]:
  fixes t :: "(unit + unit) llist"
  shows "traj t = t"
  apply (auto simp add: traj_def)
  apply (subst lmap_ident[symmetric]) back
  apply (rule lmap2_id)
proof -
  fix x :: "(unit + unit)"
  show "(case x of Inl x \<Rightarrow> Inl x | Inr x \<Rightarrow> Inr x) = x"
    by (cases x) auto
qed

lemma intro_traj: "xs \<triangleright> t \<triangleleft> ys = xs \<triangleright> traj t \<triangleleft> ys"
  by simp

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)
  apply (metis is_left.simps(2) is_right.simps(2) not_is_left swap.cases unl.simps(1) unr.simps(1))
  apply (metis is_left.simps(2) obj_sumE unl.simps(1))
  by (metis is_right.simps(2) obj_sumE unr.simps(1))

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)

lemma [simp]: "lmap f xs \<noteq> LNil \<longleftrightarrow> xs \<noteq> LNil"
  by (metis LNil_eq_llist_map)

lemma [simp]: "xs \<triangleright> t \<triangleleft> ys \<noteq> LNil \<longleftrightarrow> t \<noteq> LNil"
  by (metis traj_LNil traj_interleave)

(* 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]: "lfilter is_right (ltl (ldropWhile is_right t)) = lfilter is_right (ldropWhile is_right t)"
  apply (cases "\<exists>t'\<in>lset t. \<exists>a. t' = Inl a")
  apply (metis is_right.simps(2) lfilter_LCons lhd_ldropWhile llist.collapse ltl_simps(1))
  apply auto
  apply (subgoal_tac "ldropWhile is_right t = LNil")
  apply simp_all
  apply auto
  by (metis is_right.simps(1) obj_sumE)

lemma ldropWhile_LConsD [dest]: "ldropWhile P xs = LCons y ys \<Longrightarrow> \<exists>zs. xs = zs \<frown> LCons y ys \<and> \<not> P y \<and> (\<forall>z\<in>lset zs. P z) \<and> lfinite zs"
  by (metis lappend_ltakeWhile_ldropWhile ldropWhile_eq_LNil_iff lfinite_ltakeWhile lhd_LCons lhd_ldropWhile llist.distinct(1) lset_ltakeWhileD)

lemma ldropWhile_right_LCons [dest!]: "ldropWhile is_right t = LCons x xs \<Longrightarrow> \<exists>x'. ldropWhile is_right t = LCons (Inl x') xs"
  apply (drule ldropWhile_LConsD)
  apply (cases x)
  apply auto
  by (metis is_right.simps(2) ldropWhile_LCons ldropWhile_lappend)

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 lappend_inf lappend_ltakeWhile_ldropWhile lefts_def_var lefts_ltake_right llist.distinct(1))
  apply simp
  apply (metis Not_is_left ltl_lfilter ltl_lmap ltl_simps(2))
  apply (subst lfilter_lappend_lfinite)
  apply (metis lappend_inf lappend_ltakeWhile_ldropWhile lefts_def_var lefts_ltake_right llist.discI)
  apply simp
  apply (subst lfilter_lappend_lfinite[symmetric])
  apply (metis lappend_inf lappend_ltakeWhile_ldropWhile lefts_def_var lefts_ltake_right llist.discI)
  apply (cases "ldropWhile is_right xs")
  apply simp
  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 (metis LNil_preserve is_right.simps(2) llist.exhaust llist.simps(19) ltakeWhile_LCons ltakeWhile_LNil)

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 llength_eq_0 zero_enat_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"
  by auto

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)
    apply (simp add: lappend_inf)
    by (metis lset_ltakeWhileD)
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 (subst lmap_unl_Inl)
  apply simp
  apply (subst lmap_unl_Inl)
  apply simp
  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(19) lmap_lappend_distrib)
  apply (subgoal_tac "is_left (lhd (ldropWhile is_right t))")
  apply metis
  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)"
  by (cases n) (simp_all add: lfilter_ldropn)

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 co.enat.exhaust eSuc_minus_1 eSuc_mono)
  by (metis eSuc_mono eSuc_move)

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 (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_eq_0 zero_enat_def)
      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 (lifting) LNil_preserve lefts_def_var lefts_ltake_right lfilter_LCons lfilter_LNil llist.collapse llist.distinct(1) ltakeWhile_LCons ltakeWhile_eq_LNil_iff t_not_LNil)

      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_eq_0 zero_enat_def)
      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)
      apply (subst lmap_unl_Inl)
      apply (metis (lifting) Coinductive_List.lset_lfilter mem_Collect_eq)
      by (metis Not_is_left lhd_LCons lhd_lfilter lhd_lmap llist.distinct(1))

    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)
      apply (subst lmap_unl_Inl)
      apply (metis (lifting) Coinductive_List.lset_lfilter mem_Collect_eq)
      apply simp
      by (metis LNil_eq_llist_map ldropWhile_lfilter_rl_LNil ldropWhile_right_traj ldropWhile_rights_not_LNil lefts_def_var lhd_LCons llist.distinct(1) traj_lfilter_lefts_var)

    from Suc(3)
    have "ldropWhile is_right (traj t) \<noteq> LNil"
      apply (auto simp add: tshuffle_words_def xs_def traj_not_LNil)
      apply (rule_tac x = "Inl x'" in bexI)
      apply simp
      apply (rule lset_lfilter_var[where P = is_left])
      apply (erule rev_mp)
      apply (simp add: lefts_def)
      apply (subst lmap_unl_Inl)
      apply (metis (mono_tags) Coinductive_List.lset_lfilter mem_Collect_eq)
      apply auto
      by (metis lset_intros(1) lset_lfilter_var)

    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)
      apply (metis ltl_lmap ltl_simps(2))
      apply (simp add: lefts_def rights_def ldropWhile_def)
      apply (rule arg_cong) back
      apply (subst lfilter_ldrop)
      apply (rule arg_cong) back
      by (metis diverge_lfilter_LNil lappend_ltakeWhile_ldropWhile lfilter_left_right lset_ltakeWhileD ltake_all ltake_lappend1 not_is_left order_refl)

    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 simp del: ltakeWhile_eq_LNil_iff)

    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 1)
      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 1)
      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
    by (auto simp add: Mumble_def) (metis (full_types) imageI)
qed

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}"
    by (insert tshuffle_mumble) blast
  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>"
    by (simp add: shuffle_def Mumble_def) blast
  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 (auto simp add: Mumble_def)
    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 auto
    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"
  by (induct rule: mumble.induct) auto

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 (lifting) insert_def insert_mono l_prod_isor monoI singleton_conv)
  apply (metis (lifting) Mumble_iso insert_def insert_mono l_prod_isor monoI singleton_conv)
  apply (simp only: o_def Mumble_union Mumble_LNil)
  apply (rule ext)
  by (metis Mumble_l_prod1)

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 (simp add: Mumble_def image_def)
  apply auto
  apply auto
  apply (erule_tac x = "xa\<^sup>\<dagger>" in allE)
  apply (auto simp add: Mumble_def)
  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 (tactic {* prune_params_tac *})
  apply (rename_tac X')
  apply (simp add: powers_def)
  apply (erule exE)
  apply simp
  apply (thin_tac "X' = Language.power X i")
  apply (tactic {* prune_params_tac *})
  apply (rule fmumble_star_power)
  by assumption+

end


(*  Title:      HOL/HOLCF/IOA/NTP/Lemmas.thy
    Author:     Tobias Nipkow & Konrad Slind
*)

theory Lemmas
imports Main
begin

subsubsection \<open>Logic\<close>

lemma neg_flip: "(X = (\<not> Y)) = ((\<not>X) = Y)"
  by blast

subsection \<open>Sets\<close>

lemma set_lemmas:
  "f(x) \<in> (\<Union>x. {f(x)})"
  "f x y \<in> (\<Union>x y. {f x y})"
  "\<And>a. (\<forall>x. a \<noteq> f(x)) \<Longrightarrow> a \<notin> (\<Union>x. {f(x)})"
  "\<And>a. (\<forall>x y. a \<noteq> f x y) \<Longrightarrow> a \<notin> (\<Union>x y. {f x y})"
  by auto

subsection \<open>Arithmetic\<close>

lemma pred_suc: "0<x ==> (x - 1 = y) = (x = Suc(y))"
  by (simp add: diff_Suc split: nat.split)

lemmas [simp] = hd_append set_lemmas

end


(*  Title:       Isabelle Collections Library
    Author:      Peter Lammich <peter dot lammich at uni-muenster.de>
    Maintainer:  Peter Lammich <peter dot lammich at uni-muenster.de>
*)
header {* \isaheader{Fifo Queue by Pair of Lists} *}
theory Fifo
imports
  "../gen_algo/ListGA"
  "../tools/Record_Intf"
  "../tools/Locale_Code"
begin
text_raw {*\label{thy:Fifo}*}

(* TODO: Move to Misc *)
lemma rev_tl_rev: "rev (tl (rev l)) = butlast l"
  by (induct l) auto

(*@impl List
  @type 'a fifo
  @abbrv fifo
  Fifo-Queues implemented by two stacks.
*)

text {*
  A fifo-queue is implemented by a pair of two lists (stacks).
  New elements are pushed on the first stack, and elements are popped from
  the second stack. If the second stack is empty, the first stack is reversed
  and replaces the second stack.

  If list reversal is implemented efficiently (what is the case in Isabelle/HOL,
  cf @{thm [source] List.rev_conv_fold})
  the amortized time per buffer operation is constant.

  Moreover, this fifo implementation also supports efficient push and pop operations.
*}

subsection {* Definitions *}
type_synonym 'a fifo = "'a list \<times> 'a list"

text "Abstraction of the fifo to a list. The next element to be got is at
      the head of the list, and new elements are appended at the end of the
      list"
definition fifo_\<alpha> :: "'a fifo \<Rightarrow> 'a list"
  where "fifo_\<alpha> F == snd F @ rev (fst F)"

text "This fifo implementation has no invariants, any pair of lists is a
  valid fifo"
definition [simp, intro!]: "fifo_invar x = True"

  -- "The empty fifo"
definition fifo_empty :: "unit \<Rightarrow> 'a fifo"
  where "fifo_empty == \<lambda>_::unit. ([],[])"

  -- "True, iff the fifo is empty"
definition fifo_isEmpty :: "'a fifo \<Rightarrow> bool" where "fifo_isEmpty F == F=([],[])"

definition fifo_size :: "'a fifo \<Rightarrow> nat" where
  "fifo_size F \<equiv> length (fst F) + length (snd F)"

  -- "Add an element to the fifo"
definition fifo_appendr :: "'a \<Rightarrow> 'a fifo \<Rightarrow> 'a fifo"
  where "fifo_appendr a F == (a#fst F, snd F)"

definition fifo_appendl :: "'a \<Rightarrow> 'a fifo \<Rightarrow> 'a fifo"
  where "fifo_appendl x F == case F of (e,d) \<Rightarrow> (e,x#d)"

-- "Get an element from the fifo"
definition fifo_remover :: "'a fifo \<Rightarrow> ('a fifo \<times> 'a)" where
  "fifo_remover F ==
    case fst F of
      (a#l) \<Rightarrow> ((l,snd F),a) |
      [] \<Rightarrow> let rp=rev (snd F) in
        ((tl rp,[]),hd rp)"

definition fifo_removel :: "'a fifo \<Rightarrow> ('a \<times> 'a fifo)" where
  "fifo_removel F ==
    case snd F of
      (a#l) \<Rightarrow> (a, (fst F, l)) |
      [] \<Rightarrow> let rp=rev (fst F) in
        (hd rp, ([], tl rp))
"

definition fifo_leftmost :: "'a fifo \<Rightarrow> 'a" where
  "fifo_leftmost F \<equiv> case F of (_,x#_) \<Rightarrow> x | (l,[]) \<Rightarrow> last l"

definition fifo_rightmost :: "'a fifo \<Rightarrow> 'a" where
  "fifo_rightmost F \<equiv> case F of (x#_,_) \<Rightarrow> x | ([],l) \<Rightarrow> last l"

definition "fifo_iteratei F \<equiv> foldli (fifo_\<alpha> F)"
definition "fifo_rev_iteratei F \<equiv> foldri (fifo_\<alpha> F)"

definition "fifo_get F i \<equiv>
  let
    l2 = length (snd F)
  in
    if i < l2 then
      snd F!i
    else
      (fst F)!(length (fst F) - Suc (i - l2))
  "

definition "fifo_set F i a \<equiv> case F of (f1,f2) \<Rightarrow>
  let
    l2 = length f2
  in
    if i < l2 then
      (f1,f2[i:=a])
    else
      (f1[length (fst F) - Suc (i - l2) := a],f2)"

subsection "Correctness"

lemma fifo_empty_impl: "list_empty fifo_\<alpha> fifo_invar fifo_empty"
  apply (unfold_locales)
  by (auto simp add: fifo_\<alpha>_def fifo_empty_def)

lemma fifo_isEmpty_impl: "list_isEmpty fifo_\<alpha> fifo_invar fifo_isEmpty"
  apply (unfold_locales)
  by (case_tac s) (auto simp add: fifo_isEmpty_def fifo_\<alpha>_def)

lemma fifo_size_impl: "list_size fifo_\<alpha> fifo_invar fifo_size"
  apply unfold_locales
  by (auto simp add: fifo_size_def fifo_\<alpha>_def)

lemma fifo_appendr_impl: "list_appendr fifo_\<alpha> fifo_invar fifo_appendr"
  apply (unfold_locales)
  by (auto simp add: fifo_appendr_def fifo_\<alpha>_def)

lemma fifo_appendl_impl: "list_appendl fifo_\<alpha> fifo_invar fifo_appendl"
  apply (unfold_locales)
  by (auto simp add: fifo_appendl_def fifo_\<alpha>_def)

lemma fifo_removel_impl: "list_removel fifo_\<alpha> fifo_invar fifo_removel"
  apply (unfold_locales)
  apply (case_tac s)
  apply (case_tac b)
  apply (auto simp add: fifo_removel_def fifo_\<alpha>_def Let_def) [2]
  apply (case_tac s)
  apply (case_tac "b")
  apply (auto simp add: fifo_removel_def fifo_\<alpha>_def Let_def)
  done

lemma fifo_remover_impl: "list_remover fifo_\<alpha> fifo_invar fifo_remover"
  apply (unfold_locales)
  unfolding fifo_remover_def fifo_\<alpha>_def Let_def
  by (auto split: list.split simp: hd_rev rev_tl_rev butlast_append)

lemma fifo_leftmost_impl: "list_leftmost fifo_\<alpha> fifo_invar fifo_leftmost"
  apply unfold_locales
  by (auto simp: fifo_leftmost_def fifo_\<alpha>_def hd_rev split: list.split)

lemma fifo_rightmost_impl: "list_rightmost fifo_\<alpha> fifo_invar fifo_rightmost"
  apply unfold_locales
  by (auto simp: fifo_rightmost_def fifo_\<alpha>_def hd_rev split: list.split)

lemma fifo_get_impl: "list_get fifo_\<alpha> fifo_invar fifo_get"
  apply unfold_locales
  apply (auto simp: fifo_\<alpha>_def fifo_get_def Let_def nth_append rev_nth)
  done

lemma fifo_set_impl: "list_set fifo_\<alpha> fifo_invar fifo_set"
  apply unfold_locales
  apply (auto simp: fifo_\<alpha>_def fifo_set_def Let_def list_update_append
    rev_update)
  done

definition [icf_rec_def]: "fifo_ops \<equiv> \<lparr>
  list_op_\<alpha> = fifo_\<alpha>,
  list_op_invar = fifo_invar,
  list_op_empty = fifo_empty,
  list_op_isEmpty = fifo_isEmpty,
  list_op_size = fifo_size,
  list_op_appendl = fifo_appendl,
  list_op_removel = fifo_removel,
  list_op_leftmost = fifo_leftmost,
  list_op_appendr = fifo_appendr,
  list_op_remover = fifo_remover,
  list_op_rightmost = fifo_rightmost,
  list_op_get = fifo_get,
  list_op_set = fifo_set
  \<rparr>"

setup Locale_Code.open_block
interpretation fifo: StdList fifo_ops
  apply (rule StdList.intro)
  apply (simp_all add: icf_rec_unf)
  apply (rule
    fifo_empty_impl
    fifo_isEmpty_impl
    fifo_size_impl
    fifo_appendl_impl
    fifo_removel_impl
    fifo_leftmost_impl
    fifo_appendr_impl
    fifo_remover_impl
    fifo_rightmost_impl
    fifo_get_impl
    fifo_set_impl)+
  done
interpretation fifo: StdList_no_invar fifo_ops
  by unfold_locales (simp add: icf_rec_unf)
setup Locale_Code.close_block
setup {* ICF_Tools.revert_abbrevs "fifo" *}

definition test_codegen where "test_codegen \<equiv>
  (
    fifo.empty,
    fifo.isEmpty,
    fifo.size,
    fifo.appendl,
    fifo.removel,
    fifo.leftmost,
    fifo.appendr,
    fifo.remover,
    fifo.rightmost,
    fifo.get,
    fifo.set,
    fifo.iteratei,
    fifo.rev_iteratei
  )"

export_code test_codegen in SML

end