(*  Title:      HOL/Auth/Message.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1996  University of Cambridge

Datatypes of agents and messages;
Inductive relations "parts", "analz" and "synth"
*)

section\<open>Theory of Agents and Messages for Security Protocols against Dolev-Yao\<close>

theory Message
imports Main
begin

(*Needed occasionally with spy_analz_tac, e.g. in analz_insert_Key_newK*)
lemma [simp] : "A \<union> (B \<union> A) = B \<union> A"
by blast

type_synonym
  key = nat

consts
  all_symmetric :: bool        \<comment> \<open>true if all keys are symmetric\<close>
  invKey        :: "key=>key"  \<comment> \<open>inverse of a symmetric key\<close>

specification (invKey)
  invKey [simp]: "invKey (invKey K) = K"
  invKey_symmetric: "all_symmetric --> invKey = id"
    by (rule exI [of _ id], auto)

text\<open>The inverse of a symmetric key is itself; that of a public key
      is the private key and vice versa\<close>

definition symKeys :: "key set" where
  "symKeys == {K. invKey K = K}"

datatype  \<comment> \<open>We allow any number of friendly agents\<close>
  agent = Server | Friend nat | Spy

datatype
     msg = Agent  agent     \<comment> \<open>Agent names\<close>
         | Number nat       \<comment> \<open>Ordinary integers, timestamps, ...\<close>
         | Nonce  nat       \<comment> \<open>Unguessable nonces\<close>
         | Key    key       \<comment> \<open>Crypto keys\<close>
         | Hash   msg       \<comment> \<open>Hashing\<close>
         | MPair  msg msg   \<comment> \<open>Compound messages\<close>
         | Crypt  key msg   \<comment> \<open>Encryption, public- or shared-key\<close>

text\<open>Concrete syntax: messages appear as \<open>\<lbrace>A,B,NA\<rbrace>\<close>, etc...\<close>
syntax
  "_MTuple" :: "['a, args] => 'a * 'b"  ("(2\<lbrace>_,/ _\<rbrace>)")
translations
  "\<lbrace>x, y, z\<rbrace>"   == "\<lbrace>x, \<lbrace>y, z\<rbrace>\<rbrace>"
  "\<lbrace>x, y\<rbrace>"      == "CONST MPair x y"

definition HPair :: "[msg,msg] => msg" ("(4Hash[_] /_)" [0, 1000]) where
    \<comment> \<open>Message Y paired with a MAC computed with the help of X\<close>
    "Hash[X] Y == \<lbrace> Hash\<lbrace>X,Y\<rbrace>, Y\<rbrace>"

definition keysFor :: "msg set => key set" where
    \<comment> \<open>Keys useful to decrypt elements of a message set\<close>
  "keysFor H == invKey ` {K. \<exists>X. Crypt K X \<in> H}"

subsection\<open>Inductive definition of all parts of a message\<close>

inductive_set
  parts :: "msg set => msg set"
  for H :: "msg set"
  where
    Inj [intro]:               "X \<in> H ==> X \<in> parts H"
  | Fst:         "\<lbrace>X,Y\<rbrace>   \<in> parts H ==> X \<in> parts H"
  | Snd:         "\<lbrace>X,Y\<rbrace>   \<in> parts H ==> Y \<in> parts H"
  | Body:        "Crypt K X \<in> parts H ==> X \<in> parts H"

text\<open>Monotonicity\<close>
lemma parts_mono: "G \<subseteq> H ==> parts(G) \<subseteq> parts(H)"
apply auto
apply (erule parts.induct)
apply (blast dest: parts.Fst parts.Snd parts.Body)+
done

text\<open>Equations hold because constructors are injective.\<close>
lemma Friend_image_eq [simp]: "(Friend x \<in> Friend`A) = (x:A)"
by auto

lemma Key_image_eq [simp]: "(Key x \<in> Key`A) = (x\<in>A)"
by auto

lemma Nonce_Key_image_eq [simp]: "(Nonce x \<notin> Key`A)"
by auto

subsection\<open>Inverse of keys\<close>

lemma invKey_eq [simp]: "(invKey K = invKey K') = (K=K')"
by (metis invKey)

subsection\<open>keysFor operator\<close>

lemma keysFor_empty [simp]: "keysFor {} = {}"
by (unfold keysFor_def, blast)

lemma keysFor_Un [simp]: "keysFor (H \<union> H') = keysFor H \<union> keysFor H'"
by (unfold keysFor_def, blast)

lemma keysFor_UN [simp]: "keysFor (\<Union>i\<in>A. H i) = (\<Union>i\<in>A. keysFor (H i))"
by (unfold keysFor_def, blast)

text\<open>Monotonicity\<close>
lemma keysFor_mono: "G \<subseteq> H ==> keysFor(G) \<subseteq> keysFor(H)"
by (unfold keysFor_def, blast)

lemma keysFor_insert_Agent [simp]: "keysFor (insert (Agent A) H) = keysFor H"
by (unfold keysFor_def, auto)

lemma keysFor_insert_Nonce [simp]: "keysFor (insert (Nonce N) H) = keysFor H"
by (unfold keysFor_def, auto)

lemma keysFor_insert_Number [simp]: "keysFor (insert (Number N) H) = keysFor H"
by (unfold keysFor_def, auto)

lemma keysFor_insert_Key [simp]: "keysFor (insert (Key K) H) = keysFor H"
by (unfold keysFor_def, auto)

lemma keysFor_insert_Hash [simp]: "keysFor (insert (Hash X) H) = keysFor H"
by (unfold keysFor_def, auto)

lemma keysFor_insert_MPair [simp]: "keysFor (insert \<lbrace>X,Y\<rbrace> H) = keysFor H"
by (unfold keysFor_def, auto)

lemma keysFor_insert_Crypt [simp]:
    "keysFor (insert (Crypt K X) H) = insert (invKey K) (keysFor H)"
by (unfold keysFor_def, auto)

lemma keysFor_image_Key [simp]: "keysFor (Key`E) = {}"
by (unfold keysFor_def, auto)

lemma Crypt_imp_invKey_keysFor: "Crypt K X \<in> H ==> invKey K \<in> keysFor H"
by (unfold keysFor_def, blast)

subsection\<open>Inductive relation "parts"\<close>

lemma MPair_parts:
     "[| \<lbrace>X,Y\<rbrace> \<in> parts H;
         [| X \<in> parts H; Y \<in> parts H |] ==> P |] ==> P"
by (blast dest: parts.Fst parts.Snd)

declare MPair_parts [elim!]  parts.Body [dest!]
text\<open>NB These two rules are UNSAFE in the formal sense, as they discard the
     compound message.  They work well on THIS FILE.
  \<open>MPair_parts\<close> is left as SAFE because it speeds up proofs.
  The Crypt rule is normally kept UNSAFE to avoid breaking up certificates.\<close>

lemma parts_increasing: "H \<subseteq> parts(H)"
by blast

lemmas parts_insertI = subset_insertI [THEN parts_mono, THEN subsetD]

lemma parts_empty [simp]: "parts{} = {}"
apply safe
apply (erule parts.induct, blast+)
done

lemma parts_emptyE [elim!]: "X\<in> parts{} ==> P"
by simp

text\<open>WARNING: loops if H = {Y}, therefore must not be repeated!\<close>
lemma parts_singleton: "X\<in> parts H ==> \<exists>Y\<in>H. X\<in> parts {Y}"
by (erule parts.induct, fast+)

subsubsection\<open>Unions\<close>

lemma parts_Un_subset1: "parts(G) \<union> parts(H) \<subseteq> parts(G \<union> H)"
by (intro Un_least parts_mono Un_upper1 Un_upper2)

lemma parts_Un_subset2: "parts(G \<union> H) \<subseteq> parts(G) \<union> parts(H)"
apply (rule subsetI)
apply (erule parts.induct, blast+)
done

lemma parts_Un [simp]: "parts(G \<union> H) = parts(G) \<union> parts(H)"
by (intro equalityI parts_Un_subset1 parts_Un_subset2)

lemma parts_insert: "parts (insert X H) = parts {X} \<union> parts H"
by (metis insert_is_Un parts_Un)

text\<open>TWO inserts to avoid looping.  This rewrite is better than nothing.
  Not suitable for Addsimps: its behaviour can be strange.\<close>
lemma parts_insert2:
     "parts (insert X (insert Y H)) = parts {X} \<union> parts {Y} \<union> parts H"
by (metis Un_commute Un_empty_right Un_insert_right insert_is_Un parts_Un)

lemma parts_UN_subset1: "(\<Union>x\<in>A. parts(H x)) \<subseteq> parts(\<Union>x\<in>A. H x)"
by (intro UN_least parts_mono UN_upper)

lemma parts_UN_subset2: "parts(\<Union>x\<in>A. H x) \<subseteq> (\<Union>x\<in>A. parts(H x))"
apply (rule subsetI)
apply (erule parts.induct, blast+)
done

lemma parts_UN [simp]: "parts(\<Union>x\<in>A. H x) = (\<Union>x\<in>A. parts(H x))"
by (intro equalityI parts_UN_subset1 parts_UN_subset2)

text\<open>Added to simplify arguments to parts, analz and synth.
  NOTE: the UN versions are no longer used!\<close>

text\<open>This allows \<open>blast\<close> to simplify occurrences of
  @{term "parts(G\<union>H)"} in the assumption.\<close>
lemmas in_parts_UnE = parts_Un [THEN equalityD1, THEN subsetD, THEN UnE]
declare in_parts_UnE [elim!]

lemma parts_insert_subset: "insert X (parts H) \<subseteq> parts(insert X H)"
by (blast intro: parts_mono [THEN [2] rev_subsetD])

subsubsection\<open>Idempotence and transitivity\<close>

lemma parts_partsD [dest!]: "X\<in> parts (parts H) ==> X\<in> parts H"
by (erule parts.induct, blast+)

lemma parts_idem [simp]: "parts (parts H) = parts H"
by blast

lemma parts_subset_iff [simp]: "(parts G \<subseteq> parts H) = (G \<subseteq> parts H)"
by (metis parts_idem parts_increasing parts_mono subset_trans)

lemma parts_trans: "[| X\<in> parts G;  G \<subseteq> parts H |] ==> X\<in> parts H"
by (metis parts_subset_iff subsetD)

text\<open>Cut\<close>
lemma parts_cut:
     "[| Y\<in> parts (insert X G);  X\<in> parts H |] ==> Y\<in> parts (G \<union> H)"
by (blast intro: parts_trans)

lemma parts_cut_eq [simp]: "X\<in> parts H ==> parts (insert X H) = parts H"
by (metis insert_absorb parts_idem parts_insert)

subsubsection\<open>Rewrite rules for pulling out atomic messages\<close>

lemmas parts_insert_eq_I = equalityI [OF subsetI parts_insert_subset]

lemma parts_insert_Agent [simp]:
     "parts (insert (Agent agt) H) = insert (Agent agt) (parts H)"
apply (rule parts_insert_eq_I)
apply (erule parts.induct, auto)
done

lemma parts_insert_Nonce [simp]:
     "parts (insert (Nonce N) H) = insert (Nonce N) (parts H)"
apply (rule parts_insert_eq_I)
apply (erule parts.induct, auto)
done

lemma parts_insert_Number [simp]:
     "parts (insert (Number N) H) = insert (Number N) (parts H)"
apply (rule parts_insert_eq_I)
apply (erule parts.induct, auto)
done

lemma parts_insert_Key [simp]:
     "parts (insert (Key K) H) = insert (Key K) (parts H)"
apply (rule parts_insert_eq_I)
apply (erule parts.induct, auto)
done

lemma parts_insert_Hash [simp]:
     "parts (insert (Hash X) H) = insert (Hash X) (parts H)"
apply (rule parts_insert_eq_I)
apply (erule parts.induct, auto)
done

lemma parts_insert_Crypt [simp]:
     "parts (insert (Crypt K X) H) = insert (Crypt K X) (parts (insert X H))"
apply (rule equalityI)
apply (rule subsetI)
apply (erule parts.induct, auto)
apply (blast intro: parts.Body)
done

lemma parts_insert_MPair [simp]:
     "parts (insert \<lbrace>X,Y\<rbrace> H) =
          insert \<lbrace>X,Y\<rbrace> (parts (insert X (insert Y H)))"
apply (rule equalityI)
apply (rule subsetI)
apply (erule parts.induct, auto)
apply (blast intro: parts.Fst parts.Snd)+
done

lemma parts_image_Key [simp]: "parts (Key`N) = Key`N"
apply auto
apply (erule parts.induct, auto)
done

text\<open>In any message, there is an upper bound N on its greatest nonce.\<close>
lemma msg_Nonce_supply: "\<exists>N. \<forall>n. N\<le>n --> Nonce n \<notin> parts {msg}"
apply (induct msg)
apply (simp_all (no_asm_simp) add: exI parts_insert2)
txt\<open>Nonce case\<close>
apply (metis Suc_n_not_le_n)
txt\<open>MPair case: metis works out the necessary sum itself!\<close>
apply (metis le_trans nat_le_linear)
done

subsection\<open>Inductive relation "analz"\<close>

text\<open>Inductive definition of "analz" -- what can be broken down from a set of
    messages, including keys.  A form of downward closure.  Pairs can
    be taken apart; messages decrypted with known keys.\<close>

inductive_set
  analz :: "msg set => msg set"
  for H :: "msg set"
  where
    Inj [intro,simp] :    "X \<in> H ==> X \<in> analz H"
  | Fst:     "\<lbrace>X,Y\<rbrace> \<in> analz H ==> X \<in> analz H"
  | Snd:     "\<lbrace>X,Y\<rbrace> \<in> analz H ==> Y \<in> analz H"
  | Decrypt [dest]:
             "[|Crypt K X \<in> analz H; Key(invKey K): analz H|] ==> X \<in> analz H"

text\<open>Monotonicity; Lemma 1 of Lowe's paper\<close>
lemma analz_mono: "G\<subseteq>H ==> analz(G) \<subseteq> analz(H)"
apply auto
apply (erule analz.induct)
apply (auto dest: analz.Fst analz.Snd)
done

text\<open>Making it safe speeds up proofs\<close>
lemma MPair_analz [elim!]:
     "[| \<lbrace>X,Y\<rbrace> \<in> analz H;
             [| X \<in> analz H; Y \<in> analz H |] ==> P
          |] ==> P"
by (blast dest: analz.Fst analz.Snd)

lemma analz_increasing: "H \<subseteq> analz(H)"
by blast

lemma analz_subset_parts: "analz H \<subseteq> parts H"
apply (rule subsetI)
apply (erule analz.induct, blast+)
done

lemmas analz_into_parts = analz_subset_parts [THEN subsetD]

lemmas not_parts_not_analz = analz_subset_parts [THEN contra_subsetD]

lemma parts_analz [simp]: "parts (analz H) = parts H"
by (metis analz_increasing analz_subset_parts equalityI parts_mono parts_subset_iff)

lemma analz_parts [simp]: "analz (parts H) = parts H"
apply auto
apply (erule analz.induct, auto)
done

lemmas analz_insertI = subset_insertI [THEN analz_mono, THEN [2] rev_subsetD]

subsubsection\<open>General equational properties\<close>

lemma analz_empty [simp]: "analz{} = {}"
apply safe
apply (erule analz.induct, blast+)
done

text\<open>Converse fails: we can analz more from the union than from the
  separate parts, as a key in one might decrypt a message in the other\<close>
lemma analz_Un: "analz(G) \<union> analz(H) \<subseteq> analz(G \<union> H)"
by (intro Un_least analz_mono Un_upper1 Un_upper2)

lemma analz_insert: "insert X (analz H) \<subseteq> analz(insert X H)"
by (blast intro: analz_mono [THEN [2] rev_subsetD])

subsubsection\<open>Rewrite rules for pulling out atomic messages\<close>

lemmas analz_insert_eq_I = equalityI [OF subsetI analz_insert]

lemma analz_insert_Agent [simp]:
     "analz (insert (Agent agt) H) = insert (Agent agt) (analz H)"
apply (rule analz_insert_eq_I)
apply (erule analz.induct, auto)
done

lemma analz_insert_Nonce [simp]:
     "analz (insert (Nonce N) H) = insert (Nonce N) (analz H)"
apply (rule analz_insert_eq_I)
apply (erule analz.induct, auto)
done

lemma analz_insert_Number [simp]:
     "analz (insert (Number N) H) = insert (Number N) (analz H)"
