section {* VDM-SL in UTP *}

theory VDM
imports PFOL
  utp_theories_deep
begin

subsection {* Core operator definitions *}

typedef ('a, '\<alpha>) vexpr = "UNIV :: ('\<alpha> \<Rightarrow> 'a option) set" ..

type_synonym '\<alpha> vpred = "(bool, '\<alpha>) vexpr"

type_synonym 'a vtype = "'a set"

setup_lifting type_definition_vexpr

lift_definition vdefined :: "('a, '\<alpha>) vexpr \<Rightarrow> (bool, '\<alpha>) vexpr" ("\<D>\<^sub>v'(_')") is
"\<lambda> e b. Some (b \<in> dom e)" .

lift_definition visdefined :: "('a, '\<alpha>) vexpr \<Rightarrow> (bool, '\<alpha>) vexpr" ("!\<D>\<^sub>v'(_')") is
"\<lambda> e b. if b \<in> dom e then Some True else None" .

lift_definition vexpr :: "('a, '\<alpha>) vexpr \<Rightarrow> ('a, '\<alpha>) uexpr" ("\<lfloor>_\<rfloor>\<^sub>v") is
"\<lambda> e b. the(e b)" .

lift_definition vlift :: "('a, '\<alpha>) uexpr \<Rightarrow> ('a, '\<alpha>) vexpr" ("\<lceil>_\<rceil>\<^sub>v") is
"\<lambda> e b. Some (e b)" .

consts
  veuvar :: "'v \<Rightarrow> 'p" ("&\<^sub>v_" [999] 999)
  viuvar :: "'v \<Rightarrow> 'p" ("$\<^sub>v_" [999] 999)
  vouvar :: "'v \<Rightarrow> 'p" ("$\<^sub>v_\<acute>" [999] 999)

lift_definition vvar :: "('a \<Longrightarrow> '\<alpha>) \<Rightarrow> ('a, '\<alpha>) vexpr"
  is "\<lambda> x b. Some (get\<^bsub>x\<^esub> b)" .

definition vvar_dvar :: "'a::continuum dvar \<Rightarrow> ('a, '\<alpha>::vst) vexpr"
where "vvar_dvar x = vvar (x\<up>)"

declare vvar_dvar_def [upred_defs]

definition vivar :: "('a \<Longrightarrow> '\<alpha>) \<Rightarrow> ('a, '\<alpha> \<times> '\<beta>) vexpr"  where
"vivar x = vvar (in_var x)"

definition vivar_dvar :: "'a::continuum dvar \<Rightarrow> ('a, '\<alpha>::vst \<times> '\<beta>) vexpr"
where "vivar_dvar x = vivar (x\<up>)"

declare vivar_def [upred_defs]
declare vivar_dvar_def [upred_defs]

definition vovar :: "('a \<Longrightarrow> '\<beta>) \<Rightarrow> ('a, '\<alpha> \<times> '\<beta>) vexpr"  where
"vovar x = vvar (out_var x)"

definition vovar_dvar :: "'a::continuum dvar \<Rightarrow> ('a, '\<alpha> \<times> '\<beta>::vst) vexpr"
where "vovar_dvar x = vovar (x\<up>)"

declare vovar_def [upred_defs]
declare vovar_dvar_def [upred_defs]

adhoc_overloading
  veuvar vvar and
  veuvar vvar_dvar and
  viuvar vivar and
  viuvar vivar_dvar and
  vouvar vovar and
  vouvar vovar_dvar

lift_definition vsubst :: "'\<alpha> usubst \<Rightarrow> ('a, '\<alpha>) vexpr \<Rightarrow> ('a, '\<alpha>) vexpr"
is "\<lambda> \<sigma> e b. e (\<sigma> b)" .

adhoc_overloading
  usubst vsubst

lift_definition vsubst_lookup :: "'\<alpha> usubst \<Rightarrow> ('a \<Longrightarrow> '\<alpha>) \<Rightarrow> ('a, '\<alpha>) vexpr" ("\<langle>_\<rangle>\<^sub>v")
is "\<lambda> \<sigma> x b. Some (get\<^bsub>x\<^esub> (\<sigma> b))" .

lift_definition unrest_vexpr :: "('a \<Longrightarrow> '\<alpha>) \<Rightarrow> ('b, '\<alpha>) vexpr \<Rightarrow> bool"
is "\<lambda> x e. (\<forall>b v. e(put\<^bsub>x\<^esub> b v) = e b)" .

adhoc_overloading
  unrest unrest_vexpr

lift_definition vlit :: "'a \<Rightarrow> ('a, '\<alpha>) vexpr" ("\<guillemotleft>_\<guillemotright>\<^sub>v") is "\<lambda> v b. Some v"  .

lift_definition vundef :: "('a, '\<alpha>) vexpr" ("\<bottom>\<^sub>v") is "\<lambda> b. None" .

lift_definition vuop :: "('a \<rightharpoonup> 'b) \<Rightarrow> ('a, '\<alpha>) vexpr \<Rightarrow> ('b, '\<alpha>) vexpr"
is "\<lambda> f v b. Option.bind (v b) f" .

lift_definition vbop :: "('a \<times> 'b \<rightharpoonup> 'c) \<Rightarrow> ('a, '\<alpha>) vexpr \<Rightarrow> ('b, '\<alpha>) vexpr \<Rightarrow> ('c, '\<alpha>) vexpr"
is "\<lambda> (f :: 'a \<times> 'b \<rightharpoonup> 'c) u v b. (do { x <- u b; y <- v b; f (x, y) })" .

lift_definition vtop :: "('a \<times> 'b \<times> 'c \<rightharpoonup> 'd) \<Rightarrow> ('a, '\<alpha>) vexpr \<Rightarrow> ('b, '\<alpha>) vexpr \<Rightarrow> ('c, '\<alpha>) vexpr \<Rightarrow> ('d, '\<alpha>) vexpr"
is "\<lambda> (f :: 'a \<times> 'b \<times> 'c \<rightharpoonup> 'd) u v w b. (do { x <- u b; y <- v b; z <- w b; f (x, y, z) })" .

lift_definition vconj :: "(bool, '\<alpha>) vexpr \<Rightarrow> (bool, '\<alpha>) vexpr \<Rightarrow> (bool, '\<alpha>) vexpr"
is "\<lambda> x y b. (x b \<and>\<^sub>k y b)" .

lift_definition vdisj :: "(bool, '\<alpha>) vexpr \<Rightarrow> (bool, '\<alpha>) vexpr \<Rightarrow> (bool, '\<alpha>) vexpr"
is "\<lambda> x y b. (x b \<or>\<^sub>k y b)" .

lift_definition vimpl :: "(bool, '\<alpha>) vexpr \<Rightarrow> (bool, '\<alpha>) vexpr \<Rightarrow> (bool, '\<alpha>) vexpr"
is "\<lambda> x y b. (x b \<Rightarrow>\<^sub>k y b)" .

lift_definition vnot :: "(bool, '\<alpha>) vexpr \<Rightarrow> (bool, '\<alpha>) vexpr"
is "\<lambda> x b. \<not>\<^sub>k x b" .

lift_definition vtaut :: "(bool, '\<alpha>) vexpr \<Rightarrow> bool" ("[_]\<^sub>V")
is "\<lambda> p. \<forall> b. [p b]\<^sub>3" .

declare [[coercion vtaut]]

definition upfun :: "'a::type set \<Rightarrow> ('a \<Rightarrow> 'b::type) \<Rightarrow> ('a \<rightharpoonup> 'b)" where
[upred_defs]: "upfun A f = ((\<lambda> v. Some (f v)) |` A)"

abbreviation "upfun' \<equiv> upfun UNIV"

abbreviation (input) "vuop' f \<equiv> vuop (upfun' f)"

definition bpfun :: "('a::type * 'b::type) set \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> 'c::type) \<Rightarrow> ('a * 'b \<rightharpoonup> 'c)" where
[upred_defs]: "bpfun AB f = (\<lambda> (v1, v2). Some (f v1 v2)) |` AB"

abbreviation "bpfun' \<equiv> bpfun UNIV"

abbreviation (input) "vbop' f \<equiv> vbop (bpfun' f)"

definition tpfun :: "('a::type * 'b::type * 'c::type) set \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> 'c \<Rightarrow> 'd::type) \<Rightarrow> ('a * 'b * 'c \<rightharpoonup> 'd)" where
[upred_defs]: "tpfun ABC f = (\<lambda> (v1, v2, v3). Some (f v1 v2 v3)) |` ABC"

abbreviation "tpfun' \<equiv> tpfun UNIV"

abbreviation (input) "vtop' f \<equiv> vtop (tpfun' f)"

abbreviation "true\<^sub>v  \<equiv> \<guillemotleft>True\<guillemotright>\<^sub>v"
abbreviation "false\<^sub>v \<equiv> \<guillemotleft>False\<guillemotright>\<^sub>v"

lift_definition vexists :: "'a vtype \<Rightarrow> ('a \<Rightarrow> (bool, '\<alpha>) vexpr) \<Rightarrow> (bool, '\<alpha>) vexpr"
is "\<lambda> A P b. (\<exists>\<^sub>k x. P x b)" .

lift_definition vforall :: "'a vtype \<Rightarrow> ('a \<Rightarrow> (bool, '\<alpha>) vexpr) \<Rightarrow> (bool, '\<alpha>) vexpr"
is "\<lambda> A P b. (\<forall>\<^sub>k x. P x b)" .

instantiation vexpr :: (zero, type) zero
begin
  definition zero_vexpr :: "('a, 'b) vexpr" where [upred_defs]: "zero_vexpr = vlit 0"
  instance ..
end

instantiation vexpr :: (one, type) one
begin
  definition one_vexpr :: "('a, 'b) vexpr" where [upred_defs]: "one_vexpr = vlit 1"
  instance ..
end

instantiation vexpr :: (plus, type) plus
begin

  definition plus_vexpr :: "('a, 'b) vexpr \<Rightarrow> ('a, 'b) vexpr \<Rightarrow> ('a, 'b) vexpr"
  where [upred_defs]: "plus_vexpr x y = vbop (bpfun' (op +)) x y"

