section {* UTP expressions *}

theory utp_expr
imports
  utp_var
begin

purge_notation BNF_Def.convol ("\<langle>(_,/ _)\<rangle>")

text {* Before building the predicate model, we will build a model of expressions that generalise
        alphabetised predicates. Expressions are represented semantically as mapping from
        the alphabet to the expression's type. This general model will allow us to unify
        all constructions under one type. All definitions in the file are given using
        the \emph{lifting} package.

        Since we have two kinds of variable (deep and shallow) in the model, we will also need
        two versions of each construct that takes a variable. We make use of adhoc-overloading
        to ensure the correct instance is automatically chosen, within the user noticing a difference. *}

typedef ('t, '\<alpha>) uexpr = "UNIV :: ('\<alpha> alphabet \<Rightarrow> 't) set" ..

notation Rep_uexpr ("\<lbrakk>_\<rbrakk>\<^sub>e")

lemma uexpr_eq_iff:
  "e = f \<longleftrightarrow> (\<forall> b. \<lbrakk>e\<rbrakk>\<^sub>e b = \<lbrakk>f\<rbrakk>\<^sub>e b)"
  using Rep_uexpr_inject[of e f, THEN sym] by (auto)

named_theorems ueval and lit_simps

setup_lifting type_definition_uexpr

text {* Get the alphabet of an expression *}

definition alpha_of :: "('a, '\<alpha>) uexpr \<Rightarrow> ('\<alpha>, '\<alpha>) lens" ("\<alpha>'(_')") where
"alpha_of e = 1\<^sub>L"

text {* A variable expression corresponds to the lookup function of the variable. *}

lift_definition var :: "('t, '\<alpha>) uvar \<Rightarrow> ('t, '\<alpha>) uexpr" is lens_get .

text {* A literal is simply a constant function expression, always returning the same value. *}

lift_definition lit :: "'t \<Rightarrow> ('t, '\<alpha>) uexpr"
  is "\<lambda> v b. v" .

text {* We define lifting for unary, binary, and ternary functions, that simply apply
        the function to all possible results of the expressions. *}

lift_definition uop :: "('a \<Rightarrow> 'b) \<Rightarrow> ('a, '\<alpha>) uexpr \<Rightarrow> ('b, '\<alpha>) uexpr"
  is "\<lambda> f e b. f (e b)" .
lift_definition bop ::
  "('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> ('a, '\<alpha>) uexpr \<Rightarrow> ('b, '\<alpha>) uexpr \<Rightarrow> ('c, '\<alpha>) uexpr"
  is "\<lambda> f u v b. f (u b) (v b)" .
lift_definition trop ::
  "('a \<Rightarrow> 'b \<Rightarrow> 'c \<Rightarrow> 'd) \<Rightarrow> ('a, '\<alpha>) uexpr \<Rightarrow> ('b, '\<alpha>) uexpr \<Rightarrow> ('c, '\<alpha>) uexpr \<Rightarrow> ('d, '\<alpha>) uexpr"
  is "\<lambda> f u v w b. f (u b) (v b) (w b)" .
lift_definition qtop ::
  "('a \<Rightarrow> 'b \<Rightarrow> 'c \<Rightarrow> 'd \<Rightarrow> 'e) \<Rightarrow>
   ('a, '\<alpha>) uexpr \<Rightarrow> ('b, '\<alpha>) uexpr \<Rightarrow> ('c, '\<alpha>) uexpr \<Rightarrow> ('d, '\<alpha>) uexpr \<Rightarrow>
   ('e, '\<alpha>) uexpr"
  is "\<lambda> f u v w x b. f (u b) (v b) (w b) (x b)" .

text {* We also define a UTP expression version of function abstract *}

lift_definition ulambda :: "('a \<Rightarrow> ('b, '\<alpha>) uexpr) \<Rightarrow> ('a \<Rightarrow> 'b, '\<alpha>) uexpr"
is "\<lambda> f A x. f x A" .

text {* We define syntax for expressions using adhoc overloading -- this allows us to later define
        operators on different types if necessary (e.g. when adding types for new UTP theories). *}

consts
  ulit   :: "'t \<Rightarrow> 'e" ("\<guillemotleft>_\<guillemotright>")
  ueq    :: "'a \<Rightarrow> 'a \<Rightarrow> 'b" (infixl "=\<^sub>u" 50)

adhoc_overloading
  ulit lit

syntax
  "_uuvar" :: "svar \<Rightarrow> logic"

translations
  "_uuvar x" == "CONST var x"

syntax
  "_uuvar" :: "svar \<Rightarrow> logic" ("_")

text {* We also set up some useful standard arithmetic operators for Isabelle by lifting
        the functions to binary operators. *}

instantiation uexpr :: (zero, type) zero
begin
  definition zero_uexpr_def: "0 = lit 0"
instance ..
end

instantiation uexpr :: (one, type) one
begin
  definition one_uexpr_def: "1 = lit 1"
instance ..

end

instantiation uexpr :: (plus, type) plus
begin
  definition plus_uexpr_def: "u + v = bop (op +) u v"
instance ..
end

text {* Instantiating uminus also provides negation for predicates later *}

instantiation uexpr :: (uminus, type) uminus
begin
  definition uminus_uexpr_def: "- u = uop uminus u"
instance ..
end

instantiation uexpr :: (minus, type) minus
begin
  definition minus_uexpr_def: "u - v = bop (op -) u v"
instance ..
end

instantiation uexpr :: (times, type) times
begin
  definition times_uexpr_def: "u * v = bop (op *) u v"
instance ..
end

instance uexpr :: (Rings.dvd, type) Rings.dvd ..

instantiation uexpr :: (divide, type) divide
begin
  definition divide_uexpr :: "('a, 'b) uexpr \<Rightarrow> ('a, 'b) uexpr \<Rightarrow> ('a, 'b) uexpr" where
  "divide_uexpr u v = bop divide u v"
instance ..
end

instantiation uexpr :: (inverse, type) inverse
begin
  definition inverse_uexpr :: "('a, 'b) uexpr \<Rightarrow> ('a, 'b) uexpr"
  where "inverse_uexpr u = uop inverse u"
instance ..
end

instantiation uexpr :: (Divides.div, type) Divides.div
begin
  definition mod_uexpr_def: "u mod v = bop (op mod) u v"
instance ..
end

instantiation uexpr :: (sgn, type) sgn
begin
  definition sgn_uexpr_def: "sgn u = uop sgn u"
instance ..
end

instantiation uexpr :: (abs, type) abs
begin
  definition abs_uexpr_def: "abs u = uop abs u"
instance ..
end

instance uexpr :: (semigroup_mult, type) semigroup_mult
  by (intro_classes) (simp add: times_uexpr_def one_uexpr_def, transfer, simp add: mult.assoc)+

instance uexpr :: (monoid_mult, type) monoid_mult
  by (intro_classes) (simp add: times_uexpr_def one_uexpr_def, transfer, simp)+

instance uexpr :: (semigroup_add, type) semigroup_add
  by (intro_classes) (simp add: plus_uexpr_def zero_uexpr_def, transfer, simp add: add.assoc)+

instance uexpr :: (monoid_add, type) monoid_add
  by (intro_classes) (simp add: plus_uexpr_def zero_uexpr_def, transfer, simp)+

instance uexpr :: (ab_semigroup_add, type) ab_semigroup_add
  by (intro_classes) (simp add: plus_uexpr_def, transfer, simp add: add.commute)+

instance uexpr :: (cancel_semigroup_add, type) cancel_semigroup_add
  by (intro_classes) (simp add: plus_uexpr_def, transfer, simp add: fun_eq_iff)+

instance uexpr :: (cancel_ab_semigroup_add, type) cancel_ab_semigroup_add
  by (intro_classes, (simp add: plus_uexpr_def minus_uexpr_def, transfer, simp add: fun_eq_iff add.commute cancel_ab_semigroup_add_class.diff_diff_add)+)

instance uexpr :: (group_add, type) group_add
  by (intro_classes)
     (simp add: plus_uexpr_def uminus_uexpr_def minus_uexpr_def zero_uexpr_def, transfer, simp)+

instance uexpr :: (ab_group_add, type) ab_group_add
  by (intro_classes)
     (simp add: plus_uexpr_def uminus_uexpr_def minus_uexpr_def zero_uexpr_def, transfer, simp)+

instantiation uexpr :: (ord, type) ord
begin
  lift_definition less_eq_uexpr :: "('a, 'b) uexpr \<Rightarrow> ('a, 'b) uexpr \<Rightarrow> bool"
  is "\<lambda> P Q. (\<forall> A. P A \<le> Q A)" .
  definition less_uexpr :: "('a, 'b) uexpr \<Rightarrow> ('a, 'b) uexpr \<Rightarrow> bool"
  where "less_uexpr P Q = (P \<le> Q \<and> \<not> Q \<le> P)"
instance ..
end

instance uexpr :: (order, type) order
proof
  fix x y z :: "('a, 'b) uexpr"
  show "(x < y) = (x \<le> y \<and> \<not> y \<le> x)" by (simp add: less_uexpr_def)
  show "x \<le> x" by (transfer, auto)
  show "x \<le> y \<Longrightarrow> y \<le> z \<Longrightarrow> x \<le> z"
    by (transfer, blast intro:order.trans)
  show "x \<le> y \<Longrightarrow> y \<le> x \<Longrightarrow> x = y"
    by (transfer, rule ext, simp add: eq_iff)
qed

instance uexpr :: (ordered_ab_group_add, type) ordered_ab_group_add
  by (intro_classes) (simp add: plus_uexpr_def, transfer, simp)

instance uexpr :: (ordered_ab_group_add_abs, type) ordered_ab_group_add_abs
  apply (intro_classes)
  apply (simp add: abs_uexpr_def zero_uexpr_def plus_uexpr_def uminus_uexpr_def, transfer, simp add: abs_ge_self abs_le_iff abs_triangle_ineq)+
  apply (metis ab_group_add_class.ab_diff_conv_add_uminus abs_ge_minus_self abs_ge_self add_mono_thms_linordered_semiring(1))
done

lemma uexpr_diff_zero [simp]:
  fixes a :: "('\<alpha>::ordered_cancel_monoid_diff, 'a) uexpr"
  shows "a - 0 = a"
  by (simp add: minus_uexpr_def zero_uexpr_def, transfer, auto)

lemma uexpr_add_diff_cancel_left [simp]:
  fixes a b :: "('\<alpha>::ordered_cancel_monoid_diff, 'a) uexpr"
  shows "(a + b) - a = b"
  by (simp add: minus_uexpr_def plus_uexpr_def, transfer, auto)

instance uexpr :: (semiring, type) semiring
  by (intro_classes) (simp add: plus_uexpr_def times_uexpr_def, transfer, simp add: fun_eq_iff add.commute semiring_class.distrib_right semiring_class.distrib_left)+

instance uexpr :: (ring_1, type) ring_1
  by (intro_classes) (simp add: plus_uexpr_def uminus_uexpr_def minus_uexpr_def times_uexpr_def zero_uexpr_def one_uexpr_def, transfer, simp add: fun_eq_iff)+

instance uexpr :: (numeral, type) numeral
  by (intro_classes, simp add: plus_uexpr_def, transfer, simp add: add.assoc)

text {* Set up automation for numerals *}

lemma numeral_uexpr_rep_eq: "\<lbrakk>numeral x\<rbrakk>\<^sub>e b = numeral x"
apply (induct x)
apply (simp add: lit.rep_eq one_uexpr_def)
apply (simp add: bop.rep_eq numeral_Bit0 plus_uexpr_def)
apply (simp add: bop.rep_eq lit.rep_eq numeral_code(3) one_uexpr_def plus_uexpr_def)
done

lemma numeral_uexpr_simp: "numeral x = \<guillemotleft>numeral x\<guillemotright>"
  by (simp add: uexpr_eq_iff numeral_uexpr_rep_eq lit.rep_eq)

definition eq_upred :: "('a, '\<alpha>) uexpr \<Rightarrow> ('a, '\<alpha>) uexpr \<Rightarrow> (bool, '\<alpha>) uexpr"
where "eq_upred x y = bop HOL.eq x y"

adhoc_overloading
  ueq eq_upred

definition "fun_apply f x = f x"
declare fun_apply_def [simp]

consts
  uempty  :: "'f"
  uapply  :: "'f \<Rightarrow> 'k \<Rightarrow> 'v"
  uupd    :: "'f \<Rightarrow> 'k \<Rightarrow> 'v \<Rightarrow> 'f"
  udom    :: "'f \<Rightarrow> 'a set"
  uran    :: "'f \<Rightarrow> 'b set"
  udomres :: "'a set \<Rightarrow> 'f \<Rightarrow> 'f"
  uranres :: "'f \<Rightarrow> 'b set \<Rightarrow> 'f"
  ucard   :: "'f \<Rightarrow> nat"

definition "LNil = Nil"
definition "LZero = 0"

adhoc_overloading
  uempty LZero and uempty LNil and
  uapply fun_apply and uapply nth and uapply pfun_app and
  uapply ffun_app and
  uupd pfun_upd and uupd ffun_upd and uupd list_update and
  udom Domain and udom pdom and udom fdom and udom seq_dom and
  udom Range and uran pran and uran fran and uran set and
  udomres pdom_res and udomres fdom_res and
  uranres pran_res and udomres fran_res and
  ucard card and ucard pcard and ucard length

nonterminal utuple_args and umaplet and umaplets

