(*  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{Hash maps implementation} *}
theory HashMap_Impl
imports
  RBTMapImpl
  ListMapImpl
  "../../Lib/HashCode"
begin

text {*
  We use a red-black tree instead of an indexed array. This
  has the disadvantage of being more complex, however we need not bother
  about a fixed-size array and rehashing if the array becomes too full.

  The entries of the red-black tree are lists of (key,value) pairs.
*}

subsection {* Abstract Hashmap *}
text {*
  We first specify the behavior of our hashmap on the level of maps.
  We will then show that our implementation based on hashcode-map and bucket-map
  is a correct implementation of this specification.
*}
type_synonym
  ('k,'v) abs_hashmap = "hashcode \<rightharpoonup> ('k \<rightharpoonup> 'v)"

  -- "Map entry of map by function"
abbreviation map_entry where "map_entry k f m == m(k := f (m k))"

  -- "Invariant: Buckets only contain entries with the right hashcode and there are no empty buckets"
definition ahm_invar:: "('k::hashable,'v) abs_hashmap \<Rightarrow> bool"
  where "ahm_invar m ==
    (\<forall>hc cm k. m hc = Some cm \<and> k\<in>dom cm \<longrightarrow> hashcode k = hc) \<and>
    (\<forall>hc cm. m hc = Some cm \<longrightarrow> cm \<noteq> Map.empty)"

  -- "Abstract a hashmap to the corresponding map"
definition ahm_\<alpha> where
  "ahm_\<alpha> m k == case m (hashcode k) of
    None \<Rightarrow> None |
    Some cm \<Rightarrow> cm k"

  -- "Lookup an entry"
definition ahm_lookup :: "'k::hashable \<Rightarrow> ('k,'v) abs_hashmap \<Rightarrow> 'v option"
  where "ahm_lookup k m == (ahm_\<alpha> m) k"

  -- "The empty hashmap"
definition ahm_empty :: "('k::hashable,'v) abs_hashmap"
  where "ahm_empty = Map.empty"

  -- "Update/insert an entry"
definition ahm_update where
  "ahm_update k v m ==
    case m (hashcode k) of
      None \<Rightarrow> m (hashcode k \<mapsto> [k \<mapsto> v]) |
      Some cm \<Rightarrow> m (hashcode k \<mapsto> cm (k \<mapsto> v))
  "

  -- "Delete an entry"
definition ahm_delete where
  "ahm_delete k m == map_entry (hashcode k)
    (\<lambda>v. case v of
      None \<Rightarrow> None |
      Some bm \<Rightarrow> (
        if bm |` (- {k}) = Map.empty then
          None
        else
          Some ( bm |` (- {k}))
      )
    ) m
  "

definition ahm_isEmpty where
  "ahm_isEmpty m == m=Map.empty"

text {*
  Now follow correctness lemmas, that relate the hashmap operations to
  operations on the corresponding map. Those lemmas are named op\_correct, where
  op is the operation.
*}

lemma ahm_invarI: "\<lbrakk>
  !!hc cm k. \<lbrakk>m hc = Some cm; k\<in>dom cm\<rbrakk> \<Longrightarrow> hashcode k = hc;
  !!hc cm. \<lbrakk> m hc = Some cm \<rbrakk> \<Longrightarrow> cm \<noteq> Map.empty
  \<rbrakk> \<Longrightarrow> ahm_invar m"
  by (unfold ahm_invar_def) blast

lemma ahm_invarD: "\<lbrakk> ahm_invar m; m hc = Some cm; k\<in>dom cm \<rbrakk> \<Longrightarrow> hashcode k = hc"
  by (unfold ahm_invar_def) blast

lemma ahm_invarDne: "\<lbrakk> ahm_invar m; m hc = Some cm \<rbrakk> \<Longrightarrow> cm \<noteq> Map.empty"
  by (unfold ahm_invar_def) blast

lemma ahm_invar_bucket_not_empty[simp]:
  "ahm_invar m \<Longrightarrow> m hc \<noteq> Some Map.empty"
  by (auto dest: ahm_invarDne)

lemmas ahm_lookup_correct = ahm_lookup_def

lemma ahm_empty_correct:
  "ahm_\<alpha> ahm_empty = Map.empty"
  "ahm_invar ahm_empty"
  apply (rule ext)
  apply (unfold ahm_empty_def)
  apply (auto simp add: ahm_\<alpha>_def intro: ahm_invarI split: option.split)
  done

lemma ahm_update_correct:
  "ahm_\<alpha> (ahm_update k v m) = ahm_\<alpha> m (k \<mapsto> v)"
  "ahm_invar m \<Longrightarrow> ahm_invar (ahm_update k v m)"
  apply (rule ext)
  apply (unfold ahm_update_def)
  apply (auto simp add: ahm_\<alpha>_def split: option.split)
  apply (rule ahm_invarI)
  apply (auto dest: ahm_invarD ahm_invarDne split: split_if_asm)
  apply (rule ahm_invarI)
  apply (auto dest: ahm_invarD split: split_if_asm)
  apply (drule (1) ahm_invarD)
  apply auto
  done

lemma fun_upd_apply_ne: "x\<noteq>y \<Longrightarrow> (f(x:=v)) y = f y"
  by simp

lemma cancel_one_empty_simp: "m |` (-{k}) = Map.empty \<longleftrightarrow> dom m \<subseteq> {k}"
proof
  assume "m |` (- {k}) = Map.empty"
  hence "{} = dom (m |` (-{k}))" by auto
  also have "\<dots> = dom m - {k}" by auto
  finally show "dom m \<subseteq> {k}" by blast
next
  assume "dom m \<subseteq> {k}"
  hence "dom m - {k} = {}" by auto
  hence "dom (m |` (-{k})) = {}" by auto
  thus "m |` (-{k}) = Map.empty" by (simp only: dom_empty_simp)