instance ..
end

instantiation vexpr :: (minus, type) minus
begin

  definition minus_vexpr :: "('a, 'b) vexpr \<Rightarrow> ('a, 'b) vexpr \<Rightarrow> ('a, 'b) vexpr"
  where [upred_defs]: "minus_vexpr x y = vbop (bpfun' (op -)) x y"

instance ..
end

instantiation vexpr :: (times, type) times
begin

  definition times_vexpr :: "('a, 'b) vexpr \<Rightarrow> ('a, 'b) vexpr \<Rightarrow> ('a, 'b) vexpr"
  where [upred_defs]: "times_vexpr x y = vbop (bpfun' (op *)) x y"

instance ..
end

text {* We augment inverse and divide so that it is undefined when the divisor is 0 *}

instantiation vexpr :: ("{zero,inverse}", type) inverse
begin
  definition inverse_vexpr :: "('a, 'b) vexpr \<Rightarrow> ('a, 'b) vexpr"
  where [upred_defs]: "inverse_vexpr n = vuop (upfun {x. x \<noteq> 0} inverse) n"

  definition divide_vexpr :: "('a, 'b) vexpr \<Rightarrow> ('a, 'b) vexpr \<Rightarrow> ('a, 'b) vexpr"
  where [upred_defs]: "divide_vexpr m n = vbop (bpfun {(x,y). y \<noteq> 0} divide) m n"

instance ..
end

instance vexpr :: (semigroup_add, type) semigroup_add
  apply (intro_classes)
  apply (auto simp add: plus_vexpr_def times_vexpr_def, transfer, simp add: fun_eq_iff add.commute semiring_class.distrib_right semiring_class.distrib_left)+
  apply (rename_tac a b c x)
  apply (case_tac "a x")
  apply (simp_all)
  apply (case_tac "b x")
  apply (simp_all)
  apply (case_tac "c x")
  apply (simp_all add: bpfun_def add.assoc)
done

instance vexpr :: (numeral, type) numeral
  by (intro_classes)

definition vmap_apply :: "('a \<rightharpoonup> 'b) \<times> 'a \<Rightarrow> 'b option" where
"vmap_apply = (\<lambda> (f, x). f(x))"

definition vmap_update :: "('a \<rightharpoonup> 'b) \<times> 'a \<times> 'b \<rightharpoonup> ('a \<rightharpoonup> 'b)"
where "vmap_update = (\<lambda> (f, k, v). Some (fun_upd f k (Some v)))"

definition vseq_apply :: "'a list \<times> nat \<rightharpoonup> 'a" where
"vseq_apply = bpfun {(xs, i). length xs > i} nth"

definition vseq_update :: "'a list \<times> nat \<times> 'a \<rightharpoonup> 'a list" where
"vseq_update = tpfun {(xs, i, k). length xs > i} list_update"

consts
  vapply :: "'a \<times> 'b \<rightharpoonup> 'c"
  vupdate :: "'m \<times> 'a \<times> 'b \<rightharpoonup> 'm"

subsection {* VDM expression parser *}

adhoc_overloading
  vapply vmap_apply and
  vapply vseq_apply and
  vupdate vmap_update and
  vupdate vseq_update

nonterminal vtuple_args and vmaplet and vmaplets

text {* Tuples might need to be terminated with unit -- not totally sure at the moment *}

syntax
  "_vshEx"         :: "id \<Rightarrow> 'a vtype \<Rightarrow> logic \<Rightarrow> logic"   ("\<exists>\<^sub>v _ : _ \<bullet> _" [0, 0, 10] 10)
  "_vshAll"        :: "id \<Rightarrow> 'a vtype \<Rightarrow> logic \<Rightarrow> logic"   ("\<forall>\<^sub>v _ : _ \<bullet> _" [0, 0, 10] 10)
  "_vshbEx"        :: "id \<Rightarrow> ('a set, '\<alpha>) vexpr \<Rightarrow> logic \<Rightarrow> logic"   ("\<exists>\<^sub>v _ \<in> _ \<bullet> _" [0, 0, 10] 10)
  "_vshbAll"       :: "id \<Rightarrow> ('a set, '\<alpha>) vexpr \<Rightarrow> logic \<Rightarrow> logic"   ("\<forall>\<^sub>v _ \<in> _ \<bullet> _" [0, 0, 10] 10)
  "_vlength"       :: "('a list, '\<alpha>) vexpr \<Rightarrow> (nat, '\<alpha>) vexpr" ("len\<^sub>v'(_')")
  "_vnil"          :: "('a list, '\<alpha>) vexpr" ("[]\<^sub>v")
  "_vlist"         :: "args => ('a list, '\<alpha>) vexpr" ("[(_)]\<^sub>v")
  "_vhd"           :: "('a list, '\<alpha>) vexpr \<Rightarrow> ('a, '\<alpha>) vexpr" ("hd\<^sub>v'(_')")
  "_vtl"           :: "('a list, '\<alpha>) vexpr \<Rightarrow> ('a, '\<alpha>) vexpr" ("tl\<^sub>v'(_')")
  "_veq"           :: "('a, '\<alpha>) vexpr \<Rightarrow> ('a, '\<alpha>) vexpr \<Rightarrow> (bool, '\<alpha>) vexpr" (infix "=\<^sub>v" 50)
  "_vneq"          :: "('a, '\<alpha>) vexpr \<Rightarrow> ('a, '\<alpha>) vexpr \<Rightarrow> (bool, '\<alpha>) vexpr" (infix "<>\<^sub>v" 50)
  "_vless"         :: "('a, '\<alpha>) vexpr \<Rightarrow> ('a, '\<alpha>) vexpr \<Rightarrow> (bool, '\<alpha>) vexpr" (infix "<\<^sub>v" 50)
  "_vleq"          :: "('a, '\<alpha>) vexpr \<Rightarrow> ('a, '\<alpha>) vexpr \<Rightarrow> (bool, '\<alpha>) vexpr" (infix "\<le>\<^sub>v" 50)
  "_vgreat"        :: "('a, '\<alpha>) vexpr \<Rightarrow> ('a, '\<alpha>) vexpr \<Rightarrow> (bool, '\<alpha>) vexpr" (infix ">\<^sub>v" 50)
  "_vgeq"          :: "('a, '\<alpha>) vexpr \<Rightarrow> ('a, '\<alpha>) vexpr \<Rightarrow> (bool, '\<alpha>) vexpr" (infix "\<ge>\<^sub>v" 50)
  "_vconj"         :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixr "\<and>\<^sub>v" 35)
  "_vdisj"         :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixr "\<or>\<^sub>v" 30)
  "_vimpl"         :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixr "\<Rightarrow>\<^sub>v" 25)
  "_vnot"          :: "'a \<Rightarrow> 'a" ("\<not>\<^sub>v _" [40] 40)
  "_vempset"       :: "('a set, '\<alpha>) vexpr" ("{}\<^sub>v")
  "_vset"          :: "args => ('a set, '\<alpha>) vexpr" ("{(_)}\<^sub>v")
  "_vunion"        :: "('a set, '\<alpha>) vexpr \<Rightarrow> ('a set, '\<alpha>) vexpr \<Rightarrow> ('a set, '\<alpha>) vexpr" (infixl "\<union>\<^sub>v" 65)
  "_vinter"        :: "('a set, '\<alpha>) vexpr \<Rightarrow> ('a set, '\<alpha>) vexpr \<Rightarrow> ('a set, '\<alpha>) vexpr" (infixl "\<inter>\<^sub>v" 70)
  "_vUnion"        :: "('a set set, '\<alpha>) vexpr \<Rightarrow> ('a set, '\<alpha>) vexpr" ("\<Union>\<^sub>v")
  "_vInter"        :: "('a set set, '\<alpha>) vexpr \<Rightarrow> ('a set, '\<alpha>) vexpr" ("\<Inter>\<^sub>v")
  "_vmem"          :: "('a, '\<alpha>) vexpr \<Rightarrow> ('a set, '\<alpha>) vexpr \<Rightarrow> (bool, '\<alpha>) vexpr" (infix "\<in>\<^sub>v" 50)
  "_vnmem"         :: "('a, '\<alpha>) vexpr \<Rightarrow> ('a set, '\<alpha>) vexpr \<Rightarrow> (bool, '\<alpha>) vexpr" (infix "\<notin>\<^sub>v" 50)
  "_vsubset"       :: "('a set, '\<alpha>) vexpr \<Rightarrow> ('a set, '\<alpha>) vexpr \<Rightarrow> (bool, '\<alpha>) vexpr" (infix "\<subset>\<^sub>v" 50)
  "_vsubseteq"     :: "('a set, '\<alpha>) vexpr \<Rightarrow> ('a set, '\<alpha>) vexpr \<Rightarrow> (bool, '\<alpha>) vexpr" (infix "\<subseteq>\<^sub>v" 50)
  "_vtuple"        :: "('a, '\<alpha>) vexpr \<Rightarrow> vtuple_args \<Rightarrow> ('a * 'b, '\<alpha>) vexpr" ("(1'(_,/ _')\<^sub>v)")
  "_vtuple_arg"    :: "('a, '\<alpha>) vexpr \<Rightarrow> vtuple_args" ("_")
  "_vtuple_args"   :: "('a, '\<alpha>) vexpr => vtuple_args \<Rightarrow> vtuple_args"     ("_,/ _")
  "_vapply"        :: "('a, '\<alpha>) vexpr \<Rightarrow> ('b, '\<alpha>) vexpr \<Rightarrow> ('c, '\<alpha>) vexpr" ("_'(_')\<^sub>v" [950,0] 950)
  "_vdom"          :: "('a \<rightharpoonup> 'b, '\<alpha>) vexpr \<Rightarrow> ('a set, '\<alpha>) vexpr" ("dom\<^sub>v'(_')")
  "_vrng"          :: "('a \<rightharpoonup> 'b, '\<alpha>) vexpr \<Rightarrow> ('b set, '\<alpha>) vexpr" ("rng\<^sub>v'(_')")
  "_vcard"         :: "('a set, '\<alpha>) vexpr \<Rightarrow> (nat, '\<alpha>) vexpr" ("card\<^sub>v'(_')")
  "_vmapempty"     :: "('a \<rightharpoonup> 'b, '\<alpha>) vexpr" ("\<lbrace>\<mapsto>\<rbrace>\<^sub>v")
  "_vmaplet"       :: "('a, '\<alpha>) vexpr \<Rightarrow> ('b, '\<alpha>) vexpr \<Rightarrow> vmaplet" ("_ /\<mapsto>/ _")
  "_vmaplets_unit" :: "vmaplet \<Rightarrow> vmaplets" ("_")
  "_vmaplets"      :: "vmaplet \<Rightarrow> vmaplets \<Rightarrow> vmaplets" ("_,/ _")
  "_vmap_enum"     :: "vmaplets \<Rightarrow> ('a \<rightharpoonup> 'b, '\<alpha>) vexpr" ("\<lbrace>_\<rbrace>\<^sub>v")
  "_vdot" :: "('a, '\<alpha>) vexpr \<Rightarrow> id \<Rightarrow> ('b, '\<alpha>) vexpr" ("_.\<^sub>v_" [998,998] 998)