syntax
  "_ucoerce"    :: "('a, '\<alpha>) uexpr \<Rightarrow> type \<Rightarrow> ('a, '\<alpha>) uexpr" (infix ":\<^sub>u" 50)
  "_unil"       :: "('a list, '\<alpha>) uexpr" ("\<langle>\<rangle>")
  "_ulist"      :: "args => ('a list, '\<alpha>) uexpr"    ("\<langle>(_)\<rangle>")
  "_uappend"    :: "('a list, '\<alpha>) uexpr \<Rightarrow> ('a list, '\<alpha>) uexpr \<Rightarrow> ('a list, '\<alpha>) uexpr" (infixr "^\<^sub>u" 80)
  "_ulast"      :: "('a list, '\<alpha>) uexpr \<Rightarrow> ('a, '\<alpha>) uexpr" ("last\<^sub>u'(_')")
  "_ufront"     :: "('a list, '\<alpha>) uexpr \<Rightarrow> ('a list, '\<alpha>) uexpr" ("front\<^sub>u'(_')")
  "_uhead"      :: "('a list, '\<alpha>) uexpr \<Rightarrow> ('a, '\<alpha>) uexpr" ("head\<^sub>u'(_')")
  "_utail"      :: "('a list, '\<alpha>) uexpr \<Rightarrow> ('a list, '\<alpha>) uexpr" ("tail\<^sub>u'(_')")
  "_utake"      :: "(nat, '\<alpha>) uexpr \<Rightarrow> ('a list, '\<alpha>) uexpr \<Rightarrow> ('a list, '\<alpha>) uexpr" ("take\<^sub>u'(_,/ _')")
  "_udrop"      :: "(nat, '\<alpha>) uexpr \<Rightarrow> ('a list, '\<alpha>) uexpr \<Rightarrow> ('a list, '\<alpha>) uexpr" ("drop\<^sub>u'(_,/ _')")
  "_ucard"      :: "('a list, '\<alpha>) uexpr \<Rightarrow> (nat, '\<alpha>) uexpr" ("#\<^sub>u'(_')")
  "_ufilter"    :: "('a list, '\<alpha>) uexpr \<Rightarrow> ('a set, '\<alpha>) uexpr \<Rightarrow> ('a list, '\<alpha>) uexpr" (infixl "\<restriction>\<^sub>u" 75)
  "_uextract"   :: "('a set, '\<alpha>) uexpr \<Rightarrow> ('a list, '\<alpha>) uexpr \<Rightarrow> ('a list, '\<alpha>) uexpr" (infixl "\<upharpoonleft>\<^sub>u" 75)
  "_uelems"     :: "('a list, '\<alpha>) uexpr \<Rightarrow> ('a set, '\<alpha>) uexpr" ("elems\<^sub>u'(_')")
  "_usorted"    :: "('a list, '\<alpha>) uexpr \<Rightarrow> (bool, '\<alpha>) uexpr" ("sorted\<^sub>u'(_')")
  "_udistinct"  :: "('a list, '\<alpha>) uexpr \<Rightarrow> (bool, '\<alpha>) uexpr" ("distinct\<^sub>u'(_')")
  "_uless"      :: "('a, '\<alpha>) uexpr \<Rightarrow> ('a, '\<alpha>) uexpr \<Rightarrow> (bool, '\<alpha>) uexpr" (infix "<\<^sub>u" 50)
  "_uleq"       :: "('a, '\<alpha>) uexpr \<Rightarrow> ('a, '\<alpha>) uexpr \<Rightarrow> (bool, '\<alpha>) uexpr" (infix "\<le>\<^sub>u" 50)
  "_ugreat"     :: "('a, '\<alpha>) uexpr \<Rightarrow> ('a, '\<alpha>) uexpr \<Rightarrow> (bool, '\<alpha>) uexpr" (infix ">\<^sub>u" 50)
  "_ugeq"       :: "('a, '\<alpha>) uexpr \<Rightarrow> ('a, '\<alpha>) uexpr \<Rightarrow> (bool, '\<alpha>) uexpr" (infix "\<ge>\<^sub>u" 50)
  "_umin"       :: "logic \<Rightarrow> logic \<Rightarrow> logic" ("min\<^sub>u'(_, _')")
  "_umax"       :: "logic \<Rightarrow> logic \<Rightarrow> logic" ("max\<^sub>u'(_, _')")
  "_ugcd"       :: "logic \<Rightarrow> logic \<Rightarrow> logic" ("gcd\<^sub>u'(_, _')")
  "_uceil"      :: "logic \<Rightarrow> logic" ("\<lceil>_\<rceil>\<^sub>u")
  "_ufloor"      :: "logic \<Rightarrow> logic" ("\<lfloor>_\<rfloor>\<^sub>u")
  "_ufinite"    :: "logic \<Rightarrow> logic" ("finite\<^sub>u'(_')")
  "_uempset"    :: "('a set, '\<alpha>) uexpr" ("{}\<^sub>u")
  "_uset"       :: "args => ('a set, '\<alpha>) uexpr" ("{(_)}\<^sub>u")
  "_uunion"     :: "('a set, '\<alpha>) uexpr \<Rightarrow> ('a set, '\<alpha>) uexpr \<Rightarrow> ('a set, '\<alpha>) uexpr" (infixl "\<union>\<^sub>u" 65)
  "_uinter"     :: "('a set, '\<alpha>) uexpr \<Rightarrow> ('a set, '\<alpha>) uexpr \<Rightarrow> ('a set, '\<alpha>) uexpr" (infixl "\<inter>\<^sub>u" 70)
  "_umem"       :: "('a, '\<alpha>) uexpr \<Rightarrow> ('a set, '\<alpha>) uexpr \<Rightarrow> (bool, '\<alpha>) uexpr" (infix "\<in>\<^sub>u" 50)
  "_usubset"    :: "('a set, '\<alpha>) uexpr \<Rightarrow> ('a set, '\<alpha>) uexpr \<Rightarrow> (bool, '\<alpha>) uexpr" (infix "\<subset>\<^sub>u" 50)
  "_usubseteq"  :: "('a set, '\<alpha>) uexpr \<Rightarrow> ('a set, '\<alpha>) uexpr \<Rightarrow> (bool, '\<alpha>) uexpr" (infix "\<subseteq>\<^sub>u" 50)
  "_utuple"     :: "('a, '\<alpha>) uexpr \<Rightarrow> utuple_args \<Rightarrow> ('a * 'b, '\<alpha>) uexpr" ("(1'(_,/ _')\<^sub>u)")
  "_utuple_arg"  :: "('a, '\<alpha>) uexpr \<Rightarrow> utuple_args" ("_")
  "_utuple_args" :: "('a, '\<alpha>) uexpr => utuple_args \<Rightarrow> utuple_args"     ("_,/ _")
  "_uunit"      :: "('a, '\<alpha>) uexpr" ("'(')\<^sub>u")
  "_ufst"       :: "('a \<times> 'b, '\<alpha>) uexpr \<Rightarrow> ('a, '\<alpha>) uexpr" ("\<pi>\<^sub>1'(_')")
  "_usnd"       :: "('a \<times> 'b, '\<alpha>) uexpr \<Rightarrow> ('b, '\<alpha>) uexpr" ("\<pi>\<^sub>2'(_')")
  "_uapply"     :: "('a \<Rightarrow> 'b, '\<alpha>) uexpr \<Rightarrow> utuple_args \<Rightarrow> ('b, '\<alpha>) uexpr" ("_\<lparr>_\<rparr>\<^sub>u" [999,0] 999)
  "_ulamba"     :: "pttrn \<Rightarrow> logic \<Rightarrow> logic" ("\<lambda> _ \<bullet> _" [0, 10] 10)
  "_udom"       :: "logic \<Rightarrow> logic" ("dom\<^sub>u'(_')")
  "_uran"       :: "logic \<Rightarrow> logic" ("ran\<^sub>u'(_')")
  "_uinl"       :: "logic \<Rightarrow> logic" ("inl\<^sub>u'(_')")
  "_uinr"       :: "logic \<Rightarrow> logic" ("inr\<^sub>u'(_')")
  "_umap_empty" :: "logic" ("[]\<^sub>u")
  "_umap_plus"  :: "logic \<Rightarrow> logic \<Rightarrow> logic" (infixl "\<oplus>\<^sub>u" 85)
  "_umap_minus" :: "logic \<Rightarrow> logic \<Rightarrow> logic" (infixl "\<ominus>\<^sub>u" 85)
  "_udom_res"   :: "logic \<Rightarrow> logic \<Rightarrow> logic" (infixl "\<lhd>\<^sub>u" 85)
  "_uran_res"   :: "logic \<Rightarrow> logic \<Rightarrow> logic" (infixl "\<rhd>\<^sub>u" 85)
  "_umaplet"    :: "[logic, logic] => umaplet" ("_ /\<mapsto>/ _")
  ""            :: "umaplet => umaplets"             ("_")
  "_UMaplets"   :: "[umaplet, umaplets] => umaplets" ("_,/ _")
  "_UMapUpd"    :: "[logic, umaplets] => logic" ("_/'(_')\<^sub>u" [900,0] 900)
  "_UMap"       :: "umaplets => logic" ("(1[_]\<^sub>u)")

translations
  "f\<lparr>v\<rparr>\<^sub>u" <= "CONST uapply f v"
  "dom\<^sub>u(f)" <= "CONST udom f"
  "ran\<^sub>u(f)" <= "CONST uran f"
  "A \<lhd>\<^sub>u f" <= "CONST udomres A f"
  "f \<rhd>\<^sub>u A" <= "CONST uranres f A"
  "#\<^sub>u(f)" <= "CONST ucard f"
  "f(k \<mapsto> v)\<^sub>u" <= "CONST uupd f k v"

translations
  "x :\<^sub>u 'a" == "x :: ('a, _) uexpr"
  "\<langle>\<rangle>"       == "\<guillemotleft>[]\<guillemotright>"
  "\<langle>x, xs\<rangle>"  == "CONST bop (op #) x \<langle>xs\<rangle>"
  "\<langle>x\<rangle>"      == "CONST bop (op #) x \<langle>\<rangle>"
  "x ^\<^sub>u y"   == "CONST bop (op @) x y"
  "last\<^sub>u(xs)" == "CONST uop CONST last xs"
  "front\<^sub>u(xs)" == "CONST uop CONST butlast xs"
  "head\<^sub>u(xs)" == "CONST uop CONST hd xs"
  "tail\<^sub>u(xs)" == "CONST uop CONST tl xs"
  "drop\<^sub>u(n,xs)" == "CONST bop CONST drop n xs"
  "take\<^sub>u(n,xs)" == "CONST bop CONST take n xs"
  "#\<^sub>u(xs)" == "CONST uop CONST ucard xs"
  "elems\<^sub>u(xs)" == "CONST uop CONST set xs"
  "sorted\<^sub>u(xs)" == "CONST uop CONST sorted xs"
  "distinct\<^sub>u(xs)" == "CONST uop CONST distinct xs"
  "xs \<restriction>\<^sub>u A"   == "CONST bop CONST seq_filter xs A"
  "A \<upharpoonleft>\<^sub>u xs"   == "CONST bop (op \<upharpoonleft>\<^sub>l) A xs"
  "x <\<^sub>u y"   == "CONST bop (op <) x y"
  "x \<le>\<^sub>u y"   == "CONST bop (op \<le>) x y"
  "x >\<^sub>u y"   == "y <\<^sub>u x"
  "x \<ge>\<^sub>u y"   == "y \<le>\<^sub>u x"
  "min\<^sub>u(x, y)"  == "CONST bop (CONST min) x y"
  "max\<^sub>u(x, y)"  == "CONST bop (CONST max) x y"
  "gcd\<^sub>u(x, y)"  == "CONST bop (CONST gcd) x y"
  "\<lceil>x\<rceil>\<^sub>u" == "CONST uop CONST ceiling x"
  "\<lfloor>x\<rfloor>\<^sub>u" == "CONST uop CONST floor x"
  "finite\<^sub>u(x)" == "CONST uop (CONST finite) x"
  "{}\<^sub>u"      == "\<guillemotleft>{}\<guillemotright>"
  "{x, xs}\<^sub>u" == "CONST bop (CONST insert) x {xs}\<^sub>u"
  "{x}\<^sub>u"     == "CONST bop (CONST insert) x \<guillemotleft>{}\<guillemotright>"
  "A \<union>\<^sub>u B"   == "CONST bop (op \<union>) A B"
  "A \<inter>\<^sub>u B"   == "CONST bop (op \<inter>) A B"
  "f \<oplus>\<^sub>u g"   => "(f :: ((_, _) pfun, _) uexpr) + g"
  "f \<ominus>\<^sub>u g"   => "(f :: ((_, _) pfun, _) uexpr) - g"
  "x \<in>\<^sub>u A"   == "CONST bop (op \<in>) x A"
  "A \<subset>\<^sub>u B"   == "CONST bop (op <) A B"
  "A \<subset>\<^sub>u B"   <= "CONST bop (op \<subset>) A B"
  "f \<subset>\<^sub>u g"   <= "CONST bop (op \<subset>\<^sub>p) f g"
  "f \<subset>\<^sub>u g"   <= "CONST bop (op \<subset>\<^sub>f) f g"
  "A \<subseteq>\<^sub>u B"   == "CONST bop (op \<le>) A B"
  "A \<subseteq>\<^sub>u B"   <= "CONST bop (op \<subseteq>) A B"
  "f \<subseteq>\<^sub>u g"   <= "CONST bop (op \<subseteq>\<^sub>p) f g"
  "f \<subseteq>\<^sub>u g"   <= "CONST bop (op \<subseteq>\<^sub>f) f g"
  "()\<^sub>u"      == "\<guillemotleft>()\<guillemotright>"
  "(x, y)\<^sub>u"  == "CONST bop (CONST Pair) x y"
  "_utuple x (_utuple_args y z)" == "_utuple x (_utuple_arg (_utuple y z))"
  "\<pi>\<^sub>1(x)"    == "CONST uop CONST fst x"
  "\<pi>\<^sub>2(x)"    == "CONST uop CONST snd x"
  "f\<lparr>x\<rparr>\<^sub>u"    == "CONST bop CONST uapply f x"
  "\<lambda> x \<bullet> p" == "CONST ulambda (\<lambda> x. p)"
  "dom\<^sub>u(f)" == "CONST uop CONST udom f"
  "ran\<^sub>u(f)" == "CONST uop CONST uran f"
  "inl\<^sub>u(x)" == "CONST uop CONST Inl x"
  "inr\<^sub>u(x)" == "CONST uop CONST Inr x"
  "[]\<^sub>u"     == "\<guillemotleft>CONST uempty\<guillemotright>"
  "A \<lhd>\<^sub>u f" == "CONST bop (CONST udomres) A f"
  "f \<rhd>\<^sub>u A" == "CONST bop (CONST uranres) f A"
  "_UMapUpd m (_UMaplets xy ms)" == "_UMapUpd (_UMapUpd m xy) ms"
  "_UMapUpd m (_umaplet  x y)"   == "CONST trop CONST uupd m x y"
  "_UMap ms"                      == "_UMapUpd []\<^sub>u ms"
  "_UMap (_UMaplets ms1 ms2)"     <= "_UMapUpd (_UMap ms1) ms2"
  "_UMaplets ms1 (_UMaplets ms2 ms3)" <= "_UMaplets (_UMaplets ms1 ms2) ms3"
  "f\<lparr>x,y\<rparr>\<^sub>u"  == "CONST bop CONST uapply f (x,y)\<^sub>u"

text {* Lifting set intervals *}

syntax
  "_uset_atLeastAtMost" :: "('a, '\<alpha>) uexpr \<Rightarrow> ('a, '\<alpha>) uexpr \<Rightarrow> ('a set, '\<alpha>) uexpr" ("(1{_.._}\<^sub>u)")
  "_uset_atLeastLessThan" :: "('a, '\<alpha>) uexpr \<Rightarrow> ('a, '\<alpha>) uexpr \<Rightarrow> ('a set, '\<alpha>) uexpr" ("(1{_..<_}\<^sub>u)")
  "_uset_compr" :: "id \<Rightarrow> ('a set, '\<alpha>) uexpr \<Rightarrow> (bool, '\<alpha>) uexpr \<Rightarrow> ('b, '\<alpha>) uexpr \<Rightarrow> ('b set, '\<alpha>) uexpr" ("(1{_ :/ _ |/ _ \<bullet>/ _}\<^sub>u)")

lift_definition ZedSetCompr ::
  "('a set, '\<alpha>) uexpr \<Rightarrow> ('a \<Rightarrow> (bool, '\<alpha>) uexpr \<times> ('b, '\<alpha>) uexpr) \<Rightarrow> ('b set, '\<alpha>) uexpr"
is "\<lambda> A PF b. { snd (PF x) b | x. x \<in> A b \<and> fst (PF x) b}" .

translations
  "{x..y}\<^sub>u" == "CONST bop CONST atLeastAtMost x y"
  "{x..<y}\<^sub>u" == "CONST bop CONST atLeastLessThan x y"
  "{x : A | P \<bullet> F}\<^sub>u" == "CONST ZedSetCompr A (\<lambda> x. (P, F))"

text {* Lifting limits *}

definition "ulim_left = (\<lambda> p f. Lim (at_left p) f)"
definition "ulim_right = (\<lambda> p f. Lim (at_right p) f)"
definition "ucont_on = (\<lambda> f A. continuous_on A f)"

syntax
  "_ulim_left"  :: "id \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic" ("lim\<^sub>u'(_ \<rightarrow> _\<^sup>-')'(_')")
  "_ulim_right" :: "id \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic" ("lim\<^sub>u'(_ \<rightarrow> _\<^sup>+')'(_')")
  "_ucont_on"   :: "logic \<Rightarrow> logic \<Rightarrow> logic" (infix "cont-on\<^sub>u" 90)

translations
  "lim\<^sub>u(x \<rightarrow> p\<^sup>-)(e)" == "CONST bop CONST ulim_left p (\<lambda> x \<bullet> e)"
  "lim\<^sub>u(x \<rightarrow> p\<^sup>+)(e)" == "CONST bop CONST ulim_right p (\<lambda> x \<bullet> e)"
  "f cont-on\<^sub>u A"     == "CONST bop CONST continuous_on A f"

lemmas uexpr_defs =
  alpha_of_def
  zero_uexpr_def
  one_uexpr_def
  plus_uexpr_def
  uminus_uexpr_def
  minus_uexpr_def
  times_uexpr_def
  inverse_uexpr_def
  divide_uexpr_def
  sgn_uexpr_def
  abs_uexpr_def
  mod_uexpr_def
  eq_upred_def
  numeral_uexpr_simp
  ulim_left_def
  ulim_right_def
  ucont_on_def
  LNil_def
  LZero_def
  plus_list_def

subsection {* Evaluation laws for expressions *}

lemma lit_ueval [ueval]: "\<lbrakk>\<guillemotleft>x\<guillemotright>\<rbrakk>\<^sub>eb = x"
  by (transfer, simp)