apply (rule analz_insert_eq_I)
apply (erule analz.induct, auto)
done

lemma analz_insert_Hash [simp]:
     "analz (insert (Hash X) H) = insert (Hash X) (analz H)"
apply (rule analz_insert_eq_I)
apply (erule analz.induct, auto)
done

text\<open>Can only pull out Keys if they are not needed to decrypt the rest\<close>
lemma analz_insert_Key [simp]:
    "K \<notin> keysFor (analz H) ==>
          analz (insert (Key K) H) = insert (Key K) (analz H)"
apply (unfold keysFor_def)
apply (rule analz_insert_eq_I)
apply (erule analz.induct, auto)
done

lemma analz_insert_MPair [simp]:
     "analz (insert \<lbrace>X,Y\<rbrace> H) =
          insert \<lbrace>X,Y\<rbrace> (analz (insert X (insert Y H)))"
apply (rule equalityI)
apply (rule subsetI)
apply (erule analz.induct, auto)
apply (erule analz.induct)
apply (blast intro: analz.Fst analz.Snd)+
done

text\<open>Can pull out enCrypted message if the Key is not known\<close>
lemma analz_insert_Crypt:
     "Key (invKey K) \<notin> analz H
      ==> analz (insert (Crypt K X) H) = insert (Crypt K X) (analz H)"
apply (rule analz_insert_eq_I)
apply (erule analz.induct, auto)

done

lemma lemma1: "Key (invKey K) \<in> analz H ==>
               analz (insert (Crypt K X) H) \<subseteq>
               insert (Crypt K X) (analz (insert X H))"
apply (rule subsetI)
apply (erule_tac x = x in analz.induct, auto)
done

lemma lemma2: "Key (invKey K) \<in> analz H ==>
               insert (Crypt K X) (analz (insert X H)) \<subseteq>
               analz (insert (Crypt K X) H)"
apply auto
apply (erule_tac x = x in analz.induct, auto)
apply (blast intro: analz_insertI analz.Decrypt)
done

lemma analz_insert_Decrypt:
     "Key (invKey K) \<in> analz H ==>
               analz (insert (Crypt K X) H) =
               insert (Crypt K X) (analz (insert X H))"
by (intro equalityI lemma1 lemma2)

text\<open>Case analysis: either the message is secure, or it is not! Effective,
but can cause subgoals to blow up! Use with \<open>if_split\<close>; apparently
\<open>split_tac\<close> does not cope with patterns such as @{term"analz (insert
(Crypt K X) H)"}\<close>
lemma analz_Crypt_if [simp]:
     "analz (insert (Crypt K X) H) =
          (if (Key (invKey K) \<in> analz H)
           then insert (Crypt K X) (analz (insert X H))
           else insert (Crypt K X) (analz H))"
by (simp add: analz_insert_Crypt analz_insert_Decrypt)

text\<open>This rule supposes "for the sake of argument" that we have the key.\<close>
lemma analz_insert_Crypt_subset:
     "analz (insert (Crypt K X) H) \<subseteq>
           insert (Crypt K X) (analz (insert X H))"
apply (rule subsetI)
apply (erule analz.induct, auto)
done

lemma analz_image_Key [simp]: "analz (Key`N) = Key`N"
apply auto
apply (erule analz.induct, auto)
done

subsubsection\<open>Idempotence and transitivity\<close>

lemma analz_analzD [dest!]: "X\<in> analz (analz H) ==> X\<in> analz H"
by (erule analz.induct, blast+)

lemma analz_idem [simp]: "analz (analz H) = analz H"
by blast

lemma analz_subset_iff [simp]: "(analz G \<subseteq> analz H) = (G \<subseteq> analz H)"
by (metis analz_idem analz_increasing analz_mono subset_trans)

lemma analz_trans: "[| X\<in> analz G;  G \<subseteq> analz H |] ==> X\<in> analz H"
by (drule analz_mono, blast)

text\<open>Cut; Lemma 2 of Lowe\<close>
lemma analz_cut: "[| Y\<in> analz (insert X H);  X\<in> analz H |] ==> Y\<in> analz H"
by (erule analz_trans, blast)

(*Cut can be proved easily by induction on
   "Y: analz (insert X H) ==> X: analz H --> Y: analz H"
*)

text\<open>This rewrite rule helps in the simplification of messages that involve
  the forwarding of unknown components (X).  Without it, removing occurrences
  of X can be very complicated.\<close>
lemma analz_insert_eq: "X\<in> analz H ==> analz (insert X H) = analz H"
by (metis analz_cut analz_insert_eq_I insert_absorb)

text\<open>A congruence rule for "analz"\<close>

lemma analz_subset_cong:
     "[| analz G \<subseteq> analz G'; analz H \<subseteq> analz H' |]
      ==> analz (G \<union> H) \<subseteq> analz (G' \<union> H')"
by (metis Un_mono analz_Un analz_subset_iff subset_trans)

lemma analz_cong:
     "[| analz G = analz G'; analz H = analz H' |]
      ==> analz (G \<union> H) = analz (G' \<union> H')"
by (intro equalityI analz_subset_cong, simp_all)

lemma analz_insert_cong:
     "analz H = analz H' ==> analz(insert X H) = analz(insert X H')"
by (force simp only: insert_def intro!: analz_cong)

text\<open>If there are no pairs or encryptions then analz does nothing\<close>
lemma analz_trivial:
     "[| \<forall>X Y. \<lbrace>X,Y\<rbrace> \<notin> H;  \<forall>X K. Crypt K X \<notin> H |] ==> analz H = H"
apply safe
apply (erule analz.induct, blast+)
done

text\<open>These two are obsolete (with a single Spy) but cost little to prove...\<close>
lemma analz_UN_analz_lemma:
     "X\<in> analz (\<Union>i\<in>A. analz (H i)) ==> X\<in> analz (\<Union>i\<in>A. H i)"
apply (erule analz.induct)
apply (blast intro: analz_mono [THEN [2] rev_subsetD])+
done

lemma analz_UN_analz [simp]: "analz (\<Union>i\<in>A. analz (H i)) = analz (\<Union>i\<in>A. H i)"
by (blast intro: analz_UN_analz_lemma analz_mono [THEN [2] rev_subsetD])

subsection\<open>Inductive relation "synth"\<close>

text\<open>Inductive definition of "synth" -- what can be built up from a set of
    messages.  A form of upward closure.  Pairs can be built, messages
    encrypted with known keys.  Agent names are public domain.
    Numbers can be guessed, but Nonces cannot be.\<close>

inductive_set
  synth :: "msg set => msg set"
  for H :: "msg set"
  where
    Inj    [intro]:   "X \<in> H ==> X \<in> synth H"
  | Agent  [intro]:   "Agent agt \<in> synth H"
  | Number [intro]:   "Number n  \<in> synth H"
  | Hash   [intro]:   "X \<in> synth H ==> Hash X \<in> synth H"
  | MPair  [intro]:   "[|X \<in> synth H;  Y \<in> synth H|] ==> \<lbrace>X,Y\<rbrace> \<in> synth H"
  | Crypt  [intro]:   "[|X \<in> synth H;  Key(K) \<in> H|] ==> Crypt K X \<in> synth H"

text\<open>Monotonicity\<close>
lemma synth_mono: "G\<subseteq>H ==> synth(G) \<subseteq> synth(H)"
  by (auto, erule synth.induct, auto)

text\<open>NO \<open>Agent_synth\<close>, as any Agent name can be synthesized.
  The same holds for @{term Number}\<close>

inductive_simps synth_simps [iff]:
 "Nonce n \<in> synth H"
 "Key K \<in> synth H"
 "Hash X \<in> synth H"
 "\<lbrace>X,Y\<rbrace> \<in> synth H"
 "Crypt K X \<in> synth H"

lemma synth_increasing: "H \<subseteq> synth(H)"
by blast

subsubsection\<open>Unions\<close>

text\<open>Converse fails: we can synth more from the union than from the
  separate parts, building a compound message using elements of each.\<close>
lemma synth_Un: "synth(G) \<union> synth(H) \<subseteq> synth(G \<union> H)"
by (intro Un_least synth_mono Un_upper1 Un_upper2)

lemma synth_insert: "insert X (synth H) \<subseteq> synth(insert X H)"
by (blast intro: synth_mono [THEN [2] rev_subsetD])

subsubsection\<open>Idempotence and transitivity\<close>

lemma synth_synthD [dest!]: "X\<in> synth (synth H) ==> X\<in> synth H"
by (erule synth.induct, auto)

lemma synth_idem: "synth (synth H) = synth H"
by blast

lemma synth_subset_iff [simp]: "(synth G \<subseteq> synth H) = (G \<subseteq> synth H)"
by (metis subset_trans synth_idem synth_increasing synth_mono)

lemma synth_trans: "[| X\<in> synth G;  G \<subseteq> synth H |] ==> X\<in> synth H"
by (drule synth_mono, blast)

text\<open>Cut; Lemma 2 of Lowe\<close>
lemma synth_cut: "[| Y\<in> synth (insert X H);  X\<in> synth H |] ==> Y\<in> synth H"
by (erule synth_trans, blast)

lemma Agent_synth [simp]: "Agent A \<in> synth H"
by blast

lemma Number_synth [simp]: "Number n \<in> synth H"
by blast

lemma Nonce_synth_eq [simp]: "(Nonce N \<in> synth H) = (Nonce N \<in> H)"
by blast

lemma Crypt_synth_eq [simp]:
     "Key K \<notin> H ==> (Crypt K X \<in> synth H) = (Crypt K X \<in> H)"
by blast

lemma keysFor_synth [simp]:
    "keysFor (synth H) = keysFor H \<union> invKey`{K. Key K \<in> H}"
by (unfold keysFor_def, blast)

subsubsection\<open>Combinations of parts, analz and synth\<close>

lemma parts_synth [simp]: "parts (synth H) = parts H \<union> synth H"
apply (rule equalityI)
apply (rule subsetI)
apply (erule parts.induct)
apply (blast intro: synth_increasing [THEN parts_mono, THEN subsetD]
                    parts.Fst parts.Snd parts.Body)+
done

lemma analz_analz_Un [simp]: "analz (analz G \<union> H) = analz (G \<union> H)"
apply (intro equalityI analz_subset_cong)+
apply simp_all
done

lemma analz_synth_Un [simp]: "analz (synth G \<union> H) = analz (G \<union> H) \<union> synth G"
apply (rule equalityI)
apply (rule subsetI)
apply (erule analz.induct)
prefer 5 apply (blast intro: analz_mono [THEN [2] rev_subsetD])
apply (blast intro: analz.Fst analz.Snd analz.Decrypt)+
done

lemma analz_synth [simp]: "analz (synth H) = analz H \<union> synth H"
by (metis Un_empty_right analz_synth_Un)

subsubsection\<open>For reasoning about the Fake rule in traces\<close>

lemma parts_insert_subset_Un: "X\<in> G ==> parts(insert X H) \<subseteq> parts G \<union> parts H"
by (metis UnCI Un_upper2 insert_subset parts_Un parts_mono)

text\<open>More specifically for Fake. See also \<open>Fake_parts_sing\<close> below\<close>
lemma Fake_parts_insert:
     "X \<in> synth (analz H) ==>
      parts (insert X H) \<subseteq> synth (analz H) \<union> parts H"
by (metis Un_commute analz_increasing insert_subset parts_analz parts_mono
          parts_synth synth_mono synth_subset_iff)

lemma Fake_parts_insert_in_Un:
     "[|Z \<in> parts (insert X H);  X: synth (analz H)|]
      ==> Z \<in>  synth (analz H) \<union> parts H"
by (metis Fake_parts_insert subsetD)

text\<open>@{term H} is sometimes @{term"Key ` KK \<union> spies evs"}, so can't put
  @{term "G=H"}.\<close>
lemma Fake_analz_insert:
     "X\<in> synth (analz G) ==>
      analz (insert X H) \<subseteq> synth (analz G) \<union> analz (G \<union> H)"
apply (rule subsetI)
apply (subgoal_tac "x \<in> analz (synth (analz G) \<union> H)", force)
apply (blast intro: analz_mono [THEN [2] rev_subsetD] analz_mono [THEN synth_mono, THEN [2] rev_subsetD])
done

lemma analz_conj_parts [simp]:
     "(X \<in> analz H \<and> X \<in> parts H) = (X \<in> analz H)"
by (blast intro: analz_subset_parts [THEN subsetD])

lemma analz_disj_parts [simp]:
     "(X \<in> analz H | X \<in> parts H) = (X \<in> parts H)"
by (blast intro: analz_subset_parts [THEN subsetD])

text\<open>Without this equation, other rules for synth and analz would yield
  redundant cases\<close>
lemma MPair_synth_analz [iff]:
     "(\<lbrace>X,Y\<rbrace> \<in> synth (analz H)) =
      (X \<in> synth (analz H) \<and> Y \<in> synth (analz H))"
by blast

lemma Crypt_synth_analz:
     "[| Key K \<in> analz H;  Key (invKey K) \<in> analz H |]
       ==> (Crypt K X \<in> synth (analz H)) = (X \<in> synth (analz H))"
by blast

lemma Hash_synth_analz [simp]:
     "X \<notin> synth (analz H)
      ==> (Hash\<lbrace>X,Y\<rbrace> \<in> synth (analz H)) = (Hash\<lbrace>X,Y\<rbrace> \<in> analz H)"
by blast

subsection\<open>HPair: a combination of Hash and MPair\<close>

subsubsection\<open>Freeness\<close>

lemma Agent_neq_HPair: "Agent A ~= Hash[X] Y"
by (unfold HPair_def, simp)

lemma Nonce_neq_HPair: "Nonce N ~= Hash[X] Y"
by (unfold HPair_def, simp)

lemma Number_neq_HPair: "Number N ~= Hash[X] Y"
by (unfold HPair_def, simp)

lemma Key_neq_HPair: "Key K ~= Hash[X] Y"
by (unfold HPair_def, simp)

lemma Hash_neq_HPair: "Hash Z ~= Hash[X] Y"
by (unfold HPair_def, simp)

lemma Crypt_neq_HPair: "Crypt K X' ~= Hash[X] Y"
by (unfold HPair_def, simp)

lemmas HPair_neqs = Agent_neq_HPair Nonce_neq_HPair Number_neq_HPair
                    Key_neq_HPair Hash_neq_HPair Crypt_neq_HPair

declare HPair_neqs [iff]
declare HPair_neqs [symmetric, iff]

lemma HPair_eq [iff]: "(Hash[X'] Y' = Hash[X] Y) = (X' = X \<and> Y'=Y)"
by (simp add: HPair_def)

lemma MPair_eq_HPair [iff]:
     "(\<lbrace>X',Y'\<rbrace> = Hash[X] Y) = (X' = Hash\<lbrace>X,Y\<rbrace> \<and> Y'=Y)"
by (simp add: HPair_def)

lemma HPair_eq_MPair [iff]:
     "(Hash[X] Y = \<lbrace>X',Y'\<rbrace>) = (X' = Hash\<lbrace>X,Y\<rbrace> \<and> Y'=Y)"
by (auto simp add: HPair_def)

subsubsection\<open>Specialized laws, proved in terms of those for Hash and MPair\<close>

lemma keysFor_insert_HPair [simp]: "keysFor (insert (Hash[X] Y) H) = keysFor H"
by (simp add: HPair_def)

lemma parts_insert_HPair [simp]:
    "parts (insert (Hash[X] Y) H) =
     insert (Hash[X] Y) (insert (Hash\<lbrace>X,Y\<rbrace>) (parts (insert Y H)))"
by (simp add: HPair_def)

lemma analz_insert_HPair [simp]:
    "analz (insert (Hash[X] Y) H) =
     insert (Hash[X] Y) (insert (Hash\<lbrace>X,Y\<rbrace>) (analz (insert Y H)))"
by (simp add: HPair_def)

lemma HPair_synth_analz [simp]:
     "X \<notin> synth (analz H)
    ==> (Hash[X] Y \<in> synth (analz H)) =
        (Hash \<lbrace>X, Y\<rbrace> \<in> analz H \<and> Y \<in> synth (analz H))"
by (auto simp add: HPair_def)

text\<open>We do NOT want Crypt... messages broken up in protocols!!\<close>
declare parts.Body [rule del]

text\<open>Rewrites to push in Key and Crypt messages, so that other messages can
    be pulled out using the \<open>analz_insert\<close> rules\<close>