definition [upred_defs]: "hd_pre = {x. length x > 0}"

abbreviation "map_upd f k v \<equiv> fun_upd f k (Some v)"

definition vneq_def [upred_defs]:
  "vneq x y = vbop (bpfun' op \<noteq>) x y"

translations
  "\<forall>\<^sub>v x : A \<bullet> P" == "CONST vforall A (\<lambda> x. P)"
  "\<exists>\<^sub>v x : A \<bullet> P" == "CONST vexists A (\<lambda> x. P)"
  "[]\<^sub>v" == "\<guillemotleft>[]\<guillemotright>\<^sub>v"
  "[x, xs]\<^sub>v" == "CONST vbop (CONST bpfun' op #) x [xs]\<^sub>v"
  "[x]\<^sub>v"     == "CONST vbop (CONST bpfun' op #) x \<guillemotleft>[]\<guillemotright>\<^sub>v"
  "len\<^sub>v(xs)" == "CONST vuop (CONST upfun' CONST length) xs"
  "hd\<^sub>v(xs)"  == "CONST vuop (CONST upfun CONST hd_pre CONST hd) xs"
  "tl\<^sub>v(xs)"  == "CONST vuop (CONST upfun CONST hd_pre CONST tl) xs"
  "x =\<^sub>v y"   == "CONST vbop (CONST bpfun' op =) x y"
  "x <>\<^sub>v y"   == "CONST vneq x y"
  "x <\<^sub>v y"   == "CONST vbop (CONST bpfun' (op <)) x y"
  "x \<le>\<^sub>v y"   == "CONST vbop (CONST bpfun' (op \<le>)) x y"
  "x >\<^sub>v y"   == "y <\<^sub>v x"
  "x \<ge>\<^sub>v y"   == "y \<le>\<^sub>v x"
  "p \<and>\<^sub>v q" == "CONST vconj p q"
  "p \<or>\<^sub>v q" == "CONST vdisj p q"
  "p \<Rightarrow>\<^sub>v q" == "CONST vimpl p q"
  "\<not>\<^sub>v p"   == "CONST vnot p"
  "{}\<^sub>v"      == "\<guillemotleft>{}\<guillemotright>\<^sub>v"
  "{x, xs}\<^sub>v" == "CONST vbop (CONST bpfun' CONST insert) x {xs}\<^sub>v"
  "{x}\<^sub>v"     == "CONST vbop (CONST bpfun' CONST insert) x \<guillemotleft>{}\<guillemotright>\<^sub>v"
  "A \<union>\<^sub>v B"   == "CONST vbop (CONST bpfun' CONST Set.union) A B"
  "A \<inter>\<^sub>v B"   == "CONST vbop (CONST bpfun' CONST Set.inter) A B"
  "\<Union>\<^sub>v A"     == "CONST vuop (CONST upfun' CONST Union) A"
  "\<Inter>\<^sub>v A"     == "CONST vuop (CONST upfun' CONST Inter) A"
  "x \<in>\<^sub>v A" == "CONST vbop (CONST bpfun' (op \<in>)) x A"
  "x \<notin>\<^sub>v A" => "\<not>\<^sub>v (x \<in>\<^sub>v A)"
  "A \<subset>\<^sub>v B" == "CONST vbop (CONST bpfun' (op \<subset>)) A B"
  "A \<subseteq>\<^sub>v B" == "CONST vbop (CONST bpfun' (op \<subseteq>)) A B"
  "(x, y)\<^sub>v" == "CONST vbop (CONST bpfun' CONST Pair) x y"
  "_vtuple x (_vtuple_args y z)" == "_vtuple x (_vtuple_arg (_vtuple y z))"
  "f(x)\<^sub>v"  == "CONST vbop CONST vapply f x"
  "dom\<^sub>v(f)" == "CONST vuop (CONST upfun' CONST dom) f"
  "rng\<^sub>v(f)" == "CONST vuop (CONST upfun' CONST ran) f"
  "card\<^sub>v(f)" == "CONST vuop (CONST upfun' CONST card) f"
  "\<lbrace>\<mapsto>\<rbrace>\<^sub>v"   == "\<guillemotleft>Map.empty\<guillemotright>\<^sub>v"
  (* For some reason I can't get maps to show correctly -- seems something is wrong with these rules *)
  "_vmap_enum (_vmaplets_unit (_vmaplet k v))" == "CONST vbop (CONST bpfun' (CONST map_upd Map.empty)) k v"
  "_vmap_enum (_vmaplets (_vmaplet k v) m)" == "CONST vtop (CONST tpfun' CONST map_upd) (_vmap_enum m) k v"
  "_vdot e k" => "CONST vuop (CONST upfun' k) e"
  "\<lbrace>\<mapsto>\<rbrace>\<^sub>v"     <=   "CONST vlit CONST Map.empty"

abbreviation "vforallSet A P \<equiv> vforall UNIV (\<lambda> x. \<guillemotleft>x\<guillemotright>\<^sub>v \<in>\<^sub>v A \<Rightarrow>\<^sub>v P x)"
abbreviation "vexistsSet A P \<equiv> vexists UNIV (\<lambda> x. \<guillemotleft>x\<guillemotright>\<^sub>v \<in>\<^sub>v A \<Rightarrow>\<^sub>v P x)"

translations
  "\<forall>\<^sub>v x \<in> A \<bullet> P" == "CONST vforallSet A (\<lambda> x. P)"
  "\<exists>\<^sub>v x \<in> A \<bullet> P" == "CONST vexistsSet A (\<lambda> x. P)"

subsection {* Proof Support *}

text {* t may be better to define a designated transfer tactic for VDM. *}

theorem vexpr_eq_iff [uexpr_transfer_laws]:
"e\<^sub>1 = e\<^sub>2 \<longleftrightarrow> Rep_vexpr e\<^sub>1 = Rep_vexpr e\<^sub>2"
apply (transfer)
apply (rule refl)
done

update_uexpr_rep_eq_thms -- {* Re-reads @[thm [source] uexpr_rep_eq_thms}. *}

declare Abs_vexpr_inverse [uexpr_transfer_extra]
declare Rep_vexpr_inverse [uexpr_transfer_extra]

lemmas vexpr_rep_eq_thms [uexpr_transfer_extra] =
  VDM.vundef.rep_eq
  VDM.vlit.rep_eq
  (* VDM.vexpr.rep_eq *)
  VDM.vlift.rep_eq
  VDM.vvar.rep_eq
  VDM.vnot.rep_eq
  VDM.vtaut.rep_eq
  VDM.vsubst.rep_eq
  VDM.vsubst_lookup.rep_eq
  VDM.vuop.rep_eq
  VDM.vdefined.rep_eq
  VDM.vexists.rep_eq
  VDM.vforall.rep_eq
  VDM.vconj.rep_eq
  VDM.vdisj.rep_eq
  VDM.vimpl.rep_eq
  VDM.visdefined.rep_eq
  VDM.unrest_vexpr.rep_eq
  VDM.vbop.rep_eq
  VDM.vtop.rep_eq

subsection {* VDM Unrestriction Laws *}

text {* Unrestriction is effectively semantic freshness; an expression is unrestricted by a
        variable if the value of that variable has no effect on the value of the expresssion. *}

lemma vexpr_unrest [unrest]:
  "x \<sharp> v \<Longrightarrow> x \<sharp> \<lfloor>v\<rfloor>\<^sub>v"
  by (transfer; clarsimp)

lemma vvar_unrest [unrest]:
  "x \<bowtie> y \<Longrightarrow> y \<sharp> &\<^sub>vx"
  by (transfer; clarsimp)

lemma vlit_unrest [unrest]:
  "x \<sharp> \<guillemotleft>v\<guillemotright>\<^sub>v"
  by (transfer; clarsimp)

lemma vuop_unrest [unrest]:
  "x \<sharp> v \<Longrightarrow> x \<sharp> vuop f v"
  by (transfer; clarsimp)

lemma vbop_unrest [unrest]:
  "\<lbrakk> x \<sharp> u; x \<sharp> v \<rbrakk> \<Longrightarrow> x \<sharp> vbop f u v"
  by (transfer; clarsimp)

lemma vtop_unrest [unrest]:
  "\<lbrakk> x \<sharp> u; x \<sharp> v; x \<sharp> w \<rbrakk> \<Longrightarrow> x \<sharp> vtop f u v w"
  by (transfer; clarsimp)

subsection {* VDM Substitution *}

lemma vsubst_lookup_upd [usubst]:
  assumes "vwb_lens x" "\<D>\<^sub>v(v) = true\<^sub>v"
  shows "\<langle>\<sigma>(x \<mapsto>\<^sub>s \<lfloor>v\<rfloor>\<^sub>v)\<rangle>\<^sub>v x = v"
  using assms
  apply (simp add: subst_upd_uvar_def, transfer)
  apply (rule ext, auto simp add: dom_def fun_eq_iff)
done

lemma vsubst_lookup_upd_indep [usubst]:
  assumes "vwb_lens x" "x \<bowtie> y"
  shows "\<langle>\<sigma>(y \<mapsto>\<^sub>s v)\<rangle>\<^sub>v x = \<langle>\<sigma>\<rangle>\<^sub>v x"
  using assms
  by (simp add: subst_upd_uvar_def, transfer, simp)

lemma vvar_subst [usubst]: "\<sigma> \<dagger> &\<^sub>vx = \<langle>\<sigma>\<rangle>\<^sub>v x"
  by (transfer; clarsimp)

lemma vsubst_vnot [usubst]:
  "\<sigma> \<dagger> (\<not>\<^sub>v p ) = (\<not>\<^sub>v (\<sigma> \<dagger> p))"
  by (transfer; clarsimp)

lemma vsubst_vconj [usubst]:
  "\<sigma> \<dagger> (p \<and>\<^sub>v q) = (\<sigma> \<dagger> p \<and>\<^sub>v \<sigma> \<dagger> q)"
  by (transfer; clarsimp)

lemma vsubst_vdisj [usubst]:
  "\<sigma> \<dagger> (p \<or>\<^sub>v q) = (\<sigma> \<dagger> p \<or>\<^sub>v \<sigma> \<dagger> q)"
  by (transfer; clarsimp)

lemma vsubst_vlit [usubst]:
  "\<sigma> \<dagger> \<guillemotleft>v\<guillemotright>\<^sub>v = \<guillemotleft>v\<guillemotright>\<^sub>v"
  by (transfer; clarsimp)

lemma vsubst_vuop [usubst]:
  "\<sigma> \<dagger> (vuop f x) = vuop f (\<sigma> \<dagger> x)"
  by (transfer; clarsimp)

lemma vsubst_vbop [usubst]:
  "\<sigma> \<dagger> (vbop f x y) = vbop f (\<sigma> \<dagger> x) (\<sigma> \<dagger> y)"
  by (transfer; clarsimp)

lemma vsubst_vtop [usubst]:
  "\<sigma> \<dagger> (vtop f x y z) = vtop f (\<sigma> \<dagger> x) (\<sigma> \<dagger> y) (\<sigma> \<dagger> z)"
  by (transfer; clarsimp)

lemma vsubst_vexpr [usubst]:
  "\<sigma> \<dagger> \<lfloor>v\<rfloor>\<^sub>v = \<lfloor>\<sigma> \<dagger> v\<rfloor>\<^sub>v"
  by (transfer; clarsimp)

subsection {* Proof setup *}

text {* We here extend the set of intro-elim rules to allow discharging lifted HOL operators. These
        rule show how tautologies expressed in terms of lifted HOL functions can be directly
        dropped to the HOL operators, which makes proof support direct. *}

lemma upfun'_tvl [simp]: "[upfun' f x]\<^sub>3 = f x"
  by (auto simp add: upfun_def tvl_taut_def)