qed

lemma ahm_delete_correct:
  "ahm_\<alpha> (ahm_delete k m) = (ahm_\<alpha> m) |` (-{k})"
  "ahm_invar m \<Longrightarrow> ahm_invar (ahm_delete k m)"
  apply (rule ext)
  apply (unfold ahm_delete_def)
  apply (auto simp add: ahm_\<alpha>_def Let_def Map.restrict_map_def
              split: option.split)[1]
  apply (drule_tac x=x in fun_cong)
  apply (auto)[1]
  apply (rule ahm_invarI)
  apply (auto split: split_if_asm option.split_asm dest: ahm_invarD)
  apply (drule (1) ahm_invarD)
  apply (auto simp add: restrict_map_def split: split_if_asm option.split_asm)
  done

lemma ahm_isEmpty_correct: "ahm_invar m \<Longrightarrow> ahm_isEmpty m \<longleftrightarrow> ahm_\<alpha> m = Map.empty"
proof
  assume "ahm_invar m" "ahm_isEmpty m"
  thus "ahm_\<alpha> m = Map.empty"
    by (auto simp add: ahm_isEmpty_def ahm_\<alpha>_def intro: ext)
next
  assume I: "ahm_invar m"
    and E: "ahm_\<alpha> m = Map.empty"

  show "ahm_isEmpty m"
  proof (rule ccontr)
    assume "\<not>ahm_isEmpty m"
    then obtain hc bm where MHC: "m hc = Some bm"
      by (unfold ahm_isEmpty_def)
         (blast elim: nempty_dom dest: domD)
    from ahm_invarDne[OF I, OF MHC] obtain k v where
      BMK: "bm k = Some v"
      by (blast elim: nempty_dom dest: domD)
    from ahm_invarD[OF I, OF MHC] BMK have [simp]: "hashcode k = hc"
      by auto
    hence "ahm_\<alpha> m k = Some v"
      by (simp add: ahm_\<alpha>_def MHC BMK)
    with E show False by simp
  qed
qed

lemmas ahm_correct = ahm_empty_correct ahm_lookup_correct ahm_update_correct
                     ahm_delete_correct ahm_isEmpty_correct

  -- "Bucket entries correspond to map entries"

  -- "Map entries correspond to bucket entries"
lemma ahm_e_is_be: "\<lbrakk>
  ahm_\<alpha> m k = Some v;
  !!bm. \<lbrakk>m (hashcode k) = Some bm; bm k = Some v \<rbrakk> \<Longrightarrow> P
  \<rbrakk> \<Longrightarrow> P"
  by (unfold ahm_\<alpha>_def)
     (auto split: option.split_asm)

subsection {* Concrete Hashmap *}
text {*
  In this section, we define the concrete hashmap that is made from the
  hashcode map and the bucket map.

  We then show the correctness of the operations w.r.t. the abstract hashmap, and
  thus, indirectly, w.r.t. the corresponding map.
*}

type_synonym
  ('k,'v) hm_impl = "(hashcode, ('k,'v) lm) rm"

subsubsection "Operations"

  -- "Auxiliary function: Apply function to value of an entry"
definition rm_map_entry
  :: "hashcode \<Rightarrow> ('v option \<Rightarrow> 'v option) \<Rightarrow> (hashcode, 'v) rm \<Rightarrow> (hashcode,'v) rm"
  where
  "rm_map_entry k f m ==
      case rm.lookup k m of
        None \<Rightarrow> (
          case f None of
            None \<Rightarrow> m |
            Some v \<Rightarrow> rm.update k v m
        ) |
        Some v \<Rightarrow> (
          case f (Some v) of
            None \<Rightarrow> rm.delete k m |
            Some v' \<Rightarrow> rm.update k v' m
        )
    "

  -- "Empty hashmap"
definition empty :: "unit \<Rightarrow> ('k :: hashable, 'v) hm_impl" where "empty == rm.empty"

  -- "Update/insert entry"
definition update :: "'k::hashable \<Rightarrow> 'v \<Rightarrow> ('k,'v) hm_impl \<Rightarrow> ('k,'v) hm_impl"
  where
  "update k v m ==
   let hc = hashcode k in
     case rm.lookup hc m of
       None \<Rightarrow> rm.update hc (lm.update k v (lm.empty ())) m |
       Some bm \<Rightarrow> rm.update hc (lm.update k v bm) m"

  -- "Lookup value by key"
definition lookup :: "'k::hashable \<Rightarrow> ('k,'v) hm_impl \<Rightarrow> 'v option" where
  "lookup k m ==
   case rm.lookup (hashcode k) m of
     None \<Rightarrow> None |
     Some lm \<Rightarrow> lm.lookup k lm"

  -- "Delete entry by key"
definition delete :: "'k::hashable \<Rightarrow> ('k,'v) hm_impl \<Rightarrow> ('k,'v) hm_impl" where
  "delete k m ==
   rm_map_entry (hashcode k)
     (\<lambda>v. case v of
       None \<Rightarrow> None |
       Some lm \<Rightarrow> (
         let lm' = lm.delete k lm
         in  if lm.isEmpty lm' then None else Some lm'
       )
     ) m"

  -- "Emptiness check"
definition "isEmpty == rm.isEmpty"

  -- "Interruptible iterator"
definition "iteratei m c f \<sigma>0 ==
  rm.iteratei m c (\<lambda>(hc, lm) \<sigma>.
    lm.iteratei lm c f \<sigma>
  ) \<sigma>0"

lemma iteratei_alt_def :
  "iteratei m = set_iterator_image snd (
     set_iterator_product (rm.iteratei m) (\<lambda>hclm. lm.iteratei (snd hclm)))"