lemmas pushKeys =
  insert_commute [of "Key K" "Agent C"]
  insert_commute [of "Key K" "Nonce N"]
  insert_commute [of "Key K" "Number N"]
  insert_commute [of "Key K" "Hash X"]
  insert_commute [of "Key K" "MPair X Y"]
  insert_commute [of "Key K" "Crypt X K'"]
  for K C N X Y K'

lemmas pushCrypts =
  insert_commute [of "Crypt X K" "Agent C"]
  insert_commute [of "Crypt X K" "Agent C"]
  insert_commute [of "Crypt X K" "Nonce N"]
  insert_commute [of "Crypt X K" "Number N"]
  insert_commute [of "Crypt X K" "Hash X'"]
  insert_commute [of "Crypt X K" "MPair X' Y"]
  for X K C N X' Y

text\<open>Cannot be added with \<open>[simp]\<close> -- messages should not always be
  re-ordered.\<close>
lemmas pushes = pushKeys pushCrypts

subsection\<open>The set of key-free messages\<close>

(*Note that even the encryption of a key-free message remains key-free.
  This concept is valuable because of the theorem analz_keyfree_into_Un, proved below. *)

inductive_set
  keyfree :: "msg set"
  where
    Agent:  "Agent A \<in> keyfree"
  | Number: "Number N \<in> keyfree"
  | Nonce:  "Nonce N \<in> keyfree"
  | Hash:   "Hash X \<in> keyfree"
  | MPair:  "[|X \<in> keyfree;  Y \<in> keyfree|] ==> \<lbrace>X,Y\<rbrace> \<in> keyfree"
  | Crypt:  "[|X \<in> keyfree|] ==> Crypt K X \<in> keyfree"

declare keyfree.intros [intro]

inductive_cases keyfree_KeyE: "Key K \<in> keyfree"
inductive_cases keyfree_MPairE: "\<lbrace>X,Y\<rbrace> \<in> keyfree"
inductive_cases keyfree_CryptE: "Crypt K X \<in> keyfree"

lemma parts_keyfree: "parts (keyfree) \<subseteq> keyfree"
  by (clarify, erule parts.induct, auto elim!: keyfree_KeyE keyfree_MPairE keyfree_CryptE)

(*The key-free part of a set of messages can be removed from the scope of the analz operator.*)
lemma analz_keyfree_into_Un: "\<lbrakk>X \<in> analz (G \<union> H); G \<subseteq> keyfree\<rbrakk> \<Longrightarrow> X \<in> parts G \<union> analz H"
apply (erule analz.induct, auto)
apply (blast dest:parts.Body)
apply (blast dest: parts.Body)
apply (metis Un_absorb2 keyfree_KeyE parts_Un parts_keyfree UnI2)
done

subsection\<open>Tactics useful for many protocol proofs\<close>
ML
\<open>
(*Analysis of Fake cases.  Also works for messages that forward unknown parts,
  but this application is no longer necessary if analz_insert_eq is used.
  DEPENDS UPON "X" REFERRING TO THE FRADULENT MESSAGE *)

fun impOfSubs th = th RSN (2, @{thm rev_subsetD})

(*Apply rules to break down assumptions of the form
  Y \<in> parts(insert X H)  and  Y \<in> analz(insert X H)
*)
fun Fake_insert_tac ctxt =
    dresolve_tac ctxt [impOfSubs @{thm Fake_analz_insert},
                  impOfSubs @{thm Fake_parts_insert}] THEN'
    eresolve_tac ctxt [asm_rl, @{thm synth.Inj}];

fun Fake_insert_simp_tac ctxt i =
  REPEAT (Fake_insert_tac ctxt i) THEN asm_full_simp_tac ctxt i;

fun atomic_spy_analz_tac ctxt =
  SELECT_GOAL
   (Fake_insert_simp_tac ctxt 1 THEN
    IF_UNSOLVED
      (Blast.depth_tac
        (ctxt addIs [@{thm analz_insertI}, impOfSubs @{thm analz_subset_parts}]) 4 1));

fun spy_analz_tac ctxt i =
  DETERM
   (SELECT_GOAL
     (EVERY
      [  (*push in occurrences of X...*)
       (REPEAT o CHANGED)
         (Rule_Insts.res_inst_tac ctxt [((("x", 1), Position.none), "X")] []
          (insert_commute RS ssubst) 1),
       (*...allowing further simplifications*)
       simp_tac ctxt 1,
       REPEAT (FIRSTGOAL (resolve_tac ctxt [allI,impI,notI,conjI,iffI])),
       DEPTH_SOLVE (atomic_spy_analz_tac ctxt 1)]) i);
\<close>

text\<open>By default only \<open>o_apply\<close> is built-in.  But in the presence of
eta-expansion this means that some terms displayed as @{term "f o g"} will be
rewritten, and others will not!\<close>
declare o_def [simp]

lemma Crypt_notin_image_Key [simp]: "Crypt K X \<notin> Key ` A"
by auto

lemma Hash_notin_image_Key [simp] :"Hash X \<notin> Key ` A"
by auto

lemma synth_analz_mono: "G\<subseteq>H ==> synth (analz(G)) \<subseteq> synth (analz(H))"
by (iprover intro: synth_mono analz_mono)

lemma Fake_analz_eq [simp]:
     "X \<in> synth(analz H) ==> synth (analz (insert X H)) = synth (analz H)"
by (metis Fake_analz_insert Un_absorb Un_absorb1 Un_commute
          subset_insertI synth_analz_mono synth_increasing synth_subset_iff)

text\<open>Two generalizations of \<open>analz_insert_eq\<close>\<close>
lemma gen_analz_insert_eq [rule_format]:
     "X \<in> analz H ==> \<forall>G. H \<subseteq> G --> analz (insert X G) = analz G"
by (blast intro: analz_cut analz_insertI analz_mono [THEN [2] rev_subsetD])

lemma synth_analz_insert_eq [rule_format]:
     "X \<in> synth (analz H)
      ==> \<forall>G. H \<subseteq> G --> (Key K \<in> analz (insert X G)) = (Key K \<in> analz G)"
apply (erule synth.induct)
apply (simp_all add: gen_analz_insert_eq subset_trans [OF _ subset_insertI])
done

lemma Fake_parts_sing:
     "X \<in> synth (analz H) ==> parts{X} \<subseteq> synth (analz H) \<union> parts H"
by (metis Fake_parts_insert empty_subsetI insert_mono parts_mono subset_trans)

lemmas Fake_parts_sing_imp_Un = Fake_parts_sing [THEN [2] rev_subsetD]