lemma upfun'_tvlE [elim]: "\<lbrakk> [upfun' f x]\<^sub>3; f x \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
  by (simp)

lemma upfun'_tvlI [intro]: "f x \<Longrightarrow> [upfun' f x]\<^sub>3"
  by (simp)

lemma bpfun'_tvl [simp]: "[bpfun' f (x, y)]\<^sub>3 = f x y"
  by (auto simp add: bpfun_def tvl_taut_def)

lemma bpfun'_tvlE [elim]: "\<lbrakk> [bpfun' f (x, y)]\<^sub>3; f x y \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
  by (simp)

lemma bpfun'_tvlI [intro]: "f x y \<Longrightarrow> [bpfun' f (x, y)]\<^sub>3"
  by (simp)

lemma bpfun'_defined [intro,simp]:
  "\<D>\<^sub>3 (bpfun' f x)"
  by (auto simp add: tvl_defined_def bpfun_def split_beta)

text {* We also set up some useful default simplifications. *}

lemma true_vdm [simp]: "\<lfloor>true\<^sub>v\<rfloor>\<^sub>v = true"
  by (pred_auto)

lemma false_vdm [simp]: "\<lfloor>false\<^sub>v\<rfloor>\<^sub>v = false"
  by (pred_auto)

lemma vconj_left_unit [simp]: "(true\<^sub>v \<and>\<^sub>v p) = p"
  by (pred_auto)

lemma vconj_right_unit [simp]: "(p \<and>\<^sub>v true\<^sub>v) = p"
  by (pred_auto)

lemma vmem_UNIV [simp]: "(x \<in>\<^sub>v \<guillemotleft>UNIV\<guillemotright>\<^sub>v) = !\<D>\<^sub>v(x)"
  by (pred_auto)

lemma restrict_map_UNIV [simp]: "f |` UNIV = f"
  by (simp add: restrict_map_def)

lemma vmem_Collect_1 [simp]: "(x \<in>\<^sub>v \<guillemotleft>{x. P x}\<guillemotright>\<^sub>v) = vuop (upfun' P) x"
  by (pred_auto)

lemma vmem_Collect_2 [simp]: "((x, y)\<^sub>v \<in>\<^sub>v \<guillemotleft>{x. P x}\<guillemotright>\<^sub>v) = vbop (upfun' P) x y"
  by (pred_auto)

lemma upfun'_simp [simp]: "upfun' f x = Some (f x)"
  by (pred_auto)

lemma bpfun'_simp [simp]: "bpfun' f (x, y) = Some (f x y)"
  by (pred_auto)

text {* Here we are using introduction / elimination to prove some simple properties *}

lemma example1: "(\<forall>\<^sub>v x : Nats \<bullet> \<guillemotleft>x\<guillemotright>\<^sub>v >\<^sub>v \<guillemotleft>1 :: nat\<guillemotright>\<^sub>v) = false\<^sub>v"
  by (pred_auto)

lemma example2: "(\<exists>\<^sub>v x : Nats \<bullet> \<guillemotleft>x\<guillemotright>\<^sub>v >\<^sub>v \<guillemotleft>1 :: nat\<guillemotright>\<^sub>v) = true\<^sub>v"
  by (pred_auto)

subsection {* Definedness laws *}

text {* The proof support also relies on a decision regarding definedness of various operators. Here
        we prove some key laws. *}

lemma vdefined_visdefined [simp]: "(\<D>\<^sub>v(x) \<and>\<^sub>v !\<D>\<^sub>v(x)) = \<D>\<^sub>v(x)"
  by (pred_auto)

lemma vdefined_vdefined [simp]: "\<D>\<^sub>v(\<D>\<^sub>v(v)) = true\<^sub>v"
  by (pred_auto)

lemma vdefined_vlit [simp]: "\<D>\<^sub>v(\<guillemotleft>v\<guillemotright>\<^sub>v) = true\<^sub>v"
  by (pred_auto)

lemma vdefined_zero [simp]: "\<D>\<^sub>v(0) = true\<^sub>v"
  by (pred_auto)

lemma vdefined_one [simp]: "\<D>\<^sub>v(1) = true\<^sub>v"
  by (pred_auto)

lemma vdefined_upfun: "\<D>\<^sub>v(vuop (upfun A f) x) = (\<D>\<^sub>v(x) \<and>\<^sub>v x \<in>\<^sub>v \<guillemotleft>A\<guillemotright>\<^sub>v)"
  apply (transfer)
  apply (rule ext)
  apply (auto simp add: upfun_def bpfun_def dom_def)
  apply (rename_tac A f x b)
  apply (case_tac "x b")
  apply (auto)
  apply (meson domI domIff restrict_out)
done

lemma vdefined_upfun' [simp]: "\<D>\<^sub>v(vuop (upfun' f) x) = \<D>\<^sub>v(x)"
  by (simp add: vdefined_upfun)

lemma vdefined_bpfun: "\<D>\<^sub>v(vbop (bpfun A f) x y) = (\<D>\<^sub>v(x) \<and>\<^sub>v \<D>\<^sub>v(y) \<and>\<^sub>v (x, y)\<^sub>v \<in>\<^sub>v \<guillemotleft>A\<guillemotright>\<^sub>v)"
  apply (transfer)
  apply (rule ext)
  apply (rename_tac A f x y b)
  apply (auto simp add: bpfun_def dom_def)
  apply (case_tac "x b")
  apply (auto)
  apply (case_tac "y b")
  apply (auto)
  apply (metis option.distinct(2) restrict_out)
done

(* FIXME: Do this proof properly! *)

lemma vdefined_bpfun' [simp]: "\<D>\<^sub>v(vbop (bpfun' f) x y) = (\<D>\<^sub>v(x) \<and>\<^sub>v \<D>\<^sub>v(y))"
  by (pred_auto)

lemma vdefined_tpfun: "\<D>\<^sub>v(vtop (tpfun A f) x y z) = (\<D>\<^sub>v(x) \<and>\<^sub>v \<D>\<^sub>v(y) \<and>\<^sub>v \<D>\<^sub>v(z) \<and>\<^sub>v (x, y, z)\<^sub>v \<in>\<^sub>v \<guillemotleft>A\<guillemotright>\<^sub>v)"
  apply (transfer)
  apply (rule ext)
  apply (rename_tac A f x y z b)
  apply (auto simp add: tpfun_def dom_def)
  apply (case_tac "x b")
  apply (auto)
  apply (case_tac "y b")
  apply (auto)
  apply (case_tac "z b")
  apply (auto)
  apply (metis option.distinct(2) restrict_out)
done

lemma vdefined_upfunI:
  assumes "(x \<in>\<^sub>v \<guillemotleft>A\<guillemotright>\<^sub>v) = P(x)"
  shows "\<D>\<^sub>v(vuop (upfun A f) x) = (\<D>\<^sub>v(x) \<and>\<^sub>v P(x))"
  using assms by (simp add: vdefined_upfun hd_pre_def)

lemma vdefined_vmap_update [simp]:
  "\<D>\<^sub>v(vtop vmap_update m k v) = (\<D>\<^sub>v(m) \<and>\<^sub>v \<D>\<^sub>v(k) \<and>\<^sub>v \<D>\<^sub>v(v))"
  apply (transfer)
  apply (rule ext)
  apply (auto)
  apply (simp add: vdefined_tpfun vmap_update_def)
done

lemma vdefined_undef [simp]:
  "\<D>\<^sub>v(\<bottom>\<^sub>v) = false\<^sub>v"
  by (pred_auto)