proof -
  have aux: "\<And>c f. (\<lambda>(hc, lm). lm.iteratei lm c f) = (\<lambda>m. lm.iteratei (snd m) c f)"
    by auto
  show ?thesis
    unfolding set_iterator_product_def set_iterator_image_alt_def
      iteratei_def[abs_def] aux
    by (simp add: split_beta)
qed

subsubsection "Correctness w.r.t. Abstract HashMap"
text {*
  The following lemmas establish the correctness of the operations w.r.t. the
  abstract hashmap.

  They have the naming scheme op\_correct', where op is the name of the
  operation.
*}

  -- "Abstract concrete hashmap to abstract hashmap"
definition hm_\<alpha>' where "hm_\<alpha>' m == \<lambda>hc. case rm.\<alpha> m hc of
  None \<Rightarrow> None |
  Some lm \<Rightarrow> Some (lm.\<alpha> lm)"

  -- "Invariant for concrete hashmap:
    The hashcode-map and bucket-maps satisfy their invariants and
    the invariant of the corresponding abstract hashmap is satisfied.
  "

definition "invar m == ahm_invar (hm_\<alpha>' m)"

lemma rm_map_entry_correct:
  "rm.\<alpha> (rm_map_entry k f m) = (rm.\<alpha> m)(k := f (rm.\<alpha> m k))"
  apply (auto
    simp add: rm_map_entry_def rm.delete_correct rm.lookup_correct rm.update_correct
    split: option.split)
  apply (auto simp add: Map.restrict_map_def fun_upd_def intro: ext)
  done

