theory week05A_demo
imports Main
begin

-- ---------------------------------------------------

text{*A manual proof in set theory:*}

thm equalityI subsetI UnI1 UnI2 UnE

lemma "(A \<union> B) = (B \<union> A)"
  (*TODO*)
  apply (rule equalityI)
   apply (rule subsetI)
   apply (erule UnE)
    apply (rule UnI2)
    apply assumption
   apply (rule UnI1)
   apply assumption
  apply (rule subsetI)
  apply (erule UnE)
   apply (rule UnI2)
   apply assumption
  apply (rule UnI1)
  apply assumption
  done

thm Un_subset_iff
thm subsetD

lemma "(A \<union> B \<subseteq> C) = (A \<subseteq> C \<and> B \<subseteq> C)"
  (*TODO*)
  using [[simp_trace]]
  apply (rule iffI)
   apply (rule conjI)
    apply (rule subsetI)
    apply (erule subsetD)
    apply (rule UnI1)
    apply assumption
   apply (rule subsetI)
   apply (erule subsetD)
   apply (rule UnI2)
   apply assumption
  apply (rule subsetI)
  apply (erule conjE)
  apply (erule UnE)
  apply (erule subsetD)
   apply assumption
  apply (erule subsetD, assumption)
  done

lemma "{a,b} \<inter> {b,c} = (if a \<noteq> c then {b} else {a, b})"
  (*TODO*)
  using [[simp_trace]]
  find_theorems "_ \<subseteq> _ \<inter> _"
  apply (rule equalityI)
   apply (rule subsetI)
  apply (simp)
   apply (rule conjI)
    apply (rule impI)
    apply (erule disjE)
     apply assumption
    apply (erule conjE)
    apply (erule disjE)
     apply simp
    apply simp
   apply (rule impI)
   apply (erule disjE)
    apply (rule disjI2)
    apply assumption
   apply (erule conjE)
   apply (erule disjI1)
  apply (rule Int_greatest)
   apply (simp)
  apply (simp)
  done

text{* Most simple proofs in set theory are automatic: *}

lemma "-(A \<union> B) = (-A \<inter> -B)"
  by blast

lemma "{x. P x \<and> Q x} = {x. P x} \<inter> {x. Q x}"
  by blast

-- --------------------------------------------

text {* Introducing new types *}

-- {* a new "undefined" type: *}
typedecl names
consts blah :: names

-- {* simple abbreviation: *}
type_synonym 'a myrel = "'a \<Rightarrow> 'a \<Rightarrow> bool"

definition
  eq :: "'a myrel"
where
  "eq x y \<equiv> (x = y)"
term "eq"

-- {* type definition: pairs *}

typedef three = "{0::nat,1,2}"
  apply (rule_tac x=0 in exI)
 apply fast
 done
term Abs_three
print_theorems

definition prd :: "('a \<Rightarrow> 'b \<Rightarrow> bool) set" where
  "prd \<equiv> {f. \<exists>a b. f = (\<lambda>x y. x=a \<and> y=b)}"

typedef
  ('a, 'b) prd = "prd::('a \<Rightarrow> 'b \<Rightarrow> bool) set"
  apply (simp add: prd_def)
  apply (rule_tac x="\<lambda>x y. x=blah1 \<and> y=blah2" in exI)
  apply (rule_tac x=blah1 in exI)
  apply (rule_tac x=blah2 in exI)
  apply (rule refl)
  done

print_theorems

definition
  pair :: "'a \<Rightarrow> 'b \<Rightarrow> ('a,'b) prd"
where
  "pair a b \<equiv> Abs_prd (\<lambda>x y. x = a \<and> y = b)"

definition
  fs :: "('a,'b) prd \<Rightarrow> 'a"
where
  "fs x \<equiv> SOME a. \<exists>b. x = pair a b"

definition
  sn :: "('a,'b) prd \<Rightarrow> 'b"
where
  "sn x \<equiv> SOME b. \<exists>a. x = pair a b"

lemma in_prd: "(\<lambda>x y. x = c \<and> y = d) \<in> prd"
  apply (unfold prd_def)
  apply blast
  done

lemma pair_inject:
  "pair a b = pair a' b' \<Longrightarrow> a=a' \<and> b=b'"
  (*TODO*)
  apply (unfold pair_def)
  apply (simp add: Abs_prd_inject[OF in_prd in_prd])
  apply (blast dest: fun_cong)
  done

lemma pair_eq:
  "(pair a b = pair a' b') = (a=a' \<and> b=b')"
  by (blast dest: pair_inject)

lemma fs:
  "fs (pair a b) = a"
  apply (unfold fs_def)
  apply (blast dest: pair_inject)
  done

lemma sn:
  "sn (pair a b) = b"
  apply (unfold sn_def)
  apply (blast dest: pair_inject)
  done

-- --------------------------------------------

section{*Inductive definitions*}

subsection{*Inductive definition of finite sets*}

inductive_set Fin :: "'a set set"
where
emptyI:  "{} \<in> Fin" |
insertI: "A \<in> Fin \<Longrightarrow> insert a A \<in> Fin"

print_theorems

subsection{*Inductive definition of the even numbers*}

inductive_set Ev :: "nat set"
where
ZeroI: "0 \<in> Ev" |
Add2I: "n \<in> Ev \<Longrightarrow> Suc(Suc n) \<in> Ev"

print_theorems

text{* Using the introduction rules: *}
lemma "Suc(Suc(Suc(Suc 0))) \<in> Ev"
  apply (rule Add2I)
  apply (rule Add2I)
  apply (rule ZeroI)
  done

text{* Using the case elimination rules: *}
lemma "n \<in> Ev \<Longrightarrow> n = 0 \<or> (\<exists>n' \<in> Ev. n = Suc (Suc n'))"
  thm Ev.cases
  apply(blast elim: Ev.cases)
  done

text{*A simple inductive proof: *}
lemma "n \<in> Ev \<Longrightarrow> n+n \<in> Ev"
  thm Ev.induct
  apply (erule Ev.induct)
   apply (simp)
   apply (rule ZeroI)
  apply (simp)
  apply (rule Add2I)
  apply (rule Add2I)
  apply assumption
  sorry