lemma vdefined_vvar [simp]:
  fixes x :: "('a \<Longrightarrow> '\<alpha>)"
  shows "\<D>\<^sub>v(&\<^sub>vx) = true\<^sub>v"
  by (transfer, simp)

lemma vdefined_vmap_apply [simp]:
  "\<D>\<^sub>v(m(x)\<^sub>v) = (\<D>\<^sub>v(x) \<and>\<^sub>v \<D>\<^sub>v(m) \<and>\<^sub>v x \<in>\<^sub>v dom\<^sub>v(m))"
  apply (transfer, simp add:upfun_def bpfun_def vmap_apply_def)
  apply (rule ext)
  apply (rename_tac m x b)
  apply (case_tac "x b")
  apply (auto simp add: dom_def)
  apply (simp add: bind_eq_None_conv)
  apply (case_tac "m b")
  apply (auto simp add: dom_def)
done

lemma vdefined_divide [simp]: "\<D>\<^sub>v(x / y) = (\<D>\<^sub>v(x) \<and>\<^sub>v \<D>\<^sub>v(y) \<and>\<^sub>v y <>\<^sub>v 0)"
  apply (simp add: upred_defs vdefined_bpfun)
  apply (transfer, rule ext, auto)
  apply (case_tac "y b", auto simp add: domIff)
done

lemma vdefined_vhd [simp]: "\<D>\<^sub>v(hd\<^sub>v(xs)) = (\<D>\<^sub>v(xs) \<and>\<^sub>v len\<^sub>v(xs) >\<^sub>v \<guillemotleft>0\<guillemotright>\<^sub>v)"
  by (rule vdefined_upfunI, transfer, simp add: vdefined_upfun upfun_def bpfun_def hd_pre_def)

lemma vdefined_vtl [simp]: "\<D>\<^sub>v(tl\<^sub>v(xs)) = (\<D>\<^sub>v(xs) \<and>\<^sub>v len\<^sub>v(xs) >\<^sub>v \<guillemotleft>0\<guillemotright>\<^sub>v)"
  by (rule vdefined_upfunI, transfer, simp add: vdefined_upfun upfun_def bpfun_def hd_pre_def)
subsection {* Deduction rules *}

lemma vdm_bind_on_dom_1 [intro]:
  "\<D>\<^sub>3 (\<lfloor>b \<in> dom p\<rfloor> \<and>\<^sub>k p b)"
  by (auto simp add: kand_def)

subsection {* VDM-SL programs *}

text {* Assignment requires that the expression assigned to the
        expression be defined, otherwise an abort will result. *}

definition vassign_uvar :: "('a \<Longrightarrow> '\<alpha>) \<Rightarrow> ('a, '\<alpha>) vexpr \<Rightarrow> '\<alpha> hrel_des" where
[urel_defs]: "vassign_uvar x v = (\<lfloor> \<D>\<^sub>v(v) \<rfloor>\<^sub>v \<turnstile>\<^sub>n (x := \<lfloor>v\<rfloor>\<^sub>v))"

definition vassign_dvar :: "'a::continuum dvar \<Rightarrow> ('a, '\<alpha>::vst) vexpr \<Rightarrow> '\<alpha> hrel_des" where
[urel_defs]: "vassign_dvar x v = vassign_uvar (x\<up>) v"

consts
  vassign :: "'v \<Rightarrow> ('a, '\<alpha>) vexpr \<Rightarrow> '\<alpha> hrel_des"

adhoc_overloading
  vassign vassign_uvar and vassign vassign_dvar

text {* We define a variant of assignment that updates a particular field in a record *}

abbreviation "vassign_upd x f v \<equiv> vassign_uvar x (vbop (bpfun' (\<lambda> k. f (\<lambda>_. k))) v (&\<^sub>vx))"
(* abbreviation "vassign_map m k v \<equiv> vassign m (vtop vupdate (&\<^sub>vm) k v)" *)

(* TODO: Implement pretty print rules for record update assignment *)

syntax
  "_vassign"     :: "id \<Rightarrow> ('a, '\<alpha>) vexpr \<Rightarrow> '\<alpha> hrel_des" (infix ":=\<^sub>v" 72)
  "_vassign_rec" :: "id \<Rightarrow> id \<Rightarrow> ('a, '\<alpha>) vexpr \<Rightarrow> '\<alpha> hrel" ("_.\<^sub>v_/ :=\<^sub>v/ _" [999,999,71] 72)
  "_vassign_map" :: "id \<Rightarrow> ('a, '\<alpha>) vexpr \<Rightarrow> ('b, '\<alpha>) vexpr \<Rightarrow> '\<alpha> hrel" ("_'(_')/ :=\<^sub>v/ _" [999,999,71] 72)

translations
  "x :=\<^sub>v v" == "CONST vassign x v"
  "x.\<^sub>vf :=\<^sub>v v" == "CONST vassign_upd x (_update_name f) v"
  "m(k) :=\<^sub>v v" => "CONST vassign m (CONST vtop CONST vupdate (&\<^sub>vm) k v)"

lemma vassign_undef:
  fixes x :: "('a \<Longrightarrow> '\<alpha>)"
  shows "(x :=\<^sub>v \<bottom>\<^sub>v) = \<bottom>\<^sub>D"
  by (rel_auto robust)

lemma H1_H3_vdm_assign [simp]:
  fixes x :: "('a \<Longrightarrow> '\<alpha>)"
  shows "(x :=\<^sub>v v) is H1_H3"
  by (metis H1_rdesign H3_ndesign Healthy_def ndesign_def vassign_uvar_def)

lemma hd_nil_abort:
  fixes x :: "('a \<Longrightarrow> '\<alpha>)"
  shows "(x :=\<^sub>v hd\<^sub>v([]\<^sub>v)) = true"
  by (rel_auto)

definition wp_vdm :: "('\<alpha>, '\<beta>) rel_des \<Rightarrow> '\<beta> vpred \<Rightarrow> '\<alpha> vpred" (infix "wp\<^sub>v" 60)
where "Q wp\<^sub>v r = \<lceil>Q wp\<^sub>D \<lfloor>r\<rfloor>\<^sub>v\<rceil>\<^sub>v"

text {* Here we augment the set of design weakest precondition laws
        with the VDM assignment operator *}

theorem wpd_vdm_assign [wp]:
  fixes x :: "('a \<Longrightarrow> '\<alpha>)"
  shows "(x :=\<^sub>v v) wp\<^sub>D r = (\<lfloor>\<D>\<^sub>v(v)\<rfloor>\<^sub>v \<and> r\<lbrakk>\<lfloor>v\<rfloor>\<^sub>v/&x\<rbrakk>)"
  by (simp add: vassign_uvar_def wp usubst)

lemma wp_calc_test_1:
  "\<lbrakk> vwb_lens x; vwb_lens y \<rbrakk> \<Longrightarrow> (y :=\<^sub>v hd\<^sub>v(&\<^sub>vx)) wp\<^sub>D true
                                  = \<lfloor>len\<^sub>v(&\<^sub>vx) >\<^sub>v \<guillemotleft>0\<guillemotright>\<^sub>v\<rfloor>\<^sub>v"
  by (simp add: wp usubst)

lemma wp_calc_test_2:
  "\<lbrakk> vwb_lens x; vwb_lens y \<rbrakk> \<Longrightarrow> (y :=\<^sub>v (1 / hd\<^sub>v(&\<^sub>vx))) wp\<^sub>D true
                                  = \<lfloor>len\<^sub>v(&\<^sub>vx) >\<^sub>v \<guillemotleft>0\<guillemotright>\<^sub>v \<and>\<^sub>v hd\<^sub>v(&\<^sub>vx) <>\<^sub>v 0\<rfloor>\<^sub>v"
  by (simp add: wp usubst)

subsection {* VDM-SL operations *}

definition vdm_sl_op :: "(bool, '\<alpha>) vexpr \<Rightarrow> (bool, '\<alpha> \<times> '\<alpha>) vexpr \<Rightarrow> '\<alpha> hrel_des \<Rightarrow> '\<alpha> hrel_des"
  ("[pre _ post _ body _]\<^sub>v")
where [upred_defs]: "[pre pr post po body bd]\<^sub>v = (\<lfloor>\<D>\<^sub>v(pr)\<rfloor>\<^sub>v \<and> \<lfloor>pr\<rfloor>\<^sub>v) \<turnstile>\<^sub>n (\<lfloor>\<D>\<^sub>v(po)\<rfloor>\<^sub>v \<and> \<lfloor>po\<rfloor>\<^sub>v \<and> post\<^sub>D(bd))"

lemma vdm_sl_op_H1_H3 [closure]:
  "[pre p post Q body R]\<^sub>v is \<^bold>N"
  by (simp add: vdm_sl_op_def, metis H1_rdesign H3_ndesign Healthy_def ndesign_def)

lemma wp_vdm_sl_op [wp]: "[pre p post Q body R]\<^sub>v wp\<^sub>D r = ((\<lfloor>\<D>\<^sub>v(p)\<rfloor>\<^sub>v \<and> \<lfloor>p\<rfloor>\<^sub>v) \<and> (\<lfloor>\<D>\<^sub>v(Q)\<rfloor>\<^sub>v \<and> \<lfloor>Q\<rfloor>\<^sub>v \<and> post\<^sub>D(R)) wp r)"
  by (simp add: vdm_sl_op_def wp)

(*
lemma vdm_sl_op_true_pre_post [simp]:
  "[pre true\<^sub>v post true\<^sub>v body p \<turnstile>\<^sub>r q]\<^sub>v = true \<turnstile>\<^sub>r q"
  by (simp add: vdm_sl_op_def, pred_auto)

lemma vdm_sl_op_false_pre [simp]:
  "[pre false\<^sub>v post p body b]\<^sub>v = true"
  by (simp add: vdm_sl_op_def, pred_auto)
*)

subsection {* Support for local variables *}

alphabet vlocal =
  vlocals :: "vstore"

instantiation vlocal_ext :: (type) vst
begin
  definition [simp]: "vstore_lens_vlocal_ext = vlocals"
instance
  by (intro_classes, unfold_locales, simp_all)
end