lemma var_ueval [ueval]: "\<lbrakk>var x\<rbrakk>\<^sub>eb = get\<^bsub>x\<^esub> b"
  by (transfer, simp)

lemma uop_ueval [ueval]: "\<lbrakk>uop f x\<rbrakk>\<^sub>eb = f (\<lbrakk>x\<rbrakk>\<^sub>eb)"
  by (transfer, simp)

lemma bop_ueval [ueval]: "\<lbrakk>bop f x y\<rbrakk>\<^sub>eb = f (\<lbrakk>x\<rbrakk>\<^sub>eb) (\<lbrakk>y\<rbrakk>\<^sub>eb)"
  by (transfer, simp)

lemma trop_ueval [ueval]: "\<lbrakk>trop f x y z\<rbrakk>\<^sub>eb = f (\<lbrakk>x\<rbrakk>\<^sub>eb) (\<lbrakk>y\<rbrakk>\<^sub>eb) (\<lbrakk>z\<rbrakk>\<^sub>eb)"
  by (transfer, simp)

lemma qtop_ueval [ueval]: "\<lbrakk>qtop f x y z w\<rbrakk>\<^sub>eb = f (\<lbrakk>x\<rbrakk>\<^sub>eb) (\<lbrakk>y\<rbrakk>\<^sub>eb) (\<lbrakk>z\<rbrakk>\<^sub>eb) (\<lbrakk>w\<rbrakk>\<^sub>eb)"
  by (transfer, simp)

declare uexpr_defs [ueval]

subsection {* Misc laws *}

lemma tail_cons [simp]: "tail\<^sub>u(\<langle>x\<rangle> ^\<^sub>u xs) = xs"
  by (transfer, simp)

subsection {* Literalise tactics *}

text {* The following tactic converts literal HOL expressions to UTP expressions and vice-versa
        via a collection of simplification rules. The two tactics are called "literalise", which
        converts UTP to expressions to HOL expressions -- i.e. it pushes them into literals --
        and unliteralise that reverses this. We collect the equations in a theorem attribute
        called "lit\_simps". *}

lemma lit_num_simps [lit_simps]: "\<guillemotleft>0\<guillemotright> = 0" "\<guillemotleft>1\<guillemotright> = 1" "\<guillemotleft>numeral n\<guillemotright> = numeral n" "\<guillemotleft>- x\<guillemotright> = - \<guillemotleft>x\<guillemotright>"
  by (simp_all add: ueval, transfer, simp)

lemma lit_arith_simps [lit_simps]:
  "\<guillemotleft>- x\<guillemotright> = - \<guillemotleft>x\<guillemotright>"
  "\<guillemotleft>x + y\<guillemotright> = \<guillemotleft>x\<guillemotright> + \<guillemotleft>y\<guillemotright>" "\<guillemotleft>x - y\<guillemotright> = \<guillemotleft>x\<guillemotright> - \<guillemotleft>y\<guillemotright>"
  "\<guillemotleft>x * y\<guillemotright> = \<guillemotleft>x\<guillemotright> * \<guillemotleft>y\<guillemotright>" "\<guillemotleft>x / y\<guillemotright> = \<guillemotleft>x\<guillemotright> / \<guillemotleft>y\<guillemotright>"
  "\<guillemotleft>x div y\<guillemotright> = \<guillemotleft>x\<guillemotright> div \<guillemotleft>y\<guillemotright>"
  by (simp add: uexpr_defs, transfer, simp)+

lemma lit_fun_simps [lit_simps]:
  "\<guillemotleft>i x y z u\<guillemotright> = qtop i \<guillemotleft>x\<guillemotright> \<guillemotleft>y\<guillemotright> \<guillemotleft>z\<guillemotright> \<guillemotleft>u\<guillemotright>"
  "\<guillemotleft>h x y z\<guillemotright> = trop h \<guillemotleft>x\<guillemotright> \<guillemotleft>y\<guillemotright> \<guillemotleft>z\<guillemotright>"
  "\<guillemotleft>g x y\<guillemotright> = bop g \<guillemotleft>x\<guillemotright> \<guillemotleft>y\<guillemotright>"
  "\<guillemotleft>f x\<guillemotright> = uop f \<guillemotleft>x\<guillemotright>"
  by (transfer, simp)+

text {* In general unliteralising converts function applications to corresponding expression
  liftings. Since some operators, like + and *, have specific operators we also have to
  use @{thm uexpr_defs} in reverse to correctly interpret these. Moreover, numerals must be handled
  separately by first simplifying them and then converting them into UTP expression numerals;
  hence the following two simplification rules. *}

lemma lit_numeral_1: "uop numeral x = Abs_uexpr (\<lambda>b. numeral (\<lbrakk>x\<rbrakk>\<^sub>e b))"
  by (simp add: uop_def)

lemma lit_numeral_2: "Abs_uexpr (\<lambda> b. numeral v) = numeral v"
  by (metis lit.abs_eq lit_num_simps(3))

method literalise = (unfold lit_simps[THEN sym])
method unliteralise = (unfold lit_simps uexpr_defs[THEN sym];
                     (unfold lit_numeral_1 ; (unfold ueval); (unfold lit_numeral_2))?)+
end


(*
 * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)

(*
Termination for recursive functions.
*)
theory FactorialTest
imports
  "AutoCorres.AutoCorres"
  "Monads.OptionMonadWP"
begin

external_file "factorial.c"

(* Parse the input file. *)
install_C_file "factorial.c"

autocorres "factorial.c"

context factorial begin

(* Termination *)
thm factorial'.simps

lemma ovalidNF_grab_asm2:
  "ovalidNF (\<lambda>s. G \<and> P s) f Q \<Longrightarrow> G \<Longrightarrow> ovalidNF P f Q"
  by (auto simp: ovalidNF_def)

lemma ovalidNF_grab_asm_eq:
  "(G \<longrightarrow> ovalidNF P f Q) = ovalidNF (\<lambda>s. G \<and> P s) f Q"
  by (auto simp: ovalidNF_def)

lemma ovalid_post_triv:
  "(\<And>r s. Q r s) \<Longrightarrow> ovalid P f Q"
  by (simp add: ovalid_def)