method_setup spy_analz = \<open>
    Scan.succeed (SIMPLE_METHOD' o spy_analz_tac)\<close>
    "for proving the Fake case when analz is involved"

method_setup atomic_spy_analz = \<open>
    Scan.succeed (SIMPLE_METHOD' o atomic_spy_analz_tac)\<close>
    "for debugging spy_analz"

method_setup Fake_insert_simp = \<open>
    Scan.succeed (SIMPLE_METHOD' o Fake_insert_simp_tac)\<close>
    "for debugging spy_analz"

end


(* Author: Tobias Nipkow (based on Hauke Brinkop's tree proofs) *)

subsection \<open>Okasaki's Pairing Heap (Modified)\<close>

theory Pairing_Heap_List2_Analysis
imports
  Pairing_Heap.Pairing_Heap_List2
  Amortized_Framework
  Priority_Queue_ops_merge
  Lemmas_log
begin

text
\<open>Amortized analysis of a modified version of the pairing heaps
defined by Okasaki \<^cite>\<open>"Okasaki"\<close>.\<close>

fun lift_hp :: "'b \<Rightarrow> ('a hp \<Rightarrow> 'b) \<Rightarrow> 'a heap \<Rightarrow> 'b" where
"lift_hp c f None = c" |
"lift_hp c f (Some h) = f h"

fun size_hps :: "'a hp list \<Rightarrow> nat" where
"size_hps(Hp x hsl # hsr) = size_hps hsl + size_hps hsr + 1" |
"size_hps [] = 0"

definition size_hp :: "'a hp \<Rightarrow> nat" where
[simp]: "size_hp h = size_hps(hps h) + 1"

fun \<Phi>_hps :: "'a hp list \<Rightarrow> real" where
"\<Phi>_hps [] = 0" |
"\<Phi>_hps (Hp x hsl # hsr) = \<Phi>_hps hsl + \<Phi>_hps hsr + log 2 (size_hps hsl + size_hps hsr + 1)"

definition \<Phi>_hp :: "'a hp \<Rightarrow> real" where
[simp]: "\<Phi>_hp h = \<Phi>_hps (hps h) + log 2 (size_hps(hps(h))+1)"

abbreviation \<Phi> :: "'a heap \<Rightarrow> real" where
"\<Phi> \<equiv> lift_hp 0 \<Phi>_hp"

abbreviation size_heap :: "'a heap \<Rightarrow> nat" where
"size_heap \<equiv> lift_hp 0 size_hp"

lemma \<Phi>_hps_ge0: "\<Phi>_hps hs \<ge> 0"
by (induction hs rule: size_hps.induct) auto

declare algebra_simps[simp]

lemma size_hps_Cons[simp]: "size_hps(h # hs) = size_hp h + size_hps hs"
by(cases h) simp

lemma link2: "link (Hp x lx) h = (case h of (Hp y ly) \<Rightarrow>
    (if x < y then Hp x (Hp y ly # lx) else Hp y (Hp x lx # ly)))"
by(simp split: hp.split)

lemma size_hps_link: "size_hps(hps (link h1 h2)) = size_hp h1 + size_hp h2 - 1"
by (induction rule: link.induct) simp_all

lemma pass\<^sub>1_size[simp]: "size_hps (pass\<^sub>1 hs) = size_hps hs"
by (induct hs rule: pass\<^sub>1.induct) (simp_all add: size_hps_link)

lemma pass\<^sub>2_None[simp]: "pass\<^sub>2 hs = None \<longleftrightarrow> hs = []"
by(cases hs) auto

lemma \<Delta>\<Phi>_insert:
  "\<Phi> (Pairing_Heap_List2.insert x h) - \<Phi> h \<le> log 2 (size_heap h + 1)"
by(induct h)(auto simp: link2 split: hp.split)

lemma \<Delta>\<Phi>_link: "\<Phi>_hp (link h1 h2) - \<Phi>_hp h1 - \<Phi>_hp h2 \<le> 2 * log 2 (size_hp h1 + size_hp h2)"
by (induction h1 h2 rule: link.induct) (simp  add: add_increasing)

fun sum_ub :: "'a hp list \<Rightarrow> real" where
  "sum_ub [] = 0"
| "sum_ub [Hp _ _] = 0"
| "sum_ub [Hp _ lx, Hp _ ly] = 2*log 2 (2 + size_hps lx + size_hps ly)"
| "sum_ub (Hp _ lx # Hp _ ly # ry) = 2*log 2 (2 + size_hps lx + size_hps ly + size_hps ry)
    - 2*log 2 (size_hps ry) - 2 + sum_ub ry"

lemma \<Delta>\<Phi>_pass1_sum_ub: "\<Phi>_hps (pass\<^sub>1 h) - \<Phi>_hps h  \<le> sum_ub h"
proof (induction h rule: sum_ub.induct)
  case (3 lx x ly y)
  have 0: "\<And>x y::real. 0 \<le> x \<Longrightarrow> x \<le> y \<Longrightarrow> x \<le> 2*y" by linarith
  show ?case by (simp add: add_increasing 0)
next
  case (4 x hsx y hsy z hsize_hp)
  let ?ry = "z # hsize_hp"
  let ?rx = "Hp y hsy # ?ry"
  let ?h = "Hp x hsx # ?rx"
  have "\<Phi>_hps(pass\<^sub>1 ?h) - \<Phi>_hps ?h
    \<le> log 2 (1 + size_hps hsx + size_hps hsy) - log 2 (1 + size_hps hsy + size_hps ?ry) + sum_ub ?ry"
    using "4.IH" by simp
  also have "log 2 (1 + size_hps hsx + size_hps hsy) - log 2 (1 + size_hps hsy + size_hps ?ry)
    \<le> 2*log 2 (size_hps ?h) - 2*log 2 (size_hps ?ry) - 2"
  proof -
    have "log 2 (1 + size_hps hsx + size_hps hsy) + log 2 (size_hps ?ry) - 2*log 2 (size_hps ?h)
      = log 2 ((1 + size_hps hsx + size_hps hsy)/(size_hps ?h) ) + log 2 (size_hps ?ry / size_hps ?h)"
      by (simp add: log_divide)
    also have "\<dots> \<le> -2"
    proof -
      have "2 + \<dots>
        \<le> 2*log 2 ((1 + size_hps hsx + size_hps hsy) / size_hps ?h +  size_hps ?ry / size_hps ?h)"
        using ld_sum_inequality [of "(1 + size_hps hsx + size_hps hsy) / size_hps ?h" "(size_hps ?ry / size_hps ?h)"] by simp
      also have "\<dots> \<le> 0" by (simp add: field_simps log_divide add_pos_nonneg)
      finally show ?thesis by linarith
    qed
    finally have "log 2 (1 + size_hps hsx + size_hps hsy) + log 2 (size_hps ?ry) + 2
      \<le>  2*log 2 (size_hps ?h)" by simp
    moreover have "log 2 (size_hps ?ry) \<le> log 2 (size_hps ?rx)" by simp
    ultimately have "log 2 (1 + size_hps hsx + size_hps hsy) - \<dots>
      \<le>  2*log 2 (size_hps ?h) - 2*log 2 (size_hps ?ry) - 2" by linarith
    thus ?thesis by simp
  qed
  finally show ?case by (simp)
qed simp_all

lemma \<Delta>\<Phi>_pass1: assumes "hs \<noteq> []"
  shows "\<Phi>_hps (pass\<^sub>1 hs) - \<Phi>_hps hs \<le> 2 * log 2 (size_hps hs) - length hs + 2"
proof -
  have "sum_ub hs \<le> 2 * log 2 (size_hps hs) - length hs + 2"
    using assms by (induct hs rule: sum_ub.induct) (simp_all)
  thus ?thesis using \<Delta>\<Phi>_pass1_sum_ub[of hs] by linarith
qed

lemma \<Delta>\<Phi>_pass2: "hs \<noteq> [] \<Longrightarrow> \<Phi> (pass\<^sub>2 hs) - \<Phi>_hps hs \<le> log 2 (size_hps hs)"
proof (induction hs)
  case (Cons h hs)
  thus ?case
  proof -
    obtain x hs2 where [simp]: "h = Hp x hs2" by (metis hp.exhaust)
    show ?thesis
    proof (cases "pass\<^sub>2 hs")
      case [simp]: (Some h2)
      obtain y hs3 where [simp]: "h2 = Hp y hs3" by (metis hp.exhaust)
      from size_hps_pass2[OF Some] Cons show ?thesis
        by(cases "hs=[]")(auto simp: add_mono)
    qed simp
  qed
qed simp

lemma \<Delta>\<Phi>_del_min: assumes "hps h \<noteq> []"
  shows "\<Phi> (del_min (Some h)) - \<Phi> (Some h)
  \<le> 3 * log 2 (size_hps(hps h)) - length(hps h) + 2"
proof -
  let ?\<Delta>\<Phi>\<^sub>1 = "\<Phi>_hps(hps h) - \<Phi>_hp h"
  let ?\<Delta>\<Phi>\<^sub>2 = "\<Phi>(pass\<^sub>2(pass\<^sub>1 (hps h))) - \<Phi>_hps (hps h)"
  let ?\<Delta>\<Phi> = "\<Phi> (del_min (Some h)) - \<Phi> (Some h)"
  have "\<Phi>(pass\<^sub>2(pass\<^sub>1(hps h))) - \<Phi>_hps (pass\<^sub>1(hps h)) \<le> log 2 (size_hps(hps h))"
    using \<Delta>\<Phi>_pass2[of "pass\<^sub>1(hps h)"] using size_hps.elims assms by force
  moreover have "\<Phi>_hps (pass\<^sub>1 (hps h)) - \<Phi>_hps (hps h) \<le>  2*\<dots> - length (hps h) + 2"
    using \<Delta>\<Phi>_pass1[OF assms] by blast
  moreover have "?\<Delta>\<Phi>\<^sub>1 \<le> 0" by (cases h) simp
  moreover have "?\<Delta>\<Phi> = ?\<Delta>\<Phi>\<^sub>1 + ?\<Delta>\<Phi>\<^sub>2" by (cases h) simp
  ultimately show ?thesis by linarith
qed

fun exec :: "'a :: linorder op \<Rightarrow> 'a heap list \<Rightarrow> 'a heap" where
"exec Empty [] = None" |
"exec Del_min [h] = del_min h" |
"exec (Insert x) [h] = Pairing_Heap_List2.insert x h" |
"exec Merge [h1,h2] = merge h1 h2"

fun T\<^sub>p\<^sub>a\<^sub>s\<^sub>s\<^sub>1 :: "'a hp list \<Rightarrow> nat" where
  "T\<^sub>p\<^sub>a\<^sub>s\<^sub>s\<^sub>1 [] = 1"
| "T\<^sub>p\<^sub>a\<^sub>s\<^sub>s\<^sub>1 [_] = 1"
| "T\<^sub>p\<^sub>a\<^sub>s\<^sub>s\<^sub>1 (_ # _ # hs) = 1 + T\<^sub>p\<^sub>a\<^sub>s\<^sub>s\<^sub>1 hs"

fun T\<^sub>p\<^sub>a\<^sub>s\<^sub>s\<^sub>2 :: "'a hp list \<Rightarrow> nat" where
"T\<^sub>p\<^sub>a\<^sub>s\<^sub>s\<^sub>2 [] = 1" |
"T\<^sub>p\<^sub>a\<^sub>s\<^sub>s\<^sub>2 (_ # hs) = 1 + T\<^sub>p\<^sub>a\<^sub>s\<^sub>s\<^sub>2 hs"

fun cost :: "'a :: linorder op \<Rightarrow> 'a heap list \<Rightarrow> nat" where
"cost Empty _ = 1" |
"cost Del_min [None] = 1" |
"cost Del_min [Some(Hp x hs)] = 1 + T\<^sub>p\<^sub>a\<^sub>s\<^sub>s\<^sub>2 (pass\<^sub>1 hs) + T\<^sub>p\<^sub>a\<^sub>s\<^sub>s\<^sub>1 hs" |
"cost (Insert a) _ = 1" |
"cost Merge _ = 1"

fun U :: "'a :: linorder op \<Rightarrow> 'a heap list \<Rightarrow> real" where
"U Empty _ = 1" |
"U (Insert a) [h] = log 2 (size_heap h + 1) + 1" |
"U Del_min [h] = 3*log 2 (size_heap h + 1) + 5" |
"U Merge [h1,h2] = 2*log 2 (size_heap h1 + size_heap h2 + 1) + 1"

interpretation pairing: Amortized
where arity = arity and exec = exec and cost = cost and inv = "\<lambda>_. True"
and \<Phi> = \<Phi> and U = U
proof (standard, goal_cases)
  case (2 s) show ?case by (cases s) (auto simp: \<Phi>_hps_ge0)
next
  case (3 ss f) show ?case
  proof (cases f)
    case Empty with 3 show ?thesis by(auto)
  next
    case Insert
    thus ?thesis using Insert \<Delta>\<Phi>_insert 3 by auto
  next
    case [simp]: Del_min
    then obtain ho where [simp]: "ss = [ho]" using 3 by auto
    show ?thesis
    proof (cases ho)
      case [simp]: (Some h)
        show ?thesis
        proof (cases h)
        case [simp]: (Hp x hs)
        have "T\<^sub>p\<^sub>a\<^sub>s\<^sub>s\<^sub>2 (pass\<^sub>1 hs) + T\<^sub>p\<^sub>a\<^sub>s\<^sub>s\<^sub>1 hs \<le> 2 + length hs"
          by (induct hs rule: pass\<^sub>1.induct) simp_all
        hence  "cost f ss \<le> 1 + \<dots>" by simp
        moreover have  "\<Phi> (del_min ho) - \<Phi> ho \<le> 3*log 2 (size_heap ho + 1) - length hs + 2"
        proof (cases "hs = []")
          case False
          hence "\<Phi> (del_min ho) - \<Phi> ho \<le> 3*log 2 (size_hps hs) - length hs + 2"
            using  \<Delta>\<Phi>_del_min[of h] by simp
          also have "\<dots> \<le> 3*log 2 (size_heap ho + 1) - length hs + 2"
            using False size_hps.elims by force
          finally show ?thesis .
        qed simp
        ultimately show ?thesis by simp
      qed
    qed simp
  next
    case [simp]: Merge
    then obtain ho1 ho2 where [simp]: "ss = [ho1, ho2]"
      using 3 by(auto simp: numeral_eq_Suc)
    show ?thesis
    proof (cases "ho1 = None \<or> ho2 = None")
      case True thus ?thesis by auto
    next
      case False
      then obtain h1 h2 where [simp]: "ho1 = Some h1" "ho2 = Some h2" by auto
      have "\<Phi> (merge ho1 ho2) - \<Phi> ho1 - \<Phi> ho2 \<le> 2 * log 2 (size_heap ho1 + size_heap ho2)"
        using \<Delta>\<Phi>_link[of h1 h2] by simp
      also have "\<dots> \<le> 2 * log 2 (size_hp h1 + size_hp h2 + 1)" by (simp)
      finally show ?thesis by(simp)
    qed
  qed
qed simp

end


(*  Title:      CoW/Submonoids.thy
    Author:     Štěpán Holub, Charles University
    Author:     Štěpán Starosta, CTU in Prague
*)

theory Submonoids
  imports CoWBasic
begin

chapter \<open>Submonoids of a free monoid\<close>

text\<open>This chapter deals with properties of submonoids of a free monoid, that is, with monoids of words.
See more in Chapter 1 of @{cite Lo83}.
\<close>

section \<open>Hull\<close>

text\<open>First, we define the hull of a set of words, that is, the monoid generated by them.\<close>

inductive_set hull :: "'a list set \<Rightarrow> 'a list set" ("\<langle>_\<rangle>")
  for G where
   emp_in:  "\<epsilon> \<in> \<langle>G\<rangle>" |
   prod_cl:  "w1 \<in> G \<Longrightarrow> w2 \<in> \<langle>G\<rangle> \<Longrightarrow> w1 \<cdot> w2 \<in> \<langle>G\<rangle>"

lemmas [intro] = hull.intros

lemma hull_closed: "w1 \<in> \<langle>G\<rangle> \<Longrightarrow> w2 \<in> \<langle>G\<rangle> \<Longrightarrow> w1 \<cdot> w2 \<in> \<langle>G\<rangle>"
  by (rule hull.induct[of w1 G "\<lambda> x. (x\<cdot>w2)\<in>\<langle>G\<rangle>"]) auto+

lemma gen_in [intro]: "w \<in> G \<Longrightarrow> w \<in> \<langle>G\<rangle>"
  using hull.prod_cl by fastforce

lemma hull_induct: assumes "x \<in> \<langle>G\<rangle>" "P \<epsilon>" "\<And>w. w \<in> G \<Longrightarrow> P w"
"\<And>w1 w2. w1 \<in> \<langle>G\<rangle> \<Longrightarrow> P w1 \<Longrightarrow> w2 \<in> \<langle>G\<rangle> \<Longrightarrow> P w2 \<Longrightarrow> P (w1 \<cdot> w2)" shows  "P x"
  using hull.induct[of _ _ P, OF \<open>x \<in> \<langle>G\<rangle>\<close>  \<open>P \<epsilon>\<close>]
        assms by (simp add: gen_in)

lemma genset_sub: "G \<subseteq> \<langle>G\<rangle>"
   using gen_in ..

lemma in_lists_conv_set_subset: "set ws \<subseteq> G \<longleftrightarrow> ws \<in> lists G"
  by blast

lemma concat_in_hull [intro]:
  assumes "set ws \<subseteq> G"
  shows   "concat ws \<in> \<langle>G\<rangle>"
  using assms by (induction ws) auto

lemma concat_in_hull' [intro]:
  assumes "ws \<in> lists G"
  shows   "concat ws \<in> \<langle>G\<rangle>"
  using assms by (induction ws) auto

lemma hull_concat_lists0: "w \<in> \<langle>G\<rangle> \<Longrightarrow> (\<exists> ws \<in> lists G. concat ws = w)"
proof(rule hull.induct[of _ G], simp)
  show "\<exists>ws\<in>lists G. concat ws = \<epsilon>"
    using concat.simps(1) lists.Nil[of G] exI[of "\<lambda> x. concat x = \<epsilon>", OF concat.simps(1)] by blast
  show " \<And>w1 w2. w1 \<in> G \<Longrightarrow> w2 \<in> \<langle>G\<rangle> \<Longrightarrow> \<exists>ws\<in>lists G. concat ws = w2 \<Longrightarrow> \<exists>ws\<in>lists G. concat ws = w1 \<cdot> w2"
    by (metis Cons_in_lists_iff concat.simps(2))
qed

lemma hull_concat_lists: "\<langle>G\<rangle> = concat ` lists G"
   unfolding image_iff  using hull_concat_lists0 by blast

lemma concat_tl: "x # xs \<in> lists G \<Longrightarrow> concat xs \<in> \<langle>G\<rangle>"
  by (simp add: hull_concat_lists)

lemma nemp_concat_hull: assumes "us \<noteq> \<epsilon>" and "us \<in> lists G\<^sub>+"
  shows "concat us \<in> \<langle>G\<rangle>" and "concat us \<noteq> \<epsilon>"
  using assms by fastforce+

lemma hull_mon: "A \<subseteq> B \<Longrightarrow> \<langle>A\<rangle> \<subseteq> \<langle>B\<rangle>"
proof
  fix x assume "A \<subseteq> B" "x \<in> \<langle>A\<rangle>"
  thus "x \<in> \<langle>B\<rangle>"
    unfolding image_def hull_concat_lists using sub_lists_mono[OF \<open>A \<subseteq> B\<close>]
    by blast
qed

lemma emp_gen_set: "\<langle>{}\<rangle> = {\<epsilon>}"
  unfolding hull_concat_lists by auto

lemma hull_drop_one: "\<langle>G\<rangle> = \<langle>G\<^sub>+\<rangle>"
proof (intro equalityI subsetI)
  fix x assume "x \<in> \<langle>G\<rangle>" thus "x \<in> \<langle>G\<^sub>+\<rangle>"
    unfolding  hull_concat_lists using del_emp_concat lists_drop_emp' by blast
next
  fix x assume "x \<in> \<langle>G\<^sub>+\<rangle>" thus "x \<in> \<langle>G\<rangle>"
    unfolding  hull_concat_lists image_iff by auto
qed

lemma sing_gen_power: "u \<in> \<langle>{x}\<rangle> \<Longrightarrow> \<exists>k. u = x\<^sup>@k"
  unfolding hull_concat_lists  using one_generated_list_power by auto

lemma sing_gen: "w \<in> \<langle>{z}\<rangle> \<Longrightarrow> w \<in> z*"
  using rootI sing_gen_power by blast

lemma lists_gen_to_hull: "us \<in> lists G\<^sub>+ \<Longrightarrow> us \<in> lists \<langle>G\<rangle>\<^sub>+"
  using lists_mono genset_sub by force

lemma rev_hull0: "x \<in> rev ` \<langle>G\<rangle> \<Longrightarrow> x \<in> \<langle>rev ` G\<rangle>"
proof-
  assume "x \<in> rev ` \<langle>G\<rangle>"
  then obtain xs where "x = rev (concat xs)" and "xs \<in> lists G"
    unfolding hull_concat_lists by auto
  thus "x \<in> \<langle>rev ` G\<rangle>" unfolding image_iff hull_concat_lists using rev_concat[of xs]
    by fastforce
qed

lemma rev_hull1: "x \<in>  \<langle>rev ` G\<rangle> \<Longrightarrow> x \<in> rev ` \<langle>G\<rangle>"
proof-
  assume "x \<in>  \<langle>rev ` G\<rangle>"
  then obtain xs where "x = concat xs" and "xs \<in> lists (rev ` G)"
    unfolding hull_concat_lists by blast
  hence "rev x \<in> \<langle>G\<rangle>"
    unfolding hull_concat_lists using rev_concat by fastforce
  thus "x \<in> rev ` \<langle>G\<rangle>"
    by (simp add: rev_in_conv)
qed

lemma rev_hull: "rev`\<langle>G\<rangle> = \<langle>rev`G\<rangle>"
  by (simp add: rev_hull0 rev_hull1 set_eq_subset subsetI)

lemma power_in: "x \<in> \<langle>G\<rangle>  \<Longrightarrow> x\<^sup>@k \<in> \<langle>G\<rangle>"
  by (induction k, auto, simp add: hull_closed)

lemma hull_closed_lists:  "us \<in> lists \<langle>G\<rangle> \<Longrightarrow> concat us \<in> \<langle>G\<rangle>"
proof (induct us, auto)
  show  "\<And>a us. concat us \<in> \<langle>G\<rangle> \<Longrightarrow> a \<in> \<langle>G\<rangle> \<Longrightarrow> \<forall>x\<in>set us. x \<in> \<langle>G\<rangle> \<Longrightarrow> a \<cdot> concat us \<in> \<langle>G\<rangle> "
    by (simp add: hull_closed)
qed

lemma self_gen: "\<langle>\<langle>G\<rangle>\<rangle> = \<langle>G\<rangle>"
  using image_subsetI[of "lists \<langle>G\<rangle>" concat "\<langle>G\<rangle>", unfolded hull_concat_lists[of "\<langle>G\<rangle>", symmetric],
        THEN subset_antisym[OF _ genset_sub[of "\<langle>G\<rangle>"]]] hull_closed_lists[of _ G] by blast

text\<open>Intersection of hulls is a hull.\<close>

lemma hulls_inter: "\<langle>\<Inter> {\<langle>G\<rangle> | G. G \<in> S}\<rangle> = \<Inter> {\<langle>G\<rangle> | G. G \<in> S}"
proof
  {fix G assume "G \<in> S"
    hence "\<langle>\<Inter> {\<langle>G\<rangle> |G. G \<in> S}\<rangle> \<subseteq> \<langle>G\<rangle>"
      using Inter_lower[of "\<langle>G\<rangle>" "{\<langle>G\<rangle> |G. G \<in> S}"] mem_Collect_eq[of "\<langle>G\<rangle>" "\<lambda> A. \<exists> G. G \<in> S \<and> A = \<langle>G\<rangle>"]
        hull_mon[of "\<Inter> {\<langle>G\<rangle> |G. G \<in> S}" "\<langle>G\<rangle>"] unfolding self_gen by auto}
  thus "\<langle>\<Inter> {\<langle>G\<rangle> |G. G \<in> S}\<rangle> \<subseteq> \<Inter> {\<langle>G\<rangle> |G. G \<in> S}"  by blast
next
  show "\<Inter> {\<langle>G\<rangle> |G. G \<in> S} \<subseteq> \<langle>\<Inter> {\<langle>G\<rangle> |G. G \<in> S}\<rangle>"
    by (simp add: genset_sub)
qed

section "Factorization into generators"

text\<open>We define a decomposition (or a factorization) of a into elements of a given generating set. Such a decomposition is well defined only
if the decomposed word is an element of the hull. Even int that case, however, the decomposition need not be unique.\<close>

fun decompose :: "'a list set  \<Rightarrow> 'a list \<Rightarrow> 'a list list" ("Dec _ _" [51,51] 64) where
  "decompose G u = (SOME us. us \<in> lists G\<^sub>+ \<and> concat us = u)"

lemma dec_ex:  assumes "u \<in> \<langle>G\<rangle>" shows "\<exists> us. (us \<in> lists G\<^sub>+ \<and> concat us = u)"
  using assms unfolding image_def  hull_concat_lists[of G] mem_Collect_eq
  using del_emp_concat lists_drop_emp' by metis

lemma decI': "u \<in> \<langle>G\<rangle> \<Longrightarrow> (Dec G u) \<in> lists G\<^sub>+"
  unfolding decompose.simps using someI_ex[OF dec_ex] by blast

lemma decI: "u \<in> \<langle>G\<rangle> \<Longrightarrow> concat (Dec G u) = u"
  unfolding decompose.simps using someI_ex[OF dec_ex] by blast

lemma dec_emp: "Dec G \<epsilon> = \<epsilon>"
proof-
  have ex:  "\<epsilon> \<in> lists G\<^sub>+ \<and> concat \<epsilon> = \<epsilon>"
    by simp
  have all: "(us \<in> lists G\<^sub>+ \<and> concat us = \<epsilon>) \<Longrightarrow> us = \<epsilon>" for us
    using emp_concat_emp by auto
  show  ?thesis
    unfolding decompose.simps
    using all[OF someI[of "\<lambda> x. x \<in> lists G\<^sub>+ \<and> concat x = \<epsilon>", OF ex]].
qed

lemma dec_nemp: "u \<in> \<langle>G\<rangle>\<^sub>+ \<Longrightarrow>  Dec G u \<noteq> \<epsilon>"
  using decI[of u G] by force

lemma dec_nemp': "u \<noteq> \<epsilon> \<Longrightarrow> u \<in> \<langle>G\<rangle> \<Longrightarrow> Dec G u \<noteq> \<epsilon>"
  using dec_nemp by blast

lemma dec_dom': "u \<in> \<langle>G\<rangle> \<Longrightarrow> Dec G u \<in> lists G"
  using decI' by auto

lemma dec_hd: assumes "u \<noteq> \<epsilon>" "u \<in> \<langle>G\<rangle>" shows "hd (Dec G u) \<in> G"
  using dec_nemp'[OF assms] dec_dom'[OF \<open>u \<in> \<langle>G\<rangle>\<close>] lists_hd[of "Dec G u" G] by blast

lemma non_gen_dec: "u \<in> \<langle>G\<rangle> \<Longrightarrow> u \<notin> G \<Longrightarrow> Dec G u  \<noteq> [u]"
  using decI'  Cons_in_lists_iff by fastforce

subsection \<open>Refinement into a specific decomposition\<close>

text\<open>We extend the decomposition to lists of words. This can be seen as a refinement of a previous decomposition of some word.\<close>

fun refine :: "'a list set \<Rightarrow> 'a list list \<Rightarrow> 'a list list" ("Ref _ _" [51,51] 65) where
  "refine G us = concat(map (decompose G) us)"

lemma ref_morph: "us \<in> lists \<langle>G\<rangle> \<Longrightarrow> vs \<in> lists \<langle>G\<rangle> \<Longrightarrow> refine G (us \<cdot> vs) = refine G us \<cdot> refine G vs"
  using refine.simps by simp

lemma ref_morph_plus: "us \<in> lists \<langle>G\<rangle>\<^sub>+ \<Longrightarrow> vs \<in> lists \<langle>G\<rangle>\<^sub>+ \<Longrightarrow> refine G (us \<cdot> vs) = refine G us \<cdot> refine G vs"
  using refine.simps by simp

lemma ref_pop_hd: "us \<noteq> \<epsilon> \<Longrightarrow> us \<in> lists \<langle>G\<rangle> \<Longrightarrow> refine G us = decompose G (hd us) \<cdot> refine G (tl us)"
  unfolding  refine.simps  using list.simps(9)[of "decompose G" "hd us" "tl us"] by simp

lemma ref_in: "us \<in> lists \<langle>G\<rangle> \<Longrightarrow> (Ref G us) \<in> lists G\<^sub>+"
 proof (induction us, simp)
   case (Cons a us)
   then show ?case
      using Cons.IH Cons.prems decI' by auto
qed

lemma ref: "us \<in> lists \<langle>G\<rangle> \<Longrightarrow> concat (Ref G us) = concat us"
proof (induction us, simp)
  case (Cons a us)
  then show ?case
      using Cons.IH Cons.prems decI by auto
  qed

lemma ref_gen: "us \<in> lists B \<Longrightarrow> B \<subseteq> \<langle>G\<rangle> \<Longrightarrow> Ref G us \<in> \<langle>decompose G ` B\<rangle>"
  by (induct us, auto)

lemma emp_ref: assumes "us \<in> lists \<langle>G\<rangle>\<^sub>+" and  "Ref G us = \<epsilon>" shows "us = \<epsilon>"
  using emp_concat_emp[OF \<open>us \<in> lists \<langle>G\<rangle>\<^sub>+\<close>]
     ref[OF lists_drop_emp[OF assms(1)], unfolded \<open>Ref G us = \<epsilon>\<close> concat.simps(1),symmetric] by blast

lemma sing_ref_sing:
  assumes "us \<in> lists \<langle>G\<rangle>\<^sub>+" and "refine G us = [b]"
  shows "us = [b]"
proof-
  have "us \<noteq> \<epsilon>"
    using \<open>refine G us = [b]\<close> by auto
  have "tl us \<in> lists \<langle>G\<rangle>\<^sub>+" and "hd us \<in> \<langle>G\<rangle>\<^sub>+"
    using list.collapse[OF \<open>us \<noteq> \<epsilon>\<close>]  \<open>us \<in> lists \<langle>G\<rangle>\<^sub>+\<close> Cons_in_lists_iff[of "hd us" "tl us" "\<langle>G\<rangle>\<^sub>+"]
    by auto
  have "Dec G (hd us) \<noteq> \<epsilon>"
    using dec_nemp[OF \<open>hd us \<in> \<langle>G\<rangle>\<^sub>+\<close>].
  have "us \<in> lists \<langle>G\<rangle>"
    using \<open>us \<in> lists \<langle>G\<rangle>\<^sub>+\<close> lists_drop_emp by auto
  have "concat us = b"
    using \<open>us \<in> lists \<langle>G\<rangle>\<close> assms(2) ref by force
  have "refine G (tl us) = \<epsilon>"
    using ref_pop_hd[OF \<open>us \<noteq> \<epsilon>\<close> \<open>us \<in> lists \<langle>G\<rangle>\<close>]  unfolding  \<open>refine G us = [b]\<close>
    using \<open>Dec G (hd us) \<noteq> \<epsilon>\<close> Cons_eq_append_conv[of b \<epsilon> "(Dec G (hd us))" "(Ref G (tl us))"]
      Cons_eq_append_conv[of b \<epsilon> "(Dec G (hd us))" "(Ref G (tl us))"]  append_is_Nil_conv[of _ "(Ref G (tl us))"]
    by blast
  from  emp_ref[OF \<open>tl us \<in> lists \<langle>G\<rangle>\<^sub>+\<close> this, symmetric]
  have "\<epsilon> = tl us".
  from this[unfolded Nil_tl]
  show ?thesis
    using \<open>us \<noteq> \<epsilon>\<close> \<open>concat us = b\<close> by auto
qed

lemma ref_ex: assumes "Q \<subseteq> \<langle>G\<rangle>" and "us \<in> lists Q"
  shows "Ref G us \<in> lists G\<^sub>+" and "concat (Ref G us) = concat us"
  using  ref_in[OF sub_lists_mono[OF assms]] ref[OF sub_lists_mono[OF assms]].

section "Basis"

text\<open>An important property of monoids of words is that they have a unique minimal generating set. Which is the set consisting of indecomposable elements.\<close>

text\<open>The simple element is defined as a word which has only trivial decomposition into generators: a singleton.\<close>

function simple_element :: "'a list \<Rightarrow> 'a list set  \<Rightarrow> bool" (" _ \<in>B _ " [51,51] 50) where
  "simple_element b G = (b \<in> G \<and> (\<forall> us. us \<in> lists G\<^sub>+ \<and> concat us = b \<longrightarrow> \<^bold>|us\<^bold>| = 1))"
  using prod.exhaust by auto
termination
  using "termination" by blast

lemma simp_el_el: "b \<in>B G \<Longrightarrow> b \<in> G"
    unfolding simple_element.simps by blast

lemma simp_elD: "b \<in>B G \<Longrightarrow> us \<in> lists G\<^sub>+ \<Longrightarrow> concat us = b \<Longrightarrow> \<^bold>|us\<^bold>| = 1"
    unfolding simple_element.simps by blast

lemma simp_el_sing: assumes "b \<in>B G" "us \<in> lists G\<^sub>+" "concat us = b" shows "us = [b]"
  using simp_elD[OF assms] \<open>concat us = b\<close> concat_len_one sing_word by fastforce

lemma nonsimp: "us \<in> lists G\<^sub>+ \<Longrightarrow> concat us \<in>B G \<Longrightarrow>  us = [concat us]"
  using simp_el_sing[of "concat us" G us]   unfolding simple_element.simps
  by blast

lemma emp_nonsimp: "\<not> \<epsilon> \<in>B G"
  unfolding simple_element.simps using list.size(3) concat.simps(1) lists.Nil[of "G\<^sub>+"]
  by fastforce

lemma basis_no_fact: assumes "u \<in> \<langle>G\<rangle>" and "v \<in> \<langle>G\<rangle>" and "u \<cdot> v \<in>B G" shows "u = \<epsilon> \<or> v = \<epsilon>"
proof-
  have eq1: "concat ((Dec G u) \<cdot> (Dec G v)) = u \<cdot> v"
    using concat_morph[of "Dec G u" "Dec G v",symmetric]
    unfolding decI[OF \<open>u \<in> \<langle>G\<rangle>\<close>] decI[OF \<open>v \<in> \<langle>G\<rangle>\<close>].
  have eq2: "(Dec G u) \<cdot> (Dec G v) = [u \<cdot> v]"
    using  \<open>u \<cdot> v \<in>B G\<close> nonsimp[of "(Dec G u) \<cdot> (Dec G v)"]
    unfolding eq1 append_in_lists_conv[of "(Dec G u)" "(Dec G v)" "G\<^sub>+"]
    using decI'[OF \<open>u \<in> \<langle>G\<rangle>\<close>] decI'[OF \<open>v \<in> \<langle>G\<rangle>\<close>]
    by (meson append_in_lists_conv)
  have "Dec G u = \<epsilon> \<or> Dec G v = \<epsilon>"
    using butlast_append[of "Dec G u" "Dec G v"]  unfolding eq2 butlast.simps(2)[of "u\<cdot>v" \<epsilon>]
    using   Nil_is_append_conv[of "Dec G u" "butlast (Dec G v)"] by auto
  thus ?thesis
    using decI[OF \<open>u \<in> \<langle>G\<rangle>\<close>] decI[OF \<open>v \<in> \<langle>G\<rangle>\<close>]
      concat.simps(1)
    by auto
qed

lemma simp_elI:
  assumes "b \<in> G" and "b \<noteq> \<epsilon>"  and all: "\<forall> u v. u \<noteq> \<epsilon> \<and> u \<in> \<langle>G\<rangle> \<and> v \<noteq> \<epsilon> \<and> v \<in> \<langle>G\<rangle> \<longrightarrow> u \<cdot> v \<noteq> b"
  shows "b \<in>B G"
  unfolding simple_element.simps
proof(simp add: \<open>b \<in> G\<close>, standard, standard, elim conjE)
  fix us assume "us \<in> lists G\<^sub>+" "concat us = b"
  hence "us \<noteq> \<epsilon>" using \<open>b \<noteq> \<epsilon>\<close> concat.simps(1) by blast
  hence "hd us \<in> \<langle>G\<rangle>" and "hd us \<noteq> \<epsilon>"
    using \<open>us \<in> lists G\<^sub>+\<close> lists_hd  gen_in by auto
  have "tl us = \<epsilon>"
  proof(rule ccontr)
    assume "tl us \<noteq> \<epsilon>"
    from nemp_concat_hull[of "tl us", OF this tl_lists[OF \<open>us \<in> lists G\<^sub>+\<close>]]
    show False
      using all \<open>hd us \<noteq> \<epsilon>\<close> \<open>hd us \<in> \<langle>G\<rangle>\<close>  concat.simps(2)[of "hd us" "tl us", symmetric]
      unfolding list.collapse[OF \<open>us \<noteq> \<epsilon>\<close>] \<open>concat us = b\<close>
      by blast
  qed
  hence "\<^bold>|us\<^bold>| = 1"
    using \<open>concat us = b\<close> assms(2) long_list_tl nonsing_concat_len by blast
   thus "\<^bold>|us\<^bold>| = Suc 0"
     by (simp add: \<open>b \<in> G\<close>)
qed

lemma simp_el_indecomp:
  assumes "b \<in>B G"
  shows "b \<in> G" and  "b \<noteq> \<epsilon>" and "\<forall> u v. u \<noteq> \<epsilon> \<and> u \<in> \<langle>G\<rangle> \<and> v \<noteq> \<epsilon> \<and> v \<in> \<langle>G\<rangle> \<longrightarrow> u \<cdot> v \<noteq> b"
  using assms basis_no_fact emp_nonsimp simple_element.simps by blast+

text\<open>We are ready to define the \emph{basis} as the set of all simple elements.\<close>

fun basis :: "'a list set  \<Rightarrow> 'a list set" ("\<BB> _" [51] ) where
  basisdef:  "basis G = {x. x \<in>B G}"

lemma basisI: "x \<in>B G \<Longrightarrow> x \<in> \<BB> G"
  by simp

lemma basisD: "x \<in> \<BB> G \<Longrightarrow> x \<in>B G"
  by simp

lemma emp_not_basis: "x \<in> \<BB> G \<Longrightarrow> x \<noteq> \<epsilon>"
  using basisD emp_nonsimp by blast

lemma basis_sub: "\<BB> G \<subseteq> G"
  using  basisdef by simp

lemma basis_drop_emp: "(\<BB> G)\<^sub>+ = \<BB> G"
  using emp_not_basis by blast

lemma simp_el_hull':  assumes "b \<in>B \<langle>G\<rangle>"  shows "b \<in>B G"
proof-
  have all: "\<forall>us. us \<in> lists G\<^sub>+ \<and> concat us = b \<longrightarrow> \<^bold>|us\<^bold>| = 1"
    using assms lists_gen_to_hull unfolding simple_element.simps by metis
  have "b \<in> \<langle>G\<rangle>"
    using assms simp_elD by auto
  obtain bs where "bs \<in> lists G\<^sub>+" and "concat bs = b"
    using  dec_ex[OF \<open>b \<in> \<langle>G\<rangle>\<close>] by blast
  have "b \<in> G"
    using lists_drop_emp[OF \<open>bs \<in> lists G\<^sub>+\<close>]
          lists_gen_to_hull[OF \<open>bs \<in> lists G\<^sub>+\<close>, THEN nonsimp[of bs "\<langle>G\<rangle>"],
          unfolded \<open>concat bs = b\<close>, OF \<open>b \<in>B \<langle>G\<rangle>\<close>] by simp
  thus "b \<in>B G"
    by (simp add: all)
qed

lemma simp_el_hull:  assumes "b \<in>B G" shows "b \<in>B \<langle>G\<rangle>"
  using simp_elI[of b "\<langle>G\<rangle>"] unfolding self_gen
  using assms gen_in simp_el_indecomp[OF \<open>b \<in>B G\<close>] by auto

lemma concat_tl_basis: "x # xs \<in> lists \<BB> G \<Longrightarrow> concat xs \<in> \<langle>G\<rangle>"
  unfolding hull_concat_lists by auto

text\<open>The basis generates the hull\<close>

lemma set_concat_len: assumes "us \<in> lists G\<^sub>+" "1 < \<^bold>|us\<^bold>|" "u \<in> set us" shows "\<^bold>|u\<^bold>| < \<^bold>|concat us\<^bold>|"
proof-
  obtain x y where "us = x \<cdot> [u] \<cdot> y" and "x \<cdot> y \<noteq> \<epsilon>"
    using split_list_long[OF \<open>1 < \<^bold>|us\<^bold>|\<close> \<open>u \<in> set us\<close>].
  hence "x \<cdot> y \<in> lists G\<^sub>+"
    using \<open>us \<in> lists G\<^sub>+\<close> by auto
  hence "\<^bold>|concat (x \<cdot> y)\<^bold>| \<noteq> 0"
    using \<open>x \<cdot> y \<noteq> \<epsilon>\<close> in_lists_conv_set  by force
  hence "\<^bold>|concat us\<^bold>| = \<^bold>|u\<^bold>| + \<^bold>|concat x\<^bold>| + \<^bold>|concat y\<^bold>|"
    using length_append \<open>us = x \<cdot> [u] \<cdot> y\<close> by simp
  thus ?thesis
    using \<open>\<^bold>|concat (x \<cdot> y)\<^bold>| \<noteq> 0\<close> by auto
qed

lemma non_simp_dec: assumes "w \<notin> \<BB> G" "w \<noteq> \<epsilon>" "w \<in> G"
  obtains us where "us \<in> lists G\<^sub>+" "1 < \<^bold>|us\<^bold>|" "concat us = w"
  using \<open>w \<noteq> \<epsilon>\<close> \<open>w \<in> G\<close> \<open>w \<notin> \<BB> G\<close> nonsing_concat_len  basisI[of w G, unfolded simple_element.simps]
  by blast

lemma basis_gen: "w \<in> G \<longrightarrow> w \<in> \<langle>\<BB> G\<rangle>"
proof (induct "length w" arbitrary: w rule: less_induct)
  case less
  {assume "w \<notin> \<BB> G" "w \<noteq> \<epsilon>" "w \<in> G"
    obtain us where "us \<in> lists G\<^sub>+" "1 < \<^bold>|us\<^bold>|" "concat us = w"
      using non_simp_dec[OF \<open>w \<notin> \<BB> G\<close> \<open>w \<noteq> \<epsilon>\<close> \<open>w \<in> G\<close>] by blast
    have "u \<in> set us \<Longrightarrow> u \<in> \<langle>\<BB> G\<rangle>" for u
      using  lists_drop_emp[OF \<open>us \<in> lists G\<^sub>+\<close>]
       set_concat_len[OF \<open>us \<in> lists G\<^sub>+\<close> \<open>1 < \<^bold>|us\<^bold>|\<close>, THEN less[unfolded \<open>concat us = w\<close>[symmetric], of u]]
       unfolding in_lists_conv_set[of us G] by blast
     from subsetI[of "set us", OF this]
     have ?case
      using  concat_in_hull[of us "\<langle>\<BB> G\<rangle>", unfolded self_gen \<open>concat us = w\<close>] by blast
    }
  thus ?case
    by auto
qed

theorem basis_gen_hull: "\<langle>\<BB> G\<rangle> = \<langle>G\<rangle>"
proof
  show "\<langle>\<BB> G\<rangle> \<subseteq> \<langle>G\<rangle>"
    unfolding hull_concat_lists by auto
  show  "\<langle>G\<rangle> \<subseteq> \<langle>\<BB> G\<rangle>"
  proof
    fix x  show  "x \<in> \<langle>G\<rangle> \<Longrightarrow> x \<in> \<langle>\<BB> G\<rangle>"
    proof (induct rule: hull.induct)
      show "\<And>w1 w2. w1 \<in> G \<Longrightarrow> w2 \<in> \<langle>\<BB> G\<rangle> \<Longrightarrow> w1 \<cdot> w2 \<in> \<langle>\<BB> G\<rangle>"
        using hull_closed[of _ "\<BB> G"] basis_gen[of _ G]  by blast
    qed auto
  qed
qed

lemma basis_gen_hull': "\<langle>\<BB> \<langle>G\<rangle>\<rangle> = \<langle>G\<rangle>"
  using basis_gen_hull self_gen by blast

theorem basis_of_hull: "\<BB> G = \<BB> \<langle>G\<rangle>"
proof
  show "\<BB> G  \<subseteq>  \<BB> \<langle>G\<rangle>"
    using basisD basisI simp_el_hull by blast
  show "\<BB> \<langle>G\<rangle>  \<subseteq>  \<BB> G"
    using basisD basisI simp_el_hull' by blast
qed

text\<open>The basis is the smallest generating set.\<close>
theorem "\<langle>S\<rangle> = \<langle>G\<rangle> \<Longrightarrow> \<BB> G \<subseteq> S"
  by (metis basis_of_hull basis_sub)

text\<open>An arbitrary set between basis and the hull is generating...\<close>
lemma gen_sets: assumes "\<BB> G \<subseteq> S" and "S \<subseteq> \<langle>G\<rangle>" shows "\<langle>S\<rangle> = \<langle>G\<rangle>"
  using  image_mono[OF lists_mono[of S "\<langle>G\<rangle>"], of concat, OF \<open>S \<subseteq> \<langle>G\<rangle>\<close>] image_mono[OF lists_mono[of "\<BB> G" S], of concat, OF \<open>\<BB> G \<subseteq> S\<close>]
  unfolding sym[OF hull_concat_lists]  basis_gen_hull
  using  subset_antisym[of "\<langle>S\<rangle>" "\<langle>G\<rangle>"] self_gen by auto

text\<open>... and has the same basis\<close>
lemma basis_sets: "\<BB> G \<subseteq> S \<Longrightarrow> S \<subseteq> \<langle>G\<rangle> \<Longrightarrow> \<BB> G = \<BB> S"
  by (metis basis_of_hull  gen_sets)

text\<open>Any nonempty composed element has a decomposition into basis elements with many useful properties\<close>

lemma non_simp_fac: assumes "w \<noteq> \<epsilon>" and "w \<in> \<langle>G\<rangle>" and "w \<notin> \<BB> G"
  obtains us where "1 < \<^bold>|us\<^bold>|" and "us \<noteq> \<epsilon>" and  "us \<in> lists \<BB> G" and
    "hd us \<noteq> \<epsilon>" and "hd us \<in> \<langle>G\<rangle>" and
    "concat(tl us) \<noteq> \<epsilon>" and "concat(tl us) \<in> \<langle>G\<rangle>" and
    "w = hd us \<cdot> concat(tl us)"
proof-
  obtain us where "us \<in> lists \<BB> G" and "concat us = w"
    using \<open>w \<in> \<langle>G\<rangle>\<close> dec_dom'[of w "\<BB> G"] decI[of w "\<BB> G"]
    unfolding basis_gen_hull
    by blast
  hence "us \<noteq> \<epsilon>"
    using  \<open>w \<noteq> \<epsilon>\<close> concat.simps(1)
    by blast
  from lists_hd[OF this \<open>us \<in> lists \<BB> G\<close>, THEN emp_not_basis]
    lists_hd[OF this \<open>us \<in> lists \<BB> G\<close>, THEN gen_in[of "hd us" "\<BB> G", unfolded basis_gen_hull]]
  have "hd us \<noteq> \<epsilon>" and "hd us \<in> \<langle>G\<rangle>".
  have  "1 < \<^bold>|us\<^bold>|"
    using \<open>w \<notin> \<BB> G\<close> lists_hd[OF \<open>us \<noteq> \<epsilon>\<close> \<open>us \<in> lists \<BB> G\<close>] \<open>w \<noteq> \<epsilon>\<close> \<open>w \<in> \<langle>G\<rangle>\<close>
      concat_len_one[of us, unfolded \<open>concat us = w\<close>]  nonsing_concat_len[of us, unfolded \<open>concat us = w\<close>] by blast
  from nemp_concat_hull[OF long_list_tl[OF this], of "\<BB> G", unfolded basis_drop_emp basis_gen_hull, OF tl_lists[OF \<open>us \<in> lists \<BB> G\<close>]]
  have "concat (tl us) \<in> \<langle>G\<rangle>" and "concat(tl us) \<noteq> \<epsilon>".
  have "w = hd us \<cdot> concat(tl us)"
    using \<open>us \<noteq> \<epsilon>\<close> \<open>us \<in> lists \<BB> G\<close> \<open>concat us = w\<close> concat.simps(2)[of "hd us" "tl us"] list.collapse[of us]
    by argo
  from that[OF \<open>1 < \<^bold>|us\<^bold>|\<close> \<open>us \<noteq> \<epsilon>\<close> \<open>us \<in> lists \<BB> G\<close> \<open>hd us \<noteq> \<epsilon>\<close> \<open>hd us \<in> \<langle>G\<rangle>\<close> \<open>concat (tl us) \<noteq> \<epsilon>\<close> \<open>concat (tl us) \<in> \<langle>G\<rangle>\<close> this]
  show thesis.
qed

lemma basis_dec: "p \<in> \<langle>G\<rangle> \<Longrightarrow> s \<in> \<langle>G\<rangle> \<Longrightarrow> p \<cdot> s \<in> \<BB> G \<Longrightarrow> p = \<epsilon> \<or> s = \<epsilon>"
  using basis_no_fact[of p G s] by simp

lemma non_simp_fac': "w \<notin> \<BB> G \<Longrightarrow> w \<noteq> \<epsilon> \<Longrightarrow> w \<in> \<langle>G\<rangle> \<Longrightarrow> \<exists>us. us \<in> lists G\<^sub>+ \<and> w = concat us \<and> \<^bold>|us\<^bold>| \<noteq> 1"
  by (metis basisI concat_len_one decI' dec_dom' decI dec_nemp lists_hd nemp_elem_setI simple_element.elims(3))

lemma emp_gen_iff: "G\<^sub>+ = {} \<longleftrightarrow> \<langle>G\<rangle> = {\<epsilon>}"
proof
  assume "G\<^sub>+ = {}" show "\<langle>G\<rangle> = {\<epsilon>}"
    using  hull_drop_one[of G, unfolded \<open>G\<^sub>+ = {}\<close> emp_gen_set].
next
  assume "\<langle>G\<rangle> = {\<epsilon>}" thus"G\<^sub>+ = {}" by blast
qed

lemma emp_basis_iff:  "\<BB> G = {} \<longleftrightarrow> G\<^sub>+ = {}"
  using emp_gen_iff[of "\<BB> G", unfolded basis_gen_hull basis_drop_emp, folded emp_gen_iff].

section "Code"

text\<open>A basis freely generating its hull is called a \emph{code}. By definition,
this means that generated elements have unique factorizations into the elements of the code.\<close>

locale code =
  fixes \<C>
  assumes \<C>_is_code: "xs \<in> lists \<C> \<Longrightarrow> ys \<in> lists \<C> \<Longrightarrow> concat xs = concat ys \<Longrightarrow> xs = ys"
begin

lemma emp_not_in_code: "\<epsilon> \<notin> \<C>"
proof
  assume "\<epsilon> \<in> \<C>"
  hence "[] \<in> lists \<C>" and "[\<epsilon>] \<in> lists \<C>" and "concat [] = concat [\<epsilon>]" and "[] \<noteq> [\<epsilon>]"
    by simp+
  thus False
    using \<C>_is_code by blast
qed

lemma code_simple: "c \<in> \<C> \<Longrightarrow> c \<in>B \<C>"
  unfolding   simple_element.simps
proof
  fix c assume "c \<in> \<C>"
  hence "[c] \<in> lists \<C>"
    by simp
  show "\<forall>us. us \<in> lists \<C>\<^sub>+ \<and> concat us = c \<longrightarrow> \<^bold>|us\<^bold>| = 1"
  proof
    fix us
    {assume "us \<in> lists \<C>\<^sub>+" "concat us = c"
      hence "us \<in> lists \<C>" by blast
      hence  "us = [c]"
        using \<open>concat us = c\<close> \<open>c \<in> \<C>\<close> \<C>_is_code[of "[c]", OF \<open>[c] \<in> lists \<C>\<close> \<open>us \<in> lists \<C>\<close>] emp_not_in_code by auto}
    thus "us \<in> lists \<C>\<^sub>+ \<and> concat us = c \<longrightarrow> \<^bold>|us\<^bold>| = 1"
      using sing_len[of c] by fastforce
  qed
qed

lemma code_is_basis: "\<BB> \<C> = \<C>"
  using code_simple basisdef[of \<C>] basis_sub by blast

lemma code_unique_dec: "us \<in> lists \<C> \<Longrightarrow> Dec \<C> (concat us) = us"
  using dec_dom'[of "concat us" \<C>, THEN \<C>_is_code, of us]
    decI[of "concat us" \<C>] hull_concat_lists[of \<C>] image_eqI[of "concat us" concat us "lists \<C>"]
  by argo

lemma code_unique_ref: "us \<in> lists \<langle>\<C>\<rangle> \<Longrightarrow> refine \<C> us = decompose \<C> (concat us)"
proof-
  assume "us \<in> lists \<langle>\<C>\<rangle>"
  hence "concat (refine \<C> us) = concat us"
    using ref by fastforce
  hence eq: "concat (refine \<C> us) = concat (decompose \<C> (concat us))"
    using  decI[OF hull_closed_lists[OF \<open>us \<in> lists \<langle>\<C>\<rangle>\<close>]] by auto
  have dec: "Dec \<C> (concat us) \<in> lists \<C>"
    using \<open>us \<in> lists \<langle>\<C>\<rangle>\<close> dec_dom' hull_closed_lists by blast
  have ref: "Ref \<C> us \<in> lists \<C>"
    using lists_drop_emp[OF ref_in[OF \<open>us \<in> lists \<langle>\<C>\<rangle>\<close>]].
  show ?thesis
    using \<C>_is_code[OF ref dec eq].
qed

lemma code_dec_morph: assumes "x \<in> \<langle>\<C>\<rangle>" "y \<in> \<langle>\<C>\<rangle>"
  shows "(Dec \<C> x) \<cdot> (Dec \<C> y) = Dec \<C> (x\<cdot>y)"
proof-
  have eq: "(Dec \<C> x) \<cdot> (Dec \<C> y) = Dec \<C> (concat ((Dec \<C> x) \<cdot> (Dec \<C> y)))"
    using dec_dom'[OF \<open>x \<in> \<langle>\<C>\<rangle>\<close>] dec_dom'[OF \<open>y \<in> \<langle>\<C>\<rangle>\<close>]
      code.code_unique_dec[OF code_axioms, of "(Dec \<C> x) \<cdot> (Dec \<C> y)", unfolded append_in_lists_conv, symmetric]
    by blast
  moreover have "concat ((Dec \<C> x) \<cdot> (Dec \<C> y)) = (x \<cdot> y)"
    using concat_morph[of "Dec \<C> x" "Dec \<C> y", symmetric]
    unfolding decI[OF \<open>x \<in> \<langle>\<C>\<rangle>\<close>] decI[OF \<open>y \<in> \<langle>\<C>\<rangle>\<close>].
  ultimately show "(Dec \<C> x) \<cdot> (Dec \<C> y) = Dec \<C> (x\<cdot>y)"
    by argo
qed

lemma code_el_dec: "c \<in> \<C> \<Longrightarrow> decompose \<C> c = [c]"
  using code_unique_dec[of "[c]"] by auto

lemma code_ref_list: "us \<in> lists \<C> \<Longrightarrow> refine \<C> us = us"
proof (induct us)
  case (Cons a us)
  then show ?case using code_el_dec
    by simp
qed simp

lemma code_ref_gen: assumes "G \<subseteq> \<langle>\<C>\<rangle>" "u \<in> \<langle>G\<rangle>"
  shows "Dec \<C> u \<in> \<langle>decompose \<C> ` G\<rangle>"
proof-
  have "refine \<C> (Dec G u) = Dec \<C> u"
    using  dec_dom'[OF \<open>u \<in> \<langle>G\<rangle>\<close>]  \<open>G \<subseteq> \<langle>\<C>\<rangle>\<close> code_unique_ref[of "Dec G u", unfolded decI[OF \<open>u \<in> \<langle>G\<rangle>\<close>]] by blast
  from ref_gen[of "Dec G u" G, OF dec_dom'[OF \<open>u \<in> \<langle>G\<rangle>\<close>], of \<C>, unfolded this, OF \<open>G \<subseteq> \<langle>\<C>\<rangle>\<close>]
  show ?thesis.
qed

end \<comment> \<open>end context code\<close>

section \<open>Binary code\<close>

text\<open>We pay a special attention to two element codes.
In particular, we show that two words form a code if and only if they do not commute. This means that two
words either commute, or do not satisfy any nontrivial relation.
\<close>

locale binary_code =
  fixes u\<^sub>0 u\<^sub>1
  assumes non_comm: "u\<^sub>0 \<cdot> u\<^sub>1 \<noteq> u\<^sub>1 \<cdot> u\<^sub>0"

begin

lemma bin_fst_nemp: "u\<^sub>0 \<noteq> \<epsilon>"
  using non_comm by auto

text\<open>A crucial property of two element codes is the constant decoding delay given by the word $\alpha$,
which is a prefix of any generating word (sufficiently long), while the letter
immediately after this common prefix indicates the first element of the decomposition.
\<close>

definition  \<alpha> where bin_lcp_def [simp]: "\<alpha> =  u\<^sub>0\<cdot>u\<^sub>1 \<and>\<^sub>p u\<^sub>1\<cdot>u\<^sub>0"
definition  c\<^sub>0 where fst_mismatch_def: "c\<^sub>0 =  (u\<^sub>0\<cdot>u\<^sub>1)!\<^bold>|\<alpha>\<^bold>|"
definition  c\<^sub>1 where snd_mismatch_def: "c\<^sub>1 =  (u\<^sub>1\<cdot>u\<^sub>0)!\<^bold>|\<alpha>\<^bold>|"

lemma bin_mismatch_neq: "c\<^sub>0 \<noteq> c\<^sub>1"
  unfolding fst_mismatch_def snd_mismatch_def bin_lcp_def
  using non_comm lcp_mismatch' pref_comp_eq[of "u\<^sub>0 \<cdot> u\<^sub>1" "u\<^sub>1 \<cdot> u\<^sub>0", OF _ swap_len]
  unfolding prefix_comparable_def
  by blast

lemma bin_lcp_pref_fst_snd: "\<alpha> \<le>p u\<^sub>0 \<cdot> u\<^sub>1" and bin_lcp_pref_snd_fst: "\<alpha> \<le>p u\<^sub>1 \<cdot> u\<^sub>0"
  unfolding bin_lcp_def using longest_common_prefix_prefix1 longest_common_prefix_prefix2.

lemma bin_lcp_short: "\<^bold>|\<alpha>\<^bold>| < \<^bold>|u\<^sub>0\<^bold>| + \<^bold>|u\<^sub>1\<^bold>|"
proof-
  have "\<not> u\<^sub>0\<cdot>u\<^sub>1 \<le>p u\<^sub>1\<cdot>u\<^sub>0"
    using comm_ruler non_comm by blast
  from lcp_len'[OF this, folded bin_lcp_def, unfolded length_append]
  show  "\<^bold>|\<alpha>\<^bold>| < \<^bold>|u\<^sub>0\<^bold>| + \<^bold>|u\<^sub>1\<^bold>|".
qed

lemma bin_lcp_fst_mismatch_pref:  "\<alpha> \<cdot> [c\<^sub>0] \<le>p u\<^sub>0 \<cdot> \<alpha>"
proof-
  have "\<alpha> \<cdot> [c\<^sub>0] \<le>p u\<^sub>0 \<cdot> u\<^sub>1"
    using  append_one_prefix[of \<alpha> "u\<^sub>0 \<cdot> u\<^sub>1", folded fst_mismatch_def, OF bin_lcp_pref_fst_snd, unfolded length_append, OF bin_lcp_short].
  hence "\<alpha> \<cdot> [c\<^sub>0] \<le>p u\<^sub>0 \<cdot> (u\<^sub>1 \<cdot> u\<^sub>0)"
    using pref_prolong by blast
  from pref_prod_pref_short[OF this bin_lcp_pref_snd_fst, unfolded length_append sing_len]
  show "\<alpha> \<cdot> [c\<^sub>0] \<le>p u\<^sub>0 \<cdot> \<alpha>"
    using  nemp_len[OF bin_fst_nemp] by linarith
qed

lemma not_fst_snd_pref:  "\<not> u\<^sub>0 \<cdot> u\<^sub>1 \<le>p \<alpha>"
  using bin_lcp_short[folded length_append[of u\<^sub>0 u\<^sub>1]]  prefix_order.antisym[OF bin_lcp_pref_fst_snd] by fastforce

lemma bin_lcp_fst_mismatch_pref':  "\<alpha> \<cdot> [c\<^sub>0] \<le>p u\<^sub>0 \<cdot> u\<^sub>1"
  using strict_prefixI[OF bin_lcp_pref_fst_snd, THEN add_nth_pref, folded fst_mismatch_def] not_fst_snd_pref
  self_pref[of \<alpha>] by fastforce

interpretation symcode: binary_code u\<^sub>1 u\<^sub>0
  rewrites  "symcode.c\<^sub>0 = c\<^sub>1" and  "symcode.c\<^sub>1 = c\<^sub>0" and "symcode.\<alpha> = \<alpha>"
proof-
  show "binary_code u\<^sub>1 u\<^sub>0"
    unfolding  binary_code_def using non_comm by simp
  show "binary_code.\<alpha> u\<^sub>1 u\<^sub>0 = \<alpha>"
    by (simp add: \<open>binary_code u\<^sub>1 u\<^sub>0\<close> binary_code.bin_lcp_def lcp_sym)
  show "binary_code.c\<^sub>0 u\<^sub>1 u\<^sub>0 = c\<^sub>1"
    by (simp add: \<open>binary_code u\<^sub>1 u\<^sub>0\<close> \<open>binary_code.\<alpha> u\<^sub>1 u\<^sub>0 = \<alpha>\<close> binary_code.fst_mismatch_def snd_mismatch_def)
  show "binary_code.c\<^sub>1 u\<^sub>1 u\<^sub>0 = c\<^sub>0"
    by (simp add: \<open>binary_code u\<^sub>1 u\<^sub>0\<close> \<open>binary_code.\<alpha> u\<^sub>1 u\<^sub>0 = \<alpha>\<close> binary_code.snd_mismatch_def fst_mismatch_def)
qed

lemmas bin_snd_nemp = symcode.bin_fst_nemp and
       bin_snd_mismatch = symcode.bin_lcp_fst_mismatch_pref

lemma bin_lcp_fst_lcp: "\<alpha> \<le>p u\<^sub>0 \<cdot> \<alpha>" and bin_lcp_snd_lcp: "\<alpha> \<le>p u\<^sub>1 \<cdot> \<alpha>"
  using bin_lcp_fst_mismatch_pref  bin_snd_mismatch by auto

lemma bin_all_nemp: "ws \<in> lists {u\<^sub>0,u\<^sub>1} \<Longrightarrow> concat ws = \<epsilon> \<Longrightarrow> ws = \<epsilon>"
using bin_fst_nemp bin_snd_nemp by(induct ws, simp, auto)

lemma bin_lcp_all_lcp: "ws \<in> lists {u\<^sub>0,u\<^sub>1} \<Longrightarrow> \<alpha> \<le>p concat ws \<cdot> \<alpha>"
  proof(induct ws rule: rev_induct, simp)
    case (snoc x xs)
  have x_or: "x = u\<^sub>0 \<or> x = u\<^sub>1"
    using \<open>xs \<cdot> [x] \<in> lists {u\<^sub>0, u\<^sub>1}\<close> by simp
  have "xs \<in> lists {u\<^sub>0, u\<^sub>1}"
      using \<open>xs \<cdot> [x] \<in> lists {u\<^sub>0, u\<^sub>1}\<close> by auto
  from pref_prolong[OF snoc.hyps, OF this, of "x\<cdot>\<alpha>", unfolded lassoc]
  show ?case
    using bin_lcp_fst_lcp bin_lcp_snd_lcp disjE[OF x_or] by auto
qed

lemma bin_code_alpha: assumes "us \<in> lists {u\<^sub>0,u\<^sub>1}" and "vs \<in> lists {u\<^sub>0,u\<^sub>1}" and "hd us  \<noteq> hd vs"
  shows "concat us \<cdot> \<alpha> \<and>\<^sub>p concat vs \<cdot> \<alpha> = \<alpha>"
  using assms
proof (induct us vs rule: list_induct2', simp)
  case (2 x xs)
  show ?case
    using bin_lcp_all_lcp[OF \<open>x # xs \<in> lists {u\<^sub>0, u\<^sub>1}\<close>, folded lcp_pref_conv, unfolded lcp_sym[of \<alpha>]] by simp
next
  case (3 y ys)
  show ?case
    using bin_lcp_all_lcp[OF \<open>y # ys \<in> lists {u\<^sub>0, u\<^sub>1}\<close>, folded lcp_pref_conv] by simp
next
  case (4 x xs y ys)
  interpret i: binary_code x y
    using "4.prems"(1) "4.prems"(2) "4.prems"(3) non_comm binary_code.intro by auto
  have alph: "{u\<^sub>0,u\<^sub>1} = {x,y}"
    using "4.prems"(1) "4.prems"(2) "4.prems"(3) by auto
  from disjE[OF this[unfolded doubleton_eq_iff]]
  have \<alpha>id: "i.\<alpha> = \<alpha>"
    unfolding bin_lcp_def i.bin_lcp_def using lcp_sym by auto
  have c0: "i.\<alpha> \<cdot> [i.c\<^sub>0] \<le>p x \<cdot> concat xs \<cdot> i.\<alpha>"
    using  i.bin_lcp_all_lcp[of xs] \<open>x # xs \<in> lists {u\<^sub>0, u\<^sub>1}\<close>[unfolded Cons_in_lists_iff alph]
      pref_prolong[OF i.bin_lcp_fst_mismatch_pref] by blast
  have c1: "i.\<alpha> \<cdot> [i.c\<^sub>1] \<le>p y \<cdot> concat ys \<cdot> i.\<alpha>"
    using  i.bin_lcp_all_lcp[of ys] \<open>y # ys \<in> lists {u\<^sub>0, u\<^sub>1}\<close>[unfolded Cons_in_lists_iff alph]
      pref_prolong[OF i.bin_snd_mismatch] by blast
  have "i.\<alpha>\<cdot>[i.c\<^sub>0] \<and>\<^sub>p i.\<alpha>\<cdot>[i.c\<^sub>1] = i.\<alpha>"
    by (simp add: i.bin_mismatch_neq lcp_first_mismatch')
  from lcp_rulers[OF c0 c1, unfolded this, unfolded \<alpha>id]
  show ?case
    unfolding concat.simps(2) rassoc pref_cancel_conv  using i.bin_mismatch_neq by simp
qed

theorem bin_code: assumes "us \<in> lists {u\<^sub>0,u\<^sub>1}" and "vs \<in> lists {u\<^sub>0,u\<^sub>1}" and "concat us = concat vs"
  shows "us = vs"
  using assms
proof (induct us vs rule: list_induct2', simp)
case (2 x xs)
  then show ?case
    using bin_fst_nemp bin_snd_nemp by auto
next
  case (3 y ys)
  then show ?case
    using bin_fst_nemp bin_snd_nemp by auto
next
  case (4 x xs y ys)
  then show ?case
  proof(cases "x = y")
    assume "x = y"  thus "x # xs = y # ys"
      using "4.hyps" \<open>concat (x # xs) = concat (y # ys)\<close>[unfolded  concat.simps(2) \<open>x = y\<close>, unfolded cancel]
      \<open>y # ys \<in> lists {u\<^sub>0, u\<^sub>1}\<close>[unfolded Cons_in_lists_iff] \<open>x # xs \<in> lists {u\<^sub>0, u\<^sub>1}\<close>[unfolded Cons_in_lists_iff]
      by simp
  next
    assume "x \<noteq> y"
    have "concat(y # ys) = \<epsilon>"
      using bin_code_alpha[OF \<open>x # xs \<in> lists {u\<^sub>0, u\<^sub>1}\<close> \<open>y # ys \<in> lists {u\<^sub>0, u\<^sub>1}\<close>, unfolded list.sel(1) \<open>concat (x # xs) = concat (y # ys)\<close>, OF \<open>x \<noteq> y\<close>]
      by simp
    from bin_all_nemp[OF \<open>y # ys \<in> lists {u\<^sub>0, u\<^sub>1}\<close> this]
    have False by simp
    thus "x # xs = y # ys" by blast
  qed
qed

end

lemmas no_comm_bin_code = binary_code.bin_code[unfolded binary_code_def]

theorem bin_code_code: assumes "u \<cdot> v \<noteq> v \<cdot> u" shows "code {u, v}"
  unfolding code_def using no_comm_bin_code[OF assms] by blast

section \<open>Free hull\<close>

text\<open>While not every set $G$ of generators is a code, there is a unique minimal free monoid containing it, called the \emph{free hull} of $G$.
It can be defined inductively using the property known as the \emph{stability condition}.
\<close>

inductive_set free_hull :: "'a list set \<Rightarrow> 'a list set" ("\<langle>_\<rangle>\<^sub>F")
  for G where
    "\<epsilon> \<in> \<langle>G\<rangle>\<^sub>F"
  | free_gen_in: "w \<in> G \<Longrightarrow> w \<in> \<langle>G\<rangle>\<^sub>F"
  | "w1 \<in> \<langle>G\<rangle>\<^sub>F \<Longrightarrow> w2 \<in> \<langle>G\<rangle>\<^sub>F \<Longrightarrow> w1 \<cdot> w2 \<in> \<langle>G\<rangle>\<^sub>F"
  | "p \<in> \<langle>G\<rangle>\<^sub>F \<Longrightarrow> q \<in> \<langle>G\<rangle>\<^sub>F \<Longrightarrow> p \<cdot> w \<in> \<langle>G\<rangle>\<^sub>F \<Longrightarrow> w \<cdot> q \<in> \<langle>G\<rangle>\<^sub>F \<Longrightarrow> w \<in> \<langle>G\<rangle>\<^sub>F" \<comment> \<open>the stability condition\<close>

lemmas [intro] = free_hull.intros

text\<open>The defined set indeed is a hull.\<close>

lemma free_hull_hull: "\<langle>\<langle>G\<rangle>\<^sub>F\<rangle> = \<langle>G\<rangle>\<^sub>F"
proof
  show "\<langle>G\<rangle>\<^sub>F \<subseteq> \<langle>\<langle>G\<rangle>\<^sub>F\<rangle>"
    by (simp add: genset_sub)
  show "\<langle>\<langle>G\<rangle>\<^sub>F\<rangle> \<subseteq> \<langle>G\<rangle>\<^sub>F"
  proof
    fix x assume "x \<in> \<langle>\<langle>G\<rangle>\<^sub>F\<rangle>"
    thus "x \<in> \<langle>G\<rangle>\<^sub>F"
    proof (rule hull.induct)
      show " \<epsilon> \<in> \<langle>G\<rangle>\<^sub>F"
        by (simp add: free_hull.intros(1))
      show "\<And>w1 w2. w1 \<in> \<langle>G\<rangle>\<^sub>F \<Longrightarrow> w2 \<in> \<langle>\<langle>G\<rangle>\<^sub>F\<rangle> \<Longrightarrow> w2 \<in> \<langle>G\<rangle>\<^sub>F \<Longrightarrow> w1 \<cdot> w2 \<in> \<langle>G\<rangle>\<^sub>F"
        by (simp add: free_hull.intros(3))
    qed
  qed
qed

text\<open>The free hull is always (non-strictly) larger than the hull.\<close>

lemma hull_in_free_hull: "\<langle>G\<rangle> \<subseteq> \<langle>G\<rangle>\<^sub>F"
proof
  fix x assume "x \<in> \<langle>G\<rangle>"
  then show "x \<in> \<langle>G\<rangle>\<^sub>F"
    using free_hull.intros(3)
      hull_induct[of x G "\<lambda> x. x \<in> \<langle>G\<rangle>\<^sub>F", OF \<open>x \<in> \<langle>G\<rangle>\<close> free_hull.intros(1)[of G] free_hull.intros(2)]
    by auto
qed

text\<open>On the other hand, it can be proved that the \emph{free basis}, defined as the basis of the free hull,  has a (non-strictly) smaller cardinality than the ordinary basis.\<close>

definition free_basis ::  "'a list set \<Rightarrow> 'a list set" ("\<BB>\<^sub>F _" [54] 55)
  where  "free_basis G \<equiv> \<BB> \<langle>G\<rangle>\<^sub>F"

lemma basis_gen_hull_free: "\<langle>\<BB>\<^sub>F G\<rangle> = \<langle>G\<rangle>\<^sub>F"
  unfolding free_basis_def using basis_gen_hull free_hull_hull by blast

lemma genset_sub_free: "G \<subseteq> \<langle>G\<rangle>\<^sub>F"
  by (simp add: free_hull.free_gen_in subsetI)

text
\<open>We have developed two points of view on freeness:
\<^item> being a free hull, that is, to satisfy the stability condition;
\<^item> being generated by a code.\<close>

text\<open>We now show their equivalence\<close>

text\<open>First, basis of a free hull is a code.\<close>

lemma free_basis_code: "code (\<BB>\<^sub>F G)"
proof
  fix xs ys
  show "xs \<in> lists (\<BB>\<^sub>F G) \<Longrightarrow> ys \<in> lists (\<BB>\<^sub>F G) \<Longrightarrow> concat xs = concat ys \<Longrightarrow> xs = ys"
  proof(induction xs ys rule: list_induct2', simp)
    case (2 x xs)
    show ?case
      using listsE[OF \<open>x # xs \<in> lists (\<BB>\<^sub>F G)\<close>, of "x \<in> \<BB>\<^sub>F G", unfolded free_basis_def, THEN emp_not_basis]
      concat.simps(2)[of x xs, unfolded \<open>concat (x # xs) = concat \<epsilon>\<close>[unfolded concat.simps(1)], symmetric, unfolded append_is_Nil_conv[of x "concat xs"]]
      by blast
  next
    case (3 y ys)
    show ?case
      using  listsE[OF \<open>y # ys \<in> lists (\<BB>\<^sub>F G)\<close>, of "y \<in> \<BB>\<^sub>F G", unfolded free_basis_def, THEN emp_not_basis]
      concat.simps(2)[of y ys, unfolded \<open>concat \<epsilon> = concat (y # ys)\<close>[unfolded concat.simps(1),symmetric],symmetric, unfolded append_is_Nil_conv[of y "concat ys"]]
      by blast
  next
    case (4 x xs y ys)
    have "\<^bold>|x\<^bold>| = \<^bold>|y\<^bold>|"
    proof(rule ccontr)
      assume "\<^bold>|x\<^bold>| \<noteq> \<^bold>|y\<^bold>|"
      have "x \<cdot> concat xs = y \<cdot> concat ys"
        using \<open>concat (x # xs) = concat (y # ys)\<close> by simp
      then obtain t where or: "x = y \<cdot> t \<and> t \<cdot> concat xs = concat ys \<or> x \<cdot> t = y \<and> concat xs = t \<cdot> concat ys"
        using append_eq_append_conv2[of x "concat xs" y "concat ys"]  by blast
      hence "t \<noteq> \<epsilon>"
        using \<open>\<^bold>|x\<^bold>| \<noteq> \<^bold>|y\<^bold>|\<close> by auto
      have "x \<in> \<BB>\<^sub>F G" and "y \<in> \<BB>\<^sub>F G"
        using  listsE[OF \<open>x # xs \<in> lists (\<BB>\<^sub>F G)\<close>, of "x \<in> \<BB>\<^sub>F G" ] listsE[OF \<open>y # ys \<in> lists (\<BB>\<^sub>F G)\<close>, of "y \<in> \<BB>\<^sub>F G" ] by blast+
      hence "x \<noteq> \<epsilon>" and "y \<noteq> \<epsilon>"
        unfolding free_basis_def using emp_not_basis by blast+
      have  "x \<in> \<langle>G\<rangle>\<^sub>F" and "y \<in> \<langle>G\<rangle>\<^sub>F"
        using basis_sub[of "\<langle>G\<rangle>\<^sub>F", unfolded free_basis_def[symmetric] ] \<open>x # xs \<in> lists (\<BB>\<^sub>F G)\<close>
          \<open>y # ys \<in> lists (\<BB>\<^sub>F G)\<close> by auto
      have "concat xs \<in> \<langle>G\<rangle>\<^sub>F" and "concat ys \<in> \<langle>G\<rangle>\<^sub>F"
        using concat_tl_basis[OF \<open>x # xs \<in> lists (\<BB>\<^sub>F G)\<close>[unfolded free_basis_def]]
              concat_tl_basis[OF \<open>y # ys \<in> lists (\<BB>\<^sub>F G)\<close>[unfolded free_basis_def]] unfolding free_hull_hull.
      have "t \<in> \<langle>G\<rangle>\<^sub>F"
        using or free_hull.intros(4) \<open>x \<in> \<langle>G\<rangle>\<^sub>F\<close> \<open>y \<in> \<langle>G\<rangle>\<^sub>F\<close> \<open>concat xs \<in> \<langle>G\<rangle>\<^sub>F\<close> \<open>concat ys \<in> \<langle>G\<rangle>\<^sub>F\<close> by metis
      thus False
        using or basis_dec[of x "\<langle>G\<rangle>\<^sub>F" t, unfolded free_hull_hull, OF \<open>x \<in> \<langle>G\<rangle>\<^sub>F\<close> \<open>t \<in> \<langle>G\<rangle>\<^sub>F\<close>]
          basis_dec[of y "\<langle>G\<rangle>\<^sub>F" t, unfolded free_hull_hull, OF \<open>y \<in> \<langle>G\<rangle>\<^sub>F\<close> \<open>t \<in> \<langle>G\<rangle>\<^sub>F\<close>]
        using  \<open>t \<noteq> \<epsilon>\<close> \<open>x \<noteq> \<epsilon>\<close> \<open>y \<noteq> \<epsilon>\<close> \<open>x \<in> \<BB>\<^sub>F G\<close> \<open>y \<in> \<BB>\<^sub>F G\<close> unfolding free_basis_def
        by auto
    qed
    thus "x # xs = y # ys"
      using "4.IH" \<open>x # xs \<in> lists (\<BB>\<^sub>F G)\<close> \<open>y # ys \<in> lists (\<BB>\<^sub>F G)\<close> \<open>concat (x # xs) = concat (y # ys)\<close>
      by auto
  next
  qed
qed

text\<open>Second, a code generates its free hull.\<close>

lemma code_gen_free_hull: "code C \<Longrightarrow> \<langle>C\<rangle>\<^sub>F = \<langle>C\<rangle>"
proof
  assume "code C"
  show "\<langle>C\<rangle> \<subseteq> \<langle>C\<rangle>\<^sub>F"
    using hull_mon[of C "\<langle>C\<rangle>\<^sub>F"]
          free_hull.free_gen_in[of _ C]  subsetI[of C "\<langle>C\<rangle>\<^sub>F"]
    unfolding free_hull_hull[of C] by auto
  show "\<langle>C\<rangle>\<^sub>F \<subseteq> \<langle>C\<rangle>"
  proof
    fix x assume "x \<in> \<langle>C\<rangle>\<^sub>F"
    have "\<epsilon> \<in> \<langle>C\<rangle>"
      by (simp add: hull.intros(1))
    show "x \<in> \<langle>C\<rangle>"
    proof(rule free_hull.induct[of x C],simp add: \<open>x \<in> \<langle>C\<rangle>\<^sub>F\<close>, (simp add: hull.intros hull_closed)+,
        simp add: gen_in, simp add: hull_closed)
      fix p q w assume "p \<in> \<langle>C\<rangle>" "q \<in> \<langle>C\<rangle>" "p \<cdot> w \<in> \<langle>C\<rangle>" "w \<cdot> q \<in> \<langle>C\<rangle>"
      have eq: "(Dec C p) \<cdot> (Dec C w \<cdot> q) = (Dec C p \<cdot> w) \<cdot> (Dec C q)"
        using code.code_dec_morph[OF \<open>code C\<close> \<open>p \<in> \<langle>C\<rangle>\<close> \<open>w \<cdot> q \<in> \<langle>C\<rangle>\<close>, unfolded lassoc]
        unfolding code.code_dec_morph[OF \<open>code C\<close> \<open>p \<cdot> w \<in> \<langle>C\<rangle>\<close> \<open>q \<in> \<langle>C\<rangle>\<close>, symmetric].
      have "Dec C p \<bowtie>  Dec C p \<cdot> w"
        using eqd_comp[OF eq].
      hence "Dec C p \<le>p  Dec C p \<cdot> w"
        using \<open>p \<cdot> w \<in> \<langle>C\<rangle>\<close> \<open>p \<in> \<langle>C\<rangle>\<close> concat_morph decI prefD pref_antisym triv_pref
        unfolding prefix_comparable_def
        by metis
      then obtain ts where "(Dec C p) \<cdot> ts =  Dec C p \<cdot> w"
        using lq_pref by blast
      hence  "ts \<in> lists C"
        using  append_in_lists_conv[of "Dec C p" ts C] dec_dom'[OF \<open>p \<cdot> w \<in> \<langle>C\<rangle>\<close>]
        unfolding \<open>(Dec C p) \<cdot> ts =  Dec C p \<cdot> w\<close> by blast
      hence "concat ts = w"
        using  concat_morph[of "Dec C p" ts]
        unfolding \<open>(Dec C p) \<cdot> ts =  Dec C p \<cdot> w\<close> decI[OF \<open>p \<cdot> w \<in> \<langle>C\<rangle>\<close>]  decI[OF \<open>p \<in> \<langle>C\<rangle>\<close>] by auto
      thus "w \<in> \<langle>C\<rangle>"
        using \<open>ts \<in> lists C\<close> by auto
    qed
  qed
qed

text\<open>That is, a code is its own free basis\<close>

lemma code_free_basis: assumes "code C" shows "C = \<BB>\<^sub>F C"
  using basis_of_hull[of C, unfolded code_gen_free_hull[OF assms, symmetric]
      code.code_is_basis[OF assms]]
  unfolding free_basis_def.

text\<open>Moreover, the free hull of G is the smallest code-generated hull containing G.
In other words, the term free hull is appropriate.\<close>

text\<open>First, several intuitive monotonicity and closure results.\<close>

lemma free_hull_mono: "G \<subseteq> H \<Longrightarrow> \<langle>G\<rangle>\<^sub>F \<subseteq> \<langle>H\<rangle>\<^sub>F"
proof
  assume "G \<subseteq> H"
  fix x assume "x \<in> \<langle>G\<rangle>\<^sub>F"
  have el: "\<And> w. w \<in> G \<Longrightarrow> w \<in> \<langle>H\<rangle>\<^sub>F"
    using \<open>G \<subseteq> H\<close> free_hull.free_gen_in by auto
  show "x \<in> \<langle>H\<rangle>\<^sub>F"
  proof (rule free_hull.induct[of x G], simp add: \<open>x \<in> \<langle>G\<rangle>\<^sub>F\<close>, simp add: free_hull.intros(1),
      simp add: el, simp add: free_hull.intros(3))
    show "\<And>p q w. p \<in> \<langle>H\<rangle>\<^sub>F \<Longrightarrow>  q \<in> \<langle>H\<rangle>\<^sub>F \<Longrightarrow>  p \<cdot> w \<in> \<langle>H\<rangle>\<^sub>F \<Longrightarrow>  w \<cdot> q \<in> \<langle>H\<rangle>\<^sub>F \<Longrightarrow> w \<in> \<langle>H\<rangle>\<^sub>F"
      using free_hull.intros(4) by auto
  qed
qed

lemma free_hull_idem: "\<langle>\<langle>G\<rangle>\<^sub>F\<rangle>\<^sub>F = \<langle>G\<rangle>\<^sub>F"
proof
  show "\<langle>\<langle>G\<rangle>\<^sub>F\<rangle>\<^sub>F \<subseteq> \<langle>G\<rangle>\<^sub>F"
  proof
    fix x assume "x \<in> \<langle>\<langle>G\<rangle>\<^sub>F\<rangle>\<^sub>F"
    show "x \<in> \<langle>G\<rangle>\<^sub>F"
    proof (rule free_hull.induct[of x "\<langle>G\<rangle>\<^sub>F"], simp add: \<open>x \<in> \<langle>\<langle>G\<rangle>\<^sub>F\<rangle>\<^sub>F\<close>,
        simp add: free_hull.intros(1), simp add: free_hull.intros(2), simp add: free_hull.intros(3))
      show "\<And>p q w. p \<in> \<langle>G\<rangle>\<^sub>F \<Longrightarrow>  q \<in> \<langle>G\<rangle>\<^sub>F \<Longrightarrow>  p \<cdot> w \<in> \<langle>G\<rangle>\<^sub>F \<Longrightarrow>  w \<cdot> q \<in> \<langle>G\<rangle>\<^sub>F \<Longrightarrow> w \<in> \<langle>G\<rangle>\<^sub>F"
        using free_hull.intros(4) by auto
    qed
  qed
next
  show "\<langle>G\<rangle>\<^sub>F \<subseteq> \<langle>\<langle>G\<rangle>\<^sub>F\<rangle>\<^sub>F"
    using free_hull_hull hull_in_free_hull by auto
qed

lemma hull_gen_free_hull: "\<langle>\<langle>G\<rangle>\<rangle>\<^sub>F = \<langle>G\<rangle>\<^sub>F"
proof
  show " \<langle>\<langle>G\<rangle>\<rangle>\<^sub>F \<subseteq> \<langle>G\<rangle>\<^sub>F"
    using free_hull_idem free_hull_mono hull_in_free_hull by metis
next
  show "\<langle>G\<rangle>\<^sub>F \<subseteq> \<langle>\<langle>G\<rangle>\<rangle>\<^sub>F"
    by (simp add: free_hull_mono genset_sub)
qed

text \<open>Code is also the free basis of its hull.\<close>

lemma code_free_basis_hull: "code C \<Longrightarrow> C = \<BB>\<^sub>F \<langle>C\<rangle>"
  unfolding free_basis_def using code_free_basis[unfolded free_basis_def]
  unfolding  hull_gen_free_hull.

text\<open>The minimality of the free hull easily follows.\<close>

theorem free_hull_min: assumes "code C" and "G \<subseteq> \<langle>C\<rangle>" shows "\<langle>G\<rangle>\<^sub>F \<subseteq> \<langle>C\<rangle>"
  using free_hull_mono[OF \<open>G \<subseteq> \<langle>C\<rangle>\<close>] unfolding hull_gen_free_hull
  unfolding code_gen_free_hull[OF \<open>code C\<close>].

theorem free_hull_inter: "\<langle>G\<rangle>\<^sub>F = \<Inter> {M. G \<subseteq> M \<and> M = \<langle>M\<rangle>\<^sub>F}"
proof
  have "X \<in> {M. G \<subseteq> M \<and> M = \<langle>M\<rangle>\<^sub>F} \<Longrightarrow> \<langle>G\<rangle>\<^sub>F \<subseteq> X" for X
    unfolding mem_Collect_eq[of _ "\<lambda> M. G \<subseteq> M \<and> M = \<langle>M\<rangle>\<^sub>F"]
    using free_hull_mono[of G X] by simp
  from Inter_greatest[of "{M. G \<subseteq> M \<and> M = \<langle>M\<rangle>\<^sub>F}", OF this]
  show "\<langle>G\<rangle>\<^sub>F \<subseteq> \<Inter> {M. G \<subseteq> M \<and> M = \<langle>M\<rangle>\<^sub>F}"
    by blast
next
  show " \<Inter> {M. G \<subseteq> M \<and> M = \<langle>M\<rangle>\<^sub>F} \<subseteq> \<langle>G\<rangle>\<^sub>F"
    by (simp add: Inter_lower free_hull_idem genset_sub_free)
qed

text\<open>Decomposition into the free basis is a morphism.\<close>

lemma free_basis_dec_morph: "u \<in> \<langle>G\<rangle>\<^sub>F \<Longrightarrow> v \<in> \<langle>G\<rangle>\<^sub>F \<Longrightarrow>
    Dec (\<BB>\<^sub>F G) (u \<cdot> v) = (Dec (\<BB>\<^sub>F G) u) \<cdot> (Dec (\<BB>\<^sub>F G) v)"
  using code.code_dec_morph[OF free_basis_code, of u G v, symmetric,
        unfolded  basis_gen_hull_free[of G]].

section \<open>Lists as the free hull of singletons\<close>

text\<open>A crucial property of free monoids of words is that they can be seen as lists over the free basis,
instead as lists over the original alphabet.\<close>

abbreviation sings where "sings B \<equiv> {[b] | b. b \<in> B}"

lemma sings_image: "sings B =  (\<lambda> x. [x]) ` B"
  using Setcompr_eq_image.

lemma lists_sing_map_concat_ident: "xs \<in> lists (sings B) \<Longrightarrow> xs = map (\<lambda> x. [x]) (concat xs)"
  by (induct xs, simp, auto)

lemma code_sings: "code (sings B)"
proof
  fix xs ys assume xs: "xs \<in> lists (sings B)" and ys: "ys \<in> lists (sings B)"
     and eq: "concat xs = concat ys"
  from lists_sing_map_concat_ident[OF xs, unfolded eq]
  show "xs = ys" unfolding  lists_sing_map_concat_ident[OF ys, symmetric].
qed

lemma sings_gen_lists: "\<langle>sings B\<rangle> = lists B"
  unfolding hull_concat_lists
proof(intro equalityI subsetI, standard)
  fix xs
  show "xs \<in> concat ` lists (sings B) \<Longrightarrow> \<forall>x\<in>set xs. x \<in> B"
    by force
  assume "xs \<in> lists B"
  hence "map (\<lambda>x. x # \<epsilon>) xs \<in> lists (sings B)"
    by force
  from imageI[OF this, of concat]
  show "xs \<in> concat ` lists (sings B)"
    unfolding concat_map_sing_ident[of xs].
qed

lemma "sings B = \<BB>\<^sub>F (lists B)"
  using code_free_basis_hull[OF code_sings, of B, unfolded sings_gen_lists].

lemma map_sings: "xs \<in> lists B \<Longrightarrow> map (\<lambda>x. x # \<epsilon>) xs \<in> lists (sings B)"
  by (induct xs) auto

lemma dec_sings: "xs \<in> lists B \<Longrightarrow> Dec (sings B) xs = map (\<lambda> x. [x]) xs"
  using code.code_unique_dec[OF code_sings, of "map (\<lambda> x. [x]) xs" B, OF map_sings]
  unfolding concat_map_sing_ident.

end