subsection {*Utility functions*}

definition inds :: "'a list \<Rightarrow> nat set" where
  "inds x = {1..length x}"
end


section \<open>Transition Systems\<close>

theory Transition_System
imports "../Basic/Sequence"
begin

  subsection \<open>Universal Transition Systems\<close>

  locale transition_system_universal =
    fixes execute :: "'transition \<Rightarrow> 'state \<Rightarrow> 'state"
  begin

    abbreviation "target \<equiv> fold execute"
    abbreviation "states \<equiv> scan execute"
    abbreviation "trace \<equiv> sscan execute"

    lemma target_alt_def: "target r p = last (p # states r p)" using scan_last by rule

  end

  subsection \<open>Transition Systems\<close>

  locale transition_system =
    transition_system_universal execute
    for execute :: "'transition \<Rightarrow> 'state \<Rightarrow> 'state"
    +
    fixes enabled :: "'transition \<Rightarrow> 'state \<Rightarrow> bool"
  begin

    abbreviation "successors p \<equiv> {execute a p |a. enabled a p}"

    inductive path :: "'transition list \<Rightarrow> 'state \<Rightarrow> bool" where
      nil[intro!]: "path [] p" |
      cons[intro!]: "enabled a p \<Longrightarrow> path r (execute a p) \<Longrightarrow> path (a # r) p"

    inductive_cases path_cons_elim[elim!]: "path (a # r) p"

    lemma path_append[intro!]:
      assumes "path r p" "path s (target r p)"
      shows "path (r @ s) p"
      using assms by (induct r arbitrary: p) (auto)
    lemma path_append_elim[elim!]:
      assumes "path (r @ s) p"
      obtains "path r p" "path s (target r p)"
      using assms by (induct r arbitrary: p) (auto)

    coinductive run :: "'transition stream \<Rightarrow> 'state \<Rightarrow> bool" where
      scons[intro!]: "enabled a p \<Longrightarrow> run r (execute a p) \<Longrightarrow> run (a ## r) p"

    inductive_cases run_scons_elim[elim!]: "run (a ## r) p"

    lemma run_shift[intro!]:
      assumes "path r p" "run s (target r p)"
      shows "run (r @- s) p"
      using assms by (induct r arbitrary: p) (auto)
    lemma run_shift_elim[elim!]:
      assumes "run (r @- s) p"
      obtains "path r p" "run s (target r p)"
      using assms by (induct r arbitrary: p) (auto)

    lemma run_coinduct[case_names run, coinduct pred: run]:
      assumes "R r p"
      assumes "\<And> a r p. R (a ## r) p \<Longrightarrow> enabled a p \<and> R r (execute a p)"
      shows "run r p"
      using stream.collapse run.coinduct assms by metis
    lemma run_coinduct_shift[case_names run, consumes 1]:
      assumes "R r p"
      assumes "\<And> r p. R r p \<Longrightarrow> \<exists> s t. r = s @- t \<and> s \<noteq> [] \<and> path s p \<and> R t (target s p)"
      shows "run r p"
    proof -
      have "\<exists> s t. r = s @- t \<and> path s p \<and> R t (target s p)" using assms(1) by force
      then show ?thesis using assms(2) by (coinduct) (force elim: path.cases)
    qed
    lemma run_flat_coinduct[case_names run, consumes 1]:
      assumes "R rs p"
      assumes "\<And> r rs p. R (r ## rs) p \<Longrightarrow> r \<noteq> [] \<and> path r p \<and> R rs (target r p)"
      shows "run (flat rs) p"
    using assms(1)
    proof (coinduction arbitrary: rs p rule: run_coinduct_shift)
      case (run rs p)
      then show ?case using assms(2) by (metis stream.exhaust flat_Stream)
    qed

    inductive_set reachable :: "'state \<Rightarrow> 'state set" for p where
      reflexive[intro!]: "p \<in> reachable p" |
      execute[intro!]: "q \<in> reachable p \<Longrightarrow> enabled a q \<Longrightarrow> execute a q \<in> reachable p"

    inductive_cases reachable_elim[elim]: "q \<in> reachable p"

    lemma reachable_execute'[intro]:
      assumes "enabled a p" "q \<in> reachable (execute a p)"
      shows "q \<in> reachable p"
      using assms(2, 1) by induct auto
    lemma reachable_elim'[elim]:
      assumes "q \<in> reachable p"
      obtains "q = p" | a where "enabled a p" "q \<in> reachable (execute a p)"
      using assms by induct auto

    lemma reachable_target[intro]:
      assumes "q \<in> reachable p" "path r q"
      shows "target r q \<in> reachable p"
      using assms by (induct r arbitrary: q) (auto)
    lemma reachable_target_elim[elim]:
      assumes "q \<in> reachable p"
      obtains r
      where "path r p" "q = target r p"
      using assms by induct force+

    lemma reachable_alt_def: "reachable p = {target r p |r. path r p}" by auto

    lemma reachable_trans[trans]: "q \<in> reachable p \<Longrightarrow> s \<in> reachable q \<Longrightarrow> s \<in> reachable p" by auto

    lemma reachable_successors[intro!]: "successors p \<subseteq> reachable p" by auto

    lemma reachable_step: "reachable p = insert p (\<Union> (reachable ` successors p))" by auto

  end

  subsection \<open>Transition Systems with Initial States\<close>

  locale transition_system_initial =
    transition_system execute enabled
    for execute :: "'transition \<Rightarrow> 'state \<Rightarrow> 'state"
    and enabled :: "'transition \<Rightarrow> 'state \<Rightarrow> bool"
    +
    fixes initial :: "'state \<Rightarrow> bool"
  begin

    inductive_set nodes :: "'state set" where
      initial[intro]: "initial p \<Longrightarrow> p \<in> nodes" |
      execute[intro!]: "p \<in> nodes \<Longrightarrow> enabled a p \<Longrightarrow> execute a p \<in> nodes"

    lemma nodes_target[intro]:
      assumes "p \<in> nodes" "path r p"
      shows "target r p \<in> nodes"
      using assms by (induct r arbitrary: p) (auto)
    lemma nodes_target_elim[elim]:
      assumes "q \<in> nodes"
      obtains r p
      where "initial p" "path r p" "q = target r p"
      using assms by induct force+

    lemma nodes_alt_def: "nodes = \<Union> (reachable ` Collect initial)" by auto

    lemma nodes_trans[trans]: "p \<in> nodes \<Longrightarrow> q \<in> reachable p \<Longrightarrow> q \<in> nodes" by auto

  end

end


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

(* Lemmas about no_throw. Usually should have a conclusion "no_throw P m".
   Includes some monad equations that have no_throw as a main assumption.  *)

theory No_Throw
  imports
    WhileLoopRules
    MonadEq_Lemmas
begin

section "Basic exception reasoning"

text \<open>
  The predicates @{text no_throw} and @{text no_return} allow us to reason about functions in
  the exception monad that never throw an exception or never return normally.\<close>

definition no_throw :: "('s \<Rightarrow> bool) \<Rightarrow> ('s, 'e + 'a) nondet_monad \<Rightarrow> bool" where
  "no_throw P A \<equiv> \<lbrace>P\<rbrace> A \<lbrace>\<lambda>_ _. True\<rbrace>, \<lbrace>\<lambda>_ _. False\<rbrace>"

definition no_return :: "('a \<Rightarrow> bool) \<Rightarrow> ('a, 'b + 'c) nondet_monad \<Rightarrow> bool" where
  "no_return P A \<equiv> \<lbrace>P\<rbrace> A \<lbrace>\<lambda>_ _. False\<rbrace>, \<lbrace>\<lambda>_ _. True\<rbrace>"

(* Alternative definition of no_throw; easier to work with than unfolding validE. *)
lemma no_throw_def':
  "no_throw P A = (\<forall>s. P s \<longrightarrow> (\<forall>(r, t) \<in> fst (A s). (\<exists>x. r = Inr x)))"
  by (clarsimp simp: no_throw_def validE_def2 split_def split: sum.splits)

lemma no_throw_returnOk[simp]:
  "no_throw P (returnOk a)"
  unfolding no_throw_def
  by wp

lemma no_throw_liftE[simp]:
  "no_throw P (liftE x)"
  by (wpsimp simp: liftE_def no_throw_def validE_def)

lemma no_throw_bindE:
  "\<lbrakk> no_throw A X; \<And>a. no_throw B (Y a); \<lbrace> A \<rbrace> X \<lbrace> \<lambda>_. B \<rbrace>,\<lbrace> \<lambda>_ _. True \<rbrace> \<rbrakk>
   \<Longrightarrow> no_throw A (X >>=E Y)"
  unfolding no_throw_def
  using hoare_validE_cases seqE by blast

lemma no_throw_bindE_simple:
  "\<lbrakk> no_throw \<top> L; \<And>x. no_throw \<top> (R x) \<rbrakk> \<Longrightarrow> no_throw \<top> (L >>=E R)"
  using hoareE_TrueI no_throw_bindE by blast

lemma no_throw_handleE_simple:
  "\<lbrakk> \<And>x. no_throw \<top> L \<or> no_throw \<top> (R x) \<rbrakk> \<Longrightarrow> no_throw \<top> (L <handle> R)"
  by (fastforce simp: no_throw_def' handleE_def handleE'_def validE_def valid_def bind_def return_def
                split: sum.splits)

lemma no_throw_handle2:
  "\<lbrakk> \<And>a. no_throw Y (B a); \<lbrace> X \<rbrace> A \<lbrace> \<lambda>_ _. True \<rbrace>,\<lbrace> \<lambda>_. Y \<rbrace> \<rbrakk> \<Longrightarrow> no_throw X (A <handle2> B)"
  by (fastforce simp: no_throw_def' handleE'_def validE_def valid_def bind_def return_def
                split: sum.splits)

lemma no_throw_handle:
  "\<lbrakk> \<And>a. no_throw Y (B a); \<lbrace> X \<rbrace> A \<lbrace> \<lambda>_ _. True \<rbrace>,\<lbrace> \<lambda>_. Y \<rbrace> \<rbrakk> \<Longrightarrow> no_throw X (A <handle> B)"
  unfolding handleE_def
  by (rule no_throw_handle2)