text{* You can also use the rules for Ev as conditional simplification
rules. This can shorten proofs considerably.  \emph{Warning}:
conditional rules can lead to nontermination of the simplifier.  The
rules for Ev are OK because the premises are always `smaller' than the
conclusion. The list of rules for Ev is contained in Ev.intros.  *}
thm Ev.intros
declare Ev.intros[simp]

text{* A shorter proof: *}

lemma "n \<in> Ev \<Longrightarrow> n+n \<in> Ev"
  apply(erule Ev.induct)
  apply(simp_all)
  done

text{* Nice example, but overkill: don't need assumption
@{prop "n \<in>Ev"} because @{prop"n+n \<in> Ev"} is true for all @{text n}.

However, here we really need the assumptions: *}

lemma "\<lbrakk> m \<in> Ev; n \<in> Ev \<rbrakk> \<Longrightarrow> m+n \<in> Ev"
  apply(erule Ev.induct)
  apply(auto)
  done

text{* An inductive proof of @{prop "1 \<notin> Ev"}: *}
thm Ev.induct
lemma "n \<in> Ev \<Longrightarrow> n \<noteq> 1"
  apply(erule Ev.induct)
  apply(simp)+
  done

text{* The general case: *}
lemma "n \<in> Ev \<Longrightarrow> \<not>(\<exists>k. n = 2*k+1)"
  apply(erule Ev.induct)
   apply simp
  apply arith
  done

subsection{* Proofs about finite sets *}

text{* Above we declared @{text Ev.intros} as simplification rules.
Now we declare @{text Fin.intros} as introduction rules (via attribute
``intro''). Then fast and blast use them automatically.*}

declare Fin.intros [intro]
thm Fin.intros
lemma "\<lbrakk> A \<in> Fin; B \<in> Fin \<rbrakk> \<Longrightarrow> A \<union> B \<in> Fin"
  apply(erule Fin.induct)
   apply simp
  apply (auto)
  done

lemma "\<lbrakk> A \<in> Fin; B \<subseteq> A \<rbrakk> \<Longrightarrow> B \<in> Fin"
apply(erule Fin.induct)

txt{* The base case looks funny: why is the premise not @{prop "B \<subseteq> {}"}?
Because @{prop "B \<subseteq> A"} was not part of the conclusion we prove.
Relief: pull @{prop "B \<subseteq> A"} into the conclusion with the help of @{text"\<longrightarrow>"}.
*}
oops

lemma "A \<in> Fin \<Longrightarrow> B \<subseteq> A \<longrightarrow> B \<in> Fin"
apply(erule Fin.induct)
 apply auto[1]
apply (clarsimp del: subsetI)
txt{* We need to strengthen the theorem: quantify @{text B}. *}
oops

lemma "A \<in> Fin \<Longrightarrow> \<forall>B. B \<subseteq> A \<longrightarrow> B \<in> Fin"
apply(erule Fin.induct)
 apply(simp)
 apply(rule Fin.emptyI)
apply(rule allI)
apply(rule impI)
apply simp thm subset_insert_iff insert_Diff
apply (simp add:subset_insert_iff)
apply(simp add:subset_insert_iff split:if_split_asm)
apply(drule_tac A = B in insert_Diff)
apply(erule subst)
apply(blast)
done

-- ---------------------------------------------------

section "Inductive Predicates"

text {* The whole thing also works for predicates directly: *}

inductive
  even :: "nat \<Rightarrow> bool"
where
  0: "even 0" |
  2: "even n \<Longrightarrow> even (Suc (Suc n))"

print_theorems

end


section \<open> Simple UTP real-time theory \<close>

theory utp_simple_time imports "../utp" begin

text \<open> In this section we give a small example UTP theory, and show how Isabelle/UTP can be
  used to automate production of programming laws. \<close>

subsection \<open> Observation Space and Signature \<close>

text \<open> We first declare the observation space for our theory of timed relations. It consists
  of two variables, to denote time and the program state, respectively. \<close>

alphabet 's st_time =
  clock :: nat  st :: 's

text \<open> A timed relation is a homogeneous relation over the declared observation space. \<close>

type_synonym 's time_rel = "'s st_time hrel"

text \<open> We introduce the following operator for adding an $n$-unit delay to a timed relation. \<close>

definition Wait :: "nat \<Rightarrow> 's time_rel" where
[upred_defs]: "Wait(n) = ($clock\<acute> =\<^sub>u $clock + \<guillemotleft>n\<guillemotright> \<and> $st\<acute> =\<^sub>u $st)"

subsection \<open> UTP Theory \<close>

text \<open> We define a single healthiness condition which ensures that the clock monotonically
  advances, and so forbids reverse time travel. \<close>

definition HT :: "'s time_rel \<Rightarrow> 's time_rel" where
[upred_defs]: "HT(P) = (P \<and> $clock \<le>\<^sub>u $clock\<acute>)"

text \<open> This healthiness condition is idempotent, monotonic, and also continuous, meaning it
  distributes through arbitary non-empty infima. \<close>

theorem HT_idem: "HT(HT(P)) = HT(P)" by rel_auto

theorem HT_mono: "P \<sqsubseteq> Q \<Longrightarrow> HT(P) \<sqsubseteq> HT(Q)" by rel_auto

theorem HT_continuous: "Continuous HT" by rel_auto

text \<open> We now create the UTP theory object for timed relations. This is done using a local
  interpretation @{term "utp_theory_continuous HT"}. This raises the proof obligations
  that @{term HT} is both idempotent and continuous, which we have proved already.
  The result of this command is a collection of theorems that can be derived from these
  facts. Notably, we obtain a complete lattice of timed relations via the Knaster-Tarski theorem.
  We also apply some locale rewrites so that the theorems that are exports have a more intuitive
  form. \<close>

interpretation time_theory: utp_theory_continuous HT
  rewrites "P \<in> carrier time_theory.thy_order \<longleftrightarrow> P is HT"
  and "carrier time_theory.thy_order \<rightarrow> carrier time_theory.thy_order \<equiv> \<lbrakk>HT\<rbrakk>\<^sub>H \<rightarrow> \<lbrakk>HT\<rbrakk>\<^sub>H"
  and "le time_theory.thy_order = (\<sqsubseteq>)"
  and "eq time_theory.thy_order = (=)"
proof -
  show "utp_theory_continuous HT"
  proof
    show "\<And>P. HT (HT P) = HT P"
      by (simp add: HT_idem)
    show "Continuous HT"
      by (simp add: HT_continuous)
  qed
qed (simp_all)

text \<open> The object \textit{time-theory} is a new namespace that contains both definitions and theorems.
  Since the theory forms a complete lattice, we obtain a top element, bottom element, and a
  least fixed-point constructor. We give all of these some intuitive syntax. \<close>

notation time_theory.utp_top ("\<top>\<^sub>t")
notation time_theory.utp_bottom ("\<bottom>\<^sub>t")
notation time_theory.utp_lfp ("\<mu>\<^sub>t")

text \<open> Below is a selection of theorems that have been exported by the locale interpretation. \<close>

thm time_theory.bottom_healthy
thm time_theory.top_higher
thm time_theory.meet_bottom
thm time_theory.LFP_unfold

subsection \<open> Closure Laws \<close>

text \<open> @{term HT} applied to @{term Wait} has no affect, since the latter always advances time. \<close>

lemma HT_Wait: "HT(Wait(n)) = Wait(n)" by (rel_auto)

lemma HT_Wait_closed [closure]: "Wait(n) is HT"
  by (simp add: HT_Wait Healthy_def)

text \<open> Relational identity, @{term II}, is likewise @{term HT}-healthy. \<close>

lemma HT_skip_closed [closure]: "II is HT"
  by (rel_auto)

text \<open> @{term HT} is closed under sequential composition, which can be shown
  by transitivity of @{term "(\<le>)"}. \<close>

lemma HT_seqr_closed [closure]:
  "\<lbrakk> P is HT; Q is HT \<rbrakk> \<Longrightarrow> P ;; Q is HT"
  by (rel_auto, meson dual_order.trans) \<comment> \<open> Sledgehammer required \<close>

text \<open> Assignment is also healthy, provided that the clock variable is not assigned. \<close>

lemma HT_assign_closed [closure]: "\<lbrakk> vwb_lens x; clock \<bowtie> x \<rbrakk> \<Longrightarrow> x := v is HT"
  by (rel_auto, metis (mono_tags, lifting) eq_iff lens.select_convs(1) lens_indep_get st_time.select_convs(1))

text \<open> An alternative characterisation of the above is that @{term x} is within the state space lens. \<close>

lemma HT_assign_closed' [closure]: "\<lbrakk> vwb_lens x; x \<subseteq>\<^sub>L st \<rbrakk> \<Longrightarrow> x := v is HT"
  by (rel_auto)

subsection \<open> Algebraic Laws \<close>

text \<open> Finally, we prove some useful algebraic laws. \<close>

theorem Wait_skip: "Wait(0) = II" by (rel_auto)

theorem Wait_Wait: "Wait(m) ;; Wait(n) = Wait (m + n)" by (rel_auto)

theorem Wait_cond: "Wait(m) ;; (P \<triangleleft> b \<triangleright>\<^sub>r Q) = (Wait m ;; P) \<triangleleft> b\<lbrakk>&clock+\<guillemotleft>m\<guillemotright>/&clock\<rbrakk> \<triangleright>\<^sub>r (Wait m ;; Q)"
  by (rel_auto)

end


(*  Title:       Category theory using Isar and Locales
    Author:      Greg O'Keefe, June, July, August 2003
    License: LGPL
*)

section \<open>{{\sf Set}} is a Category\<close>

theory SetCat
imports Cat
begin

subsection\<open>Definitions\<close>

record 'c set_arrow =
  set_dom :: "'c set"
  set_func :: "'c \<Rightarrow> 'c"
  set_cod :: "'c set"

definition
  set_arrow :: "['c set, 'c set_arrow] \<Rightarrow> bool" where
  "set_arrow U f \<longleftrightarrow> set_dom f \<subseteq> U & set_cod f \<subseteq> U
    & (set_func f): (set_dom f) \<rightarrow> (set_cod f)
    & set_func f \<in> extensional (set_dom f)"

definition
  set_id :: "['c set, 'c set] \<Rightarrow> 'c set_arrow" where
  "set_id U = (\<lambda>s\<in>Pow U. \<lparr>set_dom=s, set_func=\<lambda>x\<in>s. x, set_cod=s\<rparr>)"

definition
  set_comp :: "['c set_arrow, 'c set_arrow] \<Rightarrow> 'c set_arrow"  (infix "\<odot>" 70) where
  "set_comp g f =
  \<lparr>
    set_dom = set_dom f,
    set_func = compose (set_dom f) (set_func g) (set_func f),
    set_cod = set_cod g
  \<rparr>"

definition
  set_cat :: "'c set \<Rightarrow> ('c set, 'c set_arrow) category" where
  "set_cat U =
  \<lparr>
    ob = Pow U,
    ar = {f. set_arrow U f},
    dom = set_dom,
    cod = set_cod,
    id = set_id U,
    comp = set_comp
  \<rparr>"

subsection \<open>Simple Rules and Lemmas\<close>

lemma set_objectI [intro]: "A \<subseteq> U \<Longrightarrow> A \<in> ob (set_cat U)"
  by (simp add: set_cat_def)

lemma set_objectE [intro]: "A \<in> ob (set_cat U) \<Longrightarrow> A \<subseteq> U"
  by (simp add: set_cat_def)

lemma set_homI [intro]:
  assumes "A \<subseteq> U"
  and "B \<subseteq> U"
  and "f : A\<rightarrow>B"
  and "f \<in> extensional A"
  shows "\<lparr>set_dom=A, set_func=f, set_cod=B\<rparr> \<in> hom (set_cat U) A B"
  using assms by (simp add: set_cat_def hom_def set_arrow_def)

lemma set_dom [simp]: "dom (set_cat U) f = set_dom f"
  by (simp add: set_cat_def)

lemma set_cod [simp]: "cod (set_cat U) f = set_cod f"
  by (simp add: set_cat_def)

lemma set_id [simp]: "id (set_cat U) A = set_id U A"
  by (simp add: set_cat_def)

lemma set_comp [simp]: "comp (set_cat U) g f = g \<odot> f"
  by (simp add: set_cat_def)

lemma set_dom_cod_object_subset [intro]:
  assumes f: "f \<in> ar (set_cat U)"
  shows "dom (set_cat U) f \<in> ob (set_cat U)"
    and "cod (set_cat U) f \<in> ob (set_cat U)"
    and "set_cod f \<subseteq> U"
    and "set_dom f \<subseteq> U"
proof-
  note [simp] = set_cat_def set_arrow_def
  have "dom (set_cat U) f = set_dom f" using f by simp
  also show "\<dots> \<subseteq> U" using f by simp
  finally show "dom (set_cat U) f \<in> ob (set_cat U)" ..
  have "cod (set_cat U) f = set_cod f" using f by simp
  also show "\<dots> \<subseteq> U" using f by simp
  finally show "cod (set_cat U) f \<in> ob (set_cat U)" ..
qed

text \<open>In this context, \<open>f \<in> hom A B\<close> is quite a strong claim.\<close>

lemma set_homE [intro]:
  assumes f: "f \<in> hom (set_cat U) A B"
  shows "A \<subseteq> U"
    and "B \<subseteq> U"
    and "set_dom f = A"
    and "set_func f : A \<rightarrow> B"
    and "set_cod f = B"
proof-
  have 1: "f \<in> ar (set_cat U)"
    using f by (simp add: hom_def set_cat_def)
  show 2: "set_dom f = A"
    using f by (simp add: set_cat_def hom_def set_arrow_def)
  from 1 have "set_dom f \<subseteq> U" ..
  thus "A \<subseteq> U" by (simp add: 2)
  show 3: "set_cod f = B"
    using f by (simp add: set_cat_def hom_def set_arrow_def)
  from 1 have "set_cod f \<subseteq> U" ..
  thus "B \<subseteq> U" by (simp add: 3)
  have "set_func f \<in> (set_dom f) \<rightarrow> (set_cod f)"
    using f by (auto simp add: set_cat_def hom_def set_arrow_def)
  thus "set_func f \<in> A \<rightarrow> B"
    by (simp add: 2 3)
qed

subsection \<open>Set is a Category\<close>
lemma set_id_left:
  assumes f: "f \<in> ar (set_cat U)"
  shows "set_id U (set_cod f) \<odot> f = f"
proof-
  from \<open>f \<in> ar (set_cat U)\<close> have "set_cod f \<subseteq> U" ..
  hence 1: "set_id U (set_cod f) \<odot> f =
    \<lparr>
    set_dom=set_dom f,
    set_func=compose (set_dom f) (\<lambda>x\<in>set_cod f. x) (set_func f),
    set_cod=set_cod f
    \<rparr>"
    using f by (simp add: set_comp_def set_id_def)
  have 2: "compose (set_dom f)  (\<lambda>x\<in>set_cod f. x) (set_func f) = set_func f"
  proof (rule extensionalityI)
    show "compose (set_dom f) (\<lambda>x\<in>set_cod f. x) (set_func f) \<in> extensional (set_dom f)"
      by (rule compose_extensional)
    show "set_func f \<in> extensional (set_dom f)"
      using f by (simp add: set_cat_def set_arrow_def)
    fix x
    assume x_in_dom: "x \<in> set_dom f"
    have f_into_cod: "set_func f : (set_dom f) \<rightarrow> (set_cod f)"
      using f by (simp add: set_cat_def set_arrow_def)
    from f_into_cod and x_in_dom
    have f_x_in_cod: "set_func f x \<in> set_cod f"
      by (rule funcset_mem)
    show "compose (set_dom f) (\<lambda>x\<in>set_cod f. x) (set_func f) x = set_func f x"
      by (simp add: x_in_dom f_x_in_cod compose_def)
  qed
  from 1 have "set_id U (set_cod f) \<odot> f =
    \<lparr>
    set_dom=set_dom f,
    set_func=set_func f,
    set_cod=set_cod f
    \<rparr>"
    by (simp only: 2)
  also have "\<dots> = f"
    by simp
  finally show ?thesis .
qed

lemma set_id_right:
  assumes f: "f \<in> ar (set_cat U)"
  shows "f \<odot> (set_id U (set_dom f)) = f"
proof-
  from \<open>f \<in> ar (set_cat U)\<close> have "set_dom f \<subseteq> U" ..
  hence 1: "f \<odot> (set_id U (set_dom f)) =
    \<lparr>
    set_dom=set_dom f,
    set_func=compose (set_dom f) (set_func f) (\<lambda>x\<in>set_dom f. x),
    set_cod=set_cod f
    \<rparr>"
    using f by (simp add: set_comp_def set_id_def)
  have 2: "compose (set_dom f) (set_func f) (\<lambda>x\<in>set_dom f. x) = set_func f"
  proof (rule extensionalityI)
    show "compose (set_dom f) (set_func f) (\<lambda>x\<in>set_dom f. x) \<in> extensional (set_dom f)"
      by (rule compose_extensional)
    show "set_func f \<in> extensional (set_dom f)"
      using f by (simp add: set_cat_def set_arrow_def)
    fix x
    assume x_in_dom: "x \<in> set_dom f"
    thus "compose (set_dom f) (set_func f) (\<lambda>x\<in>set_dom f. x) x = set_func f x"
      by (simp add: compose_def)
  qed
  from 1 have "f \<odot> (set_id U (set_dom f)) =
    \<lparr>
    set_dom=set_dom f,
    set_func=set_func f,
    set_cod=set_cod f
    \<rparr>"
    by (simp only: 2)
  also have "\<dots> = f"
    by simp
  finally show ?thesis .
qed

lemma set_id_hom:
  assumes "A \<in> ob (set_cat U)"
  shows "id (set_cat U) A \<in> hom (set_cat U) A A"
proof-
  from \<open>A \<in> ob (set_cat U)\<close> have 1: "A \<subseteq> U" ..
  hence "id (set_cat U) A = \<lparr>set_dom=A, set_func=\<lambda>x\<in>A. x, set_cod=A\<rparr>"
    by (simp add: set_cat_def set_id_def)
  also have "\<dots> \<in> hom (set_cat U) A A"
  proof (rule set_homI)
    show "(\<lambda>x\<in>A. x) \<in> A \<rightarrow> A"
      by (rule funcsetI, auto)
    show "(\<lambda>x\<in>A. x) \<in> extensional A"
      by (rule restrict_extensional)
  qed (rule 1, rule 1)
  finally show ?thesis .
qed

lemma set_comp_types:
"comp (set_cat U) \<in> hom (set_cat U) B C \<rightarrow> hom (set_cat U) A B \<rightarrow> hom (set_cat U) A C"
proof (rule funcsetI)
  fix g
  assume g_BC: "g \<in> hom (set_cat U) B C"
  hence comp_cod: "set_cod g = C" ..
  show "comp (set_cat U) g \<in> hom (set_cat U) A B \<rightarrow> hom (set_cat U) A C"
  proof (rule funcsetI)
    fix f
    assume f_AB: "f \<in> hom (set_cat U) A B"
    hence comp_dom: "set_dom f = A" ..
    show "comp (set_cat U) g f \<in> hom (set_cat U) A C"
    proof-
      have "comp (set_cat U) g f =
        \<lparr>
        set_dom = A,
        set_func = compose (set_dom f) (set_func g) (set_func f),
        set_cod = C
        \<rparr>"
        by (simp add: set_cat_def set_comp_def comp_cod comp_dom)
      also have "\<dots> \<in> hom (set_cat U) A C"
      proof (rule set_homI)
        from f_AB show "A \<subseteq> U" ..
        from g_BC show "C \<subseteq> U" ..
        from f_AB have fs_f: "set_func f: A \<rightarrow> B" ..
        from g_BC have fs_g: "set_func g: B \<rightarrow> C" ..
        from fs_g and fs_f
        show " compose (set_dom f) (set_func g) (set_func f) : A \<rightarrow> C"
          by (simp only: comp_dom) (rule funcset_compose)
        show "compose (set_dom f) (set_func g) (set_func f) \<in> extensional A"
          by (simp only: comp_dom) (rule compose_extensional)
      qed
      finally show ?thesis .
    qed
  qed
qed

text \<open>We reason explicitly about the function component of the
composite arrow, leaving the rest to the simplifier.\<close>

lemma set_comp_associative:
  fixes f and g and h
  assumes f: "f \<in> ar (set_cat U)"
    and g: "g \<in> ar (set_cat U)"
    and h: "h \<in> ar (set_cat U)"
    and hg: "cod (set_cat U) h = dom (set_cat U) g"
    and gf: "cod (set_cat U) g = dom (set_cat U) f"
  shows "comp (set_cat U) f (comp (set_cat U) g h) =
  comp (set_cat U) (comp (set_cat U) f g) h"
proof (simp add: set_cat_def set_comp_def)
  show "compose (set_dom h) (set_func f) (compose (set_dom h) (set_func g) (set_func h)) =
    compose (set_dom h) (compose (set_dom g) (set_func f) (set_func g)) (set_func h)"
  proof (rule compose_assoc)
    show "set_func h \<in> set_dom h \<rightarrow> set_dom g"
      using h hg by (simp add: set_cat_def set_arrow_def)
  qed
qed

theorem set_cat_cat:  "category (set_cat U)"
proof (rule category.intro)
  fix f
  assume f: "f \<in> ar (set_cat U)"
  show "dom (set_cat U) f \<in> ob (set_cat U)" using f ..
  show "cod (set_cat U) f \<in> ob (set_cat U)" using f ..
  show "comp (set_cat U) (id (set_cat U) (cod (set_cat U) f)) f = f"
    using f by (simp add: set_id_left)
  show "comp (set_cat U) f (id (set_cat U) (dom (set_cat U) f)) = f"
    using f by (simp add: set_id_right)
next
  fix A
  assume "A \<in> ob (set_cat U)"
  then show "id (set_cat U) A \<in> hom (set_cat U) A A"
    by (rule set_id_hom)
next
  fix A and B and C
  show "comp (set_cat U) \<in> hom (set_cat U) B C \<rightarrow> hom (set_cat U) A B \<rightarrow> hom (set_cat U) A C"
    by (rule set_comp_types)
next
  fix f and g and h
  assume "f \<in> ar (set_cat U)"
    and  "g \<in> ar (set_cat U)"
    and  "h \<in> ar (set_cat U)"
    and "cod (set_cat U) h = dom (set_cat U) g"
    and "cod (set_cat U) g = dom (set_cat U) f"
  then show "comp (set_cat U) f (comp (set_cat U) g h) =
    comp (set_cat U) (comp (set_cat U) f g) h"
    by (rule set_comp_associative)
qed

end


(*  Title:      CoW_Lyndon.Lyndon
    Author:     Štěpán Holub, Charles University
    Author:     Štěpán Starosta, CTU in Prague
*)
theory Lyndon
  imports Combinatorics_Words.CoWBasic
begin

chapter "Lyndon words"

text\<open>A Lyndon word is a non-empty word that is lexicographically
strictly smaller than any other word in its conjugacy class, i.e., than any its rotations.
They are named after R. Lyndon who introduced them in @{cite Lyndon54} as ``standard'' sequences.

We present elementary results on Lyndon words, mostly covered by results in @{cite \<open>Chapter 5\<close> Lo83
} and @{cite Duval80 and Duval83}.

This definition assumes a linear order on letters given by the context.
\<close>

section "Definition and elementary properties"

subsection "Underlying order"

lemma (in linorder) lexordp_mid_pref: "ord_class.lexordp u v \<Longrightarrow> ord_class.lexordp v (u\<cdot>s) \<Longrightarrow>
   u \<le>p v"
  by (induct rule: lexordp_induct, simp_all)

lemma (in linorder) lexordp_ext: "ord_class.lexordp u v \<Longrightarrow>  \<not> u \<le>p v \<Longrightarrow>
  ord_class.lexordp (u\<cdot>w) (v\<cdot>z)"
  by (induct rule: lexordp_induct, simp_all)

lemmas [code] = lexordp_simps

context linorder
begin

abbreviation Lyndon_less :: "'a list \<Rightarrow> 'a list \<Rightarrow> bool" (infixl "<lex" 50)
  where "Lyndon_less xs ys \<equiv> ord_class.lexordp xs ys"

abbreviation Lyndon_le :: "'a list \<Rightarrow> 'a list \<Rightarrow> bool" (infixl "\<le>lex" 50)
  where "Lyndon_le xs ys \<equiv> ord_class.lexordp_eq xs ys"

interpretation rlex: linorder "(\<le>lex)" "(<lex)"
  using lexordp_linorder.

interpretation dual_rlex: linorder "\<lambda> x y. y \<le>lex x" "\<lambda> x y. y <lex x"
  using rlex.dual_linorder.

lemma sorted_dual_rev_iff: "dual_rlex.sorted ws \<longleftrightarrow> rlex.sorted (rev ws)"
  unfolding rlex.sorted_rev_iff_nth_mono dual_rlex.sorted_iff_nth_mono by blast

text \<open>Several useful lemmas that are formulated for relations, interpreted for the default linear order.\<close>

lemmas lexord_suf_linorder = lexord_sufE[of _ _ _ _ "{(x, y). x < y}", folded lexordp_conv_lexord]
  and lexord_append_leftI_linorder = lexord_append_leftI[of  _ _  "{(x, y). x < y}" _, folded lexordp_conv_lexord]
  and lexord_app_right_linorder = lexord_sufI[of  _ _  "{(x, y). x < y}" _, folded lexordp_conv_lexord]
  and lexord_take_index_conv_linorder = lexord_take_index_conv[of  _ _  "{(x, y). x < y}", folded lexordp_conv_lexord]
  and mismatch_lexord_linorder = mismatch_lexord[of  _ _  "{(x, y). x < y}", folded lexordp_conv_lexord]
  and lexord_cancel_right_linorder = lexord_cancel_right[of _ _ _ _ "{(a,b). a < b}", folded lexordp_conv_lexord]

subsection "Lyndon word definition"

fun Lyndon :: "'a list \<Rightarrow> bool"
  where "Lyndon w = (w \<noteq> \<epsilon> \<and> (\<forall>n. 0 < n \<and> n < \<^bold>|w\<^bold>| \<longrightarrow> w <lex rotate n w))"

lemma LyndonD: "Lyndon w \<Longrightarrow> 0 < n \<Longrightarrow> n < \<^bold>|w\<^bold>| \<Longrightarrow> w <lex rotate n w"
  unfolding Lyndon.simps by blast

lemma LyndonD_nemp: "Lyndon w \<Longrightarrow> w \<noteq> \<epsilon>"
  unfolding Lyndon.simps by blast

lemma LyndonI: "w \<noteq> \<epsilon> \<Longrightarrow> \<forall> n. 0 < n \<and> n < \<^bold>|w\<^bold>| \<longrightarrow> w <lex rotate n w \<Longrightarrow>  Lyndon w"
  unfolding  Lyndon.simps by blast

lemma Lyndon_sing: "Lyndon [a]"
  unfolding Lyndon.simps by auto

lemma Lyndon_prim: assumes "Lyndon w"
  shows "primitive w"
proof-
  have "0 < n \<Longrightarrow> n < \<^bold>|w\<^bold>| \<Longrightarrow> rotate n w \<noteq> w" for n
    using LyndonD[OF \<open>Lyndon w\<close>, of n] rlex.less_irrefl[of w] by argo
  from no_rotate_prim[OF LyndonD_nemp[OF \<open>Lyndon w\<close>]] this
  show ?thesis by blast
qed

lemma Lyndon_conj_greater: "Lyndon (u\<cdot>v) \<Longrightarrow> u \<noteq> \<epsilon> \<Longrightarrow> v \<noteq> \<epsilon> \<Longrightarrow> u\<cdot>v <lex v\<cdot>u"
  using LyndonD[of "u\<cdot>v" "\<^bold>|u\<^bold>|", unfolded rotate_append[of u v]]
  by force

subsection "Code equations for Lyndon words"

primrec Lyndon_rec :: "'a list \<Rightarrow> nat \<Rightarrow> bool" where
    "Lyndon_rec w 0 = True" |
    "Lyndon_rec w (Suc n) = (if w <lex rotate (Suc n) w then Lyndon_rec w n else False)"

lemma Lyndon_rec_all: assumes "Lyndon_rec (a # w) (\<^bold>|w\<^bold>|)"
  shows "n < \<^bold>|a#w\<^bold>| \<Longrightarrow> 0 < n \<Longrightarrow> Lyndon_rec (a#w) n"
proof(induction n rule: strict_inc_induct)
  case (base i)
  then show ?case
    using assms by auto
next
  case (step i)
  then show ?case
    by (meson Lyndon_rec.simps(2) zero_less_Suc)
qed

lemma Lyndon_Lyndon_rec: assumes "Lyndon w"
  shows "0 < n \<Longrightarrow> n < \<^bold>|w\<^bold>| \<Longrightarrow> Lyndon_rec w n"
proof(induction n, simp)
  case (Suc n)
  have "w <lex rotate (Suc n) w"
    using LyndonD Suc.prems(2) assms by blast
  then show ?case
    using Suc.IH[OF _ Suc_lessD[OF \<open>Suc n < \<^bold>|w\<^bold>|\<close>], folded neq0_conv] Lyndon_rec.simps(1)[of w]
    unfolding Lyndon_rec.simps(2)
    by metis
qed

lemma Lyndon_code [code]:
    "Lyndon Nil = False"
    "Lyndon (a # w) = Lyndon_rec (a # w) (\<^bold>|w\<^bold>|)"
proof-
  show "Lyndon Nil = False" by simp
  have "a # w \<noteq> \<epsilon>"
    by simp
  have ax: "0 < n \<Longrightarrow> Lyndon_rec (a#w) n \<Longrightarrow> (a#w) <lex rotate n (a#w)" for n
    using Lyndon_rec.simps(2)[of "a#w"] gr0_implies_Suc[of n] by metis
  have bx: "Lyndon_rec (a # w) (\<^bold>|w\<^bold>|) = (\<forall>n. n < \<^bold>|a#w\<^bold>| \<and> 0 < n \<longrightarrow> Lyndon_rec (a#w) n)"
  proof(cases "w = \<epsilon>", simp)
    assume "w \<noteq> \<epsilon>"
    from this[folded length_greater_0_conv]
    show ?thesis
      using Lyndon_rec_all[of a w] length_Cons[of a w] lessI[of "\<^bold>|w\<^bold>|"]
      by fastforce
  qed
  show "Lyndon (a # w) = Lyndon_rec (a # w) \<^bold>|w\<^bold>|"
    unfolding bx Lyndon.simps
    using ax  LyndonI[OF \<open>a # w \<noteq> \<epsilon>\<close>]Lyndon_Lyndon_rec by blast
qed

subsection "Properties of Lyndon words"

subsubsection "Lyndon words are unbordered"

theorem Lyndon_unbordered: assumes "Lyndon w" shows "\<not> bordered w"
proof
  assume "bordered w"
  from bordered_dec[OF this]
  obtain u v where "u\<cdot>v\<cdot>u = w" and "u \<noteq> \<epsilon>".
  hence "v \<cdot> u \<noteq> \<epsilon>" and "u \<cdot> v \<noteq> \<epsilon>" by blast+
  note lyn = \<open>Lyndon w\<close>[folded  \<open>u\<cdot>v\<cdot>u = w\<close>]
  have "u\<cdot>v\<cdot>u <lex v\<cdot>u\<cdot>u"
    using Lyndon_conj_greater[of u "v\<cdot>u", OF lyn \<open>u \<noteq> \<epsilon>\<close> \<open>v \<cdot> u \<noteq> \<epsilon>\<close>, unfolded rassoc].
  from this[unfolded lassoc]
  have "u \<cdot> v \<noteq> v \<cdot> u"
    by force
  from lexord_suf_linorder[OF _ this, of u u]
  have "u\<cdot>v <lex v\<cdot>u"
    using  \<open>u\<cdot>v\<cdot>u <lex v\<cdot>u\<cdot>u\<close>  by simp
  from lexord_append_leftI_linorder[of  "u\<cdot>v" "v\<cdot>u", unfolded lassoc, OF this, unfolded rassoc]
  have "u\<cdot>u\<cdot>v <lex u\<cdot>v\<cdot>u".
  from this Lyndon_conj_greater[of "u\<cdot>v" u, unfolded rassoc, OF lyn \<open>u \<cdot> v \<noteq> \<epsilon>\<close>  \<open>u \<noteq> \<epsilon>\<close>]
  show False
    by simp
qed

subsubsection "Each conjugacy class contains a Lyndon word"

lemma conjug_Lyndon_ex: assumes "primitive w"
  obtains n where "Lyndon (rotate n w)"
proof-
  have "w \<noteq> \<epsilon>"
    using  prim_nemp[OF \<open>primitive w\<close>].

  let ?ConClass = "{rotate n w | n. 0 \<le> n \<and> n < \<^bold>|w\<^bold>|}"

  have "?ConClass \<noteq> {}"
    using \<open>w \<noteq> \<epsilon>\<close> by blast
  have "w \<in> ?ConClass"
    using \<open>w \<noteq> \<epsilon>\<close> id_apply[of w, folded rotate0]
    by force
  have "finite ?ConClass"
    by simp
  have all_rot: "rotate m w \<in> ?ConClass" for m
    using rotate_conv_mod[of _ w] mod_less_divisor[of "\<^bold>|w\<^bold>|"] \<open>w \<noteq> \<epsilon>\<close>
    by blast

  obtain w' n where "w' \<in> ?ConClass" and all_b: "\<forall> b \<in> ?ConClass. b \<le>lex w' \<longrightarrow> w' = b" and w': "w' = rotate n w"
    using rlex.finite_has_minimal[OF \<open>finite ?ConClass\<close> \<open>?ConClass \<noteq> {}\<close>] by auto

  have "rotate n w <lex rotate na (rotate n w)" if  "0 < na" and "na < \<^bold>|w\<^bold>|" for na
  proof-
    from prim_no_rotate[OF assms[unfolded prim_rotate_conv[of w n]], of na] \<open>na < \<^bold>|w\<^bold>|\<close> \<open>0 < na\<close>
    have "rotate na (rotate n w) \<noteq> rotate n w" by force
    hence "\<not> rotate na (rotate n w) \<le>lex rotate n w"
      using all_b[rule_format, OF all_rot[of "na + n", folded rotate_rotate[of na n w]]] unfolding w'
      by auto
    from rlex.not_le_imp_less[OF this]
    show "rotate n w <lex rotate na (rotate n w)".
  qed
  hence "Lyndon (rotate n w)"
    using \<open>w \<noteq> \<epsilon>\<close> by auto
  from that[OF this] show thesis.
qed

lemma conjug_Lyndon_ex': assumes "primitive w"
  obtains v where "w \<sim> v" and "Lyndon v"
  unfolding conjug_rotate_iff
  using conjug_Lyndon_ex[OF \<open>primitive w\<close>]
  by metis

section "Characterization by suffixes"

lemma Lyndon_suf_less: assumes "Lyndon w" "s \<le>ns w" "s \<noteq> w"
  shows "w <lex s"
proof-
  define p where "p = take \<^bold>|s\<^bold>| w"
  have "\<^bold>|s\<^bold>| \<le> \<^bold>|w\<^bold>|"
    using nsD[OF \<open>s \<le>ns w\<close>] by force
  have "p \<le>p w" and "\<^bold>|p\<^bold>|  = \<^bold>|s\<^bold>|"
    unfolding p_def
    using take_is_prefix \<open>\<^bold>|s\<^bold>| \<le> \<^bold>|w\<^bold>|\<close> take_len by blast+
  hence "p \<noteq> s"
    using Lyndon_unbordered[OF \<open>Lyndon w\<close>] \<open>s \<le>ns w\<close> \<open>s \<noteq> w\<close> assms
    by auto
  define p' s' where "p' = drop \<^bold>|s\<^bold>| w" and "s' = take \<^bold>|p'\<^bold>| w"
  have "p\<cdot>p' = w" and "s'\<cdot>s = w"
    unfolding p'_def p_def s'_def
    using \<open>s \<le>ns w\<close> by auto
  have "\<^bold>|p'\<^bold>| = \<^bold>|s'\<^bold>|"
    using s'_def \<open>p\<cdot>p' = w\<close> by auto
  have "w <lex s\<cdot>s'"
    using Lyndon_conj_greater[of s' s, unfolded \<open>s' \<cdot> s = w\<close>, OF \<open>Lyndon w\<close>] \<open>p \<noteq> s\<close>
    unfolding \<open>s' \<cdot> s = w\<close> p_def using \<open>s' \<cdot> s = w\<close> assms(3) by fastforce
  from lexord_suf_linorder[OF _ \<open>p \<noteq> s\<close> \<open>\<^bold>|p\<^bold>| = \<^bold>|s\<^bold>|\<close> \<open>\<^bold>|p'\<^bold>| = \<^bold>|s'\<^bold>|\<close>, OF this[folded \<open>p \<cdot> p' = w\<close>]]
  have "p <lex s".
  from lexord_app_right_linorder[OF this, of p' \<epsilon>, unfolded \<open>p \<cdot> p' = w\<close>]  \<open>\<^bold>|p\<^bold>| = \<^bold>|s\<^bold>|\<close>
  show "w <lex s"
    by simp
qed

(* TODO zkusit pouzit jinde *)
lemma Lyndon_pref_suf_less:  assumes "Lyndon w" "p \<le>p w" "s \<le>ns w" "s \<noteq> w"
  shows "p <lex s"
proof(cases "p = w", simp add: Lyndon_suf_less[OF assms(1) assms(3) assms(4)])
  assume "p \<noteq> w"
  show "p <lex s"
  proof(rule rlex.less_trans)
    show "p <lex w"
      using \<open>p \<noteq> w\<close> assms(2) lexordp_append_rightI by fastforce
    show "w <lex s"
      using Lyndon_suf_less assms(1) assms(3) assms(4) by blast
  qed
qed

lemma suf_less_Lyndon: assumes "w \<noteq> \<epsilon>" and "\<forall>s. (s \<le>ns w \<longrightarrow> s \<noteq> w \<longrightarrow> w <lex s)"
  shows "Lyndon w"
proof (cases "primitive w")
  assume "\<not> primitive w"
  obtain q k where "q \<noteq> \<epsilon>" "1 < k" "q\<^sup>@k=w" "w\<noteq>q" \<comment> \<open>the exact match of @{thm non_prim} fastens the proof considerably\<close>
    using non_prim[OF \<open>\<not> primitive w\<close> \<open>w \<noteq> \<epsilon>\<close>] by blast
  hence "q \<le>ns w"
    unfolding nonempty_suffix_def pow_eq_if_list[of q k] pow_commutes_list[symmetric]
    using sufI[of "q \<^sup>@ (k - 1)" q w]
    by presburger

  have "q <p w"
    using \<open>1 < k\<close>  \<open>q \<^sup>@ k = w\<close>
    unfolding pow_eq_if_list[of q k] pow_eq_if_list[of q "k-1"]
    using \<open>w \<noteq> \<epsilon>\<close>  by auto
  from lexordp_append_rightI[of "q\<inverse>\<^sup>>w" q,
      unfolded lq_pref[OF sprefD1[OF this]], OF lq_spref[OF this]]
  have "q <lex w".
  thus  "Lyndon w"
    unfolding Lyndon.simps using \<open>q \<le>ns w\<close> \<open>w \<noteq> \<epsilon>\<close> assms(2) rlex.order.strict_trans by blast
next
  assume "primitive w"
  have "w <lex rotate l w" if assms_l: "0 < l" "l < \<^bold>|w\<^bold>|" for l
  proof-
    have "take l w \<le>np w" and "\<^bold>|take l w\<^bold>| = l"
      using assms_l take_is_prefix  \<open>l < \<^bold>|w\<^bold>|\<close> by auto
    have "drop l w \<le>ns w"
      using \<open>l < \<^bold>|w\<^bold>|\<close> suffix_drop by auto
    have "drop l w \<noteq> w"
      using append_take_drop_id[of l w] npD'[OF \<open>take l w \<le>np w\<close>] by force
    have "drop l w \<cdot> take l w = rotate l w"
      using rotate_append[of "take l w" "drop l w", symmetric, unfolded \<open>\<^bold>|take l w\<^bold>| = l\<close>,
          unfolded append_take_drop_id].

    have "w <lex drop l w"
      using \<open>drop l w \<le>ns w\<close> \<open>drop l w \<noteq> w\<close> assms(2) by blast
    from lexord_app_right_linorder[OF this suffix_length_le[OF conjunct2[OF \<open>drop l w \<le>ns w\<close>[unfolded nonempty_suffix_def]]], of \<epsilon> "take l w", unfolded  append.right_neutral]
    have "w <lex drop l w \<cdot> take l w".
    thus "w <lex rotate l w"
      by (simp add: \<open>drop l w \<cdot> take l w = rotate l w\<close>)
  qed
  thus "Lyndon w"
    by (simp add: \<open>w \<noteq> \<epsilon>\<close> local.LyndonI)
qed

corollary Lyndon_suf_char: "w \<noteq> \<epsilon> \<Longrightarrow> Lyndon w \<longleftrightarrow> (\<forall>s. s \<le>ns w \<longrightarrow> s \<noteq> w \<longrightarrow> w <lex s)"
  using Lyndon_suf_less suf_less_Lyndon by blast

lemma Lyndon_suf_le: "Lyndon w \<Longrightarrow> s \<le>ns w \<Longrightarrow> w \<le>lex s"
  using Lyndon_suf_less rlex.not_less rlex.order.asym by blast

section "Unbordered prefix of a Lyndon word is Lyndon"

lemma unbordered_pref_Lyndon: "Lyndon (u\<cdot>v) \<Longrightarrow> u \<noteq> \<epsilon> \<Longrightarrow> \<not> bordered u \<Longrightarrow> Lyndon u"
  unfolding Lyndon_suf_char
proof(standard+)
  fix s
  assume "Lyndon (u \<cdot> v)" and  "u \<noteq> \<epsilon>" and "\<not> bordered u" and "s \<le>ns u" and "s \<noteq> u"
    hence "u \<cdot> v <lex s \<cdot> v"
      using  Lyndon_suf_less[OF \<open>Lyndon (u \<cdot> v)\<close>, of "s \<cdot> v"] by auto
    have "\<not> s \<le>p u"
      using \<open>\<not> bordered u\<close> \<open>s \<le>ns u\<close> \<open>s \<noteq> u\<close> by auto
    moreover have "\<not> u \<le>p s"
      using suf_pref_eq[OF nsD[OF\<open>s \<le>ns u\<close>]] \<open>s \<noteq> u\<close> by blast
    ultimately show "u <lex s"
      using lexord_cancel_right_linorder[OF \<open>u \<cdot> v <lex s \<cdot> v\<close>] by blast
qed

section "Concatenation of Lyndon words"

theorem Lyndon_concat: assumes  "Lyndon u" and "Lyndon v" and "u <lex v"
  shows "Lyndon (u\<cdot>v)"
proof-
  have "u\<cdot>v <lex v"
  proof(cases "u \<le>p v")
    assume "u \<le>p v"
    then obtain z where "u\<cdot>z = v" and "z \<le>ns v"
      using assms(3) dual_rlex.less_imp_neq by auto
    from Lyndon_suf_less[OF \<open>Lyndon v\<close> this(2), THEN lexord_append_leftI_linorder, of u]
      LyndonD_nemp[OF \<open>Lyndon u\<close>] this(1)
    show ?thesis
      by blast
  next
    assume "\<not> u \<le>p v"
    then show ?thesis
      using local.lexordp_linear[of v "u\<cdot>v"]
        local.lexordp_mid_pref[OF \<open>u <lex v\<close>,of v]
        prefixI[of v u v]
      by argo
  qed

  { fix z
    assume "z \<le>ns (u\<cdot>v)" "z \<noteq> u\<cdot>v"
    have "u\<cdot>v <lex z"
    proof(cases "z \<le>ns v")
      assume "z \<le>ns v"
      from Lyndon_suf_less[OF \<open>Lyndon v\<close> this]
      have "z \<noteq> v \<Longrightarrow> v <lex z"
        by blast
      thus "u\<cdot>v <lex z"
        using \<open>u \<cdot> v <lex v\<close> rlex.less_trans
        by fast
    next
      assume "\<not> z \<le>ns v"
      then obtain z' where "z' \<le>ns u" "z' \<noteq> u" "z'\<cdot>v = z"
        using \<open>z \<le>ns u \<cdot> v\<close> \<open>z \<noteq> u \<cdot> v\<close> suffix_append[of z u v]
        unfolding nonempty_suffix_def
        by force
      from Lyndon_suf_less[OF \<open>Lyndon u\<close> this(1) this(2)]
      have "u <lex z'".
      thus "u\<cdot>v <lex z"
        using  \<open>z' \<le>ns u\<close> lexord_app_right_linorder[of u z' v v] suffix_length_le[of z' u]
        unfolding nonempty_suffix_def \<open>z' \<cdot> v = z\<close>
        by blast
    qed
  }
  thus ?thesis
    using suf_nemp[OF LyndonD_nemp[OF \<open>Lyndon v\<close>], of u, THEN suf_less_Lyndon]
    by blast
qed

section "Longest Lyndon suffix"

fun longest_Lyndon_suffix:: "'a list \<Rightarrow> 'a list" ("LynSuf") where
  "longest_Lyndon_suffix \<epsilon> = \<epsilon>" |
  "longest_Lyndon_suffix (a#w) = (if Lyndon (a#w) then a#w else longest_Lyndon_suffix w)"

lemma longest_Lyndon_suf_ext: "\<not> Lyndon (a # w) \<Longrightarrow> LynSuf w = LynSuf (a # w)"
  using longest_Lyndon_suffix.simps(2) by presburger

lemma longest_Lyndon_suf_suf: "w \<noteq> \<epsilon> \<Longrightarrow> LynSuf w \<le>s w"
proof(induction w rule: longest_Lyndon_suffix.induct)
  case 1
  then show ?case by simp
next
  case (2 a w)
  show ?case
  proof(cases "Lyndon (a#w)")
    case True
    then show ?thesis by auto
  next
    case False
    from "2.IH"[OF this, unfolded longest_Lyndon_suf_ext[OF this], THEN suffix_ConsI, of a]
      Lyndon_sing False
    show ?thesis by blast
  qed
qed

lemma longest_Lyndon_suf_max:
  "v \<le>s w  \<Longrightarrow> Lyndon v \<Longrightarrow> v \<le>s (LynSuf w)"
proof(induction w arbitrary: v rule: longest_Lyndon_suffix.induct)
  case 1
  then show ?case
    using longest_Lyndon_suffix.simps(1) by presburger
next
  case (2 a w)
  show ?case
  proof(cases "Lyndon (a#w)")
    case True
    then show ?thesis
      using "2.prems"(1) longest_Lyndon_suffix.simps(2) by presburger
  next
    case False
    have "v \<noteq> a # w"
      using "2.prems"(2) False by blast
    from "2.IH"[OF False _ "2.prems"(2), unfolded longest_Lyndon_suf_ext[OF False]]
       "2.prems"(1)[unfolded suffix_Cons] this
    show ?thesis by fast
  qed
qed

lemma longest_Lyndon_suf_Lyndon_id: assumes "Lyndon w"
  shows "LynSuf w = w"
proof(cases "w = \<epsilon>", simp)
  case False
  from longest_Lyndon_suf_suf[OF this]
    suffix_order.order_refl[THEN longest_Lyndon_suf_max[OF _ assms]]
    suffix_order.antisym_conv
  show ?thesis by blast
qed

lemma longest_Lyndon_suf_longest: "w \<noteq> \<epsilon> \<Longrightarrow> v' \<le>s w \<Longrightarrow> Lyndon v' \<Longrightarrow> \<^bold>|v'\<^bold>| \<le> \<^bold>|(LynSuf w)\<^bold>|"
  using longest_Lyndon_suf_max suffix_length_le by blast

lemma longest_Lyndon_suf_sing: "LynSuf [a] = [a]"
  using Lyndon_sing longest_Lyndon_suf_Lyndon_id by blast

lemma longest_Lyndon_suf_Lyndon: "w \<noteq> \<epsilon> \<Longrightarrow> Lyndon (LynSuf w)"
proof(induction w rule: longest_Lyndon_suffix.induct, blast)
  case (2 a w)
  show ?case
  proof(cases "Lyndon (a#w)")
    case True
    then show ?thesis
      using longest_Lyndon_suf_Lyndon_id by presburger
  next
    case False
    from "2.IH"[OF this, unfolded longest_Lyndon_suf_ext[OF this]] Lyndon_sing
    show ?thesis by fastforce
  qed
qed

lemma longest_Lyndon_suf_nemp: "w \<noteq> \<epsilon> \<Longrightarrow> LynSuf w \<noteq> \<epsilon>"
  using longest_Lyndon_suf_Lyndon[THEN LyndonD_nemp].

lemma longest_Lyndon_sufI:
  assumes "q \<le>s w" and "Lyndon q" and all_s: "(\<forall> s. (s \<le>s w \<and> Lyndon s) \<longrightarrow> s \<le>s q)"
  shows "LynSuf w = q"
proof(cases "w = \<epsilon>")
  case True
  then show ?thesis
    using assms(1) by fastforce
next
  case False
  from all_s longest_Lyndon_suf_Lyndon[OF this] longest_Lyndon_suf_max[OF assms(1) assms(2)]
    longest_Lyndon_suf_suf[OF this] suffix_order.eq_iff
  show ?thesis by blast
qed

corollary longest_Lyndon_sufI':
  assumes "q \<le>s w" and "Lyndon q" and all_s: "\<forall> s. (s \<le>s w \<and> Lyndon s) \<longrightarrow> \<^bold>|s\<^bold>| \<le> \<^bold>|q\<^bold>|"
  shows "LynSuf w = q"
  using longest_Lyndon_sufI[OF \<open>q \<le>s w\<close> \<open>Lyndon q\<close>] suf_ruler_le all_s \<open>q \<le>s w\<close> by blast

text\<open>The next lemma is fabricated to suit the upcoming definition of longest Lyndon factorization.\<close>

lemma longest_Lyndon_suf_shorter: assumes "w \<noteq> \<epsilon>"
  shows "\<^bold>|w\<^sup><\<inverse>(LynSuf w)\<^bold>| < \<^bold>|w\<^bold>|"
  using nemp_len[OF longest_Lyndon_suf_nemp[OF \<open>w \<noteq> \<epsilon>\<close>]] arg_cong[OF rq_suf[OF longest_Lyndon_suf_suf[OF \<open>w \<noteq> \<epsilon>\<close>]], of length]
  unfolding length_append by linarith

section "Lyndon factorizations"

function Lyndon_fac::"'a list  \<Rightarrow> 'a list list" ("LynFac")
  where "Lyndon_fac w  = (if w \<noteq> \<epsilon> then ((Lyndon_fac (w \<^sup><\<inverse>(LynSuf w) )) \<cdot> [LynSuf w]) else \<epsilon>)"
  using longest_Lyndon_suffix.cases by blast+
termination
proof(relation "measure length", simp)
  show "\<And>w. w \<noteq> \<epsilon> \<Longrightarrow> (w\<^sup><\<inverse>LynSuf w, w) \<in> measure length"
    unfolding measure_def inv_image_def using longest_Lyndon_suf_shorter by blast
qed

text\<open>The factorization @{term "Lyndon_fac w"} obtained by taking always the longest Lyndon suffix is well defined,
and called ``Lyndon factorization (of $w$)''.\<close>

lemma Lyndon_fac_simp: "w \<noteq> \<epsilon> \<Longrightarrow> Lyndon_fac w =  Lyndon_fac (w\<^sup><\<inverse>LynSuf w) \<cdot> (LynSuf w # \<epsilon>)"
  using Lyndon_fac.simps[of w] by meson

lemma Lyndon_fac_emp: "Lyndon_fac \<epsilon> = \<epsilon>"
  by simp

text\<open>Note that the Lyndon factorization of a Lyndon word is trivial.\<close>

lemma Lyndon_fac_longest_Lyndon_id: "Lyndon w \<Longrightarrow> Lyndon_fac w = [w]"
  by (simp add: longest_Lyndon_suf_Lyndon_id)

text\<open>Lyndon factorization is composed of Lyndon words ...\<close>

lemma Lyndon_fac_set: "z \<in> set (Lyndon_fac w) \<Longrightarrow> Lyndon z"
proof(induction w rule:  Lyndon_fac.induct)
  case (1 w)
  then show "Lyndon z"
  proof (cases "w = \<epsilon>")
    assume "w \<noteq> \<epsilon>"
    have "Lyndon_fac w  = (Lyndon_fac (w \<^sup><\<inverse>(LynSuf w) )) \<cdot> [LynSuf w]"
      using Lyndon_fac_simp[OF \<open>w \<noteq> \<epsilon>\<close>].
    from set_ConsD[OF "1.prems"(1)[unfolded rotate1.simps(2)[of "LynSuf w" "Lyndon_fac (w \<^sup><\<inverse>(LynSuf w) )", folded this, symmetric], unfolded set_rotate1]]
    have "z = LynSuf w \<or> z \<in> set (Lyndon_fac (w \<^sup><\<inverse>(LynSuf w) ))".
    thus "Lyndon z"
      using "1.IH"[OF \<open>w \<noteq> \<epsilon>\<close>] longest_Lyndon_suf_Lyndon[OF \<open>w \<noteq> \<epsilon>\<close>]
      by blast
  next
    assume "w = \<epsilon>"
    thus "Lyndon z"
      using "1.prems"
      unfolding Lyndon_fac_emp[folded \<open>w = \<epsilon>\<close>] list.set(1) empty_iff
      by blast
  qed
qed

text\<open>...and it indeed is a factorization of the argument.\<close>

lemma Lyndon_fac_longest_dec: "concat (Lyndon_fac w) = w"
proof(induction w rule: Lyndon_fac.induct)
  case (1 w)
  thus "concat (LynFac w) = w"
  proof (cases "w = \<epsilon>", simp)
  assume "w \<noteq> \<epsilon>"
    have eq: "concat (Lyndon_fac w) = concat ( (Lyndon_fac (w \<^sup><\<inverse>(LynSuf w) )) ) \<cdot> concat ([LynSuf w])"
      unfolding Lyndon_fac_simp[OF \<open>w \<noteq> \<epsilon>\<close>] concat_morph..
    from this[unfolded "1.IH"[OF \<open>w \<noteq> \<epsilon>\<close>] concat_sing' rq_suf[OF longest_Lyndon_suf_suf[OF \<open>w \<noteq> \<epsilon>\<close>]]]
    show ?case.
  qed
qed

text\<open>The following lemma makes explicit the inductive character of the definition of @{term Lyndon_fac}.\<close>

lemma Lyndon_fac_longest_pref: "us \<le>p Lyndon_fac w \<Longrightarrow> Lyndon_fac (concat us) = us"
proof(induction w arbitrary: us rule:  Lyndon_fac.induct)
  case (1 w)
  thus "LynFac (concat us) = us"
  proof (cases "w = \<epsilon>", simp)
    assume "w \<noteq> \<epsilon>"
    have step: "Lyndon_fac w = (Lyndon_fac (w \<^sup><\<inverse>(LynSuf w))) \<cdot> [LynSuf w]"
      using Lyndon_fac_simp[OF \<open>w \<noteq> \<epsilon>\<close>].

    consider (neq) "us \<noteq> Lyndon_fac w" | (eq) "us = Lyndon_fac w"
      using "1.prems" le_neq_implies_less by blast
    then show "LynFac (concat us) = us"
    proof(cases)
      case neq
      hence "us \<le>p Lyndon_fac (w\<^sup><\<inverse>LynSuf w)"
        using "1.prems" last_no_split[of us "Lyndon_fac (w\<^sup><\<inverse>LynSuf w)" "LynSuf w"]
        unfolding step[symmetric] by blast
      thus "LynFac (concat us) = us"
        using "1.IH" \<open>w \<noteq> \<epsilon>\<close> by blast
    next
      case eq
      show "LynFac (concat us) = us"
        using Lyndon_fac_longest_dec[of w, folded eq] eq by simp
    qed
  qed
qed

text\<open>We give name to an important predicate: monotone (nonincreasing) list of Lyndon words.\<close>

definition Lyndon_mono :: "'a list list \<Rightarrow>  bool" where
  "Lyndon_mono ws \<longleftrightarrow> (\<forall> u \<in> set ws. Lyndon u) \<and> (rlex.sorted (rev ws))"

lemma Lyndon_mono_set: "Lyndon_mono ws \<Longrightarrow> u \<in> set ws \<Longrightarrow> Lyndon u"
  unfolding Lyndon_mono_def by blast

lemma Lyndon_mono_sorted: "Lyndon_mono ws \<Longrightarrow> rlex.sorted (rev ws)"
  unfolding Lyndon_mono_def by blast

lemma Lyndon_mono_nth: "Lyndon_mono ws \<Longrightarrow> i \<le> j \<Longrightarrow> j < \<^bold>|ws\<^bold>| \<Longrightarrow> ws!j \<le>lex ws!i"
  unfolding Lyndon_mono_def using  rlex.sorted_rev_nth_mono by blast

lemma Lyndon_mono_empty[simp]: "Lyndon_mono \<epsilon>"
  unfolding Lyndon_mono_def by auto

lemma Lyndon_mono_sing: "Lyndon u \<Longrightarrow> Lyndon_mono [u]"
  unfolding Lyndon_mono_def by auto

lemma Lyndon_mono_fac_Lyndon_mono:
  assumes "ps \<le>f ws" and "Lyndon_mono ws" shows "Lyndon_mono ps"
unfolding Lyndon_mono_def
proof
  show "\<forall>x \<in> (set ps). Lyndon x"
    using \<open>Lyndon_mono ws\<close>[unfolded Lyndon_mono_def] set_mono_sublist[OF \<open>ps \<le>f ws\<close>] by blast
  show "linorder.sorted (\<le>lex) (rev ps)"
    using rlex.sorted_append \<open>Lyndon_mono ws\<close>[unfolded Lyndon_mono_def] \<open>ps \<le>f ws\<close>[unfolded sublist_def] by fastforce
qed

text\<open>Lyndon factorization is monotone!
Altogether, we have shown that the Lyndon factorization is a monotone factorization
into Lyndon words.\<close>

theorem fac_Lyndon_mono: "Lyndon_mono (Lyndon_fac w)"
proof (induct "Lyndon_fac w" arbitrary: w rule: rev_induct, simp)
  case (snoc x xs)
  have "Lyndon x"
    using Lyndon_fac_set[of x, unfolded in_set_conv_decomp, of w, folded snoc.hyps(2)] by fast
  have "concat (xs \<cdot> [x]) = w"
    using Lyndon_fac_longest_dec[of w, folded snoc.hyps(2)] by auto
  then show "Lyndon_mono (LynFac w)"
  proof (cases "xs = \<epsilon>")
    assume "xs = \<epsilon>"
    show "Lyndon_mono (LynFac w)"
      unfolding Lyndon_mono_def \<open>xs \<cdot> [x] = LynFac w\<close>[symmetric] \<open>xs = \<epsilon>\<close> append.left_neutral
                rlex.sorted1[of x]
      using \<open>Lyndon x\<close> by force
  next
    assume "xs \<noteq> \<epsilon>"
    have "concat (xs \<cdot> [x]) \<noteq> \<epsilon>" and "w \<noteq> \<epsilon>"
      using Lyndon_fac_longest_dec snoc.hyps(2) by auto
    have "x = LynSuf w" and "xs = LynFac (w\<^sup><\<inverse>LynSuf w )"
      using Lyndon_fac.simps[of w, folded snoc.hyps(2)] \<open>w \<noteq> \<epsilon>\<close>
        Lyndon_fac_longest_dec append1_eq_conv[of xs x "LynFac (w\<^sup><\<inverse>LynSuf w )" "LynSuf w"] by presburger+
    from Lyndon_mono_sorted[OF snoc.hyps(1)[OF \<open>xs = LynFac (w\<^sup><\<inverse>LynSuf w )\<close>], folded this]
    have "dual_rlex.sorted  xs"
      unfolding sorted_dual_rev_iff.
    have "Lyndon (last xs)"
      using Lyndon_fac_set[of "last xs" "w\<^sup><\<inverse>LynSuf w", folded \<open>xs = LynFac (w\<^sup><\<inverse>LynSuf w)\<close>, OF last_in_set[OF \<open>xs \<noteq> \<epsilon>\<close>]].
    have "x \<le>lex last xs"
    proof(rule ccontr)
      assume "\<not> x \<le>lex last xs" hence "last xs <lex x" by auto
      from Lyndon_concat[OF  \<open>Lyndon (last xs)\<close> \<open>Lyndon x\<close> this]
      have "Lyndon ((last xs) \<cdot> x)".
      have "(last xs) \<cdot> x \<le>s concat (xs \<cdot> [x])"
        using \<open>xs \<noteq> \<epsilon>\<close> concat_last_suf by auto
      from longest_Lyndon_suf_longest[OF \<open>concat (xs \<cdot> [x]) \<noteq> \<epsilon>\<close>  this \<open>Lyndon ((last xs) \<cdot> x)\<close>,
          unfolded \<open>concat (xs \<cdot> [x]) = w\<close>, folded \<open>x = LynSuf w\<close>]
      show False
        using \<open>Lyndon (last xs)\<close> by simp
    qed
    have "dual_rlex.sorted (butlast xs \<cdot> [last xs])"
      by (simp add: \<open>linorder.sorted (\<lambda>x y. y \<le>lex x) xs\<close> \<open>xs \<noteq> \<epsilon>\<close>)
    from this \<open>x \<le>lex last xs\<close>
    have "dual_rlex.sorted (butlast xs \<cdot> [last xs,x])"
      using dual_rlex.sorted_append by auto
    from this[unfolded hd_word[of "last xs" "[x]"] lassoc append_butlast_last_id[OF \<open>xs \<noteq> \<epsilon>\<close>]]
    have "rlex.sorted (rev (LynFac w))"
      unfolding  \<open>xs \<cdot> [x] = LynFac w\<close>[symmetric] sorted_dual_rev_iff[symmetric].
    thus "Lyndon_mono (LynFac w)"
      unfolding Lyndon_mono_def using Lyndon_fac_set by blast
  qed
qed

text\<open>Now we want to show the converse: any monotone factorization into Lyndon words is the Lyndon factorization\<close>

text\<open>The last element in the Lyndon factorization is the smallest suffix.\<close>

lemma Lyndon_mono_last_smallest: "Lyndon_mono ws \<Longrightarrow>s \<le>ns (concat ws) \<Longrightarrow> last ws \<le>lex s"
proof(induct ws arbitrary: s rule: rev_induct, fastforce)
  case (snoc a ws)
  have "ws\<cdot>[a] \<noteq> \<epsilon>"
    by blast
  have "last (ws\<cdot>[a]) = a"
    by simp
  from last_in_set[OF \<open>ws\<cdot>[a] \<noteq> \<epsilon>\<close>, unfolded this] \<open>Lyndon_mono (ws \<cdot> [a])\<close>[unfolded Lyndon_mono_def]
  have "Lyndon a"
    by blast
  show ?case
  proof(cases "s \<le>ns a")
    case True
    from Lyndon_suf_le[OF \<open>Lyndon a\<close>] this
    show ?thesis
      by simp
  next
    case False
    hence "ws \<noteq> \<epsilon>"
      using snoc.prems(2) by force
    obtain s' where "s = s'\<cdot>a"
      using False snoc.prems(2)[unfolded concat_append[of ws "[a]", unfolded concat_sing']] suffix_append[of s "concat ws" a]
      unfolding nonempty_suffix_def
      by blast
    hence "s' \<le>ns concat ws"
      using False snoc.prems(2) by fastforce
    have "Lyndon_mono ws"
      using \<open>Lyndon_mono (ws\<cdot>[a])\<close> Lyndon_mono_fac_Lyndon_mono
      by blast
    from snoc.hyps[OF this \<open>s' \<le>ns concat ws\<close>]
    have "last ws \<le>lex s'"
      by auto
    hence "last ws \<le>lex s'\<cdot>a"
      using local.lexordp_eq_trans ord.lexordp_eq_pref by blast
    have "a \<le>lex last ws"
      using \<open>Lyndon_mono (ws\<cdot>[a])\<close>
      unfolding Lyndon_mono_def
      by (simp add: \<open>ws \<noteq> \<epsilon>\<close> last_ConsL)
    from dual_rlex.order_trans[OF \<open>last ws \<le>lex s' \<cdot> a\<close> this, folded \<open>s = s' \<cdot> a\<close>]
    show ?thesis
      unfolding \<open>last (ws\<cdot>[a]) = a\<close>
      by blast
  qed
qed

text\<open>A monotone list, if seen as a factorization,
must end with the longest suffix\<close>

lemma Lyndon_mono_last_longest: assumes "ws \<noteq> \<epsilon>" and "Lyndon_mono ws"
  shows "LynSuf (concat ws) = last ws"
proof-
  have "Lyndon (last ws)"
    using Lyndon_mono_set assms(1) assms(2) last_in_set by blast
  hence "last ws \<noteq> \<epsilon>"
    using LyndonD_nemp by blast
  hence "last ws \<le>ns LynSuf (concat ws)"
    using longest_Lyndon_suf_max[OF  concat_last_suf[OF assms(1)] \<open>Lyndon (last ws)\<close>]
    unfolding nonempty_suffix_def
    by blast

  have "concat ws \<noteq> \<epsilon>"
    using Lyndon.simps assms(2)[unfolded Lyndon_mono_def] set_nemp_concat_nemp[OF assms(1)]
    by blast
  from longest_Lyndon_suf_nemp[OF this] longest_Lyndon_suf_suf[OF this]
  have "LynSuf (concat ws) \<le>ns concat ws"
    unfolding nonempty_suffix_def
    by simp

  show ?thesis
    using Lyndon_mono_last_smallest[OF \<open>Lyndon_mono ws\<close> \<open>LynSuf (concat ws) \<le>ns concat ws\<close>]
      Lyndon_suf_le[OF longest_Lyndon_suf_Lyndon[OF \<open>concat ws \<noteq> \<epsilon>\<close>], OF \<open>last ws \<le>ns LynSuf (concat ws)\<close>]
    by simp
qed

text\<open>Therefore, by construction,
any monotone list is the Lyndon factorization of its concatenation\<close>

lemma Lyndon_mono_fac:
  "Lyndon_mono ws \<Longrightarrow> ws = Lyndon_fac (concat ws)"
proof (induct ws rule: rev_induct, simp)
  case (snoc x xs)
  have "Lyndon_mono xs"
    using \<open>Lyndon_mono (xs \<cdot> [x])\<close>
    unfolding Lyndon_mono_def
    by simp
  from snoc.hyps[OF this]
  have "xs = LynFac (concat xs)".
  have "x = LynSuf (concat (xs \<cdot> [x]))"
    using Lyndon_mono_last_longest[OF _ \<open>Lyndon_mono (xs \<cdot> [x])\<close>, unfolded last_snoc] by simp
  have "concat (xs \<cdot> [x])\<^sup><\<inverse>x = concat xs"
    by simp
  have "concat (xs \<cdot> [x]) \<noteq> \<epsilon>"
    using Lyndon_mono_set snoc.prems by auto
  from this
  show ?case
    using Lyndon_fac.simps[of "concat (xs \<cdot> [x])", folded \<open>x = LynSuf (concat (xs \<cdot> [x]))\<close>,
        unfolded \<open>concat (xs \<cdot> [x])\<^sup><\<inverse>x = concat xs\<close>, folded \<open>xs = LynFac (concat xs)\<close>]
    by presburger
qed

text\<open>This implies that the Lyndon factorization can be characterized
in two equivalent ways: as the (unique) monotone factorization (into Lyndon words) or as
the "suffix greedy" factorization (into Lyndon words).
\<close>

corollary Lyndon_mono_fac_iff: "Lyndon_mono ws \<longleftrightarrow> ws = LynFac (concat ws)"
  using Lyndon_mono_fac fac_Lyndon_mono[of "concat ws"] by fastforce

corollary Lyndon_mono_unique: assumes "Lyndon_mono ws" and "Lyndon_mono zs" and "concat ws = concat zs"
  shows "ws = zs"
  using Lyndon_mono_fac[OF \<open>Lyndon_mono ws\<close>] Lyndon_mono_fac[OF \<open>Lyndon_mono zs\<close>]
  unfolding \<open>concat ws = concat zs\<close>  by simp

subsection "Standard factorization"

lemma Lyndon_std: assumes "Lyndon w" "1 < \<^bold>|w\<^bold>|"
  obtains l m where "w = l\<cdot>m" and "Lyndon l" and "Lyndon m" and "l <lex m"
proof-
  have "w \<noteq> \<epsilon>" "tl w \<noteq> \<epsilon>"
    using \<open>1 < \<^bold>|w\<^bold>|\<close> long_list_tl by auto
  define m where  "m = LynSuf (tl w)"
  hence "Lyndon m"
    using \<open>tl w \<noteq> \<epsilon>\<close> local.longest_Lyndon_suf_Lyndon by blast
  have "m \<le>s w"
    unfolding m_def
    using suffix_order.trans[OF longest_Lyndon_suf_suf[OF \<open>tl w \<noteq> \<epsilon>\<close>] suffix_tl[of w]].
  moreover have "m \<noteq> w"
    unfolding m_def using  hd_word'[OF \<open>w \<noteq> \<epsilon>\<close>] list.simps(3) longest_Lyndon_suf_suf[OF \<open>tl w \<noteq> \<epsilon>\<close>] same_suffix_nil
    by fastforce
  ultimately obtain l where "w = l\<cdot>m" and "l \<noteq> \<epsilon>"
    by force

  have "Lyndon l"
  proof (rule unbordered_pref_Lyndon[OF \<open>Lyndon w\<close>[unfolded \<open>w = l\<cdot>m\<close>] \<open>l \<noteq> \<epsilon>\<close>], rule)
    assume "bordered l"
    from unbordered_border[OF this, unfolded border_def]
    obtain s where "s \<noteq> \<epsilon>" and "s \<noteq> l" and "s \<le>p l" and "s \<le>s l" and "\<not> bordered s"
      by blast
    have "Lyndon s"
      using unbordered_pref_Lyndon[OF _ \<open>s \<noteq> \<epsilon>\<close> \<open>\<not> bordered s\<close>, of "s\<inverse>\<^sup>>l\<cdot>m", unfolded lassoc lq_pref[OF \<open>s \<le>p l\<close>]]
      \<open>Lyndon w\<close>[unfolded \<open>w = l \<cdot> m\<close>] by blast
    have "s <lex m"
      using Lyndon_pref_suf_less[OF \<open>Lyndon w\<close> _ nsI[OF LyndonD_nemp[OF \<open>Lyndon m\<close>] \<open>m \<le>s w\<close>]
         \<open>m \<noteq> w\<close>, of s] Lyndon.elims(2)[OF \<open>Lyndon m\<close>]
         \<open>s \<le>p l\<close> prefix_append[of s l m, folded \<open>w = l \<cdot> m\<close>]
      by presburger
    from Lyndon_concat[OF \<open>Lyndon s\<close> \<open>Lyndon m\<close> this]
    have "Lyndon (s\<cdot>m)".
    moreover have "s\<cdot>m \<le>s tl w"
      unfolding \<open>w = l \<cdot> m\<close> using \<open>s \<noteq> l\<close> \<open>s \<le>s l\<close> list.collapse[OF \<open>w \<noteq> \<epsilon>\<close>, unfolded \<open>w = l \<cdot> m\<close>] by force
    ultimately show False
      using m_def \<open>s \<noteq> \<epsilon>\<close> longest_Lyndon_suf_max same_suffix_nil by blast
  qed

  have "l <lex m"
    using Lyndon_pref_suf_less[OF \<open>Lyndon w\<close> prefI[OF \<open>w = l \<cdot> m\<close>[symmetric]]
        nsI[OF longest_Lyndon_suf_nemp[OF \<open>tl w \<noteq> \<epsilon>\<close>, folded  m_def] \<open>m \<le>s w\<close>] \<open>m \<noteq> w\<close>].
  from that[OF \<open>w = l \<cdot> m\<close> \<open>Lyndon l\<close>  \<open>Lyndon m\<close> this]
  show thesis.
qed

corollary Lyndon_std_iff:
  "Lyndon w \<longleftrightarrow> (\<^bold>|w\<^bold>| = 1 \<or> (\<exists> l m. w = l\<cdot>m \<and> Lyndon l \<and> Lyndon m \<and> l <lex m))"
  (is "?L \<longleftrightarrow> ?R")
proof
  assume ?L
  show ?R
    using Lyndon_std[OF \<open>Lyndon w\<close>]
      nemp_pos_len[OF LyndonD_nemp[OF \<open>Lyndon w\<close>], unfolded le_eq_less_or_eq]
    by metis
next
  assume ?R
  thus ?L
  proof(rule disjE, fastforce)
    show \<open>\<exists>l m. w = l \<cdot> m \<and> Lyndon l \<and> Lyndon m \<and> l <lex m \<Longrightarrow> Lyndon w\<close>
      using Lyndon_concat by blast
  qed
qed

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

end


chapter\<open>Examples\<close>
text\<open>In this chapter, we provide some examples of EFSMs and proofs over them. We first present a
formalisation of a simple drinks machine. Next, we prove observational equivalence of an alternative
model. Finally, we prove some temporal properties of the first example.\<close>

section\<open>Drinks Machine\<close>
text\<open>This theory formalises a simple drinks machine. The \emph{select} operation takes one
argument - the desired beverage. The \emph{coin} operation also takes one parameter representing
the value of the coin. The \emph{vend} operation has two flavours - one which dispenses the drink if
the customer has inserted enough money, and one which dispenses nothing if the user has not inserted
sufficient funds.

We first define a datatype \emph{statemane} which corresponds to $S$ in the formal definition.
Note that, while statename has four elements, the drinks machine presented here only requires three
states. The fourth element is included here so that the \emph{statename} datatype may be used in
the next example.\<close>
theory Drinks_Machine
  imports "Extended_Finite_State_Machines-devel.EFSM"
begin

text_raw\<open>\snip{selectdef}{1}{2}{%\<close>
definition select :: "transition" where
"select \<equiv> \<lparr>
        Label = STR ''select'',
        Arity = 1,
        Guards = [],
        Outputs = [],
        Updates = [
                    (1, V (I 0)),
                    (2, L (Num 0))
                  ]
      \<rparr>"
text_raw\<open>}%endsnip\<close>

text_raw\<open>\snip{coindef}{1}{2}{%\<close>
definition coin :: "transition" where
"coin \<equiv> \<lparr>
        Label = STR ''coin'',
        Arity = 1,
        Guards = [],
        Outputs = [Plus (V (R 2)) (V (I 0))],
        Updates = [
                    (1, V (R 1)),
                    (2, Plus (V (R 2)) (V (I 0)))
                  ]
      \<rparr>"
text_raw\<open>}%endsnip\<close>

text_raw\<open>\snip{venddef}{1}{2}{%\<close>
definition vend:: "transition" where
"vend\<equiv> \<lparr>
        Label = STR ''vend'',
        Arity = 0,
        Guards = [(Ge (V (R 2)) (L (Num 100)))],
        Outputs =  [(V (R 1))],
        Updates = [(1, V (R 1)), (2, V (R 2))]
      \<rparr>"
text_raw\<open>}%endsnip\<close>

text_raw\<open>\snip{vendfaildef}{1}{2}{%\<close>
definition vend_fail :: "transition" where
"vend_fail \<equiv> \<lparr>
        Label = STR ''vend'',
        Arity = 0,
        Guards = [(Lt (V (R 2)) (L (Num 100)))],
        Outputs =  [],
        Updates = [(1, V (R 1)), (2, V (R 2))]
      \<rparr>"
text_raw\<open>}%endsnip\<close>

text_raw\<open>\snip{drinksdef}{1}{2}{%\<close>
definition drinks :: "transition_matrix" where
"drinks \<equiv> {|
          ((0,1), select),
          ((1,1), coin),
          ((1,1), vend_fail),
          ((1,2), vend)
         |}"
text_raw\<open>}%endsnip\<close>

lemmas transitions = select_def coin_def vend_def vend_fail_def

lemma drinks_states: "S drinks = {|0, 1, 2|}"
  apply (simp add: S_def drinks_def)
  by auto

lemma possible_steps_0:
  "length i = 1 \<Longrightarrow>
   possible_steps drinks 0 r (STR ''select'') i = {|(1, select)|}"
  apply (simp add: possible_steps_singleton drinks_def)
  apply safe
  by (simp_all add: transitions apply_guards_def)

lemma first_step_select:
  "(s', t) |\<in>| possible_steps drinks 0 r aa b \<Longrightarrow> s' = 1 \<and> t = select"
  apply (simp add: possible_steps_def fimage_def ffilter_def fmember_def Abs_fset_inverse Set.filter_def drinks_def)
  apply safe
  by (simp_all add: transitions)

lemma drinks_vend_insufficient:
  "r $ 2 = Some (Num x1) \<Longrightarrow>
   x1 < 100 \<Longrightarrow>
   possible_steps drinks 1 r (STR ''vend'') [] = {|(1, vend_fail)|}"
  apply (simp add: possible_steps_singleton drinks_def)
  apply safe
  by (simp_all add: transitions apply_guards_def value_gt_def join_ir_def connectives)

lemma drinks_vend_invalid:
  "\<nexists>n. r $ 2 = Some (Num n) \<Longrightarrow>
   possible_steps drinks 1 r (STR ''vend'') [] = {||}"
  apply (simp add: possible_steps_empty drinks_def can_take_transition_def can_take_def transitions)
  by (simp add: MaybeBoolInt_not_num_1 value_gt_def)

lemma possible_steps_1_coin:
  "length i = 1 \<Longrightarrow> possible_steps drinks 1 r (STR ''coin'') i = {|(1, coin)|}"
  apply (simp add: possible_steps_singleton drinks_def)
  apply safe
  by (simp_all add: transitions)

lemma possible_steps_2_vend:
  "\<exists>n. r $ 2 = Some (Num n) \<and> n \<ge> 100 \<Longrightarrow>
   possible_steps drinks 1 r (STR ''vend'') [] = {|(2, vend)|}"
  apply (simp add: possible_steps_singleton drinks_def)
  apply safe
  by (simp_all add: transitions apply_guards_def value_gt_def join_ir_def connectives)

lemma recognises_from_2:
  "recognises_execution drinks 1 <1 $:= d, 2 $:= Some (Num 100)> [(STR ''vend'', [])]"
  apply (rule recognises_execution.step)
  apply (rule_tac x="(2, vend)" in fBexI)
   apply simp
  by (simp add: possible_steps_2_vend)

lemma recognises_from_1a:
  "recognises_execution drinks 1 <1 $:= d, 2 $:= Some (Num 50)> [(STR ''coin'', [Num 50]), (STR ''vend'', [])]"
  apply (rule recognises_execution.step)
  apply (rule_tac x="(1, coin)" in fBexI)
   apply (simp add: apply_updates_def coin_def finfun_update_twist value_plus_def recognises_from_2)
  by (simp add: possible_steps_1_coin)

lemma recognises_from_1: "recognises_execution drinks 1 <2 $:= Some (Num 0), 1 $:= Some d>
     [(STR ''coin'', [Num 50]), (STR ''coin'', [Num 50]), (STR ''vend'', [])]"
  apply (rule recognises_execution.step)
  apply (rule_tac x="(1, coin)" in fBexI)
   apply (simp add: apply_updates_def coin_def value_plus_def finfun_update_twist recognises_from_1a)
  by (simp add: possible_steps_1_coin)

lemma rejects_input:
  "l \<noteq> STR ''coin'' \<Longrightarrow>
   l \<noteq> STR ''vend'' \<Longrightarrow>
   \<not> recognises_execution drinks 1 d' [(l, i)]"
  apply (rule no_possible_steps_rejects)
  by (simp add: possible_steps_empty drinks_def can_take_transition_def can_take_def transitions)

lemma rejects_recognises_prefix: "l \<noteq> STR ''coin'' \<Longrightarrow>
   l \<noteq> STR ''vend'' \<Longrightarrow>
   \<not> (recognises drinks [(STR ''select'', [Str ''coke'']), (l, i)])"
  apply (rule trace_reject_later)
  apply (simp add: possible_steps_0 select_def join_ir_def input2state_def)
  using rejects_input by blast

lemma rejects_termination:
  "observe_execution drinks 0 <> [(STR ''select'', [Str ''coke'']), (STR ''rejects'', [Num 50]), (STR ''coin'', [Num 50])] = [[]]"
  apply (rule observe_execution_step)
   apply (simp add: step_def possible_steps_0 select_def)
  apply (rule observe_execution_no_possible_step)
  by (simp add: possible_steps_empty drinks_def can_take_transition_def can_take_def transitions)

(* Part of Example 2 in Foster et. al. *)
lemma r2_0_vend:
  "can_take_transition vend i r \<Longrightarrow>
   \<exists>n. r $ 2 = Some (Num n) \<and> n \<ge> 100" (* You can't take vendimmediately after taking select *)
  apply (simp add: can_take_transition_def can_take_def vend_def apply_guards_def maybe_negate_true maybe_or_false connectives value_gt_def)
  using MaybeBoolInt.elims by force

lemma drinks_vend_sufficient: "r $ 2 = Some (Num x1) \<Longrightarrow>
                x1 \<ge> 100 \<Longrightarrow>
                possible_steps drinks 1 r (STR ''vend'') [] = {|(2, vend)|}"
  using possible_steps_2_vend by blast

lemma drinks_end: "possible_steps drinks 2 r a b = {||}"
  apply (simp add: possible_steps_def drinks_def transitions)
  by force

lemma drinks_vend_r2_String:
  "r $ 2 = Some (value.Str x2) \<Longrightarrow>
   possible_steps drinks 1 r (STR ''vend'') [] = {||}"
  apply (simp add: possible_steps_empty drinks_def can_take_transition_def can_take_def transitions)
  by (simp add: value_gt_def)

lemma drinks_vend_r2_rejects:
  "\<nexists>n. r $ 2 = Some (Num n) \<Longrightarrow> step drinks 1 r (STR ''vend'') [] = None"
  apply (rule no_possible_steps_1)
  apply (simp add: possible_steps_empty drinks_def can_take_transition_def can_take_def transitions)
  by (simp add: MaybeBoolInt_not_num_1 value_gt_def)

lemma drinks_0_rejects:
  "\<not> (fst a = STR ''select'' \<and> length (snd a) = 1) \<Longrightarrow>
    (possible_steps drinks 0 r (fst a) (snd a)) = {||}"
  apply (simp add: drinks_def possible_steps_def transitions)
  by force

lemma drinks_vend_empty: "(possible_steps drinks 0 <> (STR ''vend'') []) = {||}"
  using drinks_0_rejects
  by auto

lemma drinks_1_rejects:
  "fst a = STR ''coin'' \<longrightarrow> length (snd a) \<noteq> 1 \<Longrightarrow>
          a \<noteq> (STR ''vend'', []) \<Longrightarrow>
          possible_steps drinks 1 r (fst a) (snd a) = {||}"
  apply (simp add: possible_steps_empty drinks_def can_take_transition_def can_take_def transitions)
  by (metis prod.collapse)

lemma drinks_rejects_future: "\<not> recognises_execution drinks 2 d ((l, i)#t)"
  apply (rule no_possible_steps_rejects)
  by (simp add: possible_steps_empty drinks_def)

lemma drinks_1_rejects_trace:
  assumes not_vend: "e \<noteq> (STR ''vend'', [])"
      and not_coin: "\<nexists>i. e = (STR ''coin'', [i])"
  shows "\<not> recognises_execution drinks 1 r (e # es)"
proof-
  show ?thesis
    apply (cases e, simp)
    subgoal for a b
      apply (rule no_possible_steps_rejects)
      apply (simp add: possible_steps_empty drinks_def can_take_transition_def can_take_def transitions)
      apply (case_tac b)
      using not_vend apply simp
      using not_coin by auto
    done
qed

lemma rejects_state_step: "s > 1 \<Longrightarrow> step drinks s r l i = None"
  apply (rule no_possible_steps_1)
  by (simp add: possible_steps_empty drinks_def)

lemma invalid_other_states:
  "s > 1 \<Longrightarrow> \<not> recognises_execution drinks s r ((aa, b) # t)"
  apply (rule no_possible_steps_rejects)
  by (simp add: possible_steps_empty drinks_def)

lemma vend_ge_100:
  "possible_steps drinks 1 r l i = {|(2, vend)|} \<Longrightarrow>
   \<not>? value_gt (Some (Num 100)) (r $ 2) = trilean.true"
  apply (insert possible_steps_apply_guards[of drinks 1 r l i 2 vend])
  by (simp add: possible_steps_def apply_guards_def vend_def)

lemma drinks_no_possible_steps_1:
  assumes not_coin: "\<not> (a = STR ''coin'' \<and> length b = 1)"
      and not_vend: "\<not> (a = STR ''vend'' \<and> b = [])"
    shows "possible_steps drinks 1 r a b = {||}"
  using drinks_1_rejects not_coin not_vend by auto

lemma possible_steps_select_wrong_arity: "a = STR ''select'' \<Longrightarrow>
       length b \<noteq> 1 \<Longrightarrow>
       possible_steps drinks 0 <> a b = {||}"
  apply (simp add: possible_steps_def ffilter_def fset_both_sides Abs_fset_inverse Set.filter_def drinks_def)
  apply safe
  by (simp_all add: select_def)

lemma possible_steps_0_invalid:
  "\<not> (l = STR ''select'' \<and> length i = 1) \<Longrightarrow>
   possible_steps drinks 0 <> l i = {||}"
  using possible_steps_0_not_select possible_steps_select_wrong_arity by fastforce

end


(*<*)
theory Trace
imports Basis
begin

declare Let_def[simp] split_if_asm[split]
(*>*)

section{*A trace based model*}

text{* The only clumsy aspect of the state based model is @{text
safe}: we use a state component to record if the sequence of events
that lead to a state satisfies some property. That is, we simulate a
condition on traces via the state. Unsurprisingly, it is not trivial
to convince oneself that @{text safe} really has the informal meaning
set out at the beginning of subsection~\ref{sec:formalizing-safety}.
Hence we now describe an alternative, purely trace based model,
similar to Paulson's inductive protocol model~\cite{Paulson-JCS98}.
The events are:
*}

datatype event =
  Check_in guest room card | Enter guest room card | Exit guest room

text{* Instead of a state, we have a trace, i.e.\ list of events, and
extract the state from the trace: *}

consts
  initk :: "room \<Rightarrow> key"

primrec owns :: "event list \<Rightarrow> room \<Rightarrow> guest option" where
"owns [] r = None" |
"owns (e#s) r = (case e of
 Check_in g r' c \<Rightarrow> if r' = r then Some g else owns s r |
 Enter g r' c \<Rightarrow> owns s r |
 Exit g r' \<Rightarrow> owns s r)"

primrec currk :: "event list \<Rightarrow> room \<Rightarrow> key" where
"currk [] r = initk r" |
"currk (e#s) r = (let k = currk s r in
    case e of Check_in g r' c \<Rightarrow> if r' = r then snd c else k
            | Enter g r' c \<Rightarrow> k
            | Exit g r \<Rightarrow> k)"

primrec issued :: "event list \<Rightarrow> key set" where
"issued [] = range initk" |
"issued (e#s) = issued s \<union>
  (case e of Check_in g r c \<Rightarrow> {snd c} | Enter g r c \<Rightarrow> {} | Exit g r \<Rightarrow> {})"

primrec cards :: "event list \<Rightarrow> guest \<Rightarrow> card set" where
"cards [] g = {}" |
"cards (e#s) g = (let C = cards s g in
                    case e of Check_in g' r c \<Rightarrow> if g' = g then insert c C
                                                else C
                            | Enter g r c \<Rightarrow> C
                            | Exit g r \<Rightarrow> C)"

primrec roomk :: "event list \<Rightarrow> room \<Rightarrow> key" where
"roomk [] r = initk r" |
"roomk (e#s) r = (let k = roomk s r in
    case e of Check_in g r' c \<Rightarrow> k
            | Enter g r' (x,y) \<Rightarrow> if r' = r (*& x = k*) then y else k
            | Exit g r \<Rightarrow> k)"

primrec isin :: "event list \<Rightarrow> room \<Rightarrow> guest set" where
"isin [] r = {}" |
"isin (e#s) r = (let G = isin s r in
                 case e of Check_in g r c \<Rightarrow> G
                 | Enter g r' c \<Rightarrow> if r' = r then {g} \<union> G else G
                 | Exit g r' \<Rightarrow> if r'=r then G - {g} else G)"

primrec hotel :: "event list \<Rightarrow> bool" where
"hotel []  = True" |
"hotel (e # s) = (hotel s & (case e of
  Check_in g r (k,k') \<Rightarrow> k = currk s r \<and> k' \<notin> issued s |
  Enter g r (k,k') \<Rightarrow> (k,k') : cards s g & (roomk s r : {k, k'}) |
  Exit g r \<Rightarrow> g : isin s r))"

text{* Except for @{const initk}, which is completely unspecified,
all these functions are defined by primitive recursion over traces:
@{thm[display]owns.simps}
@{thm[display]currk.simps}
@{thm[display]issued.simps}
@{thm[display]cards.simps}
@{thm[display]roomk.simps}
@{thm[display]isin.simps}

However, not every trace is possible. Function @{const hotel} tells us
which traces correspond to real hotels:
@{thm[display]hotel.simps}
Alternatively we could have followed Paulson~\cite{Paulson-JCS98}
in defining @{const hotel} as an inductive set of traces.
The difference is only slight.

\subsection{Formalizing safety}
\label{sec:FormalSafetyTrace}

The principal advantage of the trace model is the intuitive
specification of safety. Using the auxiliary predicate @{text no_Check_in}
*}

(*<*)abbreviation no_Check_in :: "event list \<Rightarrow> room \<Rightarrow> bool" where(*>*)
"no_Check_in s r \<equiv> \<not>(\<exists>g c. Check_in g r c \<in> set s)"

text{*\medskip\noindent we define a trace to be @{text safe\<^sub>0} for a
room if the card obtained at the last @{const Check_in} was later
actually used to @{const Enter} the room: *}

(*<*)definition safe\<^sub>0 :: "event list \<Rightarrow> room \<Rightarrow> bool" where(*>*)
"safe\<^sub>0 s r = (\<exists>s\<^sub>1 s\<^sub>2 s\<^sub>3 g c.
 s = s\<^sub>3 @ [Enter g r c] @ s\<^sub>2 @ [Check_in g r c] @ s\<^sub>1 \<and> no_Check_in (s\<^sub>3 @ s\<^sub>2) r)"

text{* \medskip\noindent A trace is @{text safe} if additionally the room was
empty when it was entered: *}

(*<*)definition safe :: "event list \<Rightarrow> room \<Rightarrow> bool" where(*>*)
"safe s r = (\<exists>s\<^sub>1 s\<^sub>2 s\<^sub>3 g c.
 s = s\<^sub>3 @ [Enter g r c] @ s\<^sub>2 @ [Check_in g r c] @ s\<^sub>1 \<and>
 no_Check_in (s\<^sub>3 @ s\<^sub>2) r \<and> isin (s\<^sub>2 @ [Check_in g r c] @ s\<^sub>1) r = {})"

text{* \medskip\noindent The two notions of safety are distinguished because,
except for the main theorem, @{const safe\<^sub>0} suffices.

The alert reader may already have wondered why, in contrast to the
state based model, we do not require @{const initk} to be
injective. If @{const initk} is not injective, e.g.\ @{prop"initk
r\<^sub>1 = initk r\<^sub>2"} and @{prop"r\<^sub>1 \<noteq> r\<^sub>2"},
then @{term"[Enter g r\<^sub>2 (initk r\<^sub>1,k), Check_in g
r\<^sub>1 (initk r\<^sub>1,k)]"} is a legal trace and guest @{text
g} ends up in a room he is not the owner of.  However, this is not a
safe trace for room @{text r\<^sub>2} according to our
definition. This reflects that hotel rooms are not safe until
the first time their owner has entered them. We no longer protect the
hotel from its guests.  *}

(* state thm w/o "isin"
hotel s ==> s = Enter g # s' \<Longrightarrow> owns s' r = Some g \<or> s' = s1 @ Checkin g @ s2 \<and>
no checkin, no enter in s1

*)

(*<*)
(*
defs initk_def:  "initk == %r. if r then 1 else 0"

lemma [code_unfold]: "(UNIV::bool set) == {True,False}"
sorry

lemma "let s\<^sub>2 = [Checkin g r c'',Checkin g' r c'];
s = s\<^sub>3 @ [Enter g r c] @ s\<^sub>2 @ [Checkin g r c] in
       hotel s \<and>
       (ALL e:set s\<^sub>2. case e of Enter g' r' c \<Rightarrow> \<not>(g' = g \<and> r' = r) | _ \<Rightarrow> True) \<and>
       owns s r = Some g \<and> isin (s\<^sub>2 @ [Checkin g r c]) r = {} \<and> g' : isin s r
\<longrightarrow> g' = g"
quickcheck[iterations=100000,size=8]
*)
lemma safe_safe: "safe s r \<Longrightarrow> safe\<^sub>0 s r"
by (simp add: safe\<^sub>0_def safe_def) blast

lemma initk_issued[simp]: "hotel s \<Longrightarrow> initk r \<in> issued s"
by (induct s) (auto split:event.split)

lemma currk_issued[simp]: "hotel s \<Longrightarrow> currk s r \<in> issued s"
by (induct s) (auto split:event.split)

lemma key1_issued[simp]: "hotel s \<Longrightarrow> (k,k') : cards s g \<Longrightarrow> k \<in> issued s"
by (induct s) (auto split:event.split)

lemma key2_issued[simp]: "hotel s \<Longrightarrow> (k,k') : cards s g \<Longrightarrow> k' \<in> issued s"
by (induct s) (auto split:event.split)

lemma roomk_issued[simp]: "hotel s \<Longrightarrow> roomk s r \<in> issued s"
by (induct s) (auto split:event.split)

lemma issued_app: "issued (s @ s') = issued s \<union> issued s'"
apply (induct s) apply (auto split:event.split)
apply (induct s') apply (auto split:event.split)
done
(*
lemma cards_app[simp]: "cards (s @ s') g = cards s g \<union> cards s' g"
by (induct s) (auto split:event.split)
*)
lemma owns_app[simp]: "no_Check_in s\<^sub>2 r \<Longrightarrow> owns (s\<^sub>2 @ s\<^sub>1) r = owns s\<^sub>1 r"
by (induct s\<^sub>2) (auto split:event.split)

lemma currk_app[simp]: "no_Check_in s\<^sub>2 r \<Longrightarrow> currk (s\<^sub>2 @ s\<^sub>1) r = currk s\<^sub>1 r"
by (induct s\<^sub>2) (auto split:event.split)

lemma currk_Check_in:
 "\<lbrakk> hotel (s\<^sub>2 @ Check_in g r (k, k')# s\<^sub>1);
    k' = currk (s\<^sub>2 @ Check_in g r (k, k') # s\<^sub>1) r' \<rbrakk> \<Longrightarrow> r' = r"
by (induct s\<^sub>2) (auto simp: issued_app split:event.splits)

lemma no_checkin_no_newkey:
"\<lbrakk> hotel(s\<^sub>2 @ [Check_in g r (k,k')] @ s\<^sub>1); no_Check_in s\<^sub>2 r \<rbrakk>
 \<Longrightarrow> (k',k'') \<notin> cards (s\<^sub>2 @ Check_in g r (k,k') # s\<^sub>1) g'"
apply(induct s\<^sub>2)
 apply fastforce
apply(fastforce split:event.splits dest: currk_Check_in)
done

lemma guest_key2_disj2[simp]:
"\<lbrakk> hotel s; (k\<^sub>1,k) \<in> cards s g\<^sub>1; (k\<^sub>2,k) \<in> cards s g\<^sub>2 \<rbrakk> \<Longrightarrow> g\<^sub>1=g\<^sub>2"
apply (induct s)
apply(auto split:event.splits)
done

lemma safe_roomk_currk[simp]:
 "hotel s \<Longrightarrow> safe\<^sub>0 s r \<Longrightarrow> roomk s r = currk s r"
apply(clarsimp simp:safe\<^sub>0_def)
apply(hypsubst_thin)
apply(erule rev_mp)+
apply(induct_tac s\<^sub>3)
apply(auto split:event.split)
apply(rename_tac guest ba)
apply(subgoal_tac "(b, ba)
        \<notin> cards ((list @ Enter g r (a, b) # s\<^sub>2) @ Check_in g r (a, b) # s\<^sub>1)
           guest")
apply simp
apply(rule no_checkin_no_newkey) apply simp_all
done

(* A short proof *)
lemma "\<lbrakk> hotel s; safe s r; g \<in> isin s r \<rbrakk> \<Longrightarrow> owns s r = Some g"
apply(clarsimp simp add:safe_def)
apply(hypsubst_thin)
apply(rename_tac g' k k')
apply(erule rev_mp)+
apply(induct_tac s\<^sub>3)
 apply simp
apply (auto split:event.split)
 apply(subgoal_tac
 "safe\<^sub>0 (list @ Enter g' r (k,k') # s\<^sub>2 @ Check_in g' r (k, k') # s\<^sub>1) r")
  prefer 2
  apply(simp add:safe\<^sub>0_def)apply blast
 apply(simp)
 apply(cut_tac s\<^sub>2 = "list @ Enter g' r (k, k') # s\<^sub>2" in no_checkin_no_newkey)
   apply simp
  apply simp
 apply simp
 apply fast
apply(subgoal_tac
 "safe\<^sub>0 (list @ Enter g' r (k,k') # s\<^sub>2 @ Check_in g' r (k, k') # s\<^sub>1) r")
 apply(drule (1) only_owner_enter_normal)
  apply blast
 apply simp
apply(simp add:safe\<^sub>0_def)
apply blast
done

lemma in_set_conv_decomp_firstD:
assumes "P x"
shows "x \<in> set xs \<Longrightarrow>
  \<exists>ys x zs. xs = ys @ x # zs \<and> P x \<and> (\<forall>y \<in> set ys. \<not> P y)"
  (is "_ \<Longrightarrow> EX ys x zs. ?P xs ys x zs")
proof (induct xs)
  case Nil thus ?case by simp
next
  case (Cons a xs)
  show ?case
  proof cases
    assume "x = a \<or> P a" hence "?P (a#xs) [] a xs" using `P x` by auto
    thus ?case by blast
  next
    assume "\<not>(x = a \<or> P a)"
    with assms Cons show ?case by clarsimp (fastforce intro!: Cons_eq_appendI)
  qed
qed

lemma ownsD: "owns s r = Some g \<Longrightarrow>
 EX s\<^sub>1 s\<^sub>2 g c. s = s\<^sub>2 @ [Check_in g r c] @ s\<^sub>1 \<and> no_Check_in s\<^sub>2 r"
apply(induct s)
 apply simp
apply (auto split:event.splits)
apply(rule_tac x = s in exI)
apply(rule_tac x = "[]" in exI)
apply simp
apply(rule_tac x = s\<^sub>1 in exI)
apply simp
apply(rule_tac x = s\<^sub>1 in exI)
apply simp
apply(rule_tac x = s\<^sub>1 in exI)
apply simp
done

lemma no_Check_in_owns[simp]: "no_Check_in s r \<Longrightarrow> owns s r = None"
by (induct s) (auto split:event.split)

theorem Enter_safe:
 "\<lbrakk> hotel(Enter g r c # s); safe\<^sub>0 s r \<rbrakk> \<Longrightarrow> owns s r = Some g"
apply(subgoal_tac "\<exists>s\<^sub>1 s\<^sub>2 g c. s = s\<^sub>2 @ [Check_in g r c] @ s\<^sub>1 \<and> no_Check_in s\<^sub>2 r")
 prefer 2
 apply(simp add:safe\<^sub>0_def)
 apply(elim exE conjE)
 apply(rule_tac x = s\<^sub>1 in exI)
 apply (simp)
apply(elim exE conjE)
apply(cases c)
apply(clarsimp)
apply(erule disjE)
apply (simp add:no_checkin_no_newkey)
apply simp
apply(frule only_owner_enter_normal)
apply assumption
apply simp
apply simp
done

lemma safe_future: "safe\<^sub>0 s r \<Longrightarrow> no_Check_in s' r \<Longrightarrow> safe\<^sub>0 (s' @ s) r"
apply(clarsimp simp:safe\<^sub>0_def)
apply(rule_tac x = s\<^sub>1 in exI)
apply(rule_tac x = s\<^sub>2 in exI)
apply simp
done

corollary Enter_safe_future:
 "\<lbrakk> hotel(Enter g r c # s' @ s); safe\<^sub>0 s r; no_Check_in s' r \<rbrakk>
 \<Longrightarrow> owns s r = Some g"
apply(drule (1) safe_future)
apply(drule (1) Enter_safe)
apply simp
done
(*>*)

text_raw{*
  \begin{figure}
  \begin{center}\begin{minipage}{\textwidth}
  \isastyle\isamarkuptrue
*}
theorem safe: assumes "hotel s" and "safe s r" and "g \<in> isin s r"
                    shows "owns s r = \<lfloor>g\<rfloor>"
proof -
  { fix s\<^sub>1 s\<^sub>2 s\<^sub>3 g' k k'
    let ?b = "[Enter g' r (k,k')] @ s\<^sub>2 @ [Check_in g' r (k,k')] @ s\<^sub>1"
    let ?s = "s\<^sub>3 @ ?b"
    assume 0: "isin (s\<^sub>2 @ [Check_in g' r (k,k')] @ s\<^sub>1) r = {}"
    have "\<lbrakk> hotel ?s; no_Check_in (s\<^sub>3 @ s\<^sub>2) r; g \<in> isin ?s r \<rbrakk> \<Longrightarrow> g' = g"
    proof(induct s\<^sub>3)
      case Nil thus ?case using 0 by simp
    next
      case (Cons e s\<^sub>3)
      let ?s = "s\<^sub>3 @ ?b" and ?t = "(e \<cdot> s\<^sub>3) @ ?b"
      show ?case
      proof(cases e)
        case (Enter g'' r' c)[simp]
        show "g' = g"
        proof cases
          assume [simp]: "r' = r"
          show "g' = g"
          proof cases
            assume [simp]: "g'' = g"
            have 1: "hotel ?s" and 2: "c \<in> cards ?s g" using `hotel ?t` by auto
            have 3: "safe ?s r" using `no_Check_in ((e \<cdot> s\<^sub>3) @ s\<^sub>2) r` 0
              by(simp add:safe_def) blast
            obtain k\<^sub>1 k\<^sub>2 where [simp]: "c = (k\<^sub>1,k\<^sub>2)" by force
            have "roomk ?s r = k'"
              using safe_roomk_currk[OF 1 safe_safe[OF 3]]
                `no_Check_in ((e \<cdot> s\<^sub>3) @ s\<^sub>2) r` by auto
            hence "k\<^sub>1 \<noteq> roomk ?s r"
              using no_checkin_no_newkey[where s\<^sub>2 = "s\<^sub>3 @ [Enter g' r (k,k')] @ s\<^sub>2"]
                1 2 `no_Check_in ((e \<cdot> s\<^sub>3) @ s\<^sub>2) r` by auto
            hence "k\<^sub>2 = roomk ?s r" using `hotel ?t` by auto
            with only_owner_enter_normal[OF 1 safe_safe[OF 3]] 2
            have "owns ?t r =  \<lfloor>g\<rfloor>" by auto
            moreover have "owns ?t r = \<lfloor>g'\<rfloor>"
              using `hotel ?t` `no_Check_in ((e \<cdot> s\<^sub>3) @ s\<^sub>2) r` by simp
            ultimately show "g' = g" by simp
          next
            assume "g'' \<noteq> g" thus "g' = g" using Cons by auto
          qed
        next
          assume "r' \<noteq> r" thus "g' = g" using Cons by auto
        qed
      qed (insert Cons, auto)
    qed
  } with assms show "owns s r = \<lfloor>g\<rfloor>" by(auto simp:safe_def)
qed
text_raw{*
  \end{minipage}
  \end{center}
  \caption{Isar proof of Theorem~\ref{safe}}\label{fig:proof}
  \end{figure}
*}
text{*
\subsection{Verifying safety}

Lemma~\ref{state-lemmas} largely carries over after replacing
\mbox{@{prop"s : reach"}} by @{prop"hotel s"} and @{const safe} by
@{const safe\<^sub>0}. Only properties \ref{currk_inj} and
\ref{key1_not_currk} no longer hold because we no longer assume that
@{const roomk} is initially injective.
They are replaced by two somewhat similar properties:
\begin{lemma}\label{trace-lemmas}\mbox{}
\begin{enumerate}
\item @{thm[display,margin=80]currk_Check_in}
\item \label{no_checkin_no_newkey}
  @{thm[display,margin=100] no_checkin_no_newkey}
\end{enumerate}
\end{lemma}
Both are proved by induction on @{text s\<^sub>2}.
In addition we need some easy structural properties:
\begin{lemma}\label{app-lemmas}
\begin{enumerate}
\item @{thm issued_app}
\item @{thm owns_app}
\item \label{currk_app} @{thm currk_app}
\end{enumerate}
\end{lemma}

The main theorem again correspond closely to its state based
counterpart:
\begin{theorem}\label{safe}
@{thm[mode=IfThen] safe}
\end{theorem}
Let us examine the proof of this theorem to show how it differs from
the state based version. For the core of the proof let
@{prop"s = s\<^sub>3 @ [Enter g' r (k,k')] @ s\<^sub>2 @ [Check_in g' r (k,k')] @ s\<^sub>1"}
and assume
@{prop"isin (s\<^sub>2 @ [Check_in g' r (k,k')] @ s\<^sub>1) r = {}"} (0). By induction on
@{text s\<^sub>3} we prove
@{prop[display]"\<lbrakk>hotel s; no_Check_in (s\<^sub>3 @ s\<^sub>2) r; g \<in> isin s r \<rbrakk> \<Longrightarrow> g' = g"}
The actual theorem follows by definition of @{const safe}.
The base case of the induction follows from (0). For the induction step let
@{prop"t = (e#s\<^sub>3) @ [Enter g' r (k,k')] @ s\<^sub>2 @ [Check_in g' r (k,k')] @ s\<^sub>1"}.
We assume @{prop"hotel t"}, @{prop"no_Check_in ((e#s\<^sub>3) @ s\<^sub>2) r"},
and @{prop"g \<in> isin s r"}, and show @{prop"g' = g"}.
The proof is by case distinction on the event @{text e}.
The cases @{const Check_in} and @{const Exit} follow directly from the
induction hypothesis because the set of occupants of @{text r}
can only decrease. Now we focus on the case @{prop"e = Enter g'' r' c"}.
If @{prop"r' \<noteq> r"} the set of occupants of @{text r} remains unchanged
and the claim follow directly from the induction hypothesis.
If @{prop"g'' \<noteq> g"} then @{text g} must already have been in @{text r}
before the @{text Enter} event and the claim again follows directly
from the induction hypothesis. Now assume @{prop"r' = r"}
and @{prop"g'' = g"}.
From @{prop"hotel t"} we obtain @{prop"hotel s"} (1) and
@{prop"c \<in> cards s g"} (2), and
from @{prop"no_Check_in (s\<^sub>3 @ s\<^sub>2) r"} and (0)
we obtain @{prop"safe s r"} (3). Let @{prop"c = (k\<^sub>1,k\<^sub>2)"}.
From Lemma~\ref{state-lemmas}.\ref{safe_roomk_currk} and
Lemma~\ref{app-lemmas}.\ref{currk_app} we obtain
@{text"roomk s r = currk s r = k'"}.
Hence @{prop"k\<^sub>1 \<noteq> roomk s r"} by
Lemma~\ref{trace-lemmas}.\ref{no_checkin_no_newkey}
using (1), (2) and @{prop"no_Check_in (s\<^sub>3 @ s\<^sub>2) r"}.
Hence @{prop"k\<^sub>2 = roomk s r"} by @{prop"hotel t"}.
With Lemma~\ref{state-lemmas}.\ref{safe_only_owner_enter_normal}
and (1--3) we obtain
@{prop"owns t r =  \<lfloor>g\<rfloor>"}. At the same time we have @{prop"owns t r = \<lfloor>g'\<rfloor>"}
because @{prop"hotel t"} and @{prop"no_Check_in ((e # s\<^sub>3) @ s\<^sub>2) r"}: nobody
has checked in to room @{text r} after @{text g'}. Thus the claim
@{prop"g' = g"} follows.

The details of this proof differ from those of Theorem~\ref{safe-state}
but the structure is very similar.

\subsection{Eliminating \isa{isin}}

In the state based approach we needed @{const isin} to express our
safety guarantees. In the presence of traces, we can do away with it
and talk about @{const Enter} events instead. We show that if somebody
enters a safe room, he is the owner:
\begin{theorem}\label{Enter_safe}
@{thm[mode=IfThen] Enter_safe}
\end{theorem}
From @{prop"safe\<^sub>0 s r"} it follows that @{text s} must be of the form
@{term"s\<^sub>2 @ [Check_in g\<^sub>0 r c'] @ s\<^sub>1"} such that @{prop"no_Check_in s\<^sub>2 r"}.
Let @{prop"c = (x,y)"} and @{prop"c' = (k,k')"}.
By Lemma~\ref{state-lemmas}.\ref{safe_roomk_currk} we have
@{text"roomk s r = currk s r = k'"}.
From @{prop"hotel(Enter g r c # s)"} it follows that
@{prop"(x,y) \<in> cards s g"} and @{prop"k' \<in> {x,y}"}.
By Lemma~\ref{trace-lemmas}.\ref{no_checkin_no_newkey}
@{prop"x = k'"} would contradict @{prop"(x,y) \<in> cards s g"}.
Hence @{prop"y = k'"}.
With Lemma~\ref{state-lemmas}.\ref{safe_only_owner_enter_normal}
we obtain @{prop"owns s r = \<lfloor>g\<rfloor>"}.

Having dispensed with @{const isin} we could also eliminate @{const
Exit} to arrive at a model closer to the ones in~\cite{Jackson06}.

Finally one may quibble that all the safety theorems proved so far
assume safety of the room at that point in time when somebody enters
it.  That is, the owner of the room must be sure that once a room is
safe, it stays safe, in order to profit from those safety theorems.
Of course, this is the case as long as nobody else checks in to that room:
\begin{lemma}
@{thm[mode=IfThen]safe_future}
\end{lemma}
It follows easily that Theorem~\ref{Enter_safe} also extends until check-in:
\begin{corollary}
@{thm[mode=IfThen]Enter_safe_future}
\end{corollary}

\subsection{Completeness of @{const safe}}

Having proved correctness of @{const safe}, i.e.\ that safe behaviour
protects against intruders, one may wonder if @{const safe} is
complete, i.e.\ if it covers all safe behaviour, or if it is too
restrictive. It turns out that @{const safe} is incomplete for two
different reasons.  The trivial one is that in case @{const initk} is
injective, every room is protected against intruders right from the
start. That is, @{term"[Check_in g r c]"} will only allow @{term g} to
enter @{text r} until somebody else checks in to @{text r}. The
second, more subtle incompleteness is that even if there are previous
owners of a room, it may be safe to enter a room with an old card
@{text c}: one merely needs to make sure that no other guest checked
in after the check-in where one obtained @{text c}. However,
formalizing this is not only messy, it is also somewhat pointless:
this liberalization is not something a guest can take advantage of
because there is no (direct) way he can find out which of his cards
meets this criterion. But without this knowledge, the only safe thing
to do is to make sure he has used his latest card. This incompleteness
applies to the state based model as well.
*}

(*<*)
end
(*>*)