lemma empty_correct':
  "hm_\<alpha>' (empty ()) = ahm_empty"
  "invar (empty ())"
  by (simp_all add: hm_\<alpha>'_def empty_def ahm_empty_def rm.correct invar_def ahm_invar_def)

lemma lookup_correct':
  "invar m \<Longrightarrow> lookup k m = ahm_lookup k (hm_\<alpha>' m)"
  apply (unfold lookup_def invar_def)
  apply (auto split: option.split
              simp add: ahm_lookup_def ahm_\<alpha>_def hm_\<alpha>'_def
                        rm.correct lm.correct)
  done

lemma update_correct':
  "invar m \<Longrightarrow> hm_\<alpha>' (update k v m) = ahm_update k v (hm_\<alpha>' m)"
  "invar m \<Longrightarrow> invar (update k v m)"
proof -
  assume "invar m"
  thus "hm_\<alpha>' (update k v m) = ahm_update k v (hm_\<alpha>' m)"
    apply (unfold invar_def)
    apply (rule ext)
    apply (auto simp add: update_def ahm_update_def hm_\<alpha>'_def Let_def
                          rm.correct lm.correct
                split: option.split)
    done
  thus "invar m \<Longrightarrow> invar (update k v m)"
    by (simp add: invar_def ahm_update_correct)
qed

lemma delete_correct':
  "invar m \<Longrightarrow> hm_\<alpha>' (delete k m) = ahm_delete k (hm_\<alpha>' m)"
  "invar m \<Longrightarrow> invar (delete k m)"
proof -
  assume "invar m"
  thus "hm_\<alpha>' (delete k m) = ahm_delete k (hm_\<alpha>' m)"
    apply (unfold invar_def)
    apply (rule ext)
    apply (auto simp add: delete_def ahm_delete_def hm_\<alpha>'_def
                          rm_map_entry_correct
                          rm.correct lm.correct Let_def
                split: option.split option.split_asm)
    done
  thus "invar (delete k m)" using `invar m`
    by (simp add: ahm_delete_correct invar_def)
qed

lemma isEmpty_correct':
  "invar hm \<Longrightarrow> isEmpty hm \<longleftrightarrow> ahm_\<alpha> (hm_\<alpha>' hm) = Map.empty"
apply (simp add: isEmpty_def rm.isEmpty_correct invar_def
                 ahm_isEmpty_correct[unfolded ahm_isEmpty_def, symmetric])
by (auto simp add: hm_\<alpha>'_def ahm_\<alpha>_def fun_eq_iff split: option.split_asm)

(*
lemma sel_correct':
  assumes "invar hm"
  shows "\<lbrakk> sel hm f = Some r; \<And>u v. \<lbrakk> ahm_\<alpha> (hm_\<alpha>' hm) u = Some v; f (u, v) = Some r \<rbrakk> \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
  and "\<lbrakk> sel hm f = None; ahm_\<alpha> (hm_\<alpha>' hm) u = Some v \<rbrakk> \<Longrightarrow> f (u, v) = None"
proof -
  assume sel: "sel hm f = Some r"
    and P: "\<And>u v. \<lbrakk>ahm_\<alpha> (hm_\<alpha>' hm) u = Some v; f (u, v) = Some r\<rbrakk> \<Longrightarrow> P"
  from `invar hm` have IA: "ahm_invar (hm_\<alpha>' hm)" by(simp add: invar_def)
  from TrueI sel obtain hc lm where "rm_\<alpha> hm hc = Some lm"
    and "lm_sel lm f = Some r"
    unfolding sel_def by (rule rm.sel_someE) simp
  from TrueI `lm_sel lm f = Some r`
  obtain k v where "lm_\<alpha> lm k = Some v" "f (k, v) = Some r"
    by(rule lm.sel_someE)
  from `rm_\<alpha> hm hc = Some lm` have "hm_\<alpha>' hm hc = Some (lm_\<alpha> lm)"
    by(simp add: hm_\<alpha>'_def)
  with IA have "ahm_\<alpha> (hm_\<alpha>' hm) k = Some v" using `lm_\<alpha> lm k = Some v`
    by(rule ahm_be_is_e)
  thus P using `f (k, v) = Some r` by(rule P)
next
  assume sel: "sel hm f = None"
    and \<alpha>: "ahm_\<alpha> (hm_\<alpha>' hm) u = Some v"
  from `invar hm` have IA: "ahm_invar (hm_\<alpha>' hm)" by(simp add: invar_def)
  from \<alpha> obtain lm where \<alpha>_u: "hm_\<alpha>' hm (hashcode u) = Some lm"
    and "lm u = Some v" by (rule ahm_e_is_be)
  from \<alpha>_u obtain lmc where "rm_\<alpha> hm (hashcode u) = Some lmc" "lm = lm_\<alpha> lmc"
    by(auto simp add: hm_\<alpha>'_def split: option.split_asm)
  with `lm u = Some v` have "lm_\<alpha> lmc u = Some v" by simp
  from sel rm.sel_noneD [OF TrueI _ `rm_\<alpha> hm (hashcode u) = Some lmc`,
         of "(\<lambda>(hc, lm). lm_sel lm f)"]
  have "lm_sel lmc f = None" unfolding sel_def by simp
  with TrueI show "f (u, v) = None" using `lm_\<alpha> lmc u = Some v` by(rule lm.sel_noneD)
qed
*)

lemma iteratei_correct':
  assumes invar: "invar hm"
  shows "map_iterator (iteratei hm) (ahm_\<alpha> (hm_\<alpha>' hm))"
proof -
  from rm.iteratei_correct
  have it_rm: "map_iterator (rm.iteratei hm) (rm.\<alpha> hm)" by simp

  from lm.iteratei_correct
  have it_lm: "\<And>lm. map_iterator (lm.iteratei lm) (lm.\<alpha> lm)" by simp

  from set_iterator_product_correct
    [OF it_rm, of "\<lambda>hclm. lm.iteratei (snd hclm)"
     "\<lambda>hclm. map_to_set (lm.\<alpha> (snd hclm))", OF it_lm]
  have it_prod: "set_iterator
         (set_iterator_product (rm.iteratei hm) (\<lambda>hclm. lm.iteratei (snd hclm)))
         (SIGMA hclm:map_to_set (rm.\<alpha> hm). map_to_set (lm.\<alpha> (snd hclm)))"
    by simp

  show ?thesis unfolding iteratei_alt_def
  proof (rule set_iterator_image_correct[OF it_prod])
    from invar
    show "inj_on snd
       (SIGMA hclm:map_to_set (rm.\<alpha> hm). map_to_set (lm.\<alpha> (snd hclm)))"
      apply (simp add: inj_on_def invar_def ahm_invar_def hm_\<alpha>'_def Ball_def
                       map_to_set_def split: option.splits)
      apply (metis domI option.inject)
    done
  next
    from invar
    show "map_to_set (ahm_\<alpha> (hm_\<alpha>' hm)) =
          snd ` (SIGMA hclm:map_to_set (rm.\<alpha> hm). map_to_set (lm.\<alpha> (snd hclm)))"
      apply (simp add: inj_on_def invar_def ahm_invar_def hm_\<alpha>'_def Ball_def
                       map_to_set_def set_eq_iff image_iff split: option.splits)
      apply (auto simp add: dom_def ahm_\<alpha>_def split: option.splits)
    done
  qed
qed

lemmas hm_correct' = empty_correct' lookup_correct' update_correct'
                     delete_correct' isEmpty_correct'
                     iteratei_correct'
lemmas hm_invars = empty_correct'(2) update_correct'(2)
                   delete_correct'(2)

hide_const (open) empty invar lookup update delete isEmpty iteratei

end


header {* Monad-Zero Class *}

theory Monad_Zero
imports Monad
begin

class zeroU = tycon +
  fixes zeroU :: "udom\<cdot>'a::tycon"

class functor_zero = zeroU + "functor" +
  assumes fmapU_zeroU [coerce_simp]:
    "fmapU\<cdot>f\<cdot>zeroU = zeroU"

class monad_zero = zeroU + monad +
  assumes bindU_zeroU:
    "bindU\<cdot>zeroU\<cdot>f = zeroU"

instance monad_zero \<subseteq> functor_zero
proof
  fix f show "fmapU\<cdot>f\<cdot>zeroU = (zeroU :: udom\<cdot>'a)"
    unfolding fmapU_eq_bindU
    by (rule bindU_zeroU)
qed

definition fzero :: "'a\<cdot>'f::functor_zero"
  where "fzero = coerce\<cdot>(zeroU :: udom\<cdot>'f)"

lemma fmap_fzero:
  "fmap\<cdot>f\<cdot>(fzero :: 'a\<cdot>'f::functor_zero) = (fzero :: 'b\<cdot>'f)"
unfolding fmap_def fzero_def
by (simp add: coerce_simp)

abbreviation mzero :: "'a\<cdot>'m::monad_zero"
  where "mzero \<equiv> fzero"

lemmas mzero_def = fzero_def [where 'f="'m::monad_zero"] for f
lemmas fmap_mzero = fmap_fzero [where 'f="'m::monad_zero"] for f

lemma bindU_eq_bind: "bindU = bind"
unfolding bind_def by simp

lemma bind_mzero:
  "bind\<cdot>(fzero :: 'a\<cdot>'m::monad_zero)\<cdot>k = (mzero :: 'b\<cdot>'m)"
unfolding bind_def mzero_def
by (simp add: coerce_simp bindU_zeroU)

end


(* Author: Dmitriy Traytel *)

section \<open>Derivatives of $\Pi$-Extended Regular Expressions\<close>
(*<*)
theory Pi_Derivatives
imports Pi_Regular_Exp
begin
(*>*)

locale embed = project \<Sigma> wf_atom project lookup
  for \<Sigma> :: "nat \<Rightarrow> 'a set"
  and wf_atom :: "nat \<Rightarrow> 'b :: linorder \<Rightarrow> bool"
  and project :: "'a \<Rightarrow> 'a"
  and lookup :: "'b \<Rightarrow> 'a \<Rightarrow> bool" +
fixes embed :: "'a \<Rightarrow> 'a list"
assumes embed: "\<And>a. a \<in> \<Sigma> n \<Longrightarrow> b \<in> set (embed a) = (b \<in> \<Sigma> (Suc n) \<and> project b = a)"
begin

subsection \<open>Syntactic Derivatives\<close>

primrec lderiv :: "'a \<Rightarrow> 'b rexp \<Rightarrow> 'b rexp" where
  "lderiv _ Zero = Zero"
| "lderiv _ Full = Full"
| "lderiv _ One = Zero"
| "lderiv a (Atom b) = (if lookup b a then One else Zero)"
| "lderiv a (Plus r s) = Plus (lderiv a r) (lderiv a s)"
| "lderiv a (Times r s) =
    (let r's = Times (lderiv a r) s
     in if final r then Plus r's (lderiv a s) else r's)"
| "lderiv a (Star r) = Times (lderiv a r) (Star r)"
| "lderiv a (Not r) = Not (lderiv a r)"
| "lderiv a (Inter r s) = Inter (lderiv a r) (lderiv a s)"
| "lderiv a (Pr r) = Pr (PLUS (map (\<lambda>a'. lderiv a' r) (embed a)))"

primrec lderivs where
  "lderivs [] r = r"
| "lderivs (w#ws) r = lderivs ws (lderiv w r)"

subsection \<open>Finiteness of ACI-Equivalent Derivatives\<close>

lemma toplevel_summands_lderiv:
  "toplevel_summands (lderiv as r) = (\<Union>s\<in>toplevel_summands r. toplevel_summands (lderiv as s))"
  by (induct r) (auto simp: Let_def)

lemma lderivs_Zero[simp]: "lderivs xs Zero = Zero"
  by (induct xs) auto

lemma lderivs_Full[simp]: "lderivs xs Full = Full"
  by (induct xs) auto

lemma lderivs_One: "lderivs xs One \<in> {Zero, One}"
  by (induct xs) auto

lemma lderivs_Atom: "lderivs xs (Atom as) \<in> {Zero, One, Atom as}"
proof (induct xs)
  case (Cons x xs) thus ?case by (auto intro: insertE[OF lderivs_One])
qed simp

lemma lderivs_Plus: "lderivs xs (Plus r s) = Plus (lderivs xs r) (lderivs xs s)"
  by (induct xs arbitrary: r s) auto

lemma lderivs_PLUS: "lderivs xs (PLUS ys) = PLUS (map (lderivs xs) ys)"
  by (induct ys rule: list_singleton_induct) (auto simp: lderivs_Plus)

lemma toplevel_summands_lderivs_Times: "toplevel_summands (lderivs xs (Times r s)) \<subseteq>
  {Times (lderivs xs r) s} \<union>
  {r'. \<exists>ys zs. r' \<in> toplevel_summands (lderivs ys s) \<and> ys \<noteq> [] \<and> zs @ ys = xs}"
proof (induct xs arbitrary: r s)
  case (Cons x xs)
  thus ?case by (auto simp: Let_def lderivs_Plus) (fastforce intro: exI[of _ "x#xs"])+
qed simp

lemma toplevel_summands_lderivs_Star_nonempty:
  "xs \<noteq> [] \<Longrightarrow> toplevel_summands (lderivs xs (Star r)) \<subseteq>
    {Times (lderivs ys r) (Star r) | ys. \<exists>zs. ys \<noteq> [] \<and> zs @ ys = xs}"
proof (induct xs rule: length_induct)
  case (1 xs)
  then obtain y ys where "xs = y # ys" by (cases xs) auto
  thus ?case using spec[OF 1(1)]
    by (auto dest!: subsetD[OF toplevel_summands_lderivs_Times] intro: exI[of _ "y#ys"])
       (auto elim!: impE dest!: meta_spec subsetD)
qed

lemma toplevel_summands_lderivs_Star:
  "toplevel_summands (lderivs xs (Star r)) \<subseteq>
    {Star r} \<union> {Times (lderivs ys r) (Star r) | ys. \<exists>zs. ys \<noteq> [] \<and> zs @ ys = xs}"
  by (cases "xs = []") (auto dest!: toplevel_summands_lderivs_Star_nonempty)

lemma ex_lderivs_Pr: "\<exists>s. lderivs ass (Pr r) = Pr s"
  by (induct ass arbitrary: r) auto

lemma toplevel_summands_PLUS:
 "xs \<noteq> [] \<Longrightarrow> toplevel_summands (PLUS (map f xs)) = (\<Union>r \<in> set xs. toplevel_summands (f r))"
  by (induct xs rule: list_singleton_induct) simp_all

lemma lderiv_toplevel_summands_Zero:
  "\<lbrakk>lderivs xs (Pr r) = Pr s; toplevel_summands r = {Zero}\<rbrakk> \<Longrightarrow> toplevel_summands s = {Zero}"
proof (induct xs arbitrary: r s)
  case (Cons y ys)
  from Cons.prems(1) have "toplevel_summands (PLUS (map (\<lambda>a. lderiv a r) (embed y))) = {Zero}"
  proof (cases "embed y = []")
    case False
    show ?thesis using Cons.prems(2) unfolding toplevel_summands_PLUS[OF False]
      by (subst toplevel_summands_lderiv) (simp add: False)
  qed simp
  with Cons show ?case by simp
qed simp

lemma toplevel_summands_lderivs_Pr:
  "\<lbrakk>xs \<noteq> []; lderivs xs (Pr r) = Pr s\<rbrakk> \<Longrightarrow>
    toplevel_summands s \<subseteq> {Zero} \<or> toplevel_summands s \<subseteq> (\<Union>xs. toplevel_summands (lderivs xs r))"
proof (induct xs arbitrary: r s)
  case (Cons y ys) note * = this
  show ?case
  proof (cases "embed y = []")
    case True with Cons show ?thesis by (cases "ys = []") (auto dest: lderiv_toplevel_summands_Zero)
  next
    case False
    show ?thesis
    proof (cases ys)
      case Nil with * show ?thesis
        by (auto simp: toplevel_summands_PLUS[OF False]) (metis lderivs.simps)
    next
      case (Cons z zs)
      have "toplevel_summands s \<subseteq> {Zero} \<or> toplevel_summands s \<subseteq>
       (\<Union>xs. toplevel_summands (lderivs xs (PLUS (map (\<lambda>a. lderiv a r) (embed y)))))" (is "_ \<or> ?B")
        by (rule *(1)) (auto simp: Cons *(3)[symmetric])
      thus ?thesis
      proof
        assume ?B
        also have "\<dots> \<subseteq> (\<Union>xs. toplevel_summands (lderivs xs r))"
          by (auto simp: lderivs_PLUS toplevel_summands_PLUS[OF False]) (metis lderivs.simps(2))
        finally show ?thesis ..
      qed blast
    qed
  qed
qed simp

lemma lderivs_Pr:
  "{lderivs xs (Pr r) | xs. True} \<subseteq>
    {Pr s | s. toplevel_summands s \<subseteq> {Zero} \<or>
               toplevel_summands s \<subseteq> (\<Union>xs. toplevel_summands (lderivs xs r))}"
  (is "?L \<subseteq>?R")
proof (rule subsetI)
  fix s assume "s \<in> ?L"
  then obtain xs where "s = lderivs xs (Pr r)" by blast
  moreover obtain t where "lderivs xs (Pr r) = Pr t" using ex_lderivs_Pr by blast
  ultimately show "s \<in> ?R"
    by (cases "xs = []") (auto dest!: toplevel_summands_lderivs_Pr elim!: allE[of _ "[]"])
qed

lemma ACI_norm_toplevel_summands_Zero: "toplevel_summands r \<subseteq> {Zero} \<Longrightarrow> \<guillemotleft>r\<guillemotright> = Zero"
  by (subst ACI_norm_flatten) (auto dest: subset_singletonD)

lemma ACI_norm_lderivs_Pr:
  "ACI_norm ` {lderivs xs (Pr r) | xs. True} \<subseteq>
    {Pr Zero} \<union> {Pr \<guillemotleft>s\<guillemotright> | s. toplevel_summands s \<subseteq> (\<Union>xs. toplevel_summands \<guillemotleft>lderivs xs r\<guillemotright>)}"
proof (intro subset_trans[OF image_mono[OF lderivs_Pr]] subsetI,
       elim imageE CollectE exE conjE disjE)
  fix x x' s :: "'b rexp"
  assume *: "x = \<guillemotleft>x'\<guillemotright>" "x' = Pr s" and "toplevel_summands s \<subseteq> {Zero}"
  hence "\<guillemotleft>Pr s\<guillemotright> = Pr Zero" using ACI_norm_toplevel_summands_Zero by simp
  thus "x \<in> {Pr Zero} \<union>
    {Pr \<guillemotleft>s\<guillemotright> |s. toplevel_summands s \<subseteq> (\<Union>xs. toplevel_summands \<guillemotleft>lderivs xs r\<guillemotright>)}"
    unfolding * by blast
next
  fix x x' s :: "'b rexp"
  assume *: "x = \<guillemotleft>x'\<guillemotright>" "x' = Pr s" and "toplevel_summands s \<subseteq> (\<Union>xs. toplevel_summands (lderivs xs r))"
  hence "toplevel_summands \<guillemotleft>s\<guillemotright> \<subseteq> (\<Union>xs. toplevel_summands \<guillemotleft>lderivs xs r\<guillemotright>)"
    by (fastforce simp: toplevel_summands_ACI_norm)
  moreover have "x = Pr \<guillemotleft>\<guillemotleft>s\<guillemotright>\<guillemotright>" unfolding * ACI_norm_idem ACI_norm.simps(10) ..
  ultimately show "x \<in> {Pr Zero} \<union>
    {Pr \<guillemotleft>s\<guillemotright> |s. toplevel_summands s \<subseteq> (\<Union>xs. toplevel_summands \<guillemotleft>lderivs xs r\<guillemotright>)}"
    by blast
qed

lemma finite_ACI_norm_toplevel_summands: "finite B \<Longrightarrow> finite {f \<guillemotleft>s\<guillemotright> |s. toplevel_summands s \<subseteq> B}"
  apply (elim finite_surj [OF iffD2 [OF finite_Pow_iff], of _ _ "f o flatten PLUS o image ACI_norm"])
  apply (subst ACI_norm_flatten)
  apply auto
  done

lemma lderivs_Not: "lderivs xs (Not r) = Not (lderivs xs r)"
  by (induct xs arbitrary: r) auto

lemma lderivs_Inter: "lderivs xs (Inter r s) = Inter (lderivs xs r) (lderivs xs s)"
  by (induct xs arbitrary: r s) auto

theorem finite_lderivs: "finite {\<guillemotleft>lderivs xs r\<guillemotright> | xs . True}"
proof (induct r)
  case Zero show ?case by simp
next
  case Full show ?case by simp
next
  case One show ?case
   by (rule finite_surj[of "{Zero, One}"]) (blast intro: insertE[OF lderivs_One])+
next
  case (Atom as) show ?case
    by (rule finite_surj[of "{Zero, One, Atom as}"]) (blast intro: insertE[OF lderivs_Atom])+
next
  case (Plus r s)
  show ?case by (auto simp: lderivs_Plus intro!: finite_surj[OF finite_cartesian_product[OF Plus]])
next
  case (Times r s)
  hence "finite (\<Union> (toplevel_summands ` {\<guillemotleft>lderivs xs s\<guillemotright> | xs . True}))" by auto
  moreover have "{\<guillemotleft>r'\<guillemotright> |r'. \<exists>ys. r' \<in> toplevel_summands (lderivs ys s)} =
    {r'. \<exists>ys. r' \<in> toplevel_summands \<guillemotleft>lderivs ys s\<guillemotright>}"
    unfolding toplevel_summands_ACI_norm by auto
  ultimately have fin: "finite {\<guillemotleft>r'\<guillemotright> |r'. \<exists>ys. r' \<in> toplevel_summands (lderivs ys s)}"
    by (fastforce intro: finite_subset[of _ "\<Union> (toplevel_summands ` {\<guillemotleft>lderivs xs s\<guillemotright> | xs . True})"])
  let ?X = "\<lambda>xs. {Times (lderivs ys r) s | ys. True} \<union> {r'. r' \<in> (\<Union>ys. toplevel_summands (lderivs ys s))}"
  show ?case
  proof (simp only: ACI_norm_flatten,
      rule finite_surj[of "{X. \<exists>xs. X \<subseteq> ACI_norm ` ?X xs}" _ "flatten PLUS"])
    show "finite {X. \<exists>xs. X \<subseteq> ACI_norm ` ?X xs}"
      using fin by (fastforce simp: image_Un elim: finite_subset[rotated] intro: finite_surj[OF Times(1), of _ "\<lambda>r. Times r \<guillemotleft>s\<guillemotright>"])
  qed (fastforce dest!: subsetD[OF toplevel_summands_lderivs_Times] intro!: imageI)
next
  case (Star r)
  let ?f = "\<lambda>f r'. Times r' (Star (f r))"
  let ?X = "{Star r} \<union> ?f id ` {r'. r' \<in> {lderivs ys r|ys. True}}"
  show ?case
  proof (simp only: ACI_norm_flatten,
      rule finite_surj[of "{X. X \<subseteq> ACI_norm ` ?X}" _ "flatten PLUS"])
    have *: "\<And>X. ACI_norm ` ?f (\<lambda>x. x) ` X = ?f ACI_norm ` ACI_norm ` X" by (auto simp: image_def)
    show "finite {X. X \<subseteq> ACI_norm ` ?X}"
      by (rule finite_Collect_subsets)
         (auto simp: * intro!: finite_imageI[of _ "?f ACI_norm"] intro: finite_subset[OF _ Star])
  qed (fastforce dest!: subsetD[OF toplevel_summands_lderivs_Star] intro!: imageI)
next
  case (Not r) thus ?case by (auto simp: lderivs_Not) (blast intro: finite_surj)
next
  case (Inter r s)
  show ?case by (auto simp: lderivs_Inter intro!: finite_surj[OF finite_cartesian_product[OF Inter]])
next
  case (Pr r)
  hence *: "finite (\<Union> (toplevel_summands ` {\<guillemotleft>lderivs xs r\<guillemotright> | xs . True}))" by auto
  have "finite (\<Union>xs. toplevel_summands \<guillemotleft>lderivs xs r\<guillemotright>)" by (rule finite_subset[OF _ *]) auto
  hence fin: "finite {Pr \<guillemotleft>s\<guillemotright> |s. toplevel_summands s \<subseteq> (\<Union>xs. toplevel_summands \<guillemotleft>lderivs xs r\<guillemotright>)}"
    by (intro finite_ACI_norm_toplevel_summands)
  have "{s. \<exists>xs. s = \<guillemotleft>lderivs xs (Pr r)\<guillemotright>} = {\<guillemotleft>s\<guillemotright>| s. \<exists>xs. s = lderivs xs (Pr r)}" by auto
  thus ?case using finite_subset[OF ACI_norm_lderivs_Pr, of r] fin unfolding image_Collect by auto
qed

subsection \<open>Wellformedness and language of derivatives\<close>

lemma wf_lderiv[simp]: "wf n r \<Longrightarrow> wf n (lderiv w r)"
  by (induct r arbitrary: n w) (auto simp add: Let_def)

lemma wf_lderivs[simp]: "wf n r \<Longrightarrow> wf n (lderivs ws r)"
  by (induct ws arbitrary: r) (auto intro: wf_lderiv)

lemma lQuot_map_project:
assumes "as \<in> \<Sigma> n" "A \<subseteq> lists (\<Sigma> (Suc n))"
shows "lQuot as (map project ` A) = map project ` (\<Union>a \<in> set (embed as). lQuot a A)" (is "?L = ?R")
proof (intro equalityI image_subsetI subsetI)
  fix xss assume "xss \<in> ?L"
  with assms obtain zss
    where zss: "zss \<in> A" "as # xss = map project zss"
    unfolding lQuot_def by fastforce
  hence "xss = map project (tl zss)" by auto
  with zss assms(2) show "xss \<in> ?R" using embed[OF project, of _ n] unfolding lQuot_def by fastforce
next
  fix xss assume "xss \<in> (\<Union>a \<in> set (embed as). lQuot a A)"
  with assms(1) show "map project xss \<in> lQuot as (map project ` A)" unfolding lQuot_def
    by (fastforce intro!: rev_image_eqI simp: embed)
qed

lemma lang_lderiv: "\<lbrakk>wf n r; w \<in> \<Sigma> n\<rbrakk> \<Longrightarrow> lang n (lderiv w r) = lQuot w (lang n r)"
proof (induct r arbitrary: n w)
  case (Pr r)
  hence *: "wf (Suc n) r" "\<And>w'. w' \<in> set (embed w) \<Longrightarrow>  w' \<in> \<Sigma> (Suc n)" by (auto simp: embed)
  from Pr(1)[OF *] lQuot_map_project[OF Pr(3) lang_subset_lists[OF *(1)]] show ?case
    by (auto simp: wf_lderiv[OF *(1)])
qed (auto simp: Let_def lang_final[symmetric])

lemma lang_lderivs: "\<lbrakk>wf n r; wf_word n ws\<rbrakk> \<Longrightarrow> lang n (lderivs ws r) = lQuots ws (lang n r)"
  by (induct ws arbitrary: r) (auto simp: lang_lderiv)

corollary lderivs_final:
assumes "wf n r" "wf_word n ws"
shows "final (lderivs ws r) \<longleftrightarrow> ws \<in> lang n r"
  using lang_lderivs[OF assms] lang_final[of "lderivs ws r" n] by auto

abbreviation "lderivs_set n r s \<equiv> {(\<guillemotleft>lderivs w r\<guillemotright>, \<guillemotleft>lderivs w s\<guillemotright>) | w. wf_word n w}"

subsection \<open>Deriving preserves ACI-equivalence\<close>

lemma ACI_norm_PLUS:
  "list_all2 (\<lambda>r s. \<guillemotleft>r\<guillemotright> = \<guillemotleft>s\<guillemotright>) xs ys \<Longrightarrow> \<guillemotleft>PLUS xs\<guillemotright> = \<guillemotleft>PLUS ys\<guillemotright>"
proof (induct rule: list_all2_induct)
  case (Cons x xs y ys)
  hence "length xs = length ys" by (elim list_all2_lengthD)
  thus ?case using Cons by (induct xs ys rule: list_induct2) auto
qed simp

lemma toplevel_summands_ACI_norm_lderiv:
  "(\<Union>a\<in>toplevel_summands r. toplevel_summands \<guillemotleft>lderiv as \<guillemotleft>a\<guillemotright>\<guillemotright>) = toplevel_summands \<guillemotleft>lderiv as \<guillemotleft>r\<guillemotright>\<guillemotright>"
proof (induct r)
  case (Plus r1 r2) thus ?case
   unfolding toplevel_summands.simps toplevel_summands_ACI_norm
     toplevel_summands_lderiv[of as "\<guillemotleft>Plus r1 r2\<guillemotright>"] image_Un Union_Un_distrib
   by (simp add: image_UN)
qed (auto simp: Let_def)

theorem ACI_norm_lderiv:
  "\<guillemotleft>lderiv as \<guillemotleft>r\<guillemotright>\<guillemotright> = \<guillemotleft>lderiv as r\<guillemotright>"
proof (induct r arbitrary: as)
  case (Plus r1 r2) thus ?case
   unfolding lderiv.simps ACI_norm_flatten[of "lderiv as \<guillemotleft>Plus r1 r2\<guillemotright>"]
     toplevel_summands_lderiv[of as "\<guillemotleft>Plus r1 r2\<guillemotright>"] image_Un image_UN
   by (auto simp: toplevel_summands_ACI_norm toplevel_summands_flatten_ACI_norm_image_Union)
     (auto simp: toplevel_summands_ACI_norm[symmetric] toplevel_summands_ACI_norm_lderiv)
next
  case (Pr r)
  hence "list_all2 (\<lambda>r s. \<guillemotleft>r\<guillemotright> = \<guillemotleft>s\<guillemotright>)
    (map (\<lambda>a. lderiv a \<guillemotleft>r\<guillemotright>) (embed as)) (map (\<lambda>a. lderiv a r) (embed as))"
    unfolding list_all2_map1 list_all2_map2 by (intro list_all2_refl)
  thus ?case unfolding lderiv.simps ACI_norm.simps by (blast intro: ACI_norm_PLUS)
qed (simp_all add: Let_def)

corollary lderiv_preserves: "\<guillemotleft>r\<guillemotright> = \<guillemotleft>s\<guillemotright> \<Longrightarrow> \<guillemotleft>lderiv as r\<guillemotright> = \<guillemotleft>lderiv as s\<guillemotright>"
  by (rule box_equals[OF _ ACI_norm_lderiv ACI_norm_lderiv]) (erule arg_cong)

lemma lderivs_snoc[simp]: "lderivs (ws @ [w]) r = (lderiv w (lderivs ws r))"
  by (induct ws arbitrary: r) auto

theorem ACI_norm_lderivs:
  "\<guillemotleft>lderivs ws \<guillemotleft>r\<guillemotright>\<guillemotright> = \<guillemotleft>lderivs ws r\<guillemotright>"
proof (induct ws arbitrary: r rule: rev_induct)
  case (snoc w ws) thus ?case
    using ACI_norm_lderiv[of w "lderivs ws r"] ACI_norm_lderiv[of w "lderivs ws \<guillemotleft>r\<guillemotright>"] by auto
qed simp

lemma lderivs_alt: "\<guillemotleft>lderivs w r\<guillemotright> = fold (\<lambda>a r. \<guillemotleft>lderiv a r\<guillemotright>) w \<guillemotleft>r\<guillemotright>"
  by (induct w arbitrary: r) (auto simp: ACI_norm_lderiv)

lemma finite_fold_lderiv: "finite {fold (\<lambda>a r. \<guillemotleft>lderiv a r\<guillemotright>) w \<guillemotleft>s\<guillemotright> |w. True}"
  using finite_lderivs unfolding lderivs_alt .

end

(*<*)
end
(*>*)