lemma factorial'_terminates: "no_ofail (\<lambda>_. m > unat n) (factorial' m n)"
proof (induct n arbitrary: m rule: less_induct)
   fix x m
   assume induct_asm0: "(\<And>y m. y < x \<Longrightarrow> no_ofail (\<lambda>_. unat y < m) (factorial' m y))"
   have induct_asm: "(\<And>y m. no_ofail (\<lambda>_. y < x \<and> unat y < m) (factorial' m y))"
     apply (rule no_ofail_grab_asm)
     by (rule induct_asm0)

   show "no_ofail (\<lambda>_. unat x < m) (factorial' m x)"
     apply (subst factorial'.simps)
     apply (wp induct_asm ovalid_post_triv)
     apply unat_arith
    done
qed

lemma factorial'_terminates_old: "m > unat n \<longrightarrow> factorial' m n s \<noteq> None"
  apply (induct n arbitrary: m)
   apply (subst factorial'.simps, simp add: ocondition_def obind_def)
  apply (subst factorial'.simps, simp add: ocondition_def obind_def split: option.splits)
  apply (metis One_nat_def Suc_eq_plus1 less_diff_conv option.distinct(1) unatSuc)
  done

(* A fun fact *)
function fact :: "('n :: len) word \<Rightarrow> ('n :: len) word" where
  "fact n = (if n = 0 then 1 else n * fact (n - 1))"
  by auto
termination by (metis "termination" in_measure measure_unat wf_measure)
declare fact.simps [simp del]

(* Termination & correctness *)
lemma factorial'_correct: "ovalidNF (\<lambda>_. m > unat n) (factorial' m n) (\<lambda>r _. r = fact n)"
proof (induct n arbitrary: m)
   fix n m
   show "ovalidNF (\<lambda>_. unat 0 < m) (factorial' m 0) (\<lambda>r _. r = fact 0)"
     apply (subst factorial'.simps)
     apply (simp add: ovalidNF_def ocondition_def ofail_def oreturn_def obind_def fact.simps)
     done

   assume induct_asm0: "\<And>m. ovalidNF (\<lambda>_. unat n < m) (factorial' m n) (\<lambda>r _. r = fact n)"
   have induct_asm: "\<And>m. 1 + n \<noteq> 0 \<Longrightarrow> ovalidNF (\<lambda>_. unat n < m) (factorial' m n) (\<lambda>r _. (1 + n) * r = fact (1 + n))"
     apply (subst fact.simps)
     apply simp
     apply (insert induct_asm0)
     apply (unfold ovalidNF_def)
     apply simp
     done

   show "\<lbrakk> 1 + n \<noteq> 0 \<rbrakk>
          \<Longrightarrow> ovalidNF (\<lambda>_. unat (1 + n) < m) (factorial' m (1 + n))
              (\<lambda>r _. r = fact (1 + n))"
     apply (subst factorial'.simps)
     apply (rule_tac G = "1 + n \<noteq> 0" in ovalidNF_grab_asm2)
      apply wp
       apply (simp del: One_nat_def)
       apply (wp induct_asm)
      apply unat_arith
     apply assumption
    done
qed

lemma factorial'_correct_old: "m > unat n \<longrightarrow> factorial' m n s = Some (fact n)"
  apply (induct n arbitrary: m)
   apply (subst factorial'.simps, subst fact.simps, simp add: ocondition_def obind_def)
  apply (subst factorial'.simps, subst fact.simps, simp add: ocondition_def obind_def)
  apply (clarsimp split: option.splits)
  apply (intro conjI impI)
    apply unat_arith
   apply (metis (opaque_lifting, no_types) Nat.add_0_right le_iff_add Suc_eq_plus1_left Suc_pred factorial.factorial'_terminates_old less_nat_zero_code nat_add_left_cancel_less nat_less_le)
  apply (unat_arith, force)
  done

(* Termination & correctness of call_factorial *)
thm call_factorial'_def

lemma "\<lbrace> \<top> \<rbrace> call_factorial' \<lbrace> \<lambda>r s. r = fact 42 \<rbrace>!"
  unfolding call_factorial'_def
  apply wp
   apply (force simp: option_monad_mono_eq)
  using factorial'_correct_old apply force
  done

end

end


(* Martin Kleppmann, University of Cambridge
   Victor B. F. Gomes, University of Cambridge
   Dominic P. Mulligan, Arm Research, Cambridge
   Alastair Beresford, University of Cambridge
*)

section\<open>The Replicated Growable Array (RGA)\<close>

text\<open>The RGA algorithm \cite{Roh:2011dw} is a replicated list (or
collaborative text-editing) algorithm. In this section we prove that
RGA satisfies our list specification. The Isabelle/HOL definition of
RGA in this section is based on our prior work on formally verifying
CRDTs \cite{Gomes:2017gy,Gomes:2017vo}.\<close>

theory RGA
  imports Insert_Spec
begin

fun insert_body :: "'oid::{linorder} list \<Rightarrow> 'oid \<Rightarrow> 'oid list" where
  "insert_body []       e = [e]" |
  "insert_body (x # xs) e =
     (if x < e then e # x # xs
               else x # insert_body xs e)"

fun insert_rga :: "'oid::{linorder} list \<Rightarrow> ('oid \<times> 'oid option) \<Rightarrow> 'oid list" where
  "insert_rga  xs      (e, None)   = insert_body xs e" |
  "insert_rga  []      (e, Some i) = []" |
  "insert_rga (x # xs) (e, Some i) =
     (if x = i then
        x # insert_body xs e
      else
        x # insert_rga xs (e, Some i))"

definition interp_rga :: "('oid::{linorder} \<times> 'oid option) list \<Rightarrow> 'oid list" where
  "interp_rga ops \<equiv> foldl insert_rga [] ops"

subsection\<open>Commutativity of \isa{insert-rga}\<close>

lemma insert_body_set_ins [simp]:
  shows  "set (insert_body xs e) = insert e (set xs)"
by (induction xs, auto)

lemma insert_rga_set_ins:
  assumes "i \<in> set xs"
  shows "set (insert_rga xs (oid, Some i)) = insert oid (set xs)"
using assms by (induction xs, auto)

lemma insert_body_commutes:
  shows "insert_body (insert_body xs e1) e2 = insert_body (insert_body xs e2) e1"
by (induction xs, auto)

lemma insert_rga_insert_body_commute:
  assumes "i2 \<noteq> Some e1"
  shows "insert_rga (insert_body xs e1) (e2, i2) = insert_body (insert_rga xs (e2, i2)) e1"
using assms by (induction xs; cases i2) (auto simp add: insert_body_commutes)

lemma insert_rga_None_commutes:
  assumes "i2 \<noteq> Some e1"
  shows "insert_rga (insert_rga xs (e1, None)) (e2, i2  ) =
         insert_rga (insert_rga xs (e2, i2  )) (e1, None)"
using assms by (induction xs; cases i2) (auto simp add: insert_body_commutes)

lemma insert_rga_nonexistent:
  assumes "i \<notin> set xs"
  shows "insert_rga xs (e, Some i) = xs"
using assms by (induction xs, auto)

lemma insert_rga_Some_commutes:
  assumes "i1 \<in> set xs" and "i2 \<in> set xs"
    and "e1 \<noteq> i2" and "e2 \<noteq> i1"
  shows "insert_rga (insert_rga xs (e1, Some i1)) (e2, Some i2) =
         insert_rga (insert_rga xs (e2, Some i2)) (e1, Some i1)"
using assms proof (induction xs, simp)
  case (Cons a xs)
  then show ?case
    by (cases "a = i1"; cases "a = i2";
        auto simp add: insert_body_commutes insert_rga_insert_body_commute)
qed

lemma insert_rga_commutes:
  assumes "i2 \<noteq> Some e1" and "i1 \<noteq> Some e2"
  shows "insert_rga (insert_rga xs (e1, i1)) (e2, i2) =
         insert_rga (insert_rga xs (e2, i2)) (e1, i1)"
proof(cases i1)
  case None
  then show ?thesis
  using assms(1) insert_rga_None_commutes by (cases i2, fastforce, blast)
next
  case some_r1: (Some r1)
  then show ?thesis
  proof(cases i2)
    case None
    then show ?thesis
      using assms(2) insert_rga_None_commutes by fastforce
  next
    case some_r2: (Some r2)
    then show ?thesis
    proof(cases "r1 \<in> set xs \<and> r2 \<in> set xs")
      case True
      then show ?thesis
        using assms some_r1 some_r2 by (simp add: insert_rga_Some_commutes)
    next
      case False
      then show ?thesis
        using assms some_r1 some_r2
        by (metis insert_iff insert_rga_nonexistent insert_rga_set_ins)
    qed
  qed
qed

lemma insert_body_split:
  shows "\<exists>p s. xs = p @ s \<and> insert_body xs e = p @ e # s"
proof(induction xs, force)
  case (Cons a xs)
  then obtain p s where IH: "xs = p @ s \<and> insert_body xs e = p @ e # s"
    by blast
  then show "\<exists>p s. a # xs = p @ s \<and> insert_body (a # xs) e = p @ e # s"
  proof(cases "a < e")
    case True
    then have "a # xs = [] @ (a # p @ s) \<and> insert_body (a # xs) e = [] @ e # (a # p @ s)"
      by (simp add: IH)
    then show ?thesis by blast
  next
    case False
    then have "a # xs = (a # p) @ s \<and> insert_body (a # xs) e = (a # p) @ e # s"
      using IH by auto
    then show ?thesis by blast
  qed
qed

lemma insert_between_elements:
  assumes "xs = pre @ ref # suf"
    and "distinct xs"
    and "\<And>i. i \<in> set xs \<Longrightarrow> i < e"
  shows "insert_rga xs (e, Some ref) = pre @ ref # e # suf"
using assms proof(induction xs arbitrary: pre, force)
  case (Cons a xs)
  then show "insert_rga (a # xs) (e, Some ref) = pre @ ref # e # suf"
  proof(cases pre)
    case pre_nil: Nil
    then have "a = ref"
      using Cons.prems(1) by auto
    then show ?thesis
      using Cons.prems pre_nil by (cases suf, auto)
  next
    case (Cons b pre')
    then have "insert_rga xs (e, Some ref) = pre' @ ref # e # suf"
      using Cons.IH Cons.prems by auto
    then show ?thesis
      using Cons.prems(1) Cons.prems(2) local.Cons by auto
  qed
qed

lemma insert_rga_after_ref:
  assumes "\<forall>x\<in>set as. a \<noteq> x"
    and "insert_body (cs @ ds) e = cs @ e # ds"
  shows "insert_rga (as @ a # cs @ ds) (e, Some a) = as @ a # cs @ e # ds"
using assms by (induction as; auto)

subsection\<open>Lemmas about the \isa{rga-ops} predicate\<close>

definition rga_ops :: "('oid::{linorder} \<times> 'oid option) list \<Rightarrow> bool" where
  "rga_ops list \<equiv> crdt_ops list set_option"

lemma rga_ops_rem_last:
  assumes "rga_ops (xs @ [x])"
  shows "rga_ops xs"
using assms crdt_ops_rem_last rga_ops_def by blast

lemma rga_ops_rem_penultimate:
  assumes "rga_ops (xs @ [(i1, r1), (i2, r2)])"
    and "\<And>r. r2 = Some r \<Longrightarrow> r \<noteq> i1"
  shows "rga_ops (xs @ [(i2, r2)])"
using assms proof -
  have "crdt_ops (xs @ [(i2, r2)]) set_option"
    using assms crdt_ops_rem_penultimate rga_ops_def by fastforce
  thus "rga_ops (xs @ [(i2, r2)])"
    by (simp add: rga_ops_def)
qed

lemma rga_ops_ref_exists:
  assumes "rga_ops (pre @ (oid, Some ref) # suf)"
  shows "ref \<in> fst ` set pre"
proof -
  from assms have "crdt_ops (pre @ (oid, Some ref) # suf) set_option"
    by (simp add: rga_ops_def)
  moreover have "set_option (Some ref) = {ref}"
    by simp
  ultimately show "ref \<in> fst ` set pre"
    using crdt_ops_ref_exists by fastforce
qed

subsection\<open>Lemmas about the \isa{interp-rga} function\<close>

lemma interp_rga_tail_unfold:
  shows "interp_rga (xs@[x]) = insert_rga (interp_rga (xs)) x"
by (clarsimp simp add: interp_rga_def)

lemma interp_rga_ids:
  assumes "rga_ops xs"
  shows "set (interp_rga xs) = set (map fst xs)"
using assms proof(induction xs rule: List.rev_induct)
  case Nil
  then show "set (interp_rga []) = set (map fst [])"
    by (simp add: interp_rga_def)
next
  case (snoc x xs)
  hence IH: "set (interp_rga xs) = set (map fst xs)"
    using rga_ops_rem_last by blast
  obtain xi xr where x_pair: "x = (xi, xr)" by force
  then show "set (interp_rga (xs @ [x])) = set (map fst (xs @ [x]))"
  proof(cases xr)
    case None
    then show ?thesis
      using IH x_pair by (clarsimp simp add: interp_rga_def)
  next
    case (Some r)
    moreover from this have "r \<in> set (interp_rga xs)"
      using IH rga_ops_ref_exists by (metis x_pair list.set_map snoc.prems)
    ultimately have "set (interp_rga (xs @ [(xi, xr)])) = insert xi (set (interp_rga xs))"
      by (simp add: insert_rga_set_ins interp_rga_tail_unfold)
    then show "set (interp_rga (xs @ [x])) = set (map fst (xs @ [x]))"
      using IH x_pair by auto
  qed
qed

lemma interp_rga_distinct:
  assumes "rga_ops xs"
  shows "distinct (interp_rga xs)"
using assms proof(induction xs rule: List.rev_induct)
  case Nil
  then show "distinct (interp_rga [])" by (simp add: interp_rga_def)
next
  case (snoc x xs)
  hence IH: "distinct (interp_rga xs)"
    using rga_ops_rem_last by blast
  moreover obtain xi xr where x_pair: "x = (xi, xr)"
    by force
  moreover from this have "xi \<notin> set (interp_rga xs)"
    using interp_rga_ids crdt_ops_unique_last rga_ops_rem_last
    by (metis rga_ops_def snoc.prems)
  moreover have "\<exists>pre suf. interp_rga xs = pre@suf \<and>
           insert_rga (interp_rga xs) (xi, xr) = pre @ xi # suf"
  proof -
    have "\<And>r. r \<in> set_option xr \<Longrightarrow> r \<in> set (map fst xs)"
      using crdt_ops_ref_exists rga_ops_def snoc.prems x_pair by fastforce
    hence "xr = None \<or> (\<exists>r. xr = Some r \<and> r \<in> set (map fst xs))"
      using option.set_sel by blast
    hence "xr = None \<or> (\<exists>r. xr = Some r \<and> r \<in> set (interp_rga xs))"
      using interp_rga_ids rga_ops_rem_last snoc.prems by blast
    thus ?thesis
      using IH insert_rga_preserves_order by blast
  qed
  ultimately show "distinct (interp_rga (xs @ [x]))"
    by (metis Un_iff disjoint_insert(1) distinct.simps(2) distinct_append
        interp_rga_tail_unfold list.simps(15) set_append)
qed

subsection\<open>Proof that RGA satisfies the list specification\<close>

lemma final_insert:
  assumes "set (xs @ [x]) = set (ys @ [x])"
    and "rga_ops (xs @ [x])"
    and "insert_ops (ys @ [x])"
    and "interp_rga xs = interp_ins ys"
  shows "interp_rga (xs @ [x]) = interp_ins (ys @ [x])"
proof -
  obtain oid ref where x_pair: "x = (oid, ref)" by force
  have "distinct (xs @ [x])" and "distinct (ys @ [x])"
    using assms crdt_ops_distinct spec_ops_distinct rga_ops_def insert_ops_def by blast+
  then have "set xs = set ys"
    using assms(1) by force
  have oid_greatest: "\<And>i. i \<in> set (interp_rga xs) \<Longrightarrow> i < oid"
  proof -
    have "\<And>i. i \<in> set (map fst ys) \<Longrightarrow> i < oid"
      using assms(3) by (simp add: spec_ops_id_inc x_pair insert_ops_def)
    hence "\<And>i. i \<in> set (map fst xs) \<Longrightarrow> i < oid"
      using \<open>set xs = set ys\<close> by auto
    thus "\<And>i. i \<in> set (interp_rga xs) \<Longrightarrow> i < oid"
      using assms(2) interp_rga_ids rga_ops_rem_last by blast
  qed
  thus "interp_rga (xs @ [x]) = interp_ins (ys @ [x])"
  proof(cases ref)
    case None
    moreover from this have "insert_rga (interp_rga xs) (oid, ref) = oid # interp_rga xs"
      using oid_greatest hd_in_set insert_body.elims insert_body.simps(1)
        insert_rga.simps(1) list.sel(1) by metis
    ultimately show "interp_rga (xs @ [x]) = interp_ins (ys @ [x])"
      using assms(4) by (simp add: interp_ins_tail_unfold interp_rga_tail_unfold x_pair)
  next
    case (Some r)
    have "\<exists>as bs. interp_rga xs = as @ r # bs"
    proof -
      have "r \<in> set (map fst xs)"
        using assms(2) Some by (simp add: rga_ops_ref_exists x_pair)
      hence "r \<in> set (interp_rga xs)"
        using assms(2) interp_rga_ids rga_ops_rem_last by blast
      thus ?thesis by (simp add: split_list)
    qed
    from this obtain as bs where as_bs: "interp_rga xs = as @ r # bs" by force
    hence "distinct (as @ r # bs)"
      by (metis assms(2) interp_rga_distinct rga_ops_rem_last)
    hence "insert_rga (as @ r # bs) (oid, Some r) = as @ r # oid # bs"
      by (metis as_bs insert_between_elements oid_greatest)
    moreover have "insert_spec (as @ r # bs) (oid, Some r) = as @ r # oid # bs"
      by (meson \<open>distinct (as @ r # bs)\<close> insert_after_ref)
    ultimately show "interp_rga (xs @ [x]) = interp_ins (ys @ [x])"
      by (metis assms(4) Some as_bs interp_ins_tail_unfold interp_rga_tail_unfold x_pair)
  qed
qed

lemma interp_rga_reorder:
  assumes "rga_ops (pre @ suf @ [(oid, ref)])"
    and "\<And>i r. (i, Some r) \<in> set suf \<Longrightarrow> r \<noteq> oid"
    and "\<And>r. ref = Some r \<Longrightarrow> r \<notin> fst ` set suf"
  shows "interp_rga (pre @ (oid, ref) # suf) = interp_rga (pre @ suf @ [(oid, ref)])"
using assms proof(induction suf rule: List.rev_induct)
  case Nil
  then show ?case by simp
next
  case (snoc x xs)
  have ref_not_x: "\<And>r. ref = Some r \<Longrightarrow> r \<noteq> fst x" using snoc.prems(3) by auto
  have IH: "interp_rga (pre @ (oid, ref) # xs) = interp_rga (pre @ xs @ [(oid, ref)])"
  proof -
    have "rga_ops ((pre @ xs) @ [x] @ [(oid, ref)])"
      using snoc.prems(1) by auto
    moreover have "\<And>r. ref = Some r \<Longrightarrow> r \<noteq> fst x"
      by (simp add: ref_not_x)
    ultimately have "rga_ops ((pre @ xs) @ [(oid, ref)])"
      using rga_ops_rem_penultimate
      by (metis (no_types, lifting) Cons_eq_append_conv prod.collapse)
    thus ?thesis using snoc by force
  qed
  obtain xi xr where x_pair: "x = (xi, xr)" by force
  have "interp_rga (pre @ (oid, ref) # xs @ [(xi, xr)]) =
        insert_rga (interp_rga (pre @ xs @ [(oid, ref)])) (xi, xr)"
    using IH interp_rga_tail_unfold by (metis append.assoc append_Cons)
  moreover have "... = insert_rga (insert_rga (interp_rga (pre @ xs)) (oid, ref)) (xi, xr)"
    using interp_rga_tail_unfold by (metis append_assoc)
  moreover have "... = insert_rga (insert_rga (interp_rga (pre @ xs)) (xi, xr)) (oid, ref)"
  proof -
    have "\<And>xrr. xr = Some xrr \<Longrightarrow> xrr \<noteq> oid"
      using x_pair snoc.prems(2) by auto
    thus ?thesis
      using insert_rga_commutes ref_not_x by (metis fst_conv x_pair)
  qed
  moreover have "... = interp_rga (pre @ xs @ [x] @ [(oid, ref)])"
    by (metis append_assoc interp_rga_tail_unfold x_pair)
  ultimately show "interp_rga (pre @ (oid, ref) # xs @ [x]) =
                   interp_rga (pre @ (xs @ [x]) @ [(oid, ref)])"
    by (simp add: x_pair)
qed

lemma rga_spec_equal:
  assumes "set xs = set ys"
    and "insert_ops xs"
    and "rga_ops ys"
  shows "interp_ins xs = interp_rga ys"
using assms proof(induction xs arbitrary: ys rule: rev_induct)
  case Nil
  then show ?case by (simp add: interp_rga_def interp_ins_def)
next
  case (snoc x xs)
  hence "x \<in> set ys"
    by (metis last_in_set snoc_eq_iff_butlast)
  from this obtain pre suf where ys_split: "ys = pre @ [x] @ suf"
    using split_list_first by fastforce
  have IH: "interp_ins xs = interp_rga (pre @ suf)"
  proof -
    have "crdt_ops (pre @ suf) set_option"
    proof -
      have "crdt_ops (pre @ [x] @ suf) set_option"
        using rga_ops_def snoc.prems(3) ys_split by blast
      thus "crdt_ops (pre @ suf) set_option"
        using crdt_ops_rem_spec snoc.prems ys_split insert_ops_def by blast
    qed
    hence "rga_ops (pre @ suf)"
      using rga_ops_def by blast
    moreover have "set xs = set (pre @ suf)"
      by (metis append_set_rem_last crdt_ops_distinct insert_ops_def rga_ops_def
          snoc.prems spec_ops_distinct ys_split)
    ultimately show ?thesis
      using insert_ops_rem_last ys_split snoc by metis
  qed
  have valid_rga: "rga_ops (pre @ suf @ [x])"
  proof -
    have "crdt_ops (pre @ suf @ [x]) set_option"
      using snoc.prems ys_split
      by (simp add: crdt_ops_reorder_spec insert_ops_def rga_ops_def)
    thus "rga_ops (pre @ suf @ [x])"
      by (simp add: rga_ops_def)
  qed
  have "interp_ins (xs @ [x]) = interp_rga (pre @ suf @ [x])"
  proof -
    have "set (xs @ [x]) = set (pre @ suf @ [x])"
      using snoc.prems(1) ys_split by auto
    thus ?thesis
      using IH snoc.prems(2) valid_rga final_insert append_assoc by metis
  qed
  moreover have "... = interp_rga (pre @ [x] @ suf)"
  proof -
    obtain oid ref where x_pair: "x = (oid, ref)"
      by force
    have "\<And>op2 r. op2 \<in> snd ` set suf \<Longrightarrow> r \<in> set_option op2 \<Longrightarrow> r \<noteq> oid"
      using snoc.prems
      by (simp add: crdt_ops_independent_suf insert_ops_def rga_ops_def x_pair ys_split)
    hence "\<And>i r. (i, Some r) \<in> set suf \<Longrightarrow> r \<noteq> oid"
      by fastforce
    moreover have "\<And>r. ref = Some r \<Longrightarrow> r \<notin> fst ` set suf"
      using crdt_ops_no_future_ref snoc.prems(3) x_pair ys_split
      by (metis option.set_intros rga_ops_def)
    ultimately show "interp_rga (pre @ suf @ [x]) = interp_rga (pre @ [x] @ suf)"
      using interp_rga_reorder valid_rga x_pair by force
  qed
  ultimately show "interp_ins (xs @ [x]) = interp_rga ys"
    by (simp add: ys_split)
qed

lemma insert_ops_exist:
  assumes "rga_ops xs"
  shows "\<exists>ys. set xs = set ys \<and> insert_ops ys"
using assms by (simp add: crdt_ops_spec_ops_exist insert_ops_def rga_ops_def)

theorem rga_meets_spec:
  assumes "rga_ops xs"
  shows "\<exists>ys. set ys = set xs \<and> insert_ops ys \<and> interp_ins ys = interp_rga xs"
  using assms rga_spec_equal insert_ops_exist by metis

end


(*  Title:       POSIX Lexing with Derivatives of Extended Regular Expressions
    Author:      Christian Urban <christian.urban at kcl.ac.uk>, 2022
    Maintainer:  Christian Urban <christian.urban at kcl.ac.uk>
*)

theory Lexer3
  imports "Derivatives3"
begin

section \<open>Values\<close>

datatype 'a val =
  Void
| Atm 'a
| Seq "'a val" "'a val"
| Right "'a val"
| Left "'a val"
| Stars "('a val) list"
| Recv string "'a val"

section \<open>The string behind a value\<close>

fun
  flat :: "'a val \<Rightarrow> 'a list"
where
  "flat (Void) = []"
| "flat (Atm c) = [c]"
| "flat (Left v) = flat v"
| "flat (Right v) = flat v"
| "flat (Seq v1 v2) = (flat v1) @ (flat v2)"
| "flat (Stars []) = []"
| "flat (Stars (v#vs)) = (flat v) @ (flat (Stars vs))"
| "flat (Recv l v) = flat v"

abbreviation
  "flats vs \<equiv> concat (map flat vs)"

lemma flat_Stars [simp]:
 "flat (Stars vs) = concat (map flat vs)"
  by (induct vs) (auto)

lemma flats_empty:
  assumes "(\<forall>v\<in>set vs. flat v = [])"
  shows "flats vs = []"
using assms
by(induct vs) (simp_all)

section \<open>Relation between values and regular expressions\<close>

inductive
  Prf :: "'a val \<Rightarrow> 'a rexp \<Rightarrow> bool" ("\<turnstile> _ : _" [100, 100] 100)
where
 "\<lbrakk>\<turnstile> v1 : r1; \<turnstile> v2 : r2\<rbrakk> \<Longrightarrow> \<turnstile> Seq v1 v2 : Times r1 r2"
| "\<turnstile> v1 : r1 \<Longrightarrow> \<turnstile> Left v1 : Plus r1 r2"
| "\<turnstile> v2 : r2 \<Longrightarrow> \<turnstile> Right v2 : Plus r1 r2"
| "\<turnstile> Void : One"
| "\<turnstile> Atm c : Atom c"
| "\<lbrakk>\<forall>v \<in> set vs. \<turnstile> v : r \<and> flat v \<noteq> []\<rbrakk> \<Longrightarrow> \<turnstile> Stars vs : Star r"
| "\<lbrakk>\<forall>v \<in> set vs1. \<turnstile> v : r \<and> flat v \<noteq> [];
    \<forall>v \<in> set vs2. \<turnstile> v : r \<and> flat v = [];
    length (vs1 @ vs2) = n\<rbrakk> \<Longrightarrow> \<turnstile> Stars (vs1 @ vs2) : NTimes r n"
| "\<lbrakk>\<forall>v \<in> set vs. \<turnstile> v : r \<and> flat v \<noteq> []; length vs \<le> n\<rbrakk> \<Longrightarrow> \<turnstile> Stars vs : Upto r n"
| "\<lbrakk>\<forall>v \<in> set vs1. \<turnstile> v : r  \<and> flat v \<noteq> [];
    \<forall>v \<in> set vs2. \<turnstile> v : r \<and> flat v = [];
    length (vs1 @ vs2) = n\<rbrakk> \<Longrightarrow> \<turnstile> Stars (vs1 @ vs2) : From r n"
| "\<lbrakk>\<forall>v \<in> set vs. \<turnstile> v : r  \<and> flat v \<noteq> []; length vs > n\<rbrakk> \<Longrightarrow> \<turnstile> Stars vs : From r n"
| "\<turnstile> v : r \<Longrightarrow> \<turnstile> Recv l v : Rec l r"
| "c \<in> cs \<Longrightarrow> \<turnstile> Atm c : Charset cs"

inductive_cases Prf_elims:
  "\<turnstile> v : Zero"
  "\<turnstile> v : Times r1 r2"
  "\<turnstile> v : Plus r1 r2"
  "\<turnstile> v : One"
  "\<turnstile> v : Atom c"
  "\<turnstile> v : Star r"
  "\<turnstile> v : NTimes r n"
  "\<turnstile> v : Upto r n"
  "\<turnstile> v : From r n"
  "\<turnstile> v : Rec l r"
  "\<turnstile> v : Charset cs"

lemma Prf_NTimes_empty:
  assumes "\<forall>v \<in> set vs. \<turnstile> v : r \<and> flat v = []"
  and     "length vs = n"
  shows "\<turnstile> Stars vs : NTimes r n"
  using assms
  by (metis Prf.intros(7) empty_iff eq_Nil_appendI list.set(1))

lemma Times_decomp:
  assumes "s \<in> A @@ B"
  shows "\<exists>s1 s2. s = s1 @ s2 \<and> s1 \<in> A \<and> s2 \<in> B"
  using assms
  by blast

lemma pow_string:
  assumes "s \<in> A ^^ n"
  shows "\<exists>ss. concat ss = s \<and> (\<forall>s \<in> set ss. s \<in> A) \<and> length ss = n"
using assms
  apply(induct n arbitrary: s)
  apply(auto dest!: Times_decomp)
  apply(drule_tac x="s2" in meta_spec)
  apply(auto)
  apply(rule_tac x="s1 # ss" in exI)
  apply(simp)
  done

lemma pow_Prf:
  assumes "\<forall>v\<in>set vs. \<turnstile> v : r \<and> flat v \<in> A"
  shows "flats vs \<in> A ^^ (length vs)"
  using assms
  by (induct vs) (auto)

lemma Star_string:
  assumes "s \<in> star A"
  shows "\<exists>ss. concat ss = s \<and> (\<forall>s \<in> set ss. s \<in> A)"
using assms
by (metis in_star_iff_concat subsetD)

lemma Star_val:
  assumes "\<forall>s\<in>set ss. \<exists>v. s = flat v \<and> \<turnstile> v : r"
  shows "\<exists>vs. flats vs = concat ss \<and> (\<forall>v\<in>set vs. \<turnstile> v : r \<and> flat v \<noteq> [])"
using assms
apply(induct ss)
apply(auto)
apply (metis empty_iff list.set(1))
by (metis append.simps(1) flat.simps(7) flat_Stars set_ConsD)

lemma Aux:
  assumes "\<forall>s\<in>set ss. s = []"
  shows "concat ss = []"
using assms
by (induct ss) (auto)

lemma pow_cstring:
  assumes "s \<in> A ^^ n"
  shows "\<exists>ss1 ss2. concat (ss1 @ ss2) = s \<and> length (ss1 @ ss2) = n \<and>
         (\<forall>s \<in> set ss1. s \<in> A \<and> s \<noteq> []) \<and> (\<forall>s \<in> set ss2. s \<in> A \<and> s = [])"
using assms
apply(induct n arbitrary: s)
  apply(auto)[1]
  apply(auto dest!: Times_decomp simp add: Seq_def)
  apply(drule_tac x="s2" in meta_spec)
  apply(simp)
apply(erule exE)+
  apply(clarify)
apply(case_tac "s1 = []")
apply(simp)
apply(rule_tac x="ss1" in exI)
apply(rule_tac x="s1 # ss2" in exI)
apply(simp)
apply(rule_tac x="s1 # ss1" in exI)
apply(rule_tac x="ss2" in exI)
  apply(simp)
  done

lemma flats_cval:
  assumes "\<forall>s\<in>set ss. \<exists>v. s = flat v \<and> \<turnstile> v : r"
  shows "\<exists>vs1 vs2. flats vs1 = concat ss \<and> length (vs1 @ vs2) = length ss \<and>
          (\<forall>v\<in>set vs1. \<turnstile> v : r \<and> flat v \<noteq> []) \<and>
          (\<forall>v\<in>set vs2. \<turnstile> v : r \<and> flat v = [])"
using assms
apply(induct ss rule: rev_induct)
apply(rule_tac x="[]" in exI)+
apply(simp)
apply(simp)
  apply(clarify)
  apply(case_tac "flat v = []")
  apply(rule_tac x="vs1" in exI)
  apply(simp)
apply(rule_tac x="v#vs2" in exI)
apply(simp)
  apply(rule_tac x="vs1 @ [v]" in exI)
  apply(simp)
apply(rule_tac x="vs2" in exI)
apply(simp)
  done

lemma flats_cval2:
  assumes "\<forall>s\<in>set ss. \<exists>v. s = flat v \<and> \<turnstile> v : r"
  shows "\<exists>vs. flats vs = concat ss \<and> length vs \<le> length ss \<and> (\<forall>v\<in>set vs. \<turnstile> v : r \<and> flat v \<noteq> [])"
  using assms
  apply -
  apply(drule flats_cval)
  apply(auto)
  done

lemma Prf_flat_lang:
  assumes "\<turnstile> v : r" shows "flat v \<in> lang r"
using assms
  apply(induct v r rule: Prf.induct)
  apply(auto simp add: concat_in_star subset_eq lang_pow_add)
  apply(meson concI pow_Prf)
  apply(meson atMost_iff pow_Prf)
  apply(subgoal_tac "flats vs1 @ flats vs2 \<in> lang r ^^ length vs1")
  apply (metis add_diff_cancel_left' atLeast_iff diff_is_0_eq empty_pow_add last_in_set length_0_conv order_refl)
  apply (metis (no_types, opaque_lifting) Aux imageE list.set_map pow_Prf self_append_conv)
  apply (meson atLeast_iff less_imp_le_nat pow_Prf)
  done

lemma L_flat_Prf2:
  assumes "s \<in> lang r"
  shows "\<exists>v. \<turnstile> v : r \<and> flat v = s"
using assms
proof(induct r arbitrary: s)
  case (Star r s)
  have IH: "\<And>s. s \<in> lang r \<Longrightarrow> \<exists>v.\<turnstile> v : r \<and> flat v = s" by fact
  have "s \<in> lang (Star r)" by fact
  then obtain ss where "concat ss = s" "\<forall>s \<in> set ss. s \<in> lang r \<and> s \<noteq> []"
    by (smt (z3) IH Prf_flat_lang Star_val imageE in_star_iff_concat lang.simps(6) list.set_map subset_iff)
  then obtain vs where "flats vs = s" "\<forall>v\<in>set vs. \<turnstile> v : r \<and> flat v \<noteq> []"
  using IH by (metis Star_val)
  then show "\<exists>v. \<turnstile> v : Star r \<and> flat v = s"
  using Prf.intros(6) flat_Stars by blast
next
  case (Times r1 r2 s)
  then show "\<exists>v. \<turnstile> v : Times r1 r2 \<and> flat v = s"
  unfolding Seq_def lang.simps by (fastforce intro: Prf.intros)
next
  case (Plus r1 r2 s)
  then show "\<exists>v. \<turnstile> v : Plus r1 r2 \<and> flat v = s"
  unfolding lang.simps by (fastforce intro: Prf.intros)
next
  case (NTimes r n)
  have IH: "\<And>s. s \<in> lang r \<Longrightarrow> \<exists>v. \<turnstile> v : r \<and> flat v = s" by fact
  have "s \<in> lang (NTimes r n)" by fact
  then obtain ss1 ss2 where "concat (ss1 @ ss2) = s" "length (ss1 @ ss2) = n"
    "\<forall>s \<in> set ss1. s \<in> lang r \<and> s \<noteq> []" "\<forall>s \<in> set ss2. s \<in> lang r \<and> s = []"
  using pow_cstring by force
  then obtain vs1 vs2 where "flats (vs1 @ vs2) = s" "length (vs1 @ vs2) = n"
      "\<forall>v\<in>set vs1. \<turnstile> v : r \<and> flat v \<noteq> []" "\<forall>v\<in>set vs2. \<turnstile> v : r \<and> flat v = []"
    using IH flats_cval
  apply -
  apply(drule_tac x="ss1 @ ss2" in meta_spec)
  apply(drule_tac x="r" in meta_spec)
  apply(drule meta_mp)
  apply(simp)
  apply (metis Un_iff)
  apply(clarify)
  apply(drule_tac x="vs1" in meta_spec)
  apply(drule_tac x="vs2" in meta_spec)
  apply(simp)
  done
  then show "\<exists>v. \<turnstile> v : NTimes r n \<and> flat v = s"
    using Prf.intros(7) flat_Stars by blast
next
  case (Upto r n)
  have IH: "\<And>s. s \<in> lang r \<Longrightarrow> \<exists>v.\<turnstile> v : r \<and> flat v = s" by fact
  have "s \<in> lang (Upto r n)" by fact
  then obtain ss where "concat ss = s" "\<forall>s \<in> set ss. s \<in> lang r \<and> s \<noteq> []" "length ss \<le> n"
    apply(auto)
    by (smt (verit) Nil_eq_concat_conv pow_cstring concat_append le0 le_add_same_cancel1 le_trans length_append self_append_conv)
  then obtain vs where "flats vs = s" "\<forall>v\<in>set vs. \<turnstile> v : r \<and> flat v \<noteq> []" "length vs \<le> n"
  using IH flats_cval2
  by (smt (verit, best) le_trans)
  then show "\<exists>v. \<turnstile> v : Upto r n \<and> flat v = s"
    by (meson Prf.intros(8) flat_Stars)
next
  case (From r n)
  have IH: "\<And>s. s \<in> lang r \<Longrightarrow> \<exists>v. \<turnstile> v : r \<and> flat v = s" by fact
  have "s \<in> lang (From r n)" by fact
  then obtain ss1 ss2 k where "concat (ss1 @ ss2) = s" "length (ss1 @ ss2) = k"  "n \<le> k"
    "\<forall>s \<in> set ss1. s \<in> lang r \<and> s \<noteq> []" "\<forall>s \<in> set ss2. s \<in> lang r \<and> s = []"
    using pow_cstring by force
  then obtain vs1 vs2 where "flats (vs1 @ vs2) = s" "length (vs1 @ vs2) = k" "n \<le> k"
      "\<forall>v\<in>set vs1. \<turnstile> v : r \<and> flat v \<noteq> []" "\<forall>v\<in>set vs2. \<turnstile> v : r \<and> flat v = []"
    using IH flats_cval
  apply -
  apply(drule_tac x="ss1 @ ss2" in meta_spec)
  apply(drule_tac x="r" in meta_spec)
  apply(drule meta_mp)
  apply(simp)
  apply (metis Un_iff)
  apply(clarify)
  apply(drule_tac x="vs1" in meta_spec)
  apply(drule_tac x="vs2" in meta_spec)
  apply(simp)
  done
  then show "\<exists>v. \<turnstile> v : From r n \<and> flat v = s"
    apply(case_tac "length vs1 \<le> n")
    apply(rule_tac x="Stars (vs1 @ take (n - length vs1) vs2)" in exI)
     apply(simp)
     apply(subgoal_tac "flats (take (n - length vs1) vs2) = []")
      apply(auto)
       apply(rule Prf.intros(9))
       apply(auto)
    apply (meson in_set_takeD)
    apply (simp add: Aux)
    apply (meson in_set_takeD)
    apply(rule_tac x="Stars vs1" in exI)
    by (simp add: Prf.intros(10))
next
  case (Rec l r)
  then show ?case apply(auto)
    using Prf.intros(11) flat.simps(8) by blast
qed (auto intro: Prf.intros)

lemma L_flat_Prf:
  "lang r = {flat v | v. \<turnstile> v : r}"
  using L_flat_Prf2 Prf_flat_lang by blast

section \<open>Sulzmann and Lu functions\<close>

fun
  mkeps :: "'a rexp \<Rightarrow> 'a val"
where
  "mkeps(One) = Void"
| "mkeps(Times r1 r2) = Seq (mkeps r1) (mkeps r2)"
| "mkeps(Plus r1 r2) = (if nullable(r1) then Left (mkeps r1) else Right (mkeps r2))"
| "mkeps(Star r) = Stars []"
| "mkeps(Upto r n) = Stars []"
| "mkeps(NTimes r n) = Stars (replicate n (mkeps r))"
| "mkeps(From r n) = Stars (replicate n (mkeps r))"
| "mkeps(Rec l r) = Recv l (mkeps r)"

fun injval :: "'a rexp \<Rightarrow> 'a \<Rightarrow> 'a val \<Rightarrow> 'a val"
where
  "injval (Atom d) c Void = Atm c"
| "injval (Plus r1 r2) c (Left v1) = Left(injval r1 c v1)"
| "injval (Plus r1 r2) c (Right v2) = Right(injval r2 c v2)"
| "injval (Times r1 r2) c (Seq v1 v2) = Seq (injval r1 c v1) v2"
| "injval (Times r1 r2) c (Left (Seq v1 v2)) = Seq (injval r1 c v1) v2"
| "injval (Times r1 r2) c (Right v2) = Seq (mkeps r1) (injval r2 c v2)"
| "injval (Star r) c (Seq v (Stars vs)) = Stars ((injval r c v) # vs)"
| "injval (NTimes r n) c (Seq v (Stars vs)) = Stars ((injval r c v) # vs)"
| "injval (Upto r n) c (Seq v (Stars vs)) = Stars ((injval r c v) # vs)"
| "injval (From r n) c (Seq v (Stars vs)) = Stars ((injval r c v) # vs)"
| "injval (Rec l r) c v = Recv l (injval r c v)"
| "injval (Charset cs) c Void = Atm c"

section \<open>Mkeps, injval\<close>

lemma mkeps_flat:
  assumes "nullable(r)"
  shows "flat (mkeps r) = []"
using assms
  by (induct rule: mkeps.induct) (auto)

lemma mkeps_nullable:
  assumes "nullable r"
  shows "\<turnstile> mkeps r : r"
using assms
  apply (induct r)
  apply (auto intro: Prf.intros split: if_splits)
  apply (metis Prf.intros(7) append_Nil2 in_set_replicate list.size(3) replicate_0)
  apply(rule Prf_NTimes_empty)
  apply(auto simp add: mkeps_flat)
  apply (metis Prf.intros(9) append_Nil empty_iff list.set(1) list.size(3))
  by (metis Prf.intros(9) append_Nil empty_iff in_set_replicate length_replicate list.set(1) mkeps_flat)

lemma Prf_injval_flat:
  assumes "\<turnstile> v : deriv c r"
  shows "flat (injval r c v) = c # (flat v)"
using assms
apply(induct c r arbitrary: v rule: deriv.induct)
apply(auto elim!: Prf_elims intro: mkeps_flat split: if_splits)
done

lemma Prf_injval:
  assumes "\<turnstile> v : deriv c r"
  shows "\<turnstile> (injval r c v) : r"
using assms
apply(induct r arbitrary: c v rule: rexp.induct)
apply(auto intro!: Prf.intros mkeps_nullable elim!: Prf_elims simp add: Prf_injval_flat split: if_splits)[7]
(* NTimes *)
apply(case_tac x2)
apply(simp)
apply(simp)
apply(subst append.simps(2)[symmetric])
apply(rule Prf.intros)
apply(auto simp add: Prf_injval_flat)[4]
(* Upto *)
apply(case_tac x2)
apply(simp)
using Prf_elims(1) apply blast
apply(simp)
apply(erule Prf_elims)
apply(erule Prf_elims(8))
apply(simp)
apply(rule Prf.intros(8))
apply(auto simp add: Prf_injval_flat)[2]
(* From *)
apply(simp)
apply(case_tac x2)
apply(simp)
apply(erule Prf_elims)
apply(simp)
apply(erule Prf_elims(6))
apply(simp)
apply (simp add: Prf.intros(10) Prf_injval_flat)
apply(simp)
apply(erule Prf_elims)
apply(simp)
apply(erule Prf_elims(9))
apply(simp)
apply (smt (verit, best) Cons_eq_appendI Prf.intros(9) Prf_injval_flat length_Cons length_append list.discI set_ConsD)
apply(simp add: Prf.intros(10) Prf_injval_flat)
apply(simp add: Prf.intros(11))
by (metis Prf.intros(12) Prf_elims(1) Prf_elims(4) deriv.simps(11) injval.simps(12))

section \<open>Our Alternative Posix definition\<close>

inductive
  Posix :: "'a list \<Rightarrow> 'a rexp \<Rightarrow> 'a val \<Rightarrow> bool" ("_ \<in> _ \<rightarrow> _" [100, 100, 100] 100)
where
  Posix_One: "[] \<in> One \<rightarrow> Void"
| Posix_Atom: "[c] \<in> (Atom c) \<rightarrow> (Atm c)"
| Posix_Plus1: "s \<in> r1 \<rightarrow> v \<Longrightarrow> s \<in> (Plus r1 r2) \<rightarrow> (Left v)"
| Posix_Plus2: "\<lbrakk>s \<in> r2 \<rightarrow> v; s \<notin> lang r1\<rbrakk> \<Longrightarrow> s \<in> (Plus r1 r2) \<rightarrow> (Right v)"
| Posix_Times: "\<lbrakk>s1 \<in> r1 \<rightarrow> v1; s2 \<in> r2 \<rightarrow> v2;
    \<not>(\<exists>s\<^sub>3 s\<^sub>4. s\<^sub>3 \<noteq> [] \<and> s\<^sub>3 @ s\<^sub>4 = s2 \<and> (s1 @ s\<^sub>3) \<in> lang r1 \<and> s\<^sub>4 \<in> lang r2)\<rbrakk> \<Longrightarrow>
    (s1 @ s2) \<in> (Times r1 r2) \<rightarrow> (Seq v1 v2)"
| Posix_Star1: "\<lbrakk>s1 \<in> r \<rightarrow> v; s2 \<in> Star r \<rightarrow> Stars vs; flat v \<noteq> [];
    \<not>(\<exists>s\<^sub>3 s\<^sub>4. s\<^sub>3 \<noteq> [] \<and> s\<^sub>3 @ s\<^sub>4 = s2 \<and> (s1 @ s\<^sub>3) \<in> lang r \<and> s\<^sub>4 \<in> lang (Star r))\<rbrakk>
    \<Longrightarrow> (s1 @ s2) \<in> Star r \<rightarrow> Stars (v # vs)"
| Posix_Star2: "[] \<in> Star r \<rightarrow> Stars []"
| Posix_NTimes1: "\<lbrakk>s1 \<in> r \<rightarrow> v; s2 \<in> NTimes r n \<rightarrow> Stars vs; flat v \<noteq> [];
    \<not>(\<exists>s\<^sub>3 s\<^sub>4. s\<^sub>3 \<noteq> [] \<and> s\<^sub>3 @ s\<^sub>4 = s2 \<and> (s1 @ s\<^sub>3) \<in> lang r \<and> s\<^sub>4 \<in> lang (NTimes r n))\<rbrakk>
    \<Longrightarrow> (s1 @ s2) \<in> NTimes r (n + 1) \<rightarrow> Stars (v # vs)"
| Posix_NTimes2: "\<lbrakk>\<forall>v \<in> set vs. [] \<in> r \<rightarrow> v; length vs = n\<rbrakk>
    \<Longrightarrow> [] \<in> NTimes r n \<rightarrow> Stars vs"
| Posix_Upto1: "\<lbrakk>s1 \<in> r \<rightarrow> v; s2 \<in> Upto r n \<rightarrow> Stars vs; flat v \<noteq> [];
    \<not>(\<exists>s\<^sub>3 s\<^sub>4. s\<^sub>3 \<noteq> [] \<and> s\<^sub>3 @ s\<^sub>4 = s2 \<and> (s1 @ s\<^sub>3) \<in> lang r \<and> s\<^sub>4 \<in> lang (Upto r n))\<rbrakk>
    \<Longrightarrow> (s1 @ s2) \<in> Upto r (n + 1) \<rightarrow> Stars (v # vs)"
| Posix_Upto2: "[] \<in> Upto r n \<rightarrow> Stars []"
| Posix_From2: "\<lbrakk>\<forall>v \<in> set vs. [] \<in> r \<rightarrow> v; length vs = n\<rbrakk>
    \<Longrightarrow> [] \<in> From r n \<rightarrow> Stars vs"
| Posix_From1: "\<lbrakk>s1 \<in> r \<rightarrow> v; s2 \<in> From r (n - 1) \<rightarrow> Stars vs; flat v \<noteq> []; 0 < n;
    \<not>(\<exists>s\<^sub>3 s\<^sub>4. s\<^sub>3 \<noteq> [] \<and> s\<^sub>3 @ s\<^sub>4 = s2 \<and> (s1 @ s\<^sub>3) \<in> lang r \<and> s\<^sub>4 \<in> lang (From r (n - 1)))\<rbrakk>
    \<Longrightarrow> (s1 @ s2) \<in> From r n \<rightarrow> Stars (v # vs)"
| Posix_From3: "\<lbrakk>s1 \<in> r \<rightarrow> v; s2 \<in> Star r \<rightarrow> Stars vs; flat v \<noteq> [];
    \<not>(\<exists>s\<^sub>3 s\<^sub>4. s\<^sub>3 \<noteq> [] \<and> s\<^sub>3 @ s\<^sub>4 = s2 \<and> (s1 @ s\<^sub>3) \<in> lang r \<and> s\<^sub>4 \<in> lang (Star r))\<rbrakk>
    \<Longrightarrow> (s1 @ s2) \<in> From r 0 \<rightarrow> Stars (v # vs)"
| Posix_Rec: "s \<in> r \<rightarrow> v \<Longrightarrow> s \<in> (Rec l r) \<rightarrow> (Recv l v)"
| Posix_Cset: "c \<in> cs \<Longrightarrow> [c] \<in> (Charset cs) \<rightarrow> (Atm c)"

inductive_cases Posix_elims:
  "s \<in> Zero \<rightarrow> v"
  "s \<in> One \<rightarrow> v"
  "s \<in> Atom c \<rightarrow> v"
  "s \<in> Plus r1 r2 \<rightarrow> v"
  "s \<in> Times r1 r2 \<rightarrow> v"
  "s \<in> Star r \<rightarrow> v"
  "s \<in> NTimes r n \<rightarrow> v"
  "s \<in> Upto r n \<rightarrow> v"
  "s \<in> From r n \<rightarrow> v"
  "s \<in> Rec l r \<rightarrow> v"
  "s \<in> Charset cs \<rightarrow> v"

lemma Posix1:
  assumes "s \<in> r \<rightarrow> v"
  shows "s \<in> lang r" "flat v = s"
using assms
  apply (induct s r v rule: Posix.induct)
  apply(auto simp add: pow_empty_iff)
  apply (meson ex_in_conv set_empty)
  apply(metis Suc_pred atMost_iff concI lang_pow.simps(2) not_less_eq_eq)
  apply (meson atLeast_iff dual_order.refl in_set_conv_nth)
  apply (metis Suc_le_mono Suc_pred atLeast_iff concI lang_pow.simps(2))
  by (simp add: star_pow)

lemma Posix1a:
  assumes "s \<in> r \<rightarrow> v"
  shows "\<turnstile> v : r"
using assms
  apply(induct s r v rule: Posix.induct)
  apply(auto intro: Prf.intros)
  apply (metis Prf.intros(6) Prf_elims(6) set_ConsD val.inject(5))
  prefer 2
  using Posix1(2) Prf_NTimes_empty apply blast
  apply(erule Prf_elims)
  apply(auto)
  apply(subst append.simps(2)[symmetric])
  apply(rule Prf.intros)
  apply(auto)
  apply (metis (no_types, lifting) Prf.intros(8) Prf_elims(8) Suc_le_mono length_Cons set_ConsD val.inject(5))
  apply (metis Posix1(2) Prf.intros(9) append_Nil empty_iff list.set(1))
  apply(erule Prf_elims)
  apply(auto)
  apply (smt (verit, best) Cons_eq_appendI Prf.intros(9) Suc_pred length_Cons length_append set_ConsD)
  apply (simp add: Prf.intros(10))
  apply(erule Prf_elims)
  apply(auto)
  by (simp add: Prf.intros(10))

lemma Posix_mkeps:
  assumes "nullable r"
  shows "[] \<in> r \<rightarrow> mkeps r"
using assms
apply(induct r)
apply(auto intro: Posix.intros simp add: nullable_iff)
apply(subst append.simps(1)[symmetric])
apply(rule Posix.intros)
apply(auto)
apply(simp add: Posix_NTimes2 pow_empty_iff)
apply(simp add: Posix_From2 pow_empty_iff)
done

lemma List_eq_zipI:
  assumes "\<forall>(v1, v2) \<in> set (zip vs1 vs2). v1 = v2"
  and "length vs1 = length vs2"
  shows "vs1 = vs2"
 using assms
  apply(induct vs1 arbitrary: vs2)
   apply(case_tac vs2)
   apply(simp)
   apply(simp)
   apply(case_tac vs2)
   apply(simp)
  apply(simp)
done

text \<open>Our Posix definition determines a unique value.\<close>

lemma Posix_determ:
  assumes "s \<in> r \<rightarrow> v1" "s \<in> r \<rightarrow> v2"
  shows "v1 = v2"
using assms
proof (induct s r v1 arbitrary: v2 rule: Posix.induct)
  case (Posix_One v2)
  have "[] \<in> One \<rightarrow> v2" by fact
  then show "Void = v2" by cases auto
next
  case (Posix_Atom c v2)
  have "[c] \<in> Atom c \<rightarrow> v2" by fact
  then show "Atm c = v2" by cases auto
next
  case (Posix_Plus1 s r1 v r2 v2)
  have "s \<in> Plus r1 r2 \<rightarrow> v2" by fact
  moreover
  have "s \<in> r1 \<rightarrow> v" by fact
  then have "s \<in> lang r1" by (simp add: Posix1)
  ultimately obtain v' where eq: "v2 = Left v'" "s \<in> r1 \<rightarrow> v'" by cases auto
  moreover
  have IH: "\<And>v2. s \<in> r1 \<rightarrow> v2 \<Longrightarrow> v = v2" by fact
  ultimately have "v = v'" by simp
  then show "Left v = v2" using eq by simp
next
  case (Posix_Plus2 s r2 v r1 v2)
  have "s \<in> Plus r1 r2 \<rightarrow> v2" by fact
  moreover
  have "s \<notin> lang r1" by fact
  ultimately obtain v' where eq: "v2 = Right v'" "s \<in> r2 \<rightarrow> v'"
    by cases (auto simp add: Posix1)
  moreover
  have IH: "\<And>v2. s \<in> r2 \<rightarrow> v2 \<Longrightarrow> v = v2" by fact
  ultimately have "v = v'" by simp
  then show "Right v = v2" using eq by simp
next
  case (Posix_Times s1 r1 v1 s2 r2 v2 v')
  have "(s1 @ s2) \<in> Times r1 r2 \<rightarrow> v'"
       "s1 \<in> r1 \<rightarrow> v1" "s2 \<in> r2 \<rightarrow> v2"
       "\<not> (\<exists>s\<^sub>3 s\<^sub>4. s\<^sub>3 \<noteq> [] \<and> s\<^sub>3 @ s\<^sub>4 = s2 \<and> s1 @ s\<^sub>3 \<in> lang r1 \<and> s\<^sub>4 \<in> lang r2)" by fact+
  then obtain v1' v2' where "v' = Seq v1' v2'" "s1 \<in> r1 \<rightarrow> v1'" "s2 \<in> r2 \<rightarrow> v2'"
  apply(cases) apply (auto simp add: append_eq_append_conv2)
  using Posix1(1) by fastforce+
  moreover
  have IHs: "\<And>v1'. s1 \<in> r1 \<rightarrow> v1' \<Longrightarrow> v1 = v1'"
            "\<And>v2'. s2 \<in> r2 \<rightarrow> v2' \<Longrightarrow> v2 = v2'" by fact+
  ultimately show "Seq v1 v2 = v'" by simp
next
  case (Posix_Star1 s1 r v s2 vs v2)
  have "(s1 @ s2) \<in> Star r \<rightarrow> v2"
       "s1 \<in> r \<rightarrow> v" "s2 \<in> Star r \<rightarrow> Stars vs" "flat v \<noteq> []"
       "\<not> (\<exists>s\<^sub>3 s\<^sub>4. s\<^sub>3 \<noteq> [] \<and> s\<^sub>3 @ s\<^sub>4 = s2 \<and> s1 @ s\<^sub>3 \<in> lang r \<and> s\<^sub>4 \<in> lang (Star r))" by fact+
  then obtain v' vs' where "v2 = Stars (v' # vs')" "s1 \<in> r \<rightarrow> v'" "s2 \<in> (Star r) \<rightarrow> (Stars vs')"
  apply(cases) apply (auto simp add: append_eq_append_conv2)
  using Posix1(1) apply fastforce
  apply (metis Posix1(1) Posix_Star1.hyps(6) append_Nil append_Nil2)
  using Posix1(2) by blast
  moreover
  have IHs: "\<And>v2. s1 \<in> r \<rightarrow> v2 \<Longrightarrow> v = v2"
            "\<And>v2. s2 \<in> Star r \<rightarrow> v2 \<Longrightarrow> Stars vs = v2" by fact+
  ultimately show "Stars (v # vs) = v2" by auto
next
  case (Posix_Star2 r v2)
  have "[] \<in> Star r \<rightarrow> v2" by fact
  then show "Stars [] = v2" by cases (auto simp add: Posix1)
next
  case (Posix_NTimes2 vs r n v2)
  then show "Stars vs = v2"
    apply(erule_tac Posix_elims)
     apply(auto)
     apply (simp add: Posix1(2))
    apply(rule List_eq_zipI)
     apply(auto)
    by (meson in_set_zipE)
next
  case (Posix_NTimes1 s1 r v s2 n vs)
  have "(s1 @ s2) \<in> NTimes r (n + 1) \<rightarrow> v2"
       "s1 \<in> r \<rightarrow> v" "s2 \<in> NTimes r n \<rightarrow> Stars vs" "flat v \<noteq> []"
       "\<not> (\<exists>s\<^sub>3 s\<^sub>4. s\<^sub>3 \<noteq> [] \<and> s\<^sub>3 @ s\<^sub>4 = s2 \<and> s1 @ s\<^sub>3 \<in> lang r \<and> s\<^sub>4 \<in> lang (NTimes r n))" by fact+
  then obtain v' vs' where "v2 = Stars (v' # vs')" "s1 \<in> r \<rightarrow> v'" "s2 \<in> (NTimes r n) \<rightarrow> (Stars vs')"
  apply(cases) apply (auto simp add: append_eq_append_conv2)
    using Posix1(1) apply fastforce
    apply (metis Posix1(1) Posix_NTimes1.hyps(6) append.right_neutral append_Nil)
  using Posix1(2) by blast
  moreover
  have IHs: "\<And>v2. s1 \<in> r \<rightarrow> v2 \<Longrightarrow> v = v2"
            "\<And>v2. s2 \<in> NTimes r n \<rightarrow> v2 \<Longrightarrow> Stars vs = v2" by fact+
  ultimately show "Stars (v # vs) = v2" by auto
next
  case (Posix_Upto1 s1 r v s2 n vs)
  have "(s1 @ s2) \<in> Upto r (n + 1) \<rightarrow> v2"
       "s1 \<in> r \<rightarrow> v" "s2 \<in> Upto r n \<rightarrow> Stars vs" "flat v \<noteq> []"
       "\<not> (\<exists>s\<^sub>3 s\<^sub>4. s\<^sub>3 \<noteq> [] \<and> s\<^sub>3 @ s\<^sub>4 = s2 \<and> s1 @ s\<^sub>3 \<in> lang r \<and> s\<^sub>4 \<in> lang (Upto r n))" by fact+
  then obtain v' vs' where "v2 = Stars (v' # vs')" "s1 \<in> r \<rightarrow> v'" "s2 \<in> (Upto r n) \<rightarrow> (Stars vs')"
    apply(cases) apply (auto simp add: append_eq_append_conv2)
    using Posix1(1) apply fastforce
    apply (metis Posix1(1) Posix_Upto1.hyps(6) append.right_neutral append_Nil)
  using Posix1(2) by blast
  moreover
  have IHs: "\<And>v2. s1 \<in> r \<rightarrow> v2 \<Longrightarrow> v = v2"
            "\<And>v2. s2 \<in> Upto r n \<rightarrow> v2 \<Longrightarrow> Stars vs = v2" by fact+
  ultimately show "Stars (v # vs) = v2" by auto
next
  case (Posix_Upto2 r n)
  have "[] \<in> Upto r n \<rightarrow> v2" by fact
  then show "Stars [] = v2" by cases (auto simp add: Posix1)
next
  case (Posix_From2 vs r n v2)
  then show "Stars vs = v2"
    apply(erule_tac Posix_elims)
     apply(auto)
    apply(rule List_eq_zipI)
     apply(auto)
      apply(meson in_set_zipE)
     apply (simp add: Posix1(2))
    using Posix1(2) by blast
next
  case (Posix_From1 s1 r v s2 n vs)
  have "(s1 @ s2) \<in> From r n \<rightarrow> v2"
       "s1 \<in> r \<rightarrow> v" "s2 \<in> From r (n - 1) \<rightarrow> Stars vs" "flat v \<noteq> []" "0 < n"
       "\<not> (\<exists>s\<^sub>3 s\<^sub>4. s\<^sub>3 \<noteq> [] \<and> s\<^sub>3 @ s\<^sub>4 = s2 \<and> s1 @ s\<^sub>3 \<in> lang r \<and> s\<^sub>4 \<in> lang (From r (n - 1 )))" by fact+
  then obtain v' vs' where "v2 = Stars (v' # vs')" "s1 \<in> r \<rightarrow> v'" "s2 \<in> (From r (n - 1)) \<rightarrow> (Stars vs')"
  apply(cases) apply (auto simp add: append_eq_append_conv2)
    using Posix1(1) Posix1(2) apply blast
     apply(case_tac n)
      apply(simp)
     apply(simp)
    apply (smt (verit, ccfv_threshold) Posix1(1) UN_E append_eq_append_conv2 lang.simps(9))
    by (metis One_nat_def Posix1(1) Posix_From1.hyps(7) append_Nil2 append_self_conv2)
  moreover
  have IHs: "\<And>v2. s1 \<in> r \<rightarrow> v2 \<Longrightarrow> v = v2"
            "\<And>v2. s2 \<in> From r (n - 1) \<rightarrow> v2 \<Longrightarrow> Stars vs = v2" by fact+
  ultimately show "Stars (v # vs) = v2" by auto
next
  case (Posix_From3 s1 r v s2 vs)
  have "(s1 @ s2) \<in> From r 0 \<rightarrow> v2"
       "s1 \<in> r \<rightarrow> v" "s2 \<in> Star r \<rightarrow> Stars vs" "flat v \<noteq> []"
       "\<not> (\<exists>s\<^sub>3 s\<^sub>4. s\<^sub>3 \<noteq> [] \<and> s\<^sub>3 @ s\<^sub>4 = s2 \<and> s1 @ s\<^sub>3 \<in> lang r \<and> s\<^sub>4 \<in> lang (Star r))" by fact+
  then obtain v' vs' where "v2 = Stars (v' # vs')" "s1 \<in> r \<rightarrow> v'" "s2 \<in> (Star r) \<rightarrow> (Stars vs')"
  apply(cases) apply (auto simp add: append_eq_append_conv2)
    using Posix1(2) apply fastforce
    using Posix1(1) apply fastforce
    by (metis Posix1(1) Posix_From3.hyps(6) append.right_neutral append_Nil)
  moreover
  have IHs: "\<And>v2. s1 \<in> r \<rightarrow> v2 \<Longrightarrow> v = v2"
            "\<And>v2. s2 \<in> Star r \<rightarrow> v2 \<Longrightarrow> Stars vs = v2" by fact+
  ultimately show "Stars (v # vs) = v2" by auto
next
  case (Posix_Rec s r v l v2)
  then show "Recv l v = v2" by (metis Posix_elims(10))
next
  case (Posix_Cset c cs v2)
  have "[c] \<in> Charset cs \<rightarrow> v2" by fact
  then show "Atm c = v2" by cases auto
qed

lemma Posix_injval:
  assumes "s \<in> (deriv c r) \<rightarrow> v"
  shows "(c # s) \<in> r \<rightarrow> (injval r c v)"
using assms
proof(induct r arbitrary: s v rule: rexp.induct)
  case Zero
  have "s \<in> deriv c Zero \<rightarrow> v" by fact
  then have "s \<in> Zero \<rightarrow> v" by simp
  then have "False" by cases
  then show "(c # s) \<in> Zero \<rightarrow> (injval Zero c v)" by simp
next
  case One
  have "s \<in> deriv c One \<rightarrow> v" by fact
  then have "s \<in> Zero \<rightarrow> v" by simp
  then have "False" by cases
  then show "(c # s) \<in> One \<rightarrow> (injval One c v)" by simp
next
  case (Atom d)
  consider (eq) "c = d" | (ineq) "c \<noteq> d" by blast
  then show "(c # s) \<in> (Atom d) \<rightarrow> (injval (Atom d) c v)"
  proof (cases)
    case eq
    have "s \<in> deriv c (Atom d) \<rightarrow> v" by fact
    then have "s \<in> One \<rightarrow> v" using eq by simp
    then have eqs: "s = [] \<and> v = Void" by cases simp
    show "(c # s) \<in> Atom d \<rightarrow> injval (Atom d) c v" using eq eqs
    by (auto intro: Posix.intros)
  next
    case ineq
    have "s \<in> deriv c (Atom d) \<rightarrow> v" by fact
    then have "s \<in> Zero \<rightarrow> v" using ineq by simp
    then have "False" by cases
    then show "(c # s) \<in> Atom d \<rightarrow> injval (Atom d) c v" by simp
  qed
next
  case (Plus r1 r2)
  have IH1: "\<And>s v. s \<in> deriv c r1 \<rightarrow> v \<Longrightarrow> (c # s) \<in> r1 \<rightarrow> injval r1 c v" by fact
  have IH2: "\<And>s v. s \<in> deriv c r2 \<rightarrow> v \<Longrightarrow> (c # s) \<in> r2 \<rightarrow> injval r2 c v" by fact
  have "s \<in> deriv c (Plus r1 r2) \<rightarrow> v" by fact
  then have "s \<in> Plus (deriv c r1) (deriv c r2) \<rightarrow> v" by simp
  then consider (left) v' where "v = Left v'" "s \<in> deriv c r1 \<rightarrow> v'"
              | (right) v' where "v = Right v'" "s \<notin> lang (deriv c r1)" "s \<in> deriv c r2 \<rightarrow> v'"
              by cases auto
  then show "(c # s) \<in> Plus r1 r2 \<rightarrow> injval (Plus r1 r2) c v"
  proof (cases)
    case left
    have "s \<in> deriv c r1 \<rightarrow> v'" by fact
    then have "(c # s) \<in> r1 \<rightarrow> injval r1 c v'" using IH1 by simp
    then have "(c # s) \<in> Plus r1 r2 \<rightarrow> injval (Plus r1 r2) c (Left v')" by (auto intro: Posix.intros)
    then show "(c # s) \<in> Plus r1 r2 \<rightarrow> injval (Plus r1 r2) c v" using left by simp
  next
    case right
    have "s \<notin> lang (deriv c r1)" by fact
    then have "c # s \<notin> lang r1" by (simp add: lang_deriv Deriv_def)
    moreover
    have "s \<in> deriv c r2 \<rightarrow> v'" by fact
    then have "(c # s) \<in> r2 \<rightarrow> injval r2 c v'" using IH2 by simp
    ultimately have "(c # s) \<in> Plus r1 r2 \<rightarrow> injval (Plus r1 r2) c (Right v')"
      by (auto intro: Posix.intros)
    then show "(c # s) \<in> Plus r1 r2 \<rightarrow> injval (Plus r1 r2) c v" using right by simp
  qed
next
  case (Times r1 r2)
  have IH1: "\<And>s v. s \<in> deriv c r1 \<rightarrow> v \<Longrightarrow> (c # s) \<in> r1 \<rightarrow> injval r1 c v" by fact
  have IH2: "\<And>s v. s \<in> deriv c r2 \<rightarrow> v \<Longrightarrow> (c # s) \<in> r2 \<rightarrow> injval r2 c v" by fact
  have "s \<in> deriv c (Times r1 r2) \<rightarrow> v" by fact
  then consider
        (left_nullable) v1 v2 s1 s2 where
        "v = Left (Seq v1 v2)"  "s = s1 @ s2"
        "s1 \<in> deriv c r1 \<rightarrow> v1" "s2 \<in> r2 \<rightarrow> v2" "nullable r1"
        "\<not> (\<exists>s\<^sub>3 s\<^sub>4. s\<^sub>3 \<noteq> [] \<and> s\<^sub>3 @ s\<^sub>4 = s2 \<and> s1 @ s\<^sub>3 \<in> lang (deriv c r1) \<and> s\<^sub>4 \<in> lang r2)"
      | (right_nullable) v1 s1 s2 where
        "v = Right v1" "s = s1 @ s2"
        "s \<in> deriv c r2 \<rightarrow> v1" "nullable r1" "s1 @ s2 \<notin> lang (Times (deriv c r1) r2)"
      | (not_nullable) v1 v2 s1 s2 where
        "v = Seq v1 v2" "s = s1 @ s2"
        "s1 \<in> deriv c r1 \<rightarrow> v1" "s2 \<in> r2 \<rightarrow> v2" "\<not>nullable r1"
        "\<not> (\<exists>s\<^sub>3 s\<^sub>4. s\<^sub>3 \<noteq> [] \<and> s\<^sub>3 @ s\<^sub>4 = s2 \<and> s1 @ s\<^sub>3 \<in> lang (deriv c r1) \<and> s\<^sub>4 \<in> lang r2)"
        by (force split: if_splits elim!: Posix_elims simp add: lang_deriv Deriv_def)
  then show "(c # s) \<in> Times r1 r2 \<rightarrow> injval (Times r1 r2) c v"
    proof (cases)
      case left_nullable
      have "s1 \<in> deriv c r1 \<rightarrow> v1" by fact
      then have "(c # s1) \<in> r1 \<rightarrow> injval r1 c v1" using IH1 by simp
      moreover
      have "\<not> (\<exists>s\<^sub>3 s\<^sub>4. s\<^sub>3 \<noteq> [] \<and> s\<^sub>3 @ s\<^sub>4 = s2 \<and> s1 @ s\<^sub>3 \<in> lang (deriv c r1) \<and> s\<^sub>4 \<in> lang r2)" by fact
      then have "\<not> (\<exists>s\<^sub>3 s\<^sub>4. s\<^sub>3 \<noteq> [] \<and> s\<^sub>3 @ s\<^sub>4 = s2 \<and> (c # s1) @ s\<^sub>3 \<in> lang r1 \<and> s\<^sub>4 \<in> lang r2)"
         by (simp add: lang_deriv Deriv_def)
      ultimately have "((c # s1) @ s2) \<in> Times r1 r2 \<rightarrow> Seq (injval r1 c v1) v2" using left_nullable by (rule_tac Posix.intros)
      then show "(c # s) \<in> Times r1 r2 \<rightarrow> injval (Times r1 r2) c v" using left_nullable by simp
    next
      case right_nullable
      have "nullable r1" by fact
      then have "[] \<in> r1 \<rightarrow> (mkeps r1)" by (rule Posix_mkeps)
      moreover
      have "s \<in> deriv c r2 \<rightarrow> v1" by fact
      then have "(c # s) \<in> r2 \<rightarrow> (injval r2 c v1)" using IH2 by simp
      moreover
      have "s1 @ s2 \<notin> lang (Times (deriv c r1) r2)" by fact
      then have "\<not> (\<exists>s\<^sub>3 s\<^sub>4. s\<^sub>3 \<noteq> [] \<and> s\<^sub>3 @ s\<^sub>4 = c # s \<and> [] @ s\<^sub>3 \<in> lang r1 \<and> s\<^sub>4 \<in> lang r2)"
        using right_nullable
        apply (auto simp add: lang_deriv Deriv_def append_eq_Cons_conv)
        by (metis concI mem_Collect_eq)
      ultimately have "([] @ (c # s)) \<in> Times r1 r2 \<rightarrow> Seq (mkeps r1) (injval r2 c v1)"
      by(rule Posix.intros)
      then show "(c # s) \<in> Times r1 r2 \<rightarrow> injval (Times r1 r2) c v" using right_nullable by simp
    next
      case not_nullable
      have "s1 \<in> deriv c r1 \<rightarrow> v1" by fact
      then have "(c # s1) \<in> r1 \<rightarrow> injval r1 c v1" using IH1 by simp
      moreover
      have "\<not> (\<exists>s\<^sub>3 s\<^sub>4. s\<^sub>3 \<noteq> [] \<and> s\<^sub>3 @ s\<^sub>4 = s2 \<and> s1 @ s\<^sub>3 \<in> lang (deriv c r1) \<and> s\<^sub>4 \<in> lang r2)" by fact
      then have "\<not> (\<exists>s\<^sub>3 s\<^sub>4. s\<^sub>3 \<noteq> [] \<and> s\<^sub>3 @ s\<^sub>4 = s2 \<and> (c # s1) @ s\<^sub>3 \<in> lang r1 \<and> s\<^sub>4 \<in> lang r2)" by (simp add: lang_deriv Deriv_def)
      ultimately have "((c # s1) @ s2) \<in> Times r1 r2 \<rightarrow> Seq (injval r1 c v1) v2" using not_nullable
        by (rule_tac Posix.intros) (simp_all)
      then show "(c # s) \<in> Times r1 r2 \<rightarrow> injval (Times r1 r2) c v" using not_nullable by simp
    qed
next
  case (Star r)
  have IH: "\<And>s v. s \<in> deriv c r \<rightarrow> v \<Longrightarrow> (c # s) \<in> r \<rightarrow> injval r c v" by fact
  have "s \<in> deriv c (Star r) \<rightarrow> v" by fact
  then consider
      (cons) v1 vs s1 s2 where
        "v = Seq v1 (Stars vs)" "s = s1 @ s2"
        "s1 \<in> deriv c r \<rightarrow> v1" "s2 \<in> (Star r) \<rightarrow> (Stars vs)"
        "\<not> (\<exists>s\<^sub>3 s\<^sub>4. s\<^sub>3 \<noteq> [] \<and> s\<^sub>3 @ s\<^sub>4 = s2 \<and> s1 @ s\<^sub>3 \<in> lang (deriv c r) \<and> s\<^sub>4 \<in> lang (Star r))"
        apply(auto elim!: Posix_elims(1-5) simp add: lang_deriv Deriv_def intro: Posix.intros)
        apply(rotate_tac 3)
        apply(erule_tac Posix_elims(6))
        apply (simp add: Posix.intros(6))
        using Posix.intros(7) by blast
    then show "(c # s) \<in> Star r \<rightarrow> injval (Star r) c v"
    proof (cases)
      case cons
          have "s1 \<in> deriv c r \<rightarrow> v1" by fact
          then have "(c # s1) \<in> r \<rightarrow> injval r c v1" using IH by simp
        moreover
          have "s2 \<in> Star r \<rightarrow> Stars vs" by fact
        moreover
          have "(c # s1) \<in> r \<rightarrow> injval r c v1" by fact
          then have "flat (injval r c v1) = (c # s1)" by (rule Posix1)
          then have "flat (injval r c v1) \<noteq> []" by simp
        moreover
          have "\<not> (\<exists>s\<^sub>3 s\<^sub>4. s\<^sub>3 \<noteq> [] \<and> s\<^sub>3 @ s\<^sub>4 = s2 \<and> s1 @ s\<^sub>3 \<in> lang (deriv c r) \<and> s\<^sub>4 \<in> lang (Star r))" by fact
          then have "\<not> (\<exists>s\<^sub>3 s\<^sub>4. s\<^sub>3 \<noteq> [] \<and> s\<^sub>3 @ s\<^sub>4 = s2 \<and> (c # s1) @ s\<^sub>3 \<in> lang r \<and> s\<^sub>4 \<in> lang (Star r))"
            by (simp add: lang_deriv Deriv_def)
        ultimately
        have "((c # s1) @ s2) \<in> Star r \<rightarrow> Stars (injval r c v1 # vs)" by (rule Posix.intros)
        then show "(c # s) \<in> Star r \<rightarrow> injval (Star r) c v" using cons by(simp)
      qed
next
  case (NTimes r n)
  have IH: "\<And>s v. s \<in> deriv c r \<rightarrow> v \<Longrightarrow> (c # s) \<in> r \<rightarrow> injval r c v" by fact
  have "s \<in> deriv c (NTimes r n) \<rightarrow> v" by fact
  then consider
      (cons) v1 vs s1 s2 where
        "v = Seq v1 (Stars vs)" "s = s1 @ s2"
        "s1 \<in> deriv c r \<rightarrow> v1" "s2 \<in> (NTimes r (n - 1)) \<rightarrow> (Stars vs)" "0 < n"
        "\<not> (\<exists>s\<^sub>3 s\<^sub>4. s\<^sub>3 \<noteq> [] \<and> s\<^sub>3 @ s\<^sub>4 = s2 \<and> s1 @ s\<^sub>3 \<in> lang (deriv c r) \<and> s\<^sub>4 \<in> lang (NTimes r (n - 1)))"
    apply(auto elim: Posix_elims simp add: lang_derivs Deriv_def intro: Posix.intros split: if_splits)
    apply(erule Posix_elims)
    apply(simp)
    apply(subgoal_tac "\<exists>vss. v2 = Stars vss")
    apply(clarify)
    apply(drule_tac x="vss" in meta_spec)
    apply(drule_tac x="s1" in meta_spec)
    apply(drule_tac x="s2" in meta_spec)
     apply(simp add: lang_derivs Deriv_def)
    apply(erule Posix_elims)
     apply(auto)
      done
    then show "(c # s) \<in> (NTimes r n) \<rightarrow> injval (NTimes r n) c v"
    proof (cases)
      case cons
          have "s1 \<in> deriv c r \<rightarrow> v1" by fact
          then have "(c # s1) \<in> r \<rightarrow> injval r c v1" using IH by simp
        moreover
          have "s2 \<in> (NTimes r (n - 1)) \<rightarrow> Stars vs" by fact
        moreover
          have "(c # s1) \<in> r \<rightarrow> injval r c v1" by fact
          then have "flat (injval r c v1) = (c # s1)" by (rule Posix1)
          then have "flat (injval r c v1) \<noteq> []" by simp
        moreover
          have "\<not> (\<exists>s\<^sub>3 s\<^sub>4. s\<^sub>3 \<noteq> [] \<and> s\<^sub>3 @ s\<^sub>4 = s2 \<and> s1 @ s\<^sub>3 \<in> lang (deriv c r) \<and> s\<^sub>4 \<in> lang (NTimes r (n - 1)))" by fact
          then have "\<not> (\<exists>s\<^sub>3 s\<^sub>4. s\<^sub>3 \<noteq> [] \<and> s\<^sub>3 @ s\<^sub>4 = s2 \<and> (c # s1) @ s\<^sub>3 \<in> lang r \<and> s\<^sub>4 \<in> lang (NTimes r (n - 1)))"
            by (simp add: lang_deriv Deriv_def)
        ultimately
        have "((c # s1) @ s2) \<in> NTimes r n \<rightarrow> Stars (injval r c v1 # vs)"
          by (metis One_nat_def Posix_NTimes1 Suc_pred add.commute cons(5) plus_1_eq_Suc)
        then show "(c # s) \<in> NTimes r n \<rightarrow> injval (NTimes r n) c v" using cons by(simp)
      qed
next
  case (Upto r n)
  have IH: "\<And>s v. s \<in> deriv c r \<rightarrow> v \<Longrightarrow> (c # s) \<in> r \<rightarrow> injval r c v" by fact
  have "s \<in> deriv c (Upto r n) \<rightarrow> v" by fact
  then consider
      (cons) v1 vs s1 s2 where
        "v = Seq v1 (Stars vs)" "s = s1 @ s2"
        "s1 \<in> deriv c r \<rightarrow> v1" "s2 \<in> (Upto r (n - 1)) \<rightarrow> (Stars vs)"
        "\<not> (\<exists>s\<^sub>3 s\<^sub>4. s\<^sub>3 \<noteq> [] \<and> s\<^sub>3 @ s\<^sub>4 = s2 \<and> s1 @ s\<^sub>3 \<in> lang (deriv c r) \<and> s\<^sub>4 \<in> lang (Upto r (n - 1)))"
    apply(auto elim!: Posix_elims simp add: lang_deriv Deriv_def intro: Posix.intros)
    apply(case_tac n)
     apply(auto)
    using Posix_elims(1) apply blast
    apply(erule_tac Posix_elims)
    apply(auto)
    by (metis Posix1a Prf_elims(8) UN_E cons diff_Suc_1 lang.simps(8))
    then show "(c # s) \<in> Upto r n \<rightarrow> injval (Upto r n) c v"
    proof (cases)
      case cons
          have "s1 \<in> deriv c r \<rightarrow> v1" by fact
          then have "(c # s1) \<in> r \<rightarrow> injval r c v1" using IH by simp
        moreover
          have "s2 \<in> Upto r (n - 1) \<rightarrow> Stars vs" by fact
        moreover
          have "(c # s1) \<in> r \<rightarrow> injval r c v1" by fact
          then have "flat (injval r c v1) = (c # s1)" by (rule Posix1)
          then have "flat (injval r c v1) \<noteq> []" by simp
        moreover
          have "\<not> (\<exists>s\<^sub>3 s\<^sub>4. s\<^sub>3 \<noteq> [] \<and> s\<^sub>3 @ s\<^sub>4 = s2 \<and> s1 @ s\<^sub>3 \<in> lang (deriv c r) \<and> s\<^sub>4 \<in> lang (Upto r (n - 1)))" by fact
          then have "\<not> (\<exists>s\<^sub>3 s\<^sub>4. s\<^sub>3 \<noteq> [] \<and> s\<^sub>3 @ s\<^sub>4 = s2 \<and> (c # s1) @ s\<^sub>3 \<in> lang r \<and> s\<^sub>4 \<in> lang (Upto r (n - 1)))"
            by (simp add: lang_deriv Deriv_def)
        ultimately
        have "((c # s1) @ s2) \<in> Upto r n \<rightarrow> Stars (injval r c v1 # vs)"
          by (metis One_nat_def Posix_Upto1 Posix_elims(1) Suc_pred Upto.prems add.commute bot_nat_0.not_eq_extremum deriv.simps(8) plus_1_eq_Suc)
        then show "(c # s) \<in> Upto r n \<rightarrow> injval (Upto r n) c v" using cons by(simp)
      qed
next
  case (From r n)
  have IH: "\<And>s v. s \<in> deriv c r \<rightarrow> v \<Longrightarrow> (c # s) \<in> r \<rightarrow> injval r c v" by fact
  have "s \<in> deriv c (From r n) \<rightarrow> v" by fact
  then consider
      (cons) v1 vs s1 s2 where
        "v = Seq v1 (Stars vs)" "s = s1 @ s2"
        "s1 \<in> deriv c r \<rightarrow> v1" "s2 \<in> (From r (n - 1)) \<rightarrow> (Stars vs)" "0 < n"
        "\<not> (\<exists>s\<^sub>3 s\<^sub>4. s\<^sub>3 \<noteq> [] \<and> s\<^sub>3 @ s\<^sub>4 = s2 \<and> s1 @ s\<^sub>3 \<in> lang (deriv c r) \<and> s\<^sub>4 \<in> lang (From r (n - 1)))"
     | (null) v1 vs s1 s2 where
        "v = Seq v1 (Stars vs)" "s = s1 @ s2"  "s2 \<in> (Star r) \<rightarrow> (Stars vs)"
        "s1 \<in> deriv c r \<rightarrow> v1" "n = 0"
         "\<not> (\<exists>s\<^sub>3 s\<^sub>4. s\<^sub>3 \<noteq> [] \<and> s\<^sub>3 @ s\<^sub>4 = s2 \<and> s1 @ s\<^sub>3 \<in> lang (deriv c r) \<and> s\<^sub>4 \<in> lang (Star r))"
    apply(auto elim: Posix_elims simp add: lang_deriv Deriv_def intro: Posix.intros split: if_splits)
    apply(erule Posix_elims)
    apply(auto)
    apply(auto elim: Posix_elims simp add: lang_deriv Deriv_def intro: Posix.intros split: if_splits)
    apply(metis Posix1a Prf_elims(6))
    apply(erule Posix_elims)
    apply(auto)
    apply(erule Posix_elims(9))
    apply (metis (no_types, lifting) Nil_is_append_conv Posix_From2)
     apply (simp add: Posix_From1 that(1))
    by (simp add: Posix_From3 that(1))
    then show "(c # s) \<in> (From r n) \<rightarrow> injval (From r n) c v"
    proof (cases)
      case cons
          have "s1 \<in> deriv c r \<rightarrow> v1" by fact
          then have "(c # s1) \<in> r \<rightarrow> injval r c v1" using IH by simp
        moreover
          have "s2 \<in> (From r (n - 1)) \<rightarrow> Stars vs" by fact
        moreover
          have "(c # s1) \<in> r \<rightarrow> injval r c v1" by fact
          then have "flat (injval r c v1) = (c # s1)" by (rule Posix1)
          then have "flat (injval r c v1) \<noteq> []" by simp
        moreover
          have "\<not> (\<exists>s\<^sub>3 s\<^sub>4. s\<^sub>3 \<noteq> [] \<and> s\<^sub>3 @ s\<^sub>4 = s2 \<and> s1 @ s\<^sub>3 \<in> lang (deriv c r) \<and> s\<^sub>4 \<in> lang (From r (n - 1)))" by fact
          then have "\<not> (\<exists>s\<^sub>3 s\<^sub>4. s\<^sub>3 \<noteq> [] \<and> s\<^sub>3 @ s\<^sub>4 = s2 \<and> (c # s1) @ s\<^sub>3 \<in> lang r \<and> s\<^sub>4 \<in> lang (From r (n - 1)))"
            by (simp add: lang_deriv Deriv_def)
        ultimately
        have "((c # s1) @ s2) \<in> From r n \<rightarrow> Stars (injval r c v1 # vs)"
          by (meson Posix_From1 cons(5))
        then show "(c # s) \<in> From r n \<rightarrow> injval (From r n) c v" using cons by(simp)
      next
       case null
          have "s1 \<in> deriv c r \<rightarrow> v1" by fact
          then have "(c # s1) \<in> r \<rightarrow> injval r c v1" using IH by simp
          moreover
            have "s2 \<in> Star r \<rightarrow> Stars vs" by fact
          moreover
          have "(c # s1) \<in> r \<rightarrow> injval r c v1" by fact
          then have "flat (injval r c v1) = (c # s1)" by (rule Posix1)
          then have "flat (injval r c v1) \<noteq> []" by simp
          moreover
          have "\<not> (\<exists>s\<^sub>3 s\<^sub>4. s\<^sub>3 \<noteq> [] \<and> s\<^sub>3 @ s\<^sub>4 = s2 \<and> s1 @ s\<^sub>3 \<in> lang (deriv c r) \<and> s\<^sub>4 \<in> lang (Star r))" by fact
          then have "\<not> (\<exists>s\<^sub>3 s\<^sub>4. s\<^sub>3 \<noteq> [] \<and> s\<^sub>3 @ s\<^sub>4 = s2 \<and> (c # s1) @ s\<^sub>3 \<in> lang r \<and> s\<^sub>4 \<in> lang (Star r))"
            by (simp add: lang_deriv Deriv_def)
        ultimately
        have "((c # s1) @ s2) \<in> From r 0 \<rightarrow> Stars (injval r c v1 # vs)"
          by (metis Posix_From3)
        then show "(c # s) \<in> From r n \<rightarrow> injval (From r n) c v" using null by (simp)
      qed
next
  case (Rec l r)
  then show "(c # s) \<in> Rec l r \<rightarrow> injval (Rec l r) c v"
    by (simp add: Posix_Rec)
next
  case (Charset cs)
  consider (eq) "c \<in> cs" | (ineq) "c \<notin> cs" by blast
  then show "(c # s) \<in> (Charset cs) \<rightarrow> (injval (Charset cs) c v)"
  proof (cases)
    case eq
    have "s \<in> deriv c (Charset cs) \<rightarrow> v" by fact
    then have "s \<in> One \<rightarrow> v" using eq by simp
    then have eqs: "s = [] \<and> v = Void" by cases simp
    show "(c # s) \<in> Charset cs \<rightarrow> injval (Charset cs) c v" using eq eqs
    by (auto intro: Posix.intros)
  next
    case ineq
    have "s \<in> deriv c (Charset cs) \<rightarrow> v" by fact
    then have "s \<in> Zero \<rightarrow> v" using ineq by simp
    then have "False" by cases
    then show "(c # s) \<in> Charset cs \<rightarrow> injval (Charset cs) c v" by simp
  qed
qed

section \<open>The Lexer by Sulzmann and Lu\<close>

fun
  lexer :: "'a rexp \<Rightarrow> 'a list \<Rightarrow> ('a val) option"
where
  "lexer r [] = (if nullable r then Some(mkeps r) else None)"
| "lexer r (c#s) = (case (lexer (deriv c r) s) of
                    None \<Rightarrow> None
                  | Some(v) \<Rightarrow> Some(injval r c v))"

lemma lexer_correct_None:
  shows "s \<notin> lang r \<longleftrightarrow> lexer r s = None"
apply(induct s arbitrary: r)
apply(simp add: nullable_iff)
apply(drule_tac x="deriv a r" in meta_spec)
apply(auto simp add: lang_deriv Deriv_def)
done

lemma lexer_correct_Some:
  shows "s \<in> lang r \<longleftrightarrow> (\<exists>v. lexer r s = Some(v) \<and> s \<in> r \<rightarrow> v)"
apply(induct s arbitrary: r)
apply(auto simp add: Posix_mkeps nullable_iff)[1]
apply(drule_tac x="deriv a r" in meta_spec)
apply(simp add: lang_deriv Deriv_def)
apply(rule iffI)
apply(auto intro: Posix_injval simp add: Posix1(1))
done

lemma lexer_correctness:
  shows "(lexer r s = Some v) \<longleftrightarrow> s \<in> r \<rightarrow> v"
  and   "(lexer r s = None) \<longleftrightarrow> \<not>(\<exists>v. s \<in> r \<rightarrow> v)"
apply(auto)
using lexer_correct_None lexer_correct_Some apply fastforce
using Posix1(1) Posix_determ lexer_correct_Some apply blast
using Posix1(1) lexer_correct_None apply blast
using lexer_correct_None lexer_correct_Some by blast

end