lemma no_throw_fail[simp]:
  "no_throw P fail"
  by (clarsimp simp: no_throw_def)

lemma bindE_fail_propagates:
  "\<lbrakk> no_throw \<top> A; empty_fail A \<rbrakk> \<Longrightarrow> A >>=E (\<lambda>_. fail) = fail"
  by (fastforce simp: no_throw_def validE_def valid_def bind_def empty_fail_def
                      bindE_def split_def fail_def NonDetMonad.lift_def throwError_def
                split: sum.splits)

lemma whileLoopE_nothrow:
  "\<lbrakk> \<And>x. no_throw \<top> (B x) \<rbrakk> \<Longrightarrow> no_throw \<top> (whileLoopE C B x)"
  unfolding no_throw_def
  by (fastforce intro!: validE_whileLoopE intro: validE_weaken)

lemma handleE'_nothrow_lhs:
  "no_throw \<top> L \<Longrightarrow> no_throw \<top> (L <handle2> R)"
  unfolding no_throw_def
  using handleE'_wp[rotated] by fastforce

lemma handleE'_nothrow_rhs:
  "\<lbrakk> \<And>x. no_throw \<top> (R x) \<rbrakk> \<Longrightarrow> no_throw \<top> (L <handle2> R)"
  unfolding no_throw_def
  by (metis hoareE_TrueI no_throw_def no_throw_handle2)

lemma handleE_nothrow_lhs:
  "no_throw \<top> L \<Longrightarrow> no_throw \<top> (L <handle> R)"
  by (metis handleE'_nothrow_lhs handleE_def)

lemma handleE_nothrow_rhs:
  "\<lbrakk> \<And>x. no_throw \<top> (R x) \<rbrakk> \<Longrightarrow> no_throw \<top> (L <handle> R)"
  by (metis no_throw_handleE_simple)

lemma condition_nothrow:
  "\<lbrakk> no_throw \<top> L; no_throw \<top> R \<rbrakk> \<Longrightarrow> no_throw \<top> (condition C L R)"
  by (clarsimp simp: condition_def no_throw_def validE_def2)

lemma no_throw_Inr:
  "\<lbrakk> x \<in> fst (A s); no_throw P A; P s \<rbrakk> \<Longrightarrow> \<exists>y. fst x = Inr y"
  by (fastforce simp: no_throw_def' split: sum.splits)

lemma no_throw_handleE':
  "no_throw \<top> A \<Longrightarrow> (A <handle2> B) = A"
  apply (rule monad_eqI; monad_eq)
    apply (fastforce dest: no_throw_Inr)
   apply (metis (lifting) fst_conv no_throw_Inr)
  apply (fastforce dest: no_throw_Inr)
  done

lemma no_throw_handleE:
  "no_throw \<top> A \<Longrightarrow> (A <handle> B) = A"
  unfolding handleE_def
  by (auto simp: no_throw_handleE')

lemma bindE_handleE_join:
  "no_throw \<top> A \<Longrightarrow> (A >>=E (\<lambda>x. (B x) <handle> C)) = ((A >>=E B <handle> C))"
  by (monad_eq simp: Bex_def Ball_def no_throw_def') blast

end


theory Flatten_Iter
  imports
  Basic_Assn
  "Separation_Logic_Imperative_HOL.Imp_List_Spec"
  "HOL-Real_Asymp.Inst_Existentials"
begin

text "This locale takes an iterator that refines a list of elements that themselves
can be iterated and defines an iterator over the flattened list of lower level elements"

locale flatten_iter =
  inner_list: imp_list_iterate is_inner_list inner_is_it inner_it_init inner_it_has_next inner_it_next +
  outer_list: imp_list_iterate is_outer_list outer_is_it outer_it_init outer_it_has_next outer_it_next
  for is_outer_list :: "'l list \<Rightarrow> 'm \<Rightarrow> assn"
  and outer_is_it :: "'l list \<Rightarrow> 'm \<Rightarrow> 'l list \<Rightarrow> 'oit \<Rightarrow> assn"
  and outer_it_init :: "'m \<Rightarrow> ('oit) Heap"
  and outer_it_has_next :: "'oit \<Rightarrow> bool Heap"
  and outer_it_next :: "'oit \<Rightarrow> ('l\<times>'oit) Heap"
  and is_inner_list :: "'a list \<Rightarrow> 'l \<Rightarrow> assn"
  and inner_is_it :: "'a list \<Rightarrow> 'l \<Rightarrow> 'a list \<Rightarrow> 'iit \<Rightarrow> assn"
  and inner_it_init :: "'l \<Rightarrow> ('iit) Heap"
  and inner_it_has_next :: "'iit \<Rightarrow> bool Heap"
  and inner_it_next :: "'iit \<Rightarrow> ('a\<times>'iit) Heap"
begin

fun is_flatten_list :: "'a list \<Rightarrow> 'm \<Rightarrow> assn" where
  "is_flatten_list ls lsi = (\<exists>\<^sub>A lsi' ls'.
    is_outer_list lsi' lsi * list_assn is_inner_list ls' lsi' * \<up>(ls = concat ls')
)"

lemma flatten_prec:
  "precise is_flatten_list"
  apply (intro preciseI)
  apply (auto)
proof (goal_cases)
  case (1 aa b p F F' lsi' ls' lsi'a ls'a)
  then have *:
      "\<exists>G G'. (aa, b) \<Turnstile> list_assn is_inner_list ls'a lsi'a * G \<and>\<^sub>A list_assn is_inner_list ls' lsi' * G'"
    by (smt (z3) assn_aci(10) assn_times_comm)

  have "lsi' = lsi'a"
    using 1
    by (metis outer_list.precise preciseD star_assoc)
  moreover have "length ls'a = length lsi'a" "length ls' = length lsi'"
    using 1 by (auto simp add: mod_and_dist dest!: mod_starD list_assn_len)
  ultimately have "length ls' = length lsi'" "length lsi' = length lsi'a" "length lsi'a = length ls'a"
    by auto
  then show ?case
    using * \<open>lsi' = lsi'a\<close>
    proof(induction ls' lsi' lsi'a ls'a arbitrary: p rule: list_induct4)
      case Nil
      then show ?case by auto
    next
      case (Cons x xs y ys z zs w ws)
      then have "concat ws = concat xs"
        apply simp
        by (metis (no_types, opaque_lifting) ab_semigroup_mult_class.mult.left_commute star_assoc)
      moreover have "x = w"
        using "Cons.prems" preciseD[OF inner_list.precise, where h="(aa,b)"]
        apply(simp)
        using assn_times_assoc by fastforce
      ultimately show ?case
        by auto
    qed
qed

(*type_synonym flatten_it = "'iit \<times> 'oit"*)
fun is_flatten_it :: "'a list \<Rightarrow> 'm \<Rightarrow> 'a list \<Rightarrow> ('oit \<times> 'iit option) \<Rightarrow> assn"
  where
"is_flatten_it ls lsi [] (oit, None) =
        (\<exists>\<^sub>A lsi' lsi''.
          list_assn is_inner_list lsi'' lsi' *
           \<up>(ls = (concat lsi'')) *
          outer_is_it lsi' lsi [] oit
)" |
"is_flatten_it ls lsi ls2 (oit, Some iit) =
        (\<exists>\<^sub>A lsi' ls2' ls1' lsi1 lsi2 lsim ls2m lsm ls1m.
          list_assn is_inner_list ls1' lsi1 *
          list_assn is_inner_list ls2' lsi2 *
           \<up>(ls2m \<noteq> [] \<and> ls2 = ls2m@(concat ls2') \<and> ls = (concat (ls1'@lsm#ls2'))) *
          outer_is_it lsi' lsi lsi2 oit *
          \<up>(lsm = ls1m@ls2m \<and> lsi'=(lsi1@lsim#lsi2)) *
          inner_is_it lsm lsim ls2m iit
)
" |
"is_flatten_it _ _ _ _ = false"

partial_function (heap) flatten_it_adjust:: "'oit \<Rightarrow> 'iit \<Rightarrow> ('oit \<times> 'iit option) Heap" where
"flatten_it_adjust oit iit = do {
      ihasnext \<leftarrow> inner_it_has_next iit;
      if ihasnext then
        return (oit, Some iit)
      else do {
        ohasnext \<leftarrow> outer_it_has_next oit;
        if \<not>ohasnext then
          return (oit, None)
        else do {
          (next, oit) \<leftarrow> outer_it_next oit;
          nextit \<leftarrow> inner_it_init next;
          flatten_it_adjust oit nextit
        }
      }
  }
"

thm list_assn_len

lemma flatten_it_adjust_rule:
  " <list_assn is_inner_list ls1' ls1 * list_assn is_inner_list ls2' ls2 *
      outer_is_it (ls1@lsim#ls2) lsi ls2 oit * inner_is_it (lsm1@lsm2) lsim lsm2 iit>
  flatten_it_adjust oit iit
  <is_flatten_it (concat (ls1'@(lsm1@lsm2)#ls2')) lsi (concat (lsm2#ls2'))>\<^sub>t"
proof (induction ls2 arbitrary: ls1' ls1 ls2' lsim lsm1 lsm2 oit iit)
  case Nil
  then show ?case
  apply(subst flatten_it_adjust.simps)
  apply (sep_auto eintros del: exI heap add: inner_list.it_has_next_rule)
  apply(inst_existentials "(ls1 @ lsim # [])" ls2' ls1' ls1 "[]::'l list" lsim lsm2 "lsm1@lsm2")
  subgoal by auto
  subgoal by (sep_auto)
  apply (vcg (ss))
  apply (vcg (ss))
  apply (vcg (ss))
  apply (vcg (ss))
  apply (vcg (ss))
  apply (vcg (ss))
  apply (vcg (ss))
  subgoal
    apply (vcg (ss))
    apply (sep_auto eintros del: exI)
    apply(inst_existentials "(ls1 @ [lsim])" "ls1'@[lsm1]")
    subgoal by auto
        subgoal
          apply(auto simp add: list_assn_app_one)
          using inner_list.quit_iteration
          by (smt (z3) assn_aci(9) assn_times_comm ent_true_drop(1) fr_refl)
  done
  done
next
  case (Cons a ls2)
  show ?case
  apply(subst flatten_it_adjust.simps)
  apply (sep_auto eintros del: exI heap add: inner_list.it_has_next_rule)
  apply(inst_existentials "(ls1 @ lsim # a # ls2)" ls2' ls1' ls1 "a #ls2" lsim lsm2 "lsm1@lsm2")
  subgoal by auto
  subgoal by (sep_auto)
  apply (vcg (ss))
  apply (vcg (ss))
  apply (vcg (ss))
  apply (vcg (ss))
  apply (vcg (ss))
  apply (vcg (ss))
  apply (vcg (ss))
  subgoal by simp
  apply (vcg (ss))
  apply (vcg (ss))
  apply (vcg (ss))
  apply (vcg (ss))
  apply (vcg (ss))
  apply (vcg (ss))
  apply (vcg (ss))
  apply (vcg (ss))
  apply (case_tac ls2')
  apply simp_all
  apply (sep_auto eintros del: exI heap add: inner_list.it_init_rule)
  subgoal for x oit aa list xa
    supply R = "Cons.IH"[of "ls1'@[lsm1]" "ls1@[lsim]" list a oit "[]::'a list" aa xa, simplified]
    thm R
  find_theorems "_ \<Longrightarrow>\<^sub>A _" "<_>_<_>"
  supply Q = Hoare_Triple.cons_pre_rule[of
"inner_is_it aa a aa xa * outer_is_it (ls1 @ lsim # a # ls2) lsi ls2 oit *
     inner_is_it lsm1 lsim [] iit *
     list_assn is_inner_list ls1' ls1 *
     list_assn is_inner_list list ls2 *
     true"
"list_assn is_inner_list ls1' ls1 * is_inner_list lsm1 lsim * list_assn is_inner_list list ls2 *
 outer_is_it (ls1 @ lsim # a # ls2) lsi ls2 oit *
 inner_is_it aa a aa
  xa * true"
]
  thm Q
  apply(rule Q)
  prefer 2
  subgoal by (sep_auto heap add: R intro: inner_list.quit_iteration)
  subgoal using inner_list.quit_iteration
    by (smt (z3) assn_aci(10) assn_times_comm ent_refl_true ent_star_mono_true)
  done
  done
qed

definition flatten_it_init :: "'m \<Rightarrow> _ Heap"
  where "flatten_it_init l = do {
    oit \<leftarrow> outer_it_init l;
    ohasnext \<leftarrow> outer_it_has_next oit;
    if ohasnext then do {
       (next, oit) \<leftarrow> outer_it_next oit;
       nextit \<leftarrow> inner_it_init next;
       flatten_it_adjust oit nextit
    } else return (oit, None)
}"

lemma flatten_it_init_rule[sep_heap_rules]:
    "<is_flatten_list l p> flatten_it_init p <is_flatten_it l p l>\<^sub>t"
  unfolding flatten_it_init_def
  apply simp
  apply(rule norm_pre_ex_rule)+
  apply (vcg (ss))
  apply (vcg (ss))
  apply (vcg (ss))
  apply (vcg (ss))
  apply (vcg (ss))
  apply (vcg (ss))
  apply (vcg (ss))
  apply (vcg (ss))
  apply (vcg (ss))
  apply (vcg (ss))
  apply (vcg (ss))
  subgoal for lsi' ls' x xa
  apply (vcg (ss))
  apply (vcg (ss))
  apply (vcg (ss))
  apply (vcg (ss))
  apply (vcg (ss))
  apply (vcg (ss))
  apply (vcg (ss))
  apply(case_tac lsi'; case_tac ls')
  apply simp+
  apply(rule impI)
  thm inner_list.it_init_rule
  apply (vcg heap add: inner_list.it_init_rule)
  subgoal for _ nxt oit a list aa lista xaa
  supply R = flatten_it_adjust_rule[of "[]" "[]" lista list a p oit "[]" aa xaa, simplified]
  thm R
  apply (sep_auto heap add: R)
  done
  done
  apply (sep_auto eintros del: exI)
  apply(inst_existentials "[]::'l list" "[]::'a list list" "[]::'a list list" "[]::'l list" "[]::'l list")
  apply simp_all
  done

definition flatten_it_next where
  "flatten_it_next \<equiv> \<lambda>(oit,iit). do {
    (x, iit) \<leftarrow> inner_it_next (the iit);
    (oit, iit) \<leftarrow> flatten_it_adjust oit iit;
    return (x, (oit,iit))
  }"

lemma flatten_it_next_rule:
    " l' \<noteq> [] \<Longrightarrow>
    <is_flatten_it l p l' it>
      flatten_it_next it
    <\<lambda>(a,it'). is_flatten_it l p (tl l') it' * \<up>(a=hd l')>\<^sub>t"
  apply(subst flatten_it_next_def)
  thm inner_list.it_next_rule
  apply (vcg (ss))
  apply (vcg (ss))
  apply(case_tac iit; case_tac l')
  apply simp_all
  apply(rule norm_pre_ex_rule)+
  subgoal for oit iit a aa list lsi' ls2' ls1' lsi1 lsi2 lsim ls2m lsm ls1m
    apply(vcg (ss))
    apply(vcg (ss))
    apply(vcg (ss))
    apply(vcg (ss))
    apply(vcg (ss))
    apply(vcg (ss))
    apply(vcg (ss))
    apply(vcg (ss))
    apply(vcg (ss))
    apply(case_tac ls2m)
    apply simp_all
    subgoal for _ _ iita lista
  supply R = flatten_it_adjust_rule[of ls1' lsi1 ls2' lsi2 lsim p oit "ls1m@[aa]" "lista" iita, simplified]
  thm R
  apply (sep_auto heap add: R)
  done
  done
  done

definition flatten_it_has_next where
  "flatten_it_has_next \<equiv> \<lambda>(oit, iit). do {
    return (iit \<noteq> None)
}"

lemma flatten_it_has_next_rule[sep_heap_rules]:
    "<is_flatten_it l p l' it>
       flatten_it_has_next it
     <\<lambda>r. is_flatten_it l p l' it * \<up>(r\<longleftrightarrow>l'\<noteq>[])>\<^sub>t"
  apply(subst flatten_it_has_next_def)
  apply(sep_auto)
  apply(case_tac iit, case_tac l')
  apply simp_all
  apply sep_auto
  done

declare mult.left_assoc[simp add]
lemma flatten_quit_iteration:
    "is_flatten_it l p l' it \<Longrightarrow>\<^sub>A is_flatten_list l p * true"
  apply(cases it)
  subgoal for oit iit
    apply(cases iit; cases l')
  proof (goal_cases)
    case 1
    then show ?case
      apply (sep_auto eintros del: exI)
      subgoal for lsi' lsi''
        apply(inst_existentials lsi' lsi'')
        subgoal by auto
        subgoal by (metis (no_types, lifting) assn_aci(10) assn_times_comm fr_refl outer_list.quit_iteration)
        done
      done
  next
    case (2 lsim ll')
    then show ?case
      by (sep_auto eintros del: exI)
  next
    case (3 iit)
    then show ?case
      by (sep_auto eintros del: exI)
  next
  case (4 iit lsim ll')
    then show ?case
      apply (sep_auto eintros del: exI)
      subgoal for lsi' ls2' ls1' lsi1 lsi2 lsima ls2m lsm ls1m
        apply(inst_existentials "(lsi1 @ lsima # lsi2)" "ls1'@(ls1m@ls2m)#ls2'")
        subgoal by auto
            subgoal
              apply(rule impI; rule entails_preI)
              apply (auto dest!: mod_starD list_assn_len)
              apply(simp add:
                  mult.commute[where ?b="outer_is_it (lsi1 @ lsima # lsi2) p lsi2 oit"]
                  mult.commute[where ?b="is_outer_list (lsi1 @ lsima # lsi2) p"]
                  mult.left_assoc)
              apply(rule rem_true)
              supply R = ent_star_mono_true[of
                  "outer_is_it (lsi1 @ lsima # lsi2) p lsi2 oit"
                  "is_outer_list (lsi1 @ lsima # lsi2) p"
                  "list_assn is_inner_list ls1' lsi1 *
                         list_assn is_inner_list ls2' lsi2 *
                         inner_is_it (ls1m @ ls2m) lsima ls2m iit"
                  " list_assn is_inner_list ls1' lsi1 *
                         is_inner_list (ls1m @ ls2m) lsima *
                         list_assn is_inner_list ls2' lsi2"
              ,simplified]
              thm R
              apply(rule R)
              subgoal by (rule outer_list.quit_iteration)
              apply(simp add:
                  mult.commute[where ?b="inner_is_it (ls1m @ ls2m) lsima ls2m iit"]
                  mult.commute[where ?b="is_inner_list (ls1m @ ls2m) lsima"]
                  mult.left_assoc)
              apply(rule rem_true)
              supply R = ent_star_mono_true[of
                  "inner_is_it (ls1m @ ls2m) lsima ls2m iit"
                  "is_inner_list (ls1m @ ls2m) lsima"
                  "list_assn is_inner_list ls1' lsi1 *
                         list_assn is_inner_list ls2' lsi2"
                  " list_assn is_inner_list ls1' lsi1 *
                         list_assn is_inner_list ls2' lsi2"
              ,simplified]
              thm R
              apply(rule R)
              subgoal by (rule inner_list.quit_iteration)
              subgoal by sep_auto
              done
            done
          done
      qed
  done
declare mult.left_assoc[simp del]

interpretation flatten_it: imp_list_iterate is_flatten_list is_flatten_it flatten_it_init flatten_it_has_next flatten_it_next
  apply(unfold_locales)
  subgoal
    by (rule flatten_prec)
  subgoal for l p
    by (rule flatten_it_init_rule[of l p])
  subgoal for  l' l p it
    thm flatten_it_next_rule
    by (rule flatten_it_next_rule[of l' l p it])
  subgoal for l p l' it
    by (rule flatten_it_has_next_rule[of l p l' it])
  subgoal for l p l' it
    by (rule flatten_quit_iteration[of l p l' it])
  done
end

end