(*<*)
theory Theory_Of_Lists
imports
  HOLCF_ROOT
begin

(*>*)
section\<open> Strict lists \label{sec:theory_of_lists} \<close>

text\<open>

Head- and tail-strict lists. Many technical Isabelle details are
lifted from \<open>HOLCF-Prelude.Data_List\<close>; names follow
HOL, prefixed with \<open>s\<close>.

\<close>

domain 'a slist ("[:_:]") =
  snil ("[::]")
| scons (shead :: "'a") (stail :: "'a slist") (infixr ":#" 65)

lemma scons_strict[simp]: "scons\<cdot>\<bottom> = \<bottom>"
by (clarsimp simp: cfun_eq_iff)

lemma shead_bottom_iff[simp]: "(shead\<cdot>xs = \<bottom>) \<longleftrightarrow> (xs = \<bottom> \<or> xs = [::])"
by (cases xs) simp_all

lemma stail_bottom_iff[simp]: "(stail\<cdot>xs = \<bottom>) \<longleftrightarrow> (xs = \<bottom> \<or> xs = [::])"
by (cases xs) simp_all

lemma match_snil_match_scons_slist_case: "match_snil\<cdot>xs\<cdot>k1 +++ match_scons\<cdot>xs\<cdot>k2 = slist_case\<cdot>k1\<cdot>k2\<cdot>xs"
by (cases xs) simp_all

lemma slist_bottom': "slist_case\<cdot>\<bottom>\<cdot>\<bottom>\<cdot>xs = \<bottom>"
by (cases xs; simp)

lemma slist_bottom[simp]: "slist_case\<cdot>\<bottom>\<cdot>\<bottom> = \<bottom>"
by (simp add: cfun_eq_iff slist_bottom')

lemma slist_case_distr:
  "f\<cdot>\<bottom> = \<bottom> \<Longrightarrow> f\<cdot>(slist_case\<cdot>g\<cdot>h\<cdot>xs) = slist_case\<cdot>(f\<cdot>g)\<cdot>(\<Lambda> x xs. f\<cdot>(h\<cdot>x\<cdot>xs))\<cdot>xs"
  "slist_case\<cdot>g'\<cdot>h'\<cdot>xs\<cdot>z = slist_case\<cdot>(g'\<cdot>z)\<cdot>(\<Lambda> x xs. h'\<cdot>x\<cdot>xs\<cdot>z)\<cdot>xs"
by (case_tac [!] xs) simp_all

lemma slist_case_cong:
  assumes "xs = xs'"
  assumes "xs' = [::] \<Longrightarrow> n = n'"
  assumes "\<And>y ys. \<lbrakk>xs' = y :# ys; y \<noteq> \<bottom>; ys \<noteq> \<bottom>\<rbrakk> \<Longrightarrow> c y ys = c' y ys"
  assumes "cont (\<lambda>(x, y). c x y)"
  assumes "cont (\<lambda>(x, y). c' x y)"
  shows "slist_case\<cdot>n\<cdot>(\<Lambda> x xs. c x xs)\<cdot>xs = slist_case\<cdot>n'\<cdot>(\<Lambda> x xs. c' x xs)\<cdot>xs'"
using assms by (cases xs; cases xs'; clarsimp simp: prod_cont_iff)

text\<open>

Section syntax for @{const \<open>scons\<close>} ala Haskell.

\<close>

syntax
  "_scons_section" :: "'a \<rightarrow> [:'a:] \<rightarrow> [:'a:]" ("'(:#')")
  "_scons_section_left" :: "'a \<Rightarrow> [:'a:] \<rightarrow> [:'a:]" ("'(_:#')")
translations
  "(x:#)" == "(CONST Rep_cfun) (CONST scons) x"

abbreviation scons_section_right :: "[:'a:] \<Rightarrow> 'a \<rightarrow> [:'a:]" ("'(:#_')") where
  "(:#xs) \<equiv> \<Lambda> x. x :# xs"

syntax
  "_strict_list" :: "args \<Rightarrow> [:'a:]" ("[:(_):]")
translations
  "[:x, xs:]" == "x :# [:xs:]"
  "[:x:]" == "x :# [::]"

text\<open>

Class instances.

\<close>

instantiation slist :: (Eq) Eq_strict
begin

fixrec eq_slist :: "[:'a:] \<rightarrow> [:'a:] \<rightarrow> tr" where
  "eq_slist\<cdot>[::]\<cdot>[::] = TT"
| "\<lbrakk>x \<noteq> \<bottom>; xs \<noteq> \<bottom>\<rbrakk> \<Longrightarrow> eq_slist\<cdot>(x :# xs)\<cdot>[::] = FF"
| "\<lbrakk>y \<noteq> \<bottom>; ys \<noteq> \<bottom>\<rbrakk> \<Longrightarrow> eq_slist\<cdot>[::]\<cdot>(y :# ys) = FF"
| "\<lbrakk>x \<noteq> \<bottom>; xs \<noteq> \<bottom>; y \<noteq> \<bottom>; ys \<noteq> \<bottom>\<rbrakk> \<Longrightarrow> eq_slist\<cdot>(x :# xs)\<cdot>(y :# ys) = (eq\<cdot>x\<cdot>y andalso eq_slist\<cdot>xs\<cdot>ys)"

instance proof
  fix xs :: "[:'a:]"
  show "eq\<cdot>xs\<cdot>\<bottom> = \<bottom>"
    by (cases xs) (subst eq_slist.unfold; simp)+
  show "eq\<cdot>\<bottom>\<cdot>xs = \<bottom>"
    by (cases xs) (subst eq_slist.unfold; simp)+
qed

end

instance slist :: (Eq_sym) Eq_sym
proof
  fix xs ys :: "[:'a:]"
  show "eq\<cdot>xs\<cdot>ys = eq\<cdot>ys\<cdot>xs"
  proof (induct xs arbitrary: ys)
    case snil
    show ?case by (cases ys; simp)
  next
    case scons
    then show ?case by (cases ys; simp add: eq_sym)
  qed simp_all
qed

instance slist :: (Eq_equiv) Eq_equiv
proof
  fix xs ys zs :: "[:'a:]"
  show "eq\<cdot>xs\<cdot>xs \<noteq> FF"
    by (induct xs) simp_all
  assume "eq\<cdot>xs\<cdot>ys = TT" and "eq\<cdot>ys\<cdot>zs = TT" then show "eq\<cdot>xs\<cdot>zs = TT"
  proof (induct xs arbitrary: ys zs)
    case (snil ys zs) then show ?case by (cases ys, simp_all)
  next
    case (scons x xs ys zs) with eq_trans show ?case
      by (cases ys; cases zs) auto
  qed simp_all
qed

instance slist :: (Eq_eq) Eq_eq
proof
  fix xs ys :: "[:'a:]"
  show "eq\<cdot>xs\<cdot>xs \<noteq> FF"
    by (induct xs) simp_all
  assume "eq\<cdot>xs\<cdot>ys = TT" then show "xs = ys"
  proof (induct xs arbitrary: ys)
    case (snil ys) then show ?case by (cases ys) simp_all
  next
    case (scons x xs ys) then show ?case by (cases ys) auto
  qed simp
qed

instance slist :: (Eq_def) Eq_def
proof
  fix xs ys :: "[:'a:]"
  assume "xs \<noteq> \<bottom>" and "ys \<noteq> \<bottom>"
  then show "eq\<cdot>xs\<cdot>ys \<noteq> \<bottom>"
  proof(induct xs arbitrary: ys)
    case (snil ys) then show ?case by (cases ys) simp_all
  next
    case (scons a xs) then show ?case by (cases ys) simp_all
  qed simp
qed

lemma slist_eq_TT_snil[simp]:
  fixes xs :: "[:'a::Eq:]"
  shows "(eq\<cdot>xs\<cdot>[::] = TT) \<longleftrightarrow> (xs = [::])"
        "(eq\<cdot>[::]\<cdot>xs = TT) \<longleftrightarrow> (xs = [::])"
by (cases xs; simp)+

lemma slist_eq_FF_snil[simp]:
  fixes xs :: "[:'a::Eq:]"
  shows "(eq\<cdot>xs\<cdot>[::] = FF) \<longleftrightarrow> (\<exists>y ys. y \<noteq> \<bottom> \<and> ys \<noteq> \<bottom> \<and> xs = y :# ys)"
        "(eq\<cdot>[::]\<cdot>xs = FF) \<longleftrightarrow> (\<exists>y ys. y \<noteq> \<bottom> \<and> ys \<noteq> \<bottom> \<and> xs = y :# ys)"
by (cases xs; force)+

subsection\<open> Some of the usual reasoning infrastructure \<close>

inductive slistmem :: "'a \<Rightarrow> [:'a:] \<Rightarrow> bool" where
  "\<lbrakk>x \<noteq> \<bottom>; xs \<noteq> \<bottom>\<rbrakk> \<Longrightarrow> slistmem x (x :# xs)"
| "\<lbrakk>slistmem x xs; y \<noteq> \<bottom>\<rbrakk> \<Longrightarrow> slistmem x (y :# xs)"

lemma slistmem_bottom1[iff]:
  fixes x :: "'a"
  shows "\<not> slistmem x \<bottom>"
by rule (induct x "\<bottom>::[:'a:]" rule: slistmem.induct; fastforce)

lemma slistmem_bottom2[iff]:
  fixes xs :: "[:'a:]"
  shows "\<not> slistmem \<bottom> xs"
by rule (induct "\<bottom>::'a" xs rule: slistmem.induct; fastforce)

lemma slistmem_nil[iff]:
  shows "\<not> slistmem x [::]"
by (fastforce elim: slistmem.cases)

definition sset :: "[:'a:] \<Rightarrow> 'a set" where
  "sset xs = {x. slistmem x xs}"

lemma sset_simp[simp]:
  shows "sset \<bottom> = {}"
    and "sset [::] = {}"
    and "\<lbrakk>x \<noteq> \<bottom>; xs \<noteq> \<bottom>\<rbrakk> \<Longrightarrow> sset (x :# xs) = insert x (sset xs)"
unfolding sset_def by (auto elim: slistmem.cases intro: slistmem.intros)

lemma sset_defined[simp]:
  assumes "x \<in> sset xs"
  shows "x \<noteq> \<bottom>"
using assms sset_def by force

lemma sset_below:
  assumes "y \<in> sset ys"
  assumes "xs \<sqsubseteq> ys"
  assumes "xs \<noteq> \<bottom>"
  obtains x where "x \<in> sset xs" and "x \<sqsubseteq> y"
using assms
proof(induct ys arbitrary: xs)
  case (scons y ys xs) then show ?case by (cases xs) auto
qed simp_all

subsection\<open> Some of the usual operations \<close>

text\<open>

A variety of functions on lists. Drawn from \<^citet>\<open>"Bird:1987"\<close>, @{theory \<open>HOL.List\<close>} and
@{theory \<open>HOLCF-Prelude.Data_List\<close>}. The definitions vary because,
for instance, the strictness of some of those in
@{theory \<open>HOLCF-Prelude.Data_List\<close>} correspond neither to those in
Haskell nor Bird's expectations (specifically \<open>stails\<close>,
\<open>inits\<close>, \<open>sscanl\<close>).

\<close>

fixrec snull :: "[:'a:] \<rightarrow> tr" where
  "snull\<cdot>[::] = TT"
| "\<lbrakk>x \<noteq> \<bottom>; xs \<noteq> \<bottom>\<rbrakk> \<Longrightarrow> snull\<cdot>(x :# xs) = FF"

lemma snull_strict[simp]: "snull\<cdot>\<bottom> = \<bottom>"
by fixrec_simp

lemma snull_bottom_iff[simp]: "(snull\<cdot>xs = \<bottom>) \<longleftrightarrow> (xs = \<bottom>)"
by (cases xs) simp_all

lemma snull_FF_conv: "(snull\<cdot>xxs = FF) \<longleftrightarrow> (\<exists>x xs. xxs \<noteq> \<bottom> \<and> xxs = x :# xs)"
by (cases xxs) simp_all

lemma snull_eq_snil: "snull\<cdot>xs = eq\<cdot>xs\<cdot>[::]"
by (cases xs) simp_all

fixrec smap :: "('a \<rightarrow> 'b) \<rightarrow> [:'a:] \<rightarrow> [:'b:]" where
  "smap\<cdot>f\<cdot>[::] = [::]"
| "\<lbrakk>x \<noteq>\<bottom>; xs \<noteq> \<bottom>\<rbrakk> \<Longrightarrow> smap\<cdot>f\<cdot>(x :# xs) = f\<cdot>x :# smap\<cdot>f\<cdot>xs"

lemma smap_strict[simp]: "smap\<cdot>f\<cdot>\<bottom> = \<bottom>"
by fixrec_simp

lemma smap_bottom_iff[simp]: "(smap\<cdot>f\<cdot>xs = \<bottom>) \<longleftrightarrow> (xs = \<bottom> \<or> (\<exists>x\<in>sset xs. f\<cdot>x = \<bottom>))"
by (induct xs) simp_all

lemma smap_is_snil_conv[simp]:
  "(smap\<cdot>f\<cdot>xs = [::]) \<longleftrightarrow> (xs = [::])"
  "( [::] = smap\<cdot>f\<cdot>xs) \<longleftrightarrow> (xs = [::])"
by (cases xs; simp)+

lemma smap_strict_scons[simp]:
  assumes "f\<cdot>\<bottom> = \<bottom>"
  shows "smap\<cdot>f\<cdot>(x :# xs) = f\<cdot>x :# smap\<cdot>f\<cdot>xs"
using assms by (cases "x :# xs = \<bottom>"; fastforce)

lemma smap_ID': "smap\<cdot>ID\<cdot>xs = xs"
by (induct xs) simp_all

lemma smap_ID[simp]: "smap\<cdot>ID = ID"
by (clarsimp simp: cfun_eq_iff smap_ID')

lemma smap_cong:
  assumes "xs = xs'"
  assumes "\<And>x. x \<in> sset xs \<Longrightarrow> f\<cdot>x = f'\<cdot>x"
  shows "smap\<cdot>f\<cdot>xs = smap\<cdot>f'\<cdot>xs'"
using assms by (induct xs arbitrary: xs') auto

lemma smap_smap'[simp]:
  assumes "f\<cdot>\<bottom> = \<bottom>"
  shows "smap\<cdot>f\<cdot>(smap\<cdot>g\<cdot>xs) = smap\<cdot>(f oo g)\<cdot>xs"
using assms by (induct xs) simp_all

lemma smap_smap[simp]:
  assumes "f\<cdot>\<bottom> = \<bottom>"
  shows "smap\<cdot>f oo smap\<cdot>g = smap\<cdot>(f oo g)"
using assms by (clarsimp simp: cfun_eq_iff)

lemma sset_smap[simp]:
  assumes "\<And>x. x \<in> sset xs \<Longrightarrow> f\<cdot>x \<noteq> \<bottom>"
  shows "sset (smap\<cdot>f\<cdot>xs) = { f\<cdot>x | x. x \<in> sset xs }"
using assms by (induct xs) auto

lemma shead_smap_distr:
  assumes "f\<cdot>\<bottom> = \<bottom>"
  assumes "\<And>x. x\<in>sset xs \<Longrightarrow> f\<cdot>x \<noteq> \<bottom>"
  shows "shead\<cdot>(smap\<cdot>f\<cdot>xs) = f\<cdot>(shead\<cdot>xs)"
using assms by (induct xs) simp_all

fixrec sappend :: "[:'a:] \<rightarrow> [:'a:] \<rightarrow> [:'a:]" where
  "sappend\<cdot>[::]\<cdot>ys = ys"
| "\<lbrakk>x \<noteq> \<bottom>; xs \<noteq> \<bottom>\<rbrakk> \<Longrightarrow> sappend\<cdot>(x :# xs)\<cdot>ys = x :# sappend\<cdot>xs\<cdot>ys"

abbreviation sappend_syn :: "'a slist \<Rightarrow> 'a slist \<Rightarrow> 'a slist" (infixr ":@" 65) where
  "xs :@ ys \<equiv> sappend\<cdot>xs\<cdot>ys"

lemma sappend_strict[simp]: "sappend\<cdot>\<bottom> = \<bottom>"
by fixrec_simp

lemma sappend_strict2[simp]: "xs :@ \<bottom> = \<bottom>"
by (induct xs) simp_all

lemma sappend_bottom_iff[simp]: "(xs :@ ys = \<bottom>) \<longleftrightarrow> (xs = \<bottom> \<or> ys = \<bottom>)"
by (induct xs) simp_all

lemma sappend_scons[simp]: "(x :# xs) :@ ys = x :# xs :@ ys"
by (cases "x :# xs = \<bottom>"; fastforce)

lemma sappend_assoc[simp]: "(xs :@ ys) :@ zs = xs :@ (ys :@ zs)"
by (induct xs) simp_all

lemma sappend_snil_id_left[simp]: "sappend\<cdot>[::] = ID"
by (simp add: cfun_eq_iff)

lemma sappend_snil_id_right[iff]: "xs :@ [::] = xs"
by (induct xs) simp_all

lemma snil_append_iff[iff]: "xs :@ ys = [::] \<longleftrightarrow> xs = [::] \<and> ys = [::]"
by (induct xs) simp_all

lemma smap_sappend[simp]: "smap\<cdot>f\<cdot>(xs :@ ys) = smap\<cdot>f\<cdot>xs :@ smap\<cdot>f\<cdot>ys"
by (induct xs; cases "ys = \<bottom>"; simp)

lemma stail_sappend: "stail\<cdot>(xs :@ ys) = (case xs of [::] \<Rightarrow> stail\<cdot>ys | z :# zs \<Rightarrow> zs :@ ys)"
by (induct xs) simp_all

lemma stail_append2[simp]: "xs \<noteq> [::] \<Longrightarrow> stail\<cdot>(xs :@ ys) = stail\<cdot>xs :@ ys"
by (induct xs) simp_all

lemma slist_case_snoc:
  "g\<cdot>\<bottom>\<cdot>\<bottom> = \<bottom> \<Longrightarrow> slist_case\<cdot>f\<cdot>g\<cdot>(xs :@ [:x:]) = g\<cdot>(shead\<cdot>(xs :@ [:x:]))\<cdot>(stail\<cdot>(xs :@ [:x:]))"
by (cases "x = \<bottom>"; cases xs; clarsimp)

fixrec sall :: "('a \<rightarrow> tr) \<rightarrow> [:'a:] \<rightarrow> tr" where
  "sall\<cdot>p\<cdot>[::] = TT"
| "\<lbrakk>x \<noteq> \<bottom>; xs \<noteq> \<bottom>\<rbrakk> \<Longrightarrow> sall\<cdot>p\<cdot>(x :# xs) = (p\<cdot>x andalso sall\<cdot>p\<cdot>xs)"

lemma sall_strict[simp]: "sall\<cdot>p\<cdot>\<bottom> = \<bottom>"
by fixrec_simp

lemma sall_const_TT[simp]:
  assumes "xs \<noteq> \<bottom>"
  shows "sall\<cdot>(\<Lambda> x. TT)\<cdot>xs = TT"
using assms by (induct xs) simp_all

lemma sall_const_TT_conv[simp]: "(sall\<cdot>(\<Lambda> x. TT)\<cdot>xs = TT) \<longleftrightarrow> (xs \<noteq> \<bottom>)"
by auto

lemma sall_TT[simp]: "(sall\<cdot>p\<cdot>xs = TT) \<longleftrightarrow> (xs \<noteq> \<bottom> \<and> (\<forall>x\<in>sset xs. p\<cdot>x = TT))"
by (induct xs) simp_all

fixrec sfilter :: "('a \<rightarrow> tr) \<rightarrow> [:'a:] \<rightarrow> [:'a:]" where
  "sfilter\<cdot>p\<cdot>[::] = [::]"
| "\<lbrakk>x \<noteq> \<bottom>; xs \<noteq> \<bottom>\<rbrakk> \<Longrightarrow> sfilter\<cdot>p\<cdot>(x :# xs) = If p\<cdot>x then x :# sfilter\<cdot>p\<cdot>xs else sfilter\<cdot>p\<cdot>xs"

lemma sfilter_strict[simp]: "sfilter\<cdot>p\<cdot>\<bottom> = \<bottom>"
by fixrec_simp

lemma sfilter_bottom_iff[simp]: "(sfilter\<cdot>p\<cdot>xs = \<bottom>) \<longleftrightarrow> (xs = \<bottom> \<or> (\<exists>x\<in>sset xs. p\<cdot>x = \<bottom>))"
by (induct xs) (use trE in auto)

lemma sset_sfilter[simp]:
  assumes "\<And>x. x \<in> sset xs \<Longrightarrow> p\<cdot>x \<noteq> \<bottom>"
  shows "sset (sfilter\<cdot>p\<cdot>xs) = {x |x. x \<in> sset xs \<and> p\<cdot>x = TT}"
using assms by (induct xs) (fastforce simp: If2_def[symmetric] split: If2_splits)+

lemma sfilter_strict_scons[simp]:
  assumes "p\<cdot>\<bottom> = \<bottom>"
  shows "sfilter\<cdot>p\<cdot>(x :# xs) = If p\<cdot>x then x :# sfilter\<cdot>p\<cdot>xs else sfilter\<cdot>p\<cdot>xs"
using assms by (cases "x = \<bottom>"; cases "xs = \<bottom>"; simp)

lemma sfilter_scons_let:
  assumes "p\<cdot>\<bottom> = \<bottom>"
  shows "sfilter\<cdot>p\<cdot>(x :# xs) = (let xs' = sfilter\<cdot>p\<cdot>xs in If p\<cdot>x then x :# xs' else xs')"
unfolding Let_def using assms by simp

lemma sfilter_sappend[simp]: "sfilter\<cdot>p\<cdot>(xs :@ ys) = sfilter\<cdot>p\<cdot>xs :@ sfilter\<cdot>p\<cdot>ys"
by (cases "ys"; clarsimp) (induct xs; fastforce simp: If2_def[symmetric] split: If2_splits)

lemma sfilter_const_FF[simp]:
  assumes "xs \<noteq> \<bottom>"
  shows "sfilter\<cdot>(\<Lambda> x. FF)\<cdot>xs = [::]"
using assms by (induct xs) simp_all

lemma sfilter_const_FF_conv[simp]: "(sfilter\<cdot>(\<Lambda> x. FF)\<cdot>xs = [::]) \<longleftrightarrow> (xs \<noteq> \<bottom>)"
by auto

lemma sfilter_const_TT[simp]: "sfilter\<cdot>(\<Lambda> x. TT)\<cdot>xs = xs"
by (induct xs) simp_all

lemma sfilter_cong:
  assumes "xs = xs'"
  assumes "\<And>x. x \<in> sset xs \<Longrightarrow> p\<cdot>x = p'\<cdot>x"
  shows "sfilter\<cdot>p\<cdot>xs = sfilter\<cdot>p'\<cdot>xs'"
using assms by (induct xs arbitrary: xs') auto

lemma sfilter_snil_conv[simp]: "sfilter\<cdot>p\<cdot>xs = [::] \<longleftrightarrow> sall\<cdot>(neg oo p)\<cdot>xs = TT"
by (induct xs; force simp: If2_def[symmetric] split: If2_splits)

lemma sfilter_sfilter': "sfilter\<cdot>p\<cdot>(sfilter\<cdot>q\<cdot>xs) = sfilter\<cdot>(\<Lambda> x. q\<cdot>x andalso p\<cdot>x)\<cdot>xs"
proof(induct xs)
  case (scons x xs) from scons(1, 2) show ?case
    by (cases "sfilter\<cdot>q\<cdot>xs = \<bottom>")
       (simp_all add: If_distr If_andalso scons(3)[symmetric] del: sfilter_bottom_iff)
qed simp_all

lemma sfilter_sfilter: "sfilter\<cdot>p oo sfilter\<cdot>q = sfilter\<cdot>(\<Lambda> x. q\<cdot>x andalso p\<cdot>x)"
by (clarsimp simp: cfun_eq_iff sfilter_sfilter')

lemma sfilter_smap':
  assumes "p\<cdot>\<bottom> = \<bottom>"
  shows "sfilter\<cdot>p\<cdot>(smap\<cdot>f\<cdot>xs) = smap\<cdot>f\<cdot>(sfilter\<cdot>(p oo f)\<cdot>xs)"
using assms by (induct xs; simp add: If2_def[symmetric] split: If2_splits) (metis slist.con_rews(2) smap.simps(2) smap_strict)

lemma sfilter_smap:
  assumes "p\<cdot>\<bottom> = \<bottom>"
  shows "sfilter\<cdot>p oo smap\<cdot>f = smap\<cdot>f oo sfilter\<cdot>(p oo f)"
using assms by (clarsimp simp: cfun_eq_iff sfilter_smap')

fixrec sfoldl :: "('a::pcpo \<rightarrow> 'b::domain \<rightarrow> 'a) \<rightarrow> 'a \<rightarrow> [:'b:] \<rightarrow> 'a" where
  "sfoldl\<cdot>f\<cdot>z\<cdot>[::] = z"
| "\<lbrakk>x \<noteq> \<bottom>; xs \<noteq> \<bottom>\<rbrakk> \<Longrightarrow> sfoldl\<cdot>f\<cdot>z\<cdot>(x :# xs) = sfoldl\<cdot>f\<cdot>(f\<cdot>z\<cdot>x)\<cdot>xs"

lemma sfoldl_strict[simp]: "sfoldl\<cdot>f\<cdot>z\<cdot>\<bottom> = \<bottom>"
by fixrec_simp

lemma sfoldl_strict_f[simp]:
  assumes "f\<cdot>\<bottom> = \<bottom>"
  shows "sfoldl\<cdot>f\<cdot>\<bottom>\<cdot>xs = \<bottom>"
using assms by (induct xs) simp_all

lemma sfoldl_cong:
  assumes "xs = xs'"
  assumes "z = z'"
  assumes "\<And>x z. x \<in> sset xs \<Longrightarrow> f\<cdot>z\<cdot>x = f'\<cdot>z\<cdot>x"
  shows "sfoldl\<cdot>f\<cdot>z\<cdot>xs = sfoldl\<cdot>f'\<cdot>z'\<cdot>xs'"
using assms by (induct xs arbitrary: xs' z z') auto

lemma sfoldl_sappend[simp]:
  assumes "f\<cdot>\<bottom> = \<bottom>"
  shows "sfoldl\<cdot>f\<cdot>z\<cdot>(xs :@ ys) = sfoldl\<cdot>f\<cdot>(sfoldl\<cdot>f\<cdot>z\<cdot>xs)\<cdot>ys"
using assms by (cases "ys = \<bottom>", force) (induct xs arbitrary: z; simp)

fixrec sfoldr :: "('b \<rightarrow> 'a::pcpo \<rightarrow> 'a) \<rightarrow> 'a \<rightarrow> [:'b:] \<rightarrow> 'a" where
  "sfoldr\<cdot>f\<cdot>z\<cdot>[::] = z"
| "\<lbrakk>x \<noteq> \<bottom>; xs \<noteq> \<bottom>\<rbrakk> \<Longrightarrow> sfoldr\<cdot>f\<cdot>z\<cdot>(x :# xs) = f\<cdot>x\<cdot>(sfoldr\<cdot>f\<cdot>z\<cdot>xs)"

lemma sfoldr_strict[simp]: "sfoldr\<cdot>f\<cdot>z\<cdot>\<bottom> = \<bottom>"
by fixrec_simp

fixrec sconcat :: "[:[:'a:]:] \<rightarrow> [:'a:]" where
  "sconcat\<cdot>[::] = [::]"
| "\<lbrakk>x \<noteq> \<bottom>; xs \<noteq> \<bottom>\<rbrakk> \<Longrightarrow> sconcat\<cdot>(x :# xs) = x :@ sconcat\<cdot>xs"

lemma sconcat_scons[simp]:
  shows "sconcat\<cdot>(x :# xs) = x :@ sconcat\<cdot>xs"
by (cases "x = \<bottom>", force) (induct xs; fastforce)

lemma sconcat_sfoldl_aux: "sfoldl\<cdot>sappend\<cdot>z\<cdot>xs = z :@ sconcat\<cdot>xs"
by (induct xs arbitrary: z) simp_all

lemma sconcat_sfoldl: "sconcat = sfoldl\<cdot>sappend\<cdot>[::]"
by (clarsimp simp: cfun_eq_iff sconcat_sfoldl_aux)

lemma sconcat_sappend[simp]: "sconcat\<cdot>(xs :@ ys) = sconcat\<cdot>xs :@ sconcat\<cdot>ys"
by (induct xs) simp_all

fixrec slength :: "[:'a:] \<rightarrow> Integer"
where
  "slength\<cdot>[::] = 0"
| "\<lbrakk>x \<noteq> \<bottom>; xs \<noteq> \<bottom>\<rbrakk> \<Longrightarrow> slength\<cdot>(x :# xs) = slength\<cdot>xs + 1"

lemma slength_strict[simp]: "slength\<cdot>\<bottom> = \<bottom>"
by fixrec_simp

lemma slength_bottom_iff[simp]: "(slength\<cdot>xs = \<bottom>) \<longleftrightarrow> (xs = \<bottom>)"
by (induct xs) force+

lemma slength_ge_0: "slength\<cdot>xs = MkI\<cdot>n \<Longrightarrow> n \<ge> 0"
by (induct xs arbitrary: n) (simp add: one_Integer_def plus_eq_MkI_conv; force)+

lemma slengthE:
  shows "\<lbrakk>xs \<noteq> \<bottom>; \<And>n. \<lbrakk>slength\<cdot>xs = MkI\<cdot>n; 0 \<le> n\<rbrakk> \<Longrightarrow> Q\<rbrakk> \<Longrightarrow> Q"
by (meson Integer.exhaust slength_bottom_iff slength_ge_0)

lemma slength_0_conv[simp]:
  "(slength\<cdot>xs = 0) \<longleftrightarrow> (xs = [::])"
  "(slength\<cdot>xs = MkI\<cdot>0) \<longleftrightarrow> (xs = [::])"
  "eq\<cdot>0\<cdot>(slength\<cdot>xs) = snull\<cdot>xs"
  "eq\<cdot>(slength\<cdot>xs)\<cdot>0 = snull\<cdot>xs"
by (induct xs) (auto simp: one_Integer_def elim: slengthE)

lemma le_slength_0[simp]: "(le\<cdot>0\<cdot>(slength\<cdot>xs) = TT) \<longleftrightarrow> (xs \<noteq> \<bottom>)"
by (cases "slength\<cdot>xs") (auto simp: slength_ge_0 zero_Integer_def)

lemma lt_slength_0[simp]:
  "xs \<noteq> \<bottom> \<Longrightarrow> lt\<cdot>(slength\<cdot>xs)\<cdot>0 = FF"
  "xs \<noteq> \<bottom> \<Longrightarrow> lt\<cdot>(slength\<cdot>xs)\<cdot>(slength\<cdot>xs + 1) = TT"
unfolding zero_Integer_def one_Integer_def by (auto elim: slengthE)

lemma slength_smap[simp]:
  assumes "\<And>x. x \<noteq> \<bottom> \<Longrightarrow> f\<cdot>x \<noteq> \<bottom>"
  shows "slength\<cdot>(smap\<cdot>f\<cdot>xs) = slength\<cdot>xs"
using assms by (induct xs) simp_all

lemma slength_sappend[simp]: "slength\<cdot>(xs :@ ys) = slength\<cdot>xs + slength\<cdot>ys"
by (cases "ys = \<bottom>", force) (induct xs; force simp: ac_simps)

lemma slength_sfoldl_aux: "sfoldl\<cdot>(\<Lambda> i _. i + 1)\<cdot>z\<cdot>xs = z + slength\<cdot>xs"
by (induct xs arbitrary: z) (simp_all add: ac_simps)

lemma slength_sfoldl: "slength = sfoldl\<cdot>(\<Lambda> i _. i + 1)\<cdot>0"
by (clarsimp simp: cfun_eq_iff slength_sfoldl_aux)

lemma le_slength_plus:
  assumes "xs \<noteq> \<bottom>"
  assumes "n \<noteq> \<bottom>"
  shows "le\<cdot>n\<cdot>(slength\<cdot>xs + n) = TT"
using assms by (cases n; force elim: slengthE)

fixrec srev :: "[:'a:] \<rightarrow> [:'a:]" where
  "srev\<cdot>[::] = [::]"
| "\<lbrakk>x \<noteq> \<bottom>; xs \<noteq> \<bottom>\<rbrakk> \<Longrightarrow> srev\<cdot>(x :# xs) = srev\<cdot>xs :@ [:x:]"

lemma srev_strict[simp]: "srev\<cdot>\<bottom> = \<bottom>"
by fixrec_simp

lemma srev_bottom_iff[simp]: "(srev\<cdot>xs = \<bottom>) \<longleftrightarrow> (xs = \<bottom>)"
by (induct xs) simp_all

lemma srev_scons[simp]: "srev\<cdot>(x :# xs) = srev\<cdot>xs :@ [:x:]"
by (cases "x = \<bottom>", clarsimp) (induct xs; force)

lemma srev_sappend[simp]: "srev\<cdot>(xs :@ ys) = srev\<cdot>ys :@ srev\<cdot>xs"
by (induct xs) simp_all

lemma srev_srev_ident[simp]: "srev\<cdot>(srev\<cdot>xs) = xs"
by (induct xs) auto

lemma srev_cases[case_names bottom snil ssnoc]:
  assumes "xs = \<bottom> \<Longrightarrow> P"
  assumes "xs = [::] \<Longrightarrow> P"
  assumes "\<And>y ys. \<lbrakk>y \<noteq> \<bottom>; ys \<noteq> \<bottom>; xs = ys :@ [:y:]\<rbrakk> \<Longrightarrow> P"
  shows "P"
using assms by (metis slist.exhaust srev.simps(1) srev_scons srev_srev_ident srev_strict)

lemma srev_induct[case_names bottom snil ssnoc]:
  assumes "P \<bottom>"
  assumes "P [::]"
  assumes "\<And>x xs. \<lbrakk>x \<noteq> \<bottom>; xs \<noteq> \<bottom>; P xs\<rbrakk> \<Longrightarrow> P (xs :@ [:x:])"
  shows "P xs"
proof -
  have "P (srev\<cdot>(srev\<cdot>xs))" by (rule slist.induct[where x="srev\<cdot>xs"]; simp add: assms)
  then show ?thesis by simp
qed

lemma sfoldr_conv_sfoldl:
  assumes "\<And>x. f\<cdot>x\<cdot>\<bottom> = \<bottom>" \<comment>\<open>\<open>f\<close> must be strict in the accumulator.\<close>
  shows "sfoldr\<cdot>f\<cdot>z\<cdot>xs = sfoldl\<cdot>(\<Lambda> acc x. f\<cdot>x\<cdot>acc)\<cdot>z\<cdot>(srev\<cdot>xs)"
using assms by (induct xs arbitrary: z) simp_all

fixrec stake :: "Integer \<rightarrow> [:'a:] \<rightarrow> [:'a:]" where \<comment>\<open> Note: strict in both parameters. \<close>
  "stake\<cdot>\<bottom>\<cdot>\<bottom> = \<bottom>"
| "i \<noteq> \<bottom> \<Longrightarrow> stake\<cdot>i\<cdot>[::] = [::]"
| "\<lbrakk>x \<noteq> \<bottom>; xs \<noteq> \<bottom>\<rbrakk> \<Longrightarrow> stake\<cdot>i\<cdot>(x :# xs) = If le\<cdot>i\<cdot>0 then [::] else x :# stake\<cdot>(i - 1)\<cdot>xs"

lemma stake_strict[simp]:
  "stake\<cdot>\<bottom> = \<bottom>"
  "stake\<cdot>i\<cdot>\<bottom> = \<bottom>"
by fixrec_simp+

lemma stake_bottom_iff[simp]: "(stake\<cdot>i\<cdot>xs = \<bottom>) \<longleftrightarrow> (i = \<bottom> \<or> xs = \<bottom>)"
by (induct xs arbitrary: i; clarsimp; case_tac i; clarsimp)

lemma stake_0[simp]:
  "xs \<noteq> \<bottom> \<Longrightarrow> stake\<cdot>0\<cdot>xs = [::]"
  "xs \<noteq> \<bottom> \<Longrightarrow> stake\<cdot>(MkI\<cdot>0)\<cdot>xs = [::]"
  "stake\<cdot>0\<cdot>xs \<sqsubseteq> [::]"
by (cases xs; simp add: zero_Integer_def)+

lemma stake_scons[simp]: "le\<cdot>1\<cdot>i = TT \<Longrightarrow> stake\<cdot>i\<cdot>(x :# xs) = x :# stake\<cdot>(i - 1)\<cdot>xs"
by (cases i; cases "x = \<bottom>"; cases "xs = \<bottom>";
    simp add: zero_Integer_def one_Integer_def split: if_splits)

lemma take_MkI_scons[simp]:
  "0 < n \<Longrightarrow> stake\<cdot>(MkI\<cdot>n)\<cdot>(x :# xs) = x :# stake\<cdot>(MkI\<cdot>(n - 1))\<cdot>xs"
by (cases "x = \<bottom>"; cases "xs = \<bottom>"; simp add: zero_Integer_def one_Integer_def)

lemma stake_numeral_scons[simp]:
  "xs \<noteq> \<bottom> \<Longrightarrow> stake\<cdot>1\<cdot>(x :# xs) = [:x:]"
  "stake\<cdot>(numeral (Num.Bit0 k))\<cdot>(x :# xs) = x :# stake\<cdot>(numeral (Num.BitM k))\<cdot>xs"
  "stake\<cdot>(numeral (Num.Bit1 k))\<cdot>(x :# xs) = x :# stake\<cdot>(numeral (Num.Bit0 k))\<cdot>xs"
by (cases "x = \<bottom>"; cases xs; simp add: zero_Integer_def one_Integer_def numeral_Integer_eq)+

lemma stake_all:
  assumes "le\<cdot>(slength\<cdot>xs)\<cdot>i = TT"
  shows "stake\<cdot>i\<cdot>xs = xs"
using assms
proof(induct xs arbitrary: i)
  case (scons x xs i) then show ?case
    by (cases i; clarsimp simp: If2_def[symmetric] zero_Integer_def one_Integer_def split: If2_splits if_splits elim!: slengthE)
qed (simp_all add: le_defined)

lemma stake_all_triv[simp]: "stake\<cdot>(slength\<cdot>xs)\<cdot>xs = xs"
by (cases "xs = \<bottom>") (auto simp: stake_all)

lemma stake_append[simp]: "stake\<cdot>i\<cdot>(xs :@ ys) = stake\<cdot>i\<cdot>xs :@ stake\<cdot>(i - slength\<cdot>xs)\<cdot>ys"
proof(induct xs arbitrary: i)
  case (snil i) then show ?case by (cases i; simp add: zero_Integer_def)
next
  case (scons x xs i) then show ?case
    by (cases i; cases ys; clarsimp simp: If2_def[symmetric] zero_Integer_def one_Integer_def split: If2_splits  elim!: slengthE)
qed simp_all

fixrec sdrop :: "Integer \<rightarrow> [:'a:] \<rightarrow> [:'a:]" where \<comment>\<open> Note: strict in both parameters. \<close>
  [simp del]: "sdrop\<cdot>i\<cdot>xs = If le\<cdot>i\<cdot>0 then xs else (case xs of [::] \<Rightarrow> [::] | y :# ys \<Rightarrow> sdrop\<cdot>(i - 1)\<cdot>ys)"

lemma sdrop_strict[simp]:
  "sdrop\<cdot>\<bottom> = \<bottom>"
  "sdrop\<cdot>i\<cdot>\<bottom> = \<bottom>"
by fixrec_simp+

lemma sdrop_bottom_iff[simp]: "(sdrop\<cdot>i\<cdot>xs = \<bottom>) \<longleftrightarrow> (i = \<bottom> \<or> xs = \<bottom>)"
proof(induct xs arbitrary: i)
  case (snil i) then show ?case by (subst sdrop.unfold) (cases i; simp)
next
  case (scons x xs i) then show ?case by (subst sdrop.unfold) fastforce
qed simp

lemma sdrop_snil[simp]:
  assumes "i \<noteq> \<bottom>"
  shows "sdrop\<cdot>i\<cdot>[::] = [::]"
using assms by (subst sdrop.unfold; fastforce)

lemma sdrop_snil_conv[simp]: "(sdrop\<cdot>i\<cdot>[::] = [::]) \<longleftrightarrow> (i \<noteq> \<bottom>)"
by (subst sdrop.unfold; fastforce)

lemma sdrop_0[simp]:
  "sdrop\<cdot>0\<cdot>xs = xs"
  "sdrop\<cdot>(MkI\<cdot>0)\<cdot>xs = xs"
by (subst sdrop.simps, simp add: zero_Integer_def)+

lemma sdrop_pos:
  "le\<cdot>i\<cdot>0 = FF \<Longrightarrow> sdrop\<cdot>i\<cdot>xs = (case xs of [::] \<Rightarrow> [::] | y :# ys \<Rightarrow> sdrop\<cdot>(i - 1)\<cdot>ys)"
by (subst sdrop.simps, simp)

lemma sdrop_neg:
  "le\<cdot>i\<cdot>0 = TT \<Longrightarrow> sdrop\<cdot>i\<cdot>xs = xs"
by (subst sdrop.simps, simp)

lemma sdrop_numeral_scons[simp]:
  "x \<noteq> \<bottom> \<Longrightarrow> sdrop\<cdot>1\<cdot>(x :# xs) = xs"
  "x \<noteq> \<bottom> \<Longrightarrow> sdrop\<cdot>(numeral (Num.Bit0 k))\<cdot>(x :# xs) = sdrop\<cdot>(numeral (Num.BitM k))\<cdot>xs"
  "x \<noteq> \<bottom> \<Longrightarrow> sdrop\<cdot>(numeral (Num.Bit1 k))\<cdot>(x :# xs) = sdrop\<cdot>(numeral (Num.Bit0 k))\<cdot>xs"
by (subst sdrop.simps,
    simp add: zero_Integer_def one_Integer_def numeral_Integer_eq; cases xs; simp)+

lemma sdrop_all:
  assumes "le\<cdot>(slength\<cdot>xs)\<cdot>i = TT"
  shows "sdrop\<cdot>i\<cdot>xs = [::]"
using assms
proof(induct xs arbitrary: i)
  case (scons x xs i) then show ?case
    by (subst sdrop.unfold; cases i;
        clarsimp simp: If2_def[symmetric] zero_Integer_def one_Integer_def split: If2_splits if_splits elim!: slengthE)
qed (simp_all add: le_defined)

lemma slength_sdrop[simp]:
  "slength\<cdot>(sdrop\<cdot>i\<cdot>xs) = If le\<cdot>i\<cdot>0 then slength\<cdot>xs else If le\<cdot>(slength\<cdot>xs)\<cdot>i then 0 else slength\<cdot>xs - i"
proof(induct xs arbitrary: i)
  case (snil i) then show ?case by (cases i; simp add: zero_Integer_def)
next
  case (scons x xs i) then show ?case
    by (subst sdrop.unfold; cases i; clarsimp simp: zero_Integer_def one_Integer_def elim!: slengthE)
qed simp

lemma sdrop_not_snilD:
  assumes "sdrop\<cdot>(MkI\<cdot>i)\<cdot>xs \<noteq> [::]"
  assumes "xs \<noteq> \<bottom>"
  shows "lt\<cdot>(MkI\<cdot>i)\<cdot>(slength\<cdot>xs) = TT \<and> xs \<noteq> [::]"
using assms
proof(induct xs arbitrary: i)
  case (scons x xs i) then show ?case
    by (subst (asm) (2) sdrop.unfold, clarsimp simp: zero_Integer_def one_Integer_def not_le sdrop_all elim!: slengthE)
qed simp_all

lemma sdrop_sappend_same:
  assumes "xs \<noteq> \<bottom>"
  shows "sdrop\<cdot>(slength\<cdot>xs)\<cdot>(xs :@ ys) = ys"
using assms
proof(induct xs arbitrary: ys)
  case (scons x xs ys) then show ?case
    by (cases "ys = \<bottom>"; subst sdrop.unfold; clarsimp simp: zero_Integer_def one_Integer_def elim!: slengthE)
qed simp_all

fixrec sscanl :: "('a \<rightarrow> 'b \<rightarrow> 'a) \<rightarrow> 'a \<rightarrow> [:'b:] \<rightarrow> [:'a:]" where
  "sscanl\<cdot>f\<cdot>z\<cdot>[::] = z :# [::]"
| "\<lbrakk>x \<noteq> \<bottom>; xs \<noteq> \<bottom>\<rbrakk> \<Longrightarrow> sscanl\<cdot>f\<cdot>z\<cdot>(x :# xs) = z :# sscanl\<cdot>f\<cdot>(f\<cdot>z\<cdot>x)\<cdot>xs"

lemma sscanl_strict[simp]:
  "sscanl\<cdot>f\<cdot>\<bottom>\<cdot>xs = \<bottom>"
  "sscanl\<cdot>f\<cdot>z\<cdot>\<bottom> = \<bottom>"
by (cases xs) fixrec_simp+

lemma sscanl_cong:
  assumes "xs = xs'"
  assumes "z = z'"
  assumes "\<And>x z. x \<in> sset xs \<Longrightarrow> f\<cdot>z\<cdot>x = f'\<cdot>z\<cdot>x"
  shows "sscanl\<cdot>f\<cdot>z\<cdot>xs = sscanl\<cdot>f'\<cdot>z'\<cdot>xs'"
using assms by (induct xs arbitrary: xs' z z') auto

lemma sscanl_lfp_fusion':
  assumes "g\<cdot>\<bottom> = \<bottom>"
  assumes *: "\<And>acc x. x \<noteq> \<bottom> \<Longrightarrow> g\<cdot>(f\<cdot>acc\<cdot>x) = f'\<cdot>(g\<cdot>acc)\<cdot>x"
  shows "smap\<cdot>g\<cdot>(sscanl\<cdot>f\<cdot>z\<cdot>xs) = sscanl\<cdot>f'\<cdot>(g\<cdot>z)\<cdot>xs"
using assms by (induct xs arbitrary: z) simp_all

lemma sscanl_lfp_fusion:
  assumes "g\<cdot>\<bottom> = \<bottom>"
  assumes *: "\<And>acc x. x \<noteq> \<bottom> \<Longrightarrow> g\<cdot>(f\<cdot>acc\<cdot>x) = f'\<cdot>(g\<cdot>acc)\<cdot>x"
  shows "smap\<cdot>g oo sscanl\<cdot>f\<cdot>z = sscanl\<cdot>f'\<cdot>(g\<cdot>z)"
using assms by (clarsimp simp: cfun_eq_iff sscanl_lfp_fusion')

lemma sscanl_ww_fusion': \<comment>\<open> Worker/wrapper \<^citep>\<open>"GillHutton:2009" and "Gammie:2011"\<close> specialised to @{const \<open>sscanl\<close>} \<close>
  fixes wrap :: "'b \<rightarrow> 'a"
  fixes unwrap :: "'a \<rightarrow> 'b"
  fixes z :: "'a"
  fixes f :: "'a \<rightarrow> 'c \<rightarrow> 'a"
  fixes f' :: "'b \<rightarrow> 'c \<rightarrow> 'b"
  assumes ww: "wrap oo unwrap = ID"
  assumes wb: "\<And>z x. x \<noteq> \<bottom> \<Longrightarrow> unwrap\<cdot>(f\<cdot>(wrap\<cdot>z)\<cdot>x) = f'\<cdot>(unwrap\<cdot>(wrap\<cdot>z))\<cdot>x"
  shows "sscanl\<cdot>f\<cdot>z\<cdot>xs = smap\<cdot>wrap\<cdot>(sscanl\<cdot>f'\<cdot>(unwrap\<cdot>z)\<cdot>xs)"
using assms
by (induct xs arbitrary: z) (simp add: cfun_eq_iff retraction_cfcomp_strict | metis)+

lemma sscanl_ww_fusion: \<comment>\<open> Worker/wrapper \<^citep>\<open>"GillHutton:2009" and "Gammie:2011"\<close> specialised to @{const \<open>sscanl\<close>} \<close>
  fixes wrap :: "'b \<rightarrow> 'a"
  fixes unwrap :: "'a \<rightarrow> 'b"
  fixes z :: "'a"
  fixes f :: "'a \<rightarrow> 'c \<rightarrow> 'a"
  fixes f' :: "'b \<rightarrow> 'c \<rightarrow> 'b"
  assumes ww: "wrap oo unwrap = ID"
  assumes wb: "\<And>z x. x \<noteq> \<bottom> \<Longrightarrow> unwrap\<cdot>(f\<cdot>(wrap\<cdot>z)\<cdot>x) = f'\<cdot>(unwrap\<cdot>(wrap\<cdot>z))\<cdot>x"
  shows "sscanl\<cdot>f\<cdot>z = smap\<cdot>wrap oo sscanl\<cdot>f'\<cdot>(unwrap\<cdot>z)"
using assms by (clarsimp simp: cfun_eq_iff sscanl_ww_fusion')

fixrec sinits :: "[:'a:] \<rightarrow> [:[:'a:]:]" where
  "sinits\<cdot>[::] = [::] :# [::]"
| "\<lbrakk>x \<noteq> \<bottom>; xs \<noteq> \<bottom>\<rbrakk> \<Longrightarrow> sinits\<cdot>(x :# xs) = [::] :# smap\<cdot>(scons\<cdot>x)\<cdot>(sinits\<cdot>xs)"

lemma sinits_strict[simp]: "sinits\<cdot>\<bottom> = \<bottom>"
by fixrec_simp

lemma sinits_bottom_iff[simp]: "(sinits\<cdot>xs = \<bottom>) \<longleftrightarrow> (xs = \<bottom>)"
by (induct xs) simp_all

lemma sinits_not_snil[iff]: "sinits\<cdot>xs \<noteq> [::]"
by (cases xs) simp_all

lemma sinits_empty_bottom[simp]: "(sset (sinits\<cdot>xs) = {}) \<longleftrightarrow> (xs = \<bottom>)"
by (cases xs) simp_all

lemma sinits_scons[simp]: "sinits\<cdot>(x :# xs) = [::] :# smap\<cdot>(x :#)\<cdot>(sinits\<cdot>xs)"
by (cases "x = \<bottom>", force) (induct xs; force)

lemma sinits_length[simp]: "slength\<cdot>(sinits\<cdot>xs) = slength\<cdot>xs + 1"
by (induct xs) simp_all

lemma sinits_snoc[simp]: "sinits\<cdot>(xs :@ [:x:]) = sinits\<cdot>xs :@ [:xs :@ [:x:]:]"
by (induct xs) simp_all

lemma sinits_foldr': \<comment>\<open> \<^citet>\<open>\<open>p30\<close> in "Bird:1987"\<close> \<close>
  shows "sinits\<cdot>xs = sfoldr\<cdot>(\<Lambda> x xs. [:[::]:] :@ smap\<cdot>(x :#)\<cdot>xs)\<cdot>[:[::]:]\<cdot>xs"
by (induct xs) simp_all

lemma sinits_sscanl':
  shows "smap\<cdot>(sfoldl\<cdot>f\<cdot>z)\<cdot>(sinits\<cdot>xs) = sscanl\<cdot>f\<cdot>z\<cdot>xs"
by (induct xs arbitrary: z) (simp_all cong: smap_cong add: oo_def eta_cfun)

lemma sinits_sscanl: \<comment>\<open> \<^citet>\<open>\<open>Lemma~5\<close> in "Bird:1987"\<close>, \<^citet>\<open>\<open>p118 ``the scan lemma''\<close> in "Bird:PearlsofFAD:2010"\<close> \<close>
  shows "smap\<cdot>(sfoldl\<cdot>f\<cdot>z) oo sinits = sscanl\<cdot>f\<cdot>z"
by (simp add: sinits_sscanl' cfun_eq_iff)

lemma sinits_all[simp]: "(xs \<in> sset (sinits\<cdot>xs)) \<longleftrightarrow> (xs \<noteq> \<bottom>)"
by (induct xs) simp_all

fixrec stails :: "[:'a:] \<rightarrow> [:[:'a:]:]" where
  "stails\<cdot>[::] = [::] :# [::]"
| "\<lbrakk>x \<noteq> \<bottom>; xs \<noteq> \<bottom>\<rbrakk> \<Longrightarrow> stails\<cdot>(x :# xs) = (x :# xs) :# stails\<cdot>xs"

lemma stails_strict[simp]: "stails\<cdot>\<bottom> = \<bottom>"
by fixrec_simp

lemma stails_bottom_iff[simp]: "(stails\<cdot>xs = \<bottom>) \<longleftrightarrow> (xs = \<bottom>)"
by (induct xs) simp_all

lemma stails_not_snil[iff]: "stails\<cdot>xs \<noteq> [::]"
by (cases xs) simp_all

lemma stails_scons[simp]: "stails\<cdot>(x :# xs) = (x :# xs) :# stails\<cdot>xs"
by (induct xs) (cases "x = \<bottom>"; simp)+

lemma stails_slength[simp]: "slength\<cdot>(stails\<cdot>xs) = slength\<cdot>xs + 1"
by (induct xs) simp_all

lemma stails_snoc[simp]:
  shows "stails\<cdot>(xs :@ [:x:]) = smap\<cdot>(\<Lambda> ys. ys :@ [:x:])\<cdot>(stails\<cdot>xs) :@ [:[::]:]"
by (induct xs) simp_all

lemma stails_sfoldl':
  shows "stails\<cdot>xs = sfoldl\<cdot>(\<Lambda> xs x. smap\<cdot>(\<Lambda> ys. ys :@ [:x:])\<cdot>xs :@ [:[::]:])\<cdot>[:[::]:]\<cdot>xs"
by (induct xs rule: srev_induct) simp_all

lemma stails_sfoldl:
  shows "stails = sfoldl\<cdot>(\<Lambda> xs x. smap\<cdot>(\<Lambda> ys. ys :@ [:x:])\<cdot>xs :@ [:[::]:])\<cdot>[:[::]:]"
by (clarsimp simp: cfun_eq_iff stails_sfoldl')

fixrec selem :: "'a::Eq_def \<rightarrow> [:'a:] \<rightarrow> tr" where
  "selem\<cdot>x\<cdot>[::] = FF"
| "\<lbrakk>y \<noteq> \<bottom>; ys \<noteq> \<bottom>\<rbrakk> \<Longrightarrow> selem\<cdot>x\<cdot>(y :# ys) = (eq\<cdot>x\<cdot>y orelse selem\<cdot>x\<cdot>ys)"

lemma selem_strict[simp]: "selem\<cdot>x\<cdot>\<bottom> = \<bottom>"
by fixrec_simp

lemma selem_bottom_iff[simp]: "(selem\<cdot>x\<cdot>xs = \<bottom>) \<longleftrightarrow> (xs = \<bottom> \<or> (xs \<noteq> [::] \<and> x = \<bottom>))"
by (induct xs) auto

lemma selem_sappend[simp]:
  assumes "ys \<noteq> \<bottom>"
  shows "selem\<cdot>x\<cdot>(xs :@ ys) = (selem\<cdot>x\<cdot>xs orelse selem\<cdot>x\<cdot>ys)"
using assms by (induct xs) simp_all

lemma elem_TT[simp]: "(selem\<cdot>x\<cdot>xs = TT) \<longleftrightarrow> (x \<in> sset xs)"
by (induct xs; auto) (metis sset_defined)+

lemma elem_FF[simp]: "(selem\<cdot>x\<cdot>xs = FF) \<longleftrightarrow> (xs = [::] \<or> (x \<noteq> \<bottom> \<and> xs \<noteq> \<bottom> \<and> x \<notin> sset xs))"
by (induct xs) auto

lemma selem_snil_stails[iff]:
  assumes "xs \<noteq> \<bottom>"
  shows "selem\<cdot>[::]\<cdot>(stails\<cdot>xs) = TT"
using assms by (induct xs) simp_all

fixrec sconcatMap :: "('a \<rightarrow> [:'b:]) \<rightarrow> [:'a:] \<rightarrow> [:'b:]" where
[simp del]: "sconcatMap\<cdot>f = sconcat oo smap\<cdot>f"

lemma sconcatMap_strict[simp]: "sconcatMap\<cdot>f\<cdot>\<bottom> = \<bottom>"
by fixrec_simp

lemma sconcatMap_snil[simp]: "sconcatMap\<cdot>f\<cdot>[::] = [::]"
by fixrec_simp

lemma sconcatMap_scons[simp]: "x \<noteq> \<bottom> \<Longrightarrow> sconcatMap\<cdot>f\<cdot>(x :# xs) = f\<cdot>x :@ sconcatMap\<cdot>f\<cdot>xs"
by (cases "xs = \<bottom>"; simp add: sconcatMap.unfold)

lemma sconcatMap_bottom_iff[simp]: "(sconcatMap\<cdot>f\<cdot>xs = \<bottom>) \<longleftrightarrow> (xs = \<bottom> \<or> (\<exists>x\<in>sset xs. f\<cdot>x = \<bottom>))"
by (induct xs) simp_all

lemma sconcatMap_sappend[simp]: "sconcatMap\<cdot>f\<cdot>(xs :@ ys) = sconcatMap\<cdot>f\<cdot>xs :@ sconcatMap\<cdot>f\<cdot>ys"
by (induct xs) simp_all

lemma sconcatMap_monad_laws:
  "sconcatMap\<cdot>(\<Lambda> x. [:x:])\<cdot>xs = xs"
  "sconcatMap\<cdot>g\<cdot>(sconcatMap\<cdot>f\<cdot>xs) = sconcatMap\<cdot>(\<Lambda> x. sconcatMap\<cdot>g\<cdot>(f\<cdot>x))\<cdot>xs"
by (induct xs) simp_all

fixrec supto :: "Integer \<rightarrow> Integer \<rightarrow> [:Integer:]" where
  [simp del]: "supto\<cdot>i\<cdot>j = If le\<cdot>i\<cdot>j then i :# supto\<cdot>(i+1)\<cdot>j else [::]"

lemma upto_strict[simp]:
  "supto\<cdot>\<bottom> = \<bottom>"
  "supto\<cdot>m\<cdot>\<bottom> = \<bottom>"
by fixrec_simp+

lemma supto_is_snil_conv[simp]:
  "(supto\<cdot>(MkI\<cdot>i)\<cdot>(MkI\<cdot>j) = [::]) \<longleftrightarrow> (j < i)"
  "([::] = supto\<cdot>(MkI\<cdot>i)\<cdot>(MkI\<cdot>j)) \<longleftrightarrow> (j < i)"
by (subst supto.unfold; simp)+

lemma supto_simp[simp]:
  "j < i \<Longrightarrow> supto\<cdot>(MkI\<cdot>i)\<cdot>(MkI\<cdot>j) = [::]"
  "i \<le> j \<Longrightarrow> supto\<cdot>(MkI\<cdot>i)\<cdot>(MkI\<cdot>j) = MkI\<cdot>i :# supto\<cdot>(MkI\<cdot>i+1)\<cdot>(MkI\<cdot>j)"
  "supto\<cdot>0\<cdot>0 = [:0:]"
by (subst supto.simps, simp)+

lemma supto_defined[simp]: "supto\<cdot>(MkI\<cdot>i)\<cdot>(MkI\<cdot>j) \<noteq> \<bottom>" (is "?P i j")
proof (cases "j - i")
  fix d
  assume "j - i = int d"
  then show "?P i j"
  proof (induct d arbitrary: i j)
    case (Suc d i j)
    then have "j - (i + 1) = int d" and le: "i \<le> j" by simp_all
    from Suc(1)[OF this(1)] have IH: "?P (i+1) j" .
    then show ?case using le by (simp add: one_Integer_def)
  qed (simp add: one_Integer_def)
next
  fix d
  assume "j - i = - int d"
  then have "j \<le> i" by auto
  moreover
  { assume "j = i" then have "?P i j" by (simp add: one_Integer_def) }
  moreover
  { assume "j < i" then have "?P i j" by (simp add: one_Integer_def) }
  ultimately show ?thesis by arith
qed

lemma supto_bottom_iff[simp]:
  "(supto\<cdot>i\<cdot>j = \<bottom>) \<longleftrightarrow> (i = \<bottom> \<or> j = \<bottom>)"
by (cases i; simp; cases j; simp)

lemma supto_snoc[simp]:
  "i \<le> j \<Longrightarrow> supto\<cdot>(MkI\<cdot>i)\<cdot>(MkI\<cdot>j) = supto\<cdot>(MkI\<cdot>i)\<cdot>(MkI\<cdot>j-1) :@ [:MkI\<cdot>j:]"
proof(induct "nat(j - i)" arbitrary: i j)
  case 0 then show ?case by (simp add: one_Integer_def)
next
  case (Suc k i j)
  then have "k = nat (j - (i + 1))" "i < j" by linarith+
  from this(2) Suc.hyps(1)[OF this(1)] Suc(2,3) show ?case by (simp add: one_Integer_def)
qed

lemma slength_supto[simp]: "slength\<cdot>(supto\<cdot>(MkI\<cdot>i)\<cdot>(MkI\<cdot>j)) = MkI\<cdot>(if j < i then 0 else j - i + 1)" (is "?P i j")
proof (cases "j - i")
  fix d
  assume "j - i = int d"
  then show "?P i j"
  proof (induct d arbitrary: i j)
    case (Suc d i j)
    then have "j - (i + 1) = int d" and le: "i \<le> j" by simp_all
    from Suc(1)[OF this(1)] have IH: "?P (i+1) j" .
    then show ?case using le by (simp add: one_Integer_def)
  qed (simp add: one_Integer_def)
next
  fix d
  assume "j - i = - int d"
  then have "j \<le> i" by auto
  moreover
  { assume "j = i" then have "?P i j" by (simp add: one_Integer_def) }
  moreover
  { assume "j < i" then have "?P i j" by (simp add: one_Integer_def) }
  ultimately show ?thesis by arith
qed

lemma sset_supto[simp]:
  "sset (supto\<cdot>(MkI\<cdot>i)\<cdot>(MkI\<cdot>j)) = {MkI\<cdot>k |k. i \<le> k \<and> k \<le> j}" (is "sset (?u i j) = ?R i j")
proof (cases "j - i")
  case (nonneg k)
  then show ?thesis
  proof (induct k arbitrary: i j)
    case (Suc k)
    then have *: "j - (i + 1) = int k" by simp
    from Suc(1)[OF *] have IH: "sset (?u (i+1) j) = ?R (i+1) j" .
    from * have "i \<le> j" by simp
    then have "sset (?u i j) = sset (MkI\<cdot>i :# ?u (i+1) j)" by (simp add: one_Integer_def)
    also have "\<dots> = insert (MkI\<cdot>i) (?R (i+1) j)" by (simp add: IH)
    also have "\<dots> = ?R i j" using \<open>i \<le> j\<close> by auto
    finally show ?case .
  qed (force simp: one_Integer_def)
qed simp

lemma supto_split1: \<comment>\<open>From \<open>HOL.List\<close>\<close>
  assumes "i \<le> j"
  assumes "j \<le> k"
  shows "supto\<cdot>(MkI\<cdot>i)\<cdot>(MkI\<cdot>k) = supto\<cdot>(MkI\<cdot>i)\<cdot>(MkI\<cdot>(j - 1)) :@ supto\<cdot>(MkI\<cdot>j)\<cdot>(MkI\<cdot>k)"
using assms
proof (induct j rule: int_ge_induct)
  case (step l) with supto_simp(2) supto_snoc show ?case by (clarsimp simp: one_Integer_def)
qed simp

lemma supto_split3: \<comment>\<open>From \<open>HOL.List\<close>\<close>
  assumes "i \<le> j"
  assumes "j \<le> k"
  shows "supto\<cdot>(MkI\<cdot>i)\<cdot>(MkI\<cdot>k) = supto\<cdot>(MkI\<cdot>i)\<cdot>(MkI\<cdot>(j - 1)) :@ MkI\<cdot>j :# supto\<cdot>(MkI\<cdot>(j + 1))\<cdot>(MkI\<cdot>k)"
using assms supto_simp(2) supto_split1 by (metis one_Integer_def plus_MkI_MkI)

lemma sinits_stake':
  shows "sinits\<cdot>xs = smap\<cdot>(\<Lambda> i. stake\<cdot>i\<cdot>xs)\<cdot>(supto\<cdot>0\<cdot>(slength\<cdot>xs))"
proof(induct xs rule: srev_induct)
  case (ssnoc x xs) then show ?case
    apply (clarsimp simp: zero_Integer_def one_Integer_def stake_all
                simp del: supto_simp
                   elim!: slengthE)
    apply (rule arg_cong, rule smap_cong[OF refl])
    apply clarsimp
    done
qed simp_all

lemma stails_sdrop':
  shows "stails\<cdot>xs = smap\<cdot>(\<Lambda> i. sdrop\<cdot>i\<cdot>xs)\<cdot>(supto\<cdot>0\<cdot>(slength\<cdot>xs))"
proof(induct xs rule: srev_induct)
  case (ssnoc x xs) then show ?case
    apply (clarsimp simp: zero_Integer_def one_Integer_def sdrop_all
                simp del: supto_simp
                   elim!: slengthE)
    apply (rule arg_cong, rule smap_cong[OF refl])
    apply clarsimp
    apply (subst (3) sdrop_neg; fastforce simp: zero_Integer_def)
    done
qed simp_all

lemma sdrop_elem_stails[iff]:
  assumes "xs \<noteq> \<bottom>"
  shows "sdrop\<cdot>(MkI\<cdot>i)\<cdot>xs \<in> sset (stails\<cdot>xs)"
using assms
by (clarsimp simp: stails_sdrop' zero_Integer_def one_Integer_def elim!: slengthE)
   (metis add.left_neutral le_MkI_MkI le_cases not_less sdrop_all sdrop_neg zero_Integer_def zless_imp_add1_zle)

fixrec slast :: "[:'a:] \<rightarrow> 'a" where
  "slast\<cdot>[::] = \<bottom>"
| "\<lbrakk>x \<noteq> \<bottom>; xs \<noteq> \<bottom>\<rbrakk> \<Longrightarrow> slast\<cdot>(x :# xs) = (case xs of [::] \<Rightarrow> x | y :# ys \<Rightarrow> slast\<cdot>xs)"

lemma slast_strict[simp]:
  "slast\<cdot>\<bottom> = \<bottom>"
by fixrec_simp

lemma slast_singleton[simp]: "slast\<cdot>[:x:] = x"
by (cases "x = \<bottom>"; simp)

lemma slast_sappend_ssnoc[simp]:
  assumes "xs \<noteq> \<bottom>"
  shows "slast\<cdot>(xs :@ [:x:]) = x"
using assms
proof(induct xs)
  case (scons y ys) then show ?case by (cases "x = \<bottom>"; simp; cases ys; simp)
qed simp_all

fixrec sbutlast :: "[:'a:] \<rightarrow> [:'a:]" where
  "sbutlast\<cdot>[::] = [::]"
| "\<lbrakk>x \<noteq> \<bottom>; xs \<noteq> \<bottom>\<rbrakk> \<Longrightarrow> sbutlast\<cdot>(x :# xs) = (case xs of [::] \<Rightarrow> [::] | y :# ys \<Rightarrow> x :# sbutlast\<cdot>xs)"

lemma sbutlast_strict[simp]:
  "sbutlast\<cdot>\<bottom> = \<bottom>"
by fixrec_simp

lemma sbutlast_sappend_ssnoc[simp]:
  assumes "x \<noteq> \<bottom>"
  shows "sbutlast\<cdot>(xs :@ [:x:]) = xs"
using assms
proof(induct xs)
  case (scons y ys) then show ?case by (cases ys; simp)
qed simp_all

fixrec prefix :: "[:'a::Eq_def:] \<rightarrow> [:'a:] \<rightarrow> tr" where
  "prefix\<cdot>xs\<cdot>\<bottom> = \<bottom>"
| "ys \<noteq> \<bottom> \<Longrightarrow> prefix\<cdot>[::]\<cdot>ys = TT"
| "\<lbrakk>x \<noteq> \<bottom>; xs \<noteq> \<bottom>\<rbrakk> \<Longrightarrow> prefix\<cdot>(x :# xs)\<cdot>[::] = FF"
| "\<lbrakk>x \<noteq> \<bottom>; xs \<noteq> \<bottom>; y \<noteq> \<bottom>; ys \<noteq> \<bottom>\<rbrakk> \<Longrightarrow> prefix\<cdot>(x :# xs)\<cdot>(y :# ys) = (eq\<cdot>x\<cdot>y andalso prefix\<cdot>xs\<cdot>ys)"

lemma prefix_strict[simp]: "prefix\<cdot>\<bottom> = \<bottom>"
by (clarsimp simp: cfun_eq_iff) fixrec_simp

lemma prefix_bottom_iff[simp]: "(prefix\<cdot>xs\<cdot>ys = \<bottom>) \<longleftrightarrow> (xs = \<bottom> \<or> ys = \<bottom>)"
proof(induct xs arbitrary: ys)
  case (snil ys) then show ?case by (cases ys) simp_all
next
  case (scons a xs) then show ?case by (cases ys) simp_all
qed simp

lemma prefix_definedD:
  assumes "prefix\<cdot>xs\<cdot>ys = TT"
  shows "xs \<noteq> \<bottom> \<and> ys \<noteq> \<bottom>"
using assms by (induct xs arbitrary: ys) auto

lemma prefix_refl[simp]:
  assumes "xs \<noteq> \<bottom>"
  shows "prefix\<cdot>xs\<cdot>xs = TT"
using assms by (induct xs) simp_all

lemma prefix_refl_conv[simp]: "(prefix\<cdot>xs\<cdot>xs = TT) \<longleftrightarrow> (xs \<noteq> \<bottom>)"
by auto

lemma  prefix_of_snil[simp]: "prefix\<cdot>xs\<cdot>[::] = (case xs of [::] \<Rightarrow> TT | x :# xs \<Rightarrow> FF)"
by (cases xs) simp_all

lemma prefix_singleton_TT:
  shows "prefix\<cdot>[:x:]\<cdot>ys = TT \<longleftrightarrow> (x \<noteq> \<bottom> \<and> (\<exists>zs. zs \<noteq> \<bottom> \<and> ys = x :# zs))"
by (cases "x = \<bottom>"; clarsimp; cases ys; fastforce)

lemma prefix_singleton_FF:
  shows "prefix\<cdot>[:x:]\<cdot>ys = FF \<longleftrightarrow> (x \<noteq> \<bottom> \<and> (ys = [::] \<or> (\<exists>z zs. z \<noteq> \<bottom> \<and> zs \<noteq> \<bottom> \<and> ys = z :# zs \<and> x \<noteq> z)))"
by (cases "x = \<bottom>"; clarsimp; cases ys; fastforce)

lemma prefix_FF_not_snilD:
  assumes "prefix\<cdot>xs\<cdot>ys = FF"
  shows "xs \<noteq> [::]"
using assms by (cases xs; cases ys; simp)

lemma prefix_slength:
  assumes "prefix\<cdot>xs\<cdot>ys = TT"
  shows "le\<cdot>(slength\<cdot>xs)\<cdot>(slength\<cdot>ys) = TT"
using assms
proof(induct ys arbitrary: xs)
  case (snil xs) then show ?case by (cases xs) simp_all
next
  case (scons a ys) then show ?case by (cases xs) (simp_all add: le_plus_1)
qed simp

lemma prefix_slength_strengthen: "prefix\<cdot>xs\<cdot>ys = (le\<cdot>(slength\<cdot>xs)\<cdot>(slength\<cdot>ys) andalso prefix\<cdot>xs\<cdot>ys)"
by (rule andalso_weaken_left) (auto dest: prefix_slength)

lemma prefix_scons_snil[simp]: "prefix\<cdot>(x :# xs)\<cdot>[::] \<noteq> TT"
by (cases "x :# xs \<noteq> \<bottom>") auto

lemma scons_prefix_scons[simp]:
  "(prefix\<cdot>(x :# xs)\<cdot>(y :# ys) = TT) \<longleftrightarrow> (eq\<cdot>x\<cdot>y = TT \<and> prefix\<cdot>xs\<cdot>ys = TT)"
by (cases "x :# xs \<noteq> \<bottom> \<and> y :# ys \<noteq> \<bottom>") auto

lemma append_prefixD:
  assumes "prefix\<cdot>(xs :@ ys)\<cdot>zs = TT"
  shows "prefix\<cdot>xs\<cdot>zs = TT"
using assms
proof(induct xs arbitrary: zs)
  case (snil zs) then show ?case using prefix.simps(2) by force
next
  case (scons x xs zs) then show ?case
    by (metis prefix.simps(1) prefix_scons_snil sappend_scons scons_prefix_scons slist.exhaust)
qed simp

lemma same_prefix_prefix[simp]:
  assumes "xs \<noteq> \<bottom>"
  shows "prefix\<cdot>(xs :@ ys)\<cdot>(xs :@ zs) = prefix\<cdot>ys\<cdot>zs"
using assms
proof(cases "ys = \<bottom>" "zs = \<bottom>" rule: bool.exhaust[case_product bool.exhaust])
  case False_False with assms show ?thesis by (induct xs) simp_all
qed simp_all

lemma eq_prefix_TT:
  assumes "eq\<cdot>xs\<cdot>ys = TT"
  shows "prefix\<cdot>xs\<cdot>ys = TT"
using assms by (induct xs arbitrary: ys) (case_tac ys; simp)+

lemma prefix_eq_FF:
  assumes "prefix\<cdot>xs\<cdot>ys = FF"
  shows "eq\<cdot>xs\<cdot>ys = FF"
using assms by (induct xs arbitrary: ys) (case_tac ys; auto)+

lemma prefix_slength_eq:
  shows "eq\<cdot>xs\<cdot>ys = (eq\<cdot>(slength\<cdot>xs)\<cdot>(slength\<cdot>ys) andalso prefix\<cdot>xs\<cdot>ys)"
proof(induct xs arbitrary: ys)
  case (snil ys) then show ?case
    by (cases ys; clarsimp simp: one_Integer_def elim!: slengthE)
next
  case (scons x xs ys) then show ?case
    by (cases ys; clarsimp simp: zero_Integer_def one_Integer_def elim!: slengthE)
qed simp

lemma stake_slength_plus_1:
  shows "stake\<cdot>(slength\<cdot>xs + 1)\<cdot>(y :# ys) = y :# stake\<cdot>(slength\<cdot>xs)\<cdot>ys"
by (cases "xs = \<bottom>" "y = \<bottom>" "ys = \<bottom>" rule: bool.exhaust[case_product bool.exhaust bool.exhaust]; clarsimp)
   (auto simp: If2_def[symmetric] zero_Integer_def one_Integer_def split: If2_splits elim!: slengthE)

lemma sdrop_slength_plus_1:
  assumes "y \<noteq> \<bottom>"
  shows "sdrop\<cdot>(slength\<cdot>xs + 1)\<cdot>(y :# ys) = sdrop\<cdot>(slength\<cdot>xs)\<cdot>ys"
using assms
by (subst sdrop.simps;
    cases "xs = \<bottom>"; clarsimp; cases "ys = \<bottom>";
    clarsimp simp: If2_def[symmetric] zero_Integer_def one_Integer_def split: If2_splits elim!: slengthE)

lemma eq_take_length_prefix: "prefix\<cdot>xs\<cdot>ys = eq\<cdot>xs\<cdot>(stake\<cdot>(slength\<cdot>xs)\<cdot>ys)"
proof (induct xs arbitrary: ys)
  case (snil ys) show ?case by (cases ys; clarsimp)
next
  case (scons x xs ys)
  note IH = this
  show ?case
  proof (cases "slength\<cdot>xs = \<bottom>")
    case True then show ?thesis by simp
  next
    case False
    show ?thesis
    proof (cases ys)
      case bottom
      then show ?thesis using False
        using le_slength_plus[of xs 1] by simp
    next
      case snil then show ?thesis using False and IH(1,2) by simp
    next
      case (scons z zs)
      then show ?thesis
        using False and IH(1,2) IH(3)[of zs]
        by (simp add: stake_slength_plus_1 monofun_cfun_arg)
    qed
  qed
qed simp

lemma prefix_sdrop_slength:
  assumes "prefix\<cdot>xs\<cdot>ys = TT"
  shows "xs :@ sdrop\<cdot>(slength\<cdot>xs)\<cdot>ys = ys"
using assms by (induct xs arbitrary: ys) (case_tac ys; simp add: sdrop_slength_plus_1)+

lemma prefix_sdrop_prefix_eq:
  assumes "prefix\<cdot>xs\<cdot>ys = TT"
  shows "eq\<cdot>(sdrop\<cdot>(slength\<cdot>xs)\<cdot>ys)\<cdot>[::] = eq\<cdot>ys\<cdot>xs"
using assms by (induct xs arbitrary: ys) (case_tac ys; simp add: sdrop_slength_plus_1)+
(*<*)

end
(*>*)


theory topo_operators_basic
  imports sse_operation_positive_quantification
begin
nitpick_params[assms=true, user_axioms=true, show_all, expect=genuine, format=3] (*default Nitpick settings*)

abbreviation implies_rl::"bool\<Rightarrow>bool\<Rightarrow>bool" (infixl "\<longleftarrow>" 25) where "\<phi> \<longleftarrow> \<psi> \<equiv> \<psi> \<longrightarrow> \<phi>" (*for readability*)

section \<open>Topological operators\<close>

text\<open>\noindent{Below we define some conditions on algebraic operations (aka. operators) with type @{text "\<sigma>\<Rightarrow>\<sigma>"}.
Those operations are aimed at extending a Boolean 'algebra of propositions' towards different
generalizations of topological algebras.
We divide this section into two parts. In the first we define and interrelate the topological operators of
interior, closure, border and frontier. In the second we introduce the (more fundamental) notion of
derivative (aka. derived set) and its related notion of (Cantorian) coherence, defining both as operators.
We follow the naming conventions introduced originally by Kuratowski @{cite Kuratowski1}
(cf. also @{cite Kuratowski2}) and Zarycki @{cite Zarycki1}.}\<close>

subsection \<open>Interior and closure\<close>
text\<open>\noindent{In this section we examine the traditional notion of topological (closure, resp. interior) algebras
in the spirit of McKinsey \& Tarski @{cite AOT}, but drawing primarily from the works of Zarycki
@{cite Zarycki1} and Kuratowski @{cite Kuratowski1}.
We also explore the less-known notions of border (cf. 'Rand' @{cite Hausdorff}, 'bord' @{cite Zarycki1}) and
frontier (aka. 'boundary'; cf. 'Grenze' @{cite Hausdorff}, 'fronti\`ere' @{cite Zarycki1} @{cite Kuratowski2})
as studied by Zarycki @{cite Zarycki1} and define corresponding operations for them.}\<close>

subsubsection \<open>Interior conditions\<close>

abbreviation "Int_1 \<phi>  \<equiv> MULT \<phi>"
abbreviation "Int_1a \<phi> \<equiv> MULT_a \<phi>"
abbreviation "Int_1b \<phi> \<equiv> MULT_b \<phi>"
abbreviation "Int_2 \<phi>  \<equiv> dEXP \<phi>"
abbreviation "Int_3 \<phi>  \<equiv> dNOR \<phi>"
abbreviation "Int_4 \<phi>  \<equiv> IDEM \<phi>"
abbreviation "Int_4' \<phi> \<equiv> IDEMa \<phi>"

abbreviation "Int_5 \<phi>  \<equiv> NOR \<phi>"
definition "Int_6 \<phi>  \<equiv> \<forall>A B. \<phi>(A \<^bold>\<leftharpoonup> B) \<^bold>\<preceq> \<phi>(A) \<^bold>\<leftharpoonup> \<phi>(B)"
definition "Int_7 \<phi>  \<equiv> \<forall>A B. \<phi>(A \<^bold>\<rightarrow> B) \<^bold>\<preceq> \<phi>(A) \<^bold>\<rightarrow> \<phi>(B)"
definition "Int_8 \<phi>  \<equiv> \<forall>A B. \<phi>(\<phi> A \<^bold>\<or> \<phi> B) \<^bold>\<approx> (\<phi> A) \<^bold>\<or> (\<phi> B)"
definition "Int_9 \<phi>  \<equiv> \<forall>A B. \<phi> A \<^bold>\<preceq> B \<longrightarrow> \<phi> A \<^bold>\<preceq> \<phi> B"

text\<open>\noindent{@{text "\<phi>"} is an interior operator (@{text "\<II>(\<phi>)"}) iff it satisfies conditions 1-4 (cf. @{cite Zarycki1}
and also @{cite Kuratowski2}). This characterization is shown consistent by generating a non-trivial model.}\<close>
abbreviation "\<II> \<phi> \<equiv> Int_1 \<phi> \<and> Int_2 \<phi> \<and> Int_3 \<phi> \<and> Int_4 \<phi>"
lemma "\<II> \<phi>" nitpick[satisfy, card w=3] oops (*model found: characterization is consistent*)

text\<open>\noindent{We verify some properties which will become useful later (also to improve provers' performance).}\<close>
lemma PI1: "Int_1 \<phi> = (Int_1a \<phi> \<and> Int_1b \<phi>)" by (metis MULT_def MULT_a_def MULT_b_def)
lemma PI4: "Int_2 \<phi> \<Longrightarrow> (Int_4 \<phi> = Int_4' \<phi>)" unfolding dEXP_def IDEM_def IDEMa_def by blast
lemma PI5: "Int_2 \<phi> \<Longrightarrow> Int_5 \<phi>" unfolding dEXP_def NOR_def conn by blast
lemma PI6: "Int_1a \<phi> \<Longrightarrow> Int_2 \<phi> \<Longrightarrow> Int_6 \<phi>" by (smt dEXP_def Int_6_def MONO_MULTa MONO_def conn)
lemma PI7: "Int_1 \<phi> \<Longrightarrow> Int_7 \<phi>" proof -
  assume int1: "Int_1 \<phi>"
  { fix a b
    have "a \<^bold>\<and> b = a \<^bold>\<and> (a \<^bold>\<rightarrow> b)" unfolding conn by blast
    hence "\<phi>(a \<^bold>\<and> b) = \<phi>(a \<^bold>\<and> (a \<^bold>\<rightarrow> b))" by simp
    moreover from int1 have "\<phi>(a \<^bold>\<and> b) \<^bold>\<approx> \<phi> a \<^bold>\<and> \<phi> b" by (simp add: MULT_def)
    moreover from int1 have "\<phi>(a \<^bold>\<and> (a \<^bold>\<rightarrow> b)) \<^bold>\<approx> \<phi> a \<^bold>\<and> \<phi> (a \<^bold>\<rightarrow> b)" by (simp add: MULT_def)
    ultimately have "\<phi> a \<^bold>\<and> \<phi> (a \<^bold>\<rightarrow> b) \<^bold>\<approx> \<phi> a \<^bold>\<and> \<phi> b" by simp
    hence "\<phi> a \<^bold>\<and> \<phi> (a \<^bold>\<rightarrow> b) \<^bold>\<approx> \<phi> a \<^bold>\<and> (\<phi> a \<^bold>\<rightarrow> \<phi> b)" unfolding conn by blast
    hence "\<phi>(a \<^bold>\<rightarrow> b) \<^bold>\<preceq> \<phi> a \<^bold>\<rightarrow> \<phi> b" unfolding conn by blast
  } thus ?thesis by (simp add: Int_7_def)
qed
lemma PI8: "Int_1a \<phi> \<Longrightarrow> Int_2 \<phi> \<Longrightarrow> Int_4 \<phi> \<Longrightarrow> Int_8 \<phi>" using ADDI_b_def IDEM_def Int_8_def MONO_ADDIb MONO_MULTa dEXP_def join_def by auto
lemma PI9: "Int_1a \<phi> \<Longrightarrow> Int_4 \<phi> \<Longrightarrow> Int_9 \<phi>" using IDEM_def Int_9_def MONO_def MONO_MULTa by simp

subsubsection \<open>Closure conditions\<close>

abbreviation "Cl_1 \<phi> \<equiv> ADDI \<phi>"
abbreviation "Cl_1a \<phi> \<equiv> ADDI_a \<phi>"
abbreviation "Cl_1b \<phi> \<equiv> ADDI_b \<phi>"
abbreviation "Cl_2 \<phi> \<equiv> EXP \<phi>"
abbreviation "Cl_3 \<phi>  \<equiv> NOR \<phi>"
abbreviation "Cl_4 \<phi> \<equiv> IDEM \<phi>"
abbreviation "Cl_4' \<phi> \<equiv> IDEMb \<phi>"

abbreviation "Cl_5 \<phi>  \<equiv> dNOR \<phi>"
definition "Cl_6 \<phi>  \<equiv> \<forall>A B. (\<phi> A) \<^bold>\<leftharpoonup> (\<phi> B) \<^bold>\<preceq> \<phi> (A \<^bold>\<leftharpoonup> B)"
definition "Cl_7 \<phi> \<equiv> \<forall>A B. (\<phi> A) \<^bold>\<rightarrow> (\<phi> B) \<^bold>\<preceq> \<phi> (A \<^bold>\<rightarrow> B)"
definition "Cl_8 \<phi>  \<equiv> \<forall>A B. \<phi>(\<phi> A \<^bold>\<and> \<phi> B) \<^bold>\<approx> (\<phi> A) \<^bold>\<and> (\<phi> B)"
definition "Cl_9 \<phi>  \<equiv> \<forall>A B.  A \<^bold>\<preceq> \<phi> B \<longrightarrow> \<phi> A \<^bold>\<preceq> \<phi> B"

text\<open>\noindent{@{text "\<phi>"} is a closure operator (@{text "\<CC>(\<phi>)"}) iff it satisfies conditions 1-4 (cf. @{cite Kuratowski1}
@{cite Kuratowski2}). This characterization is shown consistent by generating a non-trivial model.}\<close>
abbreviation "\<CC> \<phi>  \<equiv> Cl_1 \<phi> \<and> Cl_2 \<phi> \<and> Cl_3  \<phi> \<and> Cl_4 \<phi>"
lemma "\<CC> \<phi>" nitpick[satisfy, card w=3] oops (*model found: characterization is consistent*)

text\<open>\noindent{We verify some properties that will become useful later.}\<close>

subsubsection \<open>Exploring dualities\<close>

lemma IC1_dual: "Int_1a \<phi> = Cl_1b \<phi>" using MONO_ADDIb MONO_MULTa by auto
lemma "Int_1b \<phi> = Cl_1a \<phi>" nitpick oops

lemma IC1a: "Int_1a \<phi> \<Longrightarrow> Cl_1b \<phi>\<^sup>d" by (smt MULT_a_def ADDI_b_def MONO_def MONO_MULTa dual_def conn)
lemma IC1b: "Int_1b \<phi> \<Longrightarrow> Cl_1a \<phi>\<^sup>d" unfolding MULT_b_def ADDI_a_def dual_def conn by auto
lemma IC1:  "Int_1 \<phi>  \<Longrightarrow> Cl_1 \<phi>\<^sup>d" unfolding MULT_def ADDI_def dual_def conn by simp
lemma IC2:  "Int_2 \<phi>  \<Longrightarrow> Cl_2 \<phi>\<^sup>d" unfolding dEXP_def EXP_def dual_def conn by blast
lemma IC3:  "Int_3 \<phi>  \<Longrightarrow> Cl_3 \<phi>\<^sup>d" unfolding dNOR_def NOR_def dual_def conn by simp
lemma IC4:  "Int_4 \<phi>  \<Longrightarrow> Cl_4 \<phi>\<^sup>d" unfolding IDEM_def IDEM_def dual_def conn by simp
lemma IC4': "Int_4' \<phi> \<Longrightarrow> Cl_4' \<phi>\<^sup>d" unfolding IDEMa_def IDEMb_def dual_def conn by metis
lemma IC5:  "Int_5 \<phi>  \<Longrightarrow> Cl_5 \<phi>\<^sup>d" unfolding NOR_def dNOR_def dual_def conn by simp

lemma CI1a: "Cl_1a \<phi>  \<Longrightarrow> Int_1b \<phi>\<^sup>d" proof -
  assume cl1a: "Cl_1a \<phi>"
  { fix A B
    have "\<^bold>\<midarrow>\<phi>(\<^bold>\<midarrow>(A \<^bold>\<and> B)) \<^bold>\<approx> \<^bold>\<midarrow>\<phi>(\<^bold>\<midarrow>A \<^bold>\<or> \<^bold>\<midarrow>B)" unfolding conn by simp
    moreover from cl1a have "\<^bold>\<midarrow>(\<phi>(\<^bold>\<midarrow>A) \<^bold>\<or> \<phi>(\<^bold>\<midarrow>B)) \<^bold>\<preceq> \<^bold>\<midarrow>\<phi>(\<^bold>\<midarrow>A \<^bold>\<or> \<^bold>\<midarrow>B)" using ADDI_a_def conn by metis
    ultimately have "\<^bold>\<midarrow>(\<phi>(\<^bold>\<midarrow>A)) \<^bold>\<and> \<^bold>\<midarrow>(\<phi>(\<^bold>\<midarrow>B)) \<^bold>\<preceq> \<^bold>\<midarrow>\<phi>(\<^bold>\<midarrow>(A \<^bold>\<and> B))" unfolding conn by simp
    hence "(\<phi>\<^sup>d A) \<^bold>\<and> (\<phi>\<^sup>d B) \<^bold>\<preceq> (\<phi>\<^sup>d (A \<^bold>\<and> B))" unfolding dual_def by simp
  } thus "Int_1b \<phi>\<^sup>d" using MULT_b_def by blast
qed
lemma CI1b: "Cl_1b \<phi> \<Longrightarrow> Int_1a \<phi>\<^sup>d" by (metis IC1a MONO_ADDIb MONO_MULTa)
lemma CI1:  "Cl_1 \<phi>  \<Longrightarrow> Int_1 \<phi>\<^sup>d" by (simp add: CI1a CI1b PC1 PI1)
lemma CI2:  "Cl_2 \<phi>  \<Longrightarrow> Int_2 \<phi>\<^sup>d" unfolding EXP_def dEXP_def dual_def conn by metis
lemma CI3:  "Cl_3 \<phi>  \<Longrightarrow> Int_3 \<phi>\<^sup>d" unfolding NOR_def dNOR_def dual_def conn by simp
lemma CI4:  "Cl_4 \<phi>  \<Longrightarrow> Int_4 \<phi>\<^sup>d" unfolding IDEM_def IDEM_def dual_def conn by simp
lemma CI4': "Cl_4' \<phi> \<Longrightarrow> Int_4' \<phi>\<^sup>d" unfolding IDEMa_def IDEMb_def dual_def conn by metis
lemma CI5:  "Cl_5 \<phi>  \<Longrightarrow> Int_5 \<phi>\<^sup>d" unfolding dNOR_def NOR_def dual_def conn by simp

subsection \<open>Frontier and border\<close>

subsubsection \<open>Frontier conditions\<close>

definition "Fr_1a \<phi> \<equiv> \<forall>A B. (A \<^bold>\<and> B) \<^bold>\<and> \<phi>(A \<^bold>\<and> B) \<^bold>\<preceq> (A \<^bold>\<and> B) \<^bold>\<and> (\<phi> A \<^bold>\<or> \<phi> B)"
definition "Fr_1b \<phi> \<equiv> \<forall>A B. (A \<^bold>\<and> B) \<^bold>\<and> \<phi>(A \<^bold>\<and> B) \<^bold>\<succeq> (A \<^bold>\<and> B) \<^bold>\<and> (\<phi> A \<^bold>\<or> \<phi> B)"
definition "Fr_1 \<phi>  \<equiv> \<forall>A B. (A \<^bold>\<and> B) \<^bold>\<and> \<phi>(A \<^bold>\<and> B) \<^bold>\<approx> (A \<^bold>\<and> B) \<^bold>\<and> (\<phi> A \<^bold>\<or> \<phi> B)"
definition "Fr_2 \<phi> \<equiv> \<forall>A. \<phi> A \<^bold>\<approx> \<phi>(\<^bold>\<midarrow>A)"
abbreviation "Fr_3 \<phi> \<equiv> NOR \<phi>"
definition "Fr_4 \<phi> \<equiv> \<forall>A. \<phi>(\<phi> A) \<^bold>\<preceq> (\<phi> A)"

definition "Fr_5 \<phi> \<equiv> \<forall>A. \<phi>(\<phi>(\<phi> A)) \<^bold>\<approx> \<phi>(\<phi> A)"
definition "Fr_6 \<phi> \<equiv> \<forall>A B. A \<^bold>\<preceq> B \<longrightarrow> (\<phi> A \<^bold>\<preceq> B \<^bold>\<or> \<phi> B)"

text\<open>\noindent{@{text "\<phi>"} is a topological frontier operator (@{text "\<FF>(\<phi>)"}) iff it satisfies conditions 1-4
(cf. @{cite Zarycki1}). This is also shown consistent by generating a non-trivial model.}\<close>
abbreviation "\<FF> \<phi>  \<equiv> Fr_1 \<phi> \<and> Fr_2 \<phi> \<and> Fr_3 \<phi> \<and> Fr_4 \<phi>"
lemma "\<FF> \<phi>" nitpick[satisfy, card w=3] oops (*model found: characterization is consistent*)

text\<open>\noindent{We now verify some useful properties of the frontier operator.}\<close>
lemma PF1: "Fr_1 \<phi> = (Fr_1a \<phi> \<and> Fr_1b \<phi>)" unfolding Fr_1_def Fr_1a_def Fr_1b_def by meson
lemma PF5: "Fr_1 \<phi> \<Longrightarrow> Fr_4 \<phi> \<Longrightarrow> Fr_5 \<phi>" proof -
  assume fr1: "Fr_1 \<phi>" and fr4: "Fr_4 \<phi>"
  { fix A
    from fr1 have "(\<phi>(\<phi> A) \<^bold>\<and> (\<phi> A)) \<^bold>\<and> \<phi>(\<phi>(\<phi> A) \<^bold>\<and> (\<phi> A)) \<^bold>\<approx> (\<phi>(\<phi> A) \<^bold>\<and> (\<phi> A)) \<^bold>\<and> (\<phi>(\<phi>(\<phi> A)) \<^bold>\<or> \<phi>(\<phi> A))" by (simp add: Fr_1_def)
    moreover have r1: "\<phi>(\<phi> A) \<^bold>\<and> (\<phi> A) \<^bold>\<approx> \<phi>(\<phi> A)" using meet_char Fr_4_def fr4 by simp
    moreover have r2: "\<phi>(\<phi>(\<phi> A)) \<^bold>\<or> \<phi>(\<phi> A) \<^bold>\<approx> \<phi>(\<phi> A)" using join_char Fr_4_def fr4 by simp
    ultimately have "(\<phi>(\<phi> A) \<^bold>\<and> (\<phi> A)) \<^bold>\<and> \<phi>(\<phi>(\<phi> A)) \<^bold>\<approx> (\<phi>(\<phi> A) \<^bold>\<and> (\<phi> A)) \<^bold>\<and> \<phi>(\<phi> A)" unfolding conn by auto
    hence "\<phi>(\<phi>(\<phi> A)) \<^bold>\<approx> \<phi>(\<phi> A)" using r1 r2 conn by auto
  } thus ?thesis by (simp add: Fr_5_def)
qed
lemma PF6: "Fr_1b \<phi> \<Longrightarrow> Fr_2 \<phi> \<Longrightarrow> Fr_6 \<phi>" proof -
  assume fr1b: "Fr_1b \<phi>" and fr2: "Fr_2 \<phi>"
  { fix A B
    have "\<phi>(\<^bold>\<midarrow>(A \<^bold>\<or> B)) \<^bold>\<approx> \<phi>(\<^bold>\<midarrow>A \<^bold>\<and> \<^bold>\<midarrow>B)" unfolding conn by simp
    hence aux: "\<phi>(\<^bold>\<midarrow>A \<^bold>\<and> \<^bold>\<midarrow>B) \<^bold>\<approx> \<phi>(A \<^bold>\<or> B)" by (metis (mono_tags) Fr_2_def fr2)
    from fr1b have "(\<^bold>\<midarrow>A \<^bold>\<and> \<^bold>\<midarrow>B) \<^bold>\<and> \<phi>(\<^bold>\<midarrow>A \<^bold>\<and> \<^bold>\<midarrow>B) \<^bold>\<succeq> (\<^bold>\<midarrow>A \<^bold>\<and> \<^bold>\<midarrow>B) \<^bold>\<and> (\<phi>(\<^bold>\<midarrow>A) \<^bold>\<or> \<phi>(\<^bold>\<midarrow>B))" using Fr_1b_def by metis
    hence "A \<^bold>\<or> B \<^bold>\<or> \<^bold>\<midarrow>\<phi>(\<^bold>\<midarrow>A \<^bold>\<and> \<^bold>\<midarrow>B) \<^bold>\<preceq> A \<^bold>\<or> B \<^bold>\<or> (\<^bold>\<midarrow>(\<phi> A) \<^bold>\<and> \<^bold>\<midarrow>(\<phi> B))" using Fr_2_def fr2 conn by auto
    hence "\<^bold>\<midarrow>A \<^bold>\<and> \<^bold>\<midarrow>B \<^bold>\<and> \<^bold>\<midarrow>\<phi>(\<^bold>\<midarrow>A \<^bold>\<and> \<^bold>\<midarrow>B) \<^bold>\<preceq> \<^bold>\<midarrow>A \<^bold>\<and> \<^bold>\<midarrow>B \<^bold>\<and> \<^bold>\<midarrow>(\<phi> A) \<^bold>\<and> \<^bold>\<midarrow>(\<phi> B)" unfolding conn by blast
    hence "A \<^bold>\<or> B \<^bold>\<or> \<phi>(A \<^bold>\<or> B) \<^bold>\<succeq> A \<^bold>\<or> B \<^bold>\<or> (\<phi> A) \<^bold>\<or> (\<phi> B)" using aux unfolding conn by blast
    hence "A \<^bold>\<preceq> B \<longrightarrow> B \<^bold>\<or> \<phi>(A \<^bold>\<or> B) \<^bold>\<succeq> B \<^bold>\<or> (\<phi> A) \<^bold>\<or> (\<phi> B)" unfolding conn by auto
    hence "A \<^bold>\<preceq> B \<longrightarrow> B \<^bold>\<or> (\<phi> B) \<^bold>\<succeq> B \<^bold>\<or> (\<phi> A) \<^bold>\<or> (\<phi> B)" using join_char unfolding conn by simp
    hence "A \<^bold>\<preceq> B \<longrightarrow> (\<phi> A) \<^bold>\<preceq> B \<^bold>\<or> (\<phi> B)" unfolding conn by simp
  } thus "Fr_6 \<phi>" by (simp add: Fr_6_def)
qed

subsubsection \<open>Border conditions\<close>

definition "Br_1 \<phi> \<equiv> \<forall>A B. \<phi>(A \<^bold>\<and> B) \<^bold>\<approx> (A \<^bold>\<and> \<phi> B) \<^bold>\<or> (B \<^bold>\<and> \<phi> A)"
definition "Br_2 \<phi> \<equiv> (\<phi> \<^bold>\<top>) \<^bold>\<approx> \<^bold>\<bottom>"
definition "Br_3 \<phi> \<equiv> \<forall>A. \<phi>(\<phi>\<^sup>d A) \<^bold>\<preceq> A"

definition "Br_4 \<phi> \<equiv> \<forall>A B. A \<^bold>\<preceq> B \<longrightarrow> A \<^bold>\<and> (\<phi> B) \<^bold>\<preceq> \<phi> A"
definition "Br_5a \<phi> \<equiv> \<forall>A. \<phi>(\<phi>\<^sup>d A) \<^bold>\<preceq> \<phi> A"
definition "Br_5b \<phi> \<equiv> \<forall>A. \<phi> A \<^bold>\<preceq> A"
definition "Br_5c \<phi> \<equiv> \<forall>A. A \<^bold>\<preceq> \<phi>\<^sup>d A"
definition "Br_5d \<phi> \<equiv> \<forall>A. \<phi>\<^sup>d A \<^bold>\<preceq> \<phi>\<^sup>d(\<phi> A)"
abbreviation "Br_6 \<phi> \<equiv> IDEM \<phi>"
abbreviation "Br_7 \<phi> \<equiv> ADDI_a \<phi>"
abbreviation "Br_8 \<phi> \<equiv> MULT_b \<phi>"
definition "Br_9 \<phi> \<equiv> \<forall>A B. \<phi>(A \<^bold>\<and> B) \<^bold>\<preceq> (\<phi> A) \<^bold>\<or> (\<phi> B)"
definition "Br_10 \<phi> \<equiv> \<forall>A. \<phi>(\<^bold>\<midarrow>(\<phi> A) \<^bold>\<and> \<phi>\<^sup>d A) \<^bold>\<approx> \<^bold>\<bottom>"

text\<open>\noindent{@{text "\<phi>"} is a topological border operator (@{text "\<BB>(\<phi>)"}) iff it satisfies conditions 1-3
(cf. @{cite Zarycki1}). This is also shown consistent.}\<close>
abbreviation "\<BB> \<phi>  \<equiv> Br_1 \<phi> \<and> Br_2 \<phi> \<and> Br_3 \<phi>"
lemma "\<BB> \<phi>" nitpick[satisfy, card w=3] oops (*model found: characterization is consistent*)

text\<open>\noindent{We now verify some useful properties of the border operator.}\<close>

subsubsection \<open>Relation with closure and interior\<close>

text\<open>\noindent{We define and verify some conversion operators useful to derive border and frontier operators from
closure/interior operators and also between each other.}\<close>

text\<open>\noindent{Frontier operator as derived from interior.}\<close>
definition Fr_int::"(\<sigma>\<Rightarrow>\<sigma>)\<Rightarrow>(\<sigma>\<Rightarrow>\<sigma>)" ("\<F>\<^sub>I") where "\<F>\<^sub>I \<I> \<equiv> \<lambda>A. \<^bold>\<midarrow>(\<I> A) \<^bold>\<and> \<I>\<^sup>d A"
lemma FI1: "Int_1 \<phi> \<Longrightarrow> Int_2 \<phi> \<Longrightarrow>  Fr_1(\<F>\<^sub>I \<phi>)" using EXP_def Fr_1_def Fr_int_def IC2 MULT_def conn by auto
lemma FI2: "Fr_2(\<F>\<^sub>I \<phi>)" using Fr_2_def Fr_int_def dual_def dual_symm unfolding conn by smt
lemma FI3: "Int_3 \<phi> \<Longrightarrow> Fr_3(\<F>\<^sub>I \<phi>)" using NOR_def Fr_int_def IC3 unfolding conn by auto
lemma FI4: "Int_1a \<phi> \<Longrightarrow> Int_2 \<phi>  \<Longrightarrow> Int_4 \<phi> \<Longrightarrow> Fr_4(\<F>\<^sub>I \<phi>)" unfolding Fr_int_def Fr_4_def dual_def conn by (smt Int_9_def MONO_MULTa PI9)

text\<open>\noindent{Frontier operator as derived from closure.}\<close>
definition Fr_cl::"(\<sigma>\<Rightarrow>\<sigma>)\<Rightarrow>(\<sigma>\<Rightarrow>\<sigma>)" ("\<F>\<^sub>C") where "\<F>\<^sub>C \<C> \<equiv> \<lambda>A. (\<C> A) \<^bold>\<and> \<C>(\<^bold>\<midarrow>A)"
lemma FC1: "Cl_1 \<phi> \<Longrightarrow> Cl_2 \<phi> \<Longrightarrow>  Fr_1(\<F>\<^sub>C \<phi>)" using CI1 EXP_def Fr_1_def Fr_cl_def MULT_def dual_def unfolding conn by smt
lemma FC2: "Fr_2(\<F>\<^sub>C \<phi>)" using Fr_2_def Fr_cl_def dual_def dual_symm unfolding conn by smt
lemma FC3: "Cl_3 \<phi> \<Longrightarrow> Fr_3(\<F>\<^sub>C \<phi>)" unfolding NOR_def Fr_cl_def conn by simp
lemma FC4: "Cl_1b \<phi> \<Longrightarrow> Cl_2 \<phi> \<Longrightarrow> Cl_4 \<phi> \<Longrightarrow> Fr_4(\<F>\<^sub>C \<phi>)" using Cl_8_def MONO_ADDIb PC8 unfolding Fr_cl_def Fr_4_def conn by blast

text\<open>\noindent{Frontier operator as derived from border.}\<close>
definition Fr_br::"(\<sigma>\<Rightarrow>\<sigma>)\<Rightarrow>(\<sigma>\<Rightarrow>\<sigma>)" ("\<F>\<^sub>B") where "\<F>\<^sub>B \<B> \<equiv> \<lambda>A. \<B> A \<^bold>\<or> \<B>(\<^bold>\<midarrow>A)"
lemma FB1: "Br_1 \<phi> \<Longrightarrow>  Fr_1(\<F>\<^sub>B \<phi>)" unfolding Fr_br_def Fr_1_def using Br_1_def Br_5b_def PB5b conn by smt
lemma FB2: "Fr_2(\<F>\<^sub>B \<phi>)" unfolding Fr_br_def Fr_2_def conn by auto
lemma FB3: "Br_1 \<phi> \<Longrightarrow> Br_2 \<phi> \<Longrightarrow>  Fr_3(\<F>\<^sub>B \<phi>)" using Br_2_def Br_5b_def PB5b unfolding Fr_br_def NOR_def conn by force
lemma FB4: "Br_1 \<phi> \<Longrightarrow> Br_3 \<phi> \<Longrightarrow>  Fr_4(\<F>\<^sub>B \<phi>)" proof -
  assume br1: "Br_1 \<phi>" and br3: "Br_3 \<phi>"
  { fix A
   have "(\<F>\<^sub>B \<phi>) ((\<F>\<^sub>B \<phi>) A) = \<phi>(\<phi> A \<^bold>\<or> \<phi>(\<^bold>\<midarrow>A)) \<^bold>\<or> \<phi>(\<^bold>\<midarrow>(\<phi> A \<^bold>\<or> \<phi>(\<^bold>\<midarrow>A)))" by (simp add: Fr_br_def conn)
   also have "... = \<phi>(\<phi> A \<^bold>\<or> \<phi>(\<^bold>\<midarrow>A)) \<^bold>\<or> \<phi>(\<^bold>\<midarrow>(\<phi> A) \<^bold>\<and> \<phi>\<^sup>d A)" by (simp add: dual_def conn)
   also from br1 br3 have "... = \<phi>(\<phi> A \<^bold>\<or> \<phi>(\<^bold>\<midarrow>A)) \<^bold>\<or> \<^bold>\<bottom>" using Br_10_def PB10 by metis
   finally have "(\<F>\<^sub>B \<phi>) ((\<F>\<^sub>B \<phi>) A) \<^bold>\<approx> \<phi>(\<phi> A \<^bold>\<or> \<phi>(\<^bold>\<midarrow>A))" unfolding conn by simp
   hence "(\<F>\<^sub>B \<phi>) ((\<F>\<^sub>B \<phi>) A) \<^bold>\<preceq> (\<F>\<^sub>B \<phi>) A" using Br_5b_def Fr_br_def PB5b br1 by fastforce
  } thus "Fr_4(\<F>\<^sub>B \<phi>)" using Fr_4_def by blast
qed

text\<open>\noindent{Border operator as derived from interior.}\<close>
definition Br_int::"(\<sigma>\<Rightarrow>\<sigma>)\<Rightarrow>(\<sigma>\<Rightarrow>\<sigma>)" ("\<B>\<^sub>I") where "\<B>\<^sub>I \<I> \<equiv> \<lambda>A. A \<^bold>\<leftharpoonup> (\<I> A)"
lemma BI1: "Int_1 \<phi> \<Longrightarrow>  Br_1 (\<B>\<^sub>I \<phi>)" using Br_1_def Br_int_def MULT_def conn by auto
lemma BI2: "Int_3 \<phi> \<Longrightarrow>  Br_2 (\<B>\<^sub>I \<phi>)" by (simp add: Br_2_def Br_int_def dNOR_def conn)
lemma BI3: "Int_1a \<phi> \<Longrightarrow> Int_4 \<phi> \<Longrightarrow> Br_3 (\<B>\<^sub>I \<phi>)" unfolding Br_int_def Br_3_def dual_def by (smt Int_9_def MONO_MULTa PI9 conn)

text\<open>\noindent{Border operator as derived from closure.}\<close>
definition Br_cl::"(\<sigma>\<Rightarrow>\<sigma>)\<Rightarrow>(\<sigma>\<Rightarrow>\<sigma>)" ("\<B>\<^sub>C")  where "\<B>\<^sub>C \<C> \<equiv> \<lambda>A. A \<^bold>\<and> \<C>(\<^bold>\<midarrow>A)"
lemma BC1: "Cl_1 \<phi> \<Longrightarrow>  Br_1(\<B>\<^sub>C \<phi>)" using Br_1_def Br_cl_def CI1 MULT_def dual_def unfolding conn by smt
lemma BC2: "Cl_3 \<phi> \<Longrightarrow>  Br_2(\<B>\<^sub>C \<phi>)" using Br_2_def Br_cl_def CI3 dNOR_def dual_def unfolding conn by auto
lemma BC3: "Cl_1b \<phi> \<Longrightarrow> Cl_4 \<phi> \<Longrightarrow> Br_3 (\<B>\<^sub>C \<phi>)" unfolding Br_cl_def Br_3_def dual_def conn by (metis (mono_tags, lifting) Cl_9_def PC9)

text\<open>\noindent{Note that the previous two conversion functions are related:}\<close>
lemma BI_BC_rel: "(\<B>\<^sub>I \<phi>) = \<B>\<^sub>C(\<phi>\<^sup>d)" by (simp add: Br_cl_def Br_int_def dual_def conn)

text\<open>\noindent{Border operator as derived from frontier.}\<close>
definition Br_fr::"(\<sigma>\<Rightarrow>\<sigma>)\<Rightarrow>(\<sigma>\<Rightarrow>\<sigma>)" ("\<B>\<^sub>F") where "\<B>\<^sub>F \<F> \<equiv> \<lambda>A. A \<^bold>\<and> (\<F> A)"
lemma BF1: "Fr_1 \<phi> \<Longrightarrow> Br_1(\<B>\<^sub>F \<phi>)" using Br_1_def Br_fr_def Fr_1_def conn by auto
lemma BF2: "Fr_2 \<phi> \<Longrightarrow> Fr_3 \<phi> \<Longrightarrow> Br_2(\<B>\<^sub>F \<phi>)" using Br_2_def Br_fr_def Fr_2_def NOR_def unfolding conn by fastforce
lemma BF3: "Fr_1b \<phi> \<Longrightarrow> Fr_2 \<phi> \<Longrightarrow> Fr_4 \<phi> \<Longrightarrow> Br_3(\<B>\<^sub>F \<phi>)" proof -
  assume fr1b: "Fr_1b \<phi>" and fr2: "Fr_2 \<phi>" and fr4: "Fr_4 \<phi>"
  { fix A
    from fr1b fr2 have "let M= \<^bold>\<midarrow>A \<^bold>\<and> \<phi> A ; N= \<phi> A in M \<^bold>\<preceq> N \<longrightarrow> (\<phi> M \<^bold>\<preceq> N \<^bold>\<or> \<phi> N)" using PF1 PF6 by (simp add: Fr_6_def)
    hence "\<phi>(\<^bold>\<midarrow>A \<^bold>\<and> \<phi> A) \<^bold>\<preceq> \<phi> A \<^bold>\<or> \<phi>(\<phi> A)" unfolding conn by meson
    hence "\<phi>(\<^bold>\<midarrow>A \<^bold>\<and> \<phi> A) \<^bold>\<preceq> \<phi> A" using Fr_4_def fr4 unfolding conn by metis
    hence aux: "\<phi>(\<^bold>\<midarrow>A \<^bold>\<and> \<phi> A) \<^bold>\<and> \<^bold>\<midarrow>(\<phi> A) \<^bold>\<approx> \<^bold>\<bottom>" unfolding conn by blast
    have "(\<B>\<^sub>F \<phi>)((\<B>\<^sub>F \<phi>)\<^sup>d A) = \<^bold>\<midarrow>(\<^bold>\<midarrow>A \<^bold>\<and> \<phi>(\<^bold>\<midarrow>A)) \<^bold>\<and> \<phi>(\<^bold>\<midarrow>(\<^bold>\<midarrow>A \<^bold>\<and> \<phi>(\<^bold>\<midarrow>A)))" unfolding Br_fr_def dual_def by simp
    also have "... = (A \<^bold>\<or> \<^bold>\<midarrow>\<phi> A) \<^bold>\<and> \<phi>(\<^bold>\<midarrow>A \<^bold>\<and> \<phi> A)" using Fr_2_def fr2 unfolding conn by force
    also have "... = (A \<^bold>\<and> \<phi>(\<^bold>\<midarrow>A \<^bold>\<and> \<phi> A)) \<^bold>\<or> (\<^bold>\<midarrow>\<phi> A \<^bold>\<and> \<phi>(\<^bold>\<midarrow>A \<^bold>\<and> \<phi> A))" unfolding conn by auto
    also have "... = (A \<^bold>\<and> \<phi>(\<^bold>\<midarrow>A \<^bold>\<and> \<phi> A))" using aux unfolding conn by blast
    finally have "(\<B>\<^sub>F \<phi>)((\<B>\<^sub>F \<phi>)\<^sup>d A) = A \<^bold>\<and> \<phi>(\<^bold>\<midarrow>A \<^bold>\<and> \<phi> A)" unfolding Br_fr_def dual_def conn by simp
  } thus "Br_3(\<B>\<^sub>F \<phi>)" unfolding Br_3_def Br_fr_def conn by meson
qed

text\<open>\noindent{Interior operator as derived from border.}\<close>
definition Int_br::"(\<sigma>\<Rightarrow>\<sigma>)\<Rightarrow>(\<sigma>\<Rightarrow>\<sigma>)" ("\<I>\<^sub>B") where "\<I>\<^sub>B \<B> \<equiv> \<lambda>A. A \<^bold>\<leftharpoonup> (\<B> A)"
lemma IB1: "Br_1 \<phi> \<Longrightarrow> Int_1(\<I>\<^sub>B \<phi>)" using Br_1_def MULT_def Int_br_def conn by auto
lemma IB2: "Int_2(\<I>\<^sub>B \<phi>)" by (simp add: dEXP_def Int_br_def conn)
lemma IB3: "Br_2 \<phi> \<Longrightarrow> Int_3(\<I>\<^sub>B \<phi>)" by (simp add: Br_2_def dNOR_def Int_br_def conn)
lemma IB4: "Br_1 \<phi> \<Longrightarrow> Br_3 \<phi> \<Longrightarrow> Int_4(\<I>\<^sub>B \<phi>)" unfolding Int_br_def IDEM_def conn
  using Br_1_def Br_5c_def Br_5d_def PB5c PB5d dual_def unfolding conn by (metis (full_types))

text\<open>\noindent{Interior operator as derived from frontier.}\<close>
definition Int_fr::"(\<sigma>\<Rightarrow>\<sigma>)\<Rightarrow>(\<sigma>\<Rightarrow>\<sigma>)" ("\<I>\<^sub>F") where "\<I>\<^sub>F \<F> \<equiv> \<lambda>A. A \<^bold>\<leftharpoonup> (\<F> A)"
lemma IF1a: "Fr_1b \<phi> \<Longrightarrow> Int_1a(\<I>\<^sub>F \<phi>)" using Fr_1b_def MULT_a_def Int_fr_def conn by auto
lemma IF1b: "Fr_1a \<phi> \<Longrightarrow> Int_1b(\<I>\<^sub>F \<phi>)" using Fr_1a_def MULT_b_def Int_fr_def conn by auto
lemma IF1: "Fr_1 \<phi> \<Longrightarrow> Int_1(\<I>\<^sub>F \<phi>)" by (simp add: IF1a IF1b PF1 PI1)
lemma IF2: "Int_2(\<I>\<^sub>F \<phi>)" by (simp add: dEXP_def Int_fr_def conn)
lemma IF3: "Fr_2 \<phi> \<Longrightarrow> Fr_3 \<phi> \<Longrightarrow> Int_3(\<I>\<^sub>F \<phi>)" using BF2 Br_2_def Br_fr_def dNOR_def Int_fr_def unfolding conn by auto
lemma IF4: "Fr_1a \<phi> \<Longrightarrow> Fr_2 \<phi> \<Longrightarrow> Fr_4 \<phi> \<Longrightarrow> Int_4(\<I>\<^sub>F \<phi>)"
  using Fr_1a_def Fr_2_def Fr_4_def unfolding Int_fr_def IDEM_def conn by metis

text\<open>\noindent{Closure operator as derived from border.}\<close>
definition Cl_br::"(\<sigma>\<Rightarrow>\<sigma>)\<Rightarrow>(\<sigma>\<Rightarrow>\<sigma>)" ("\<C>\<^sub>B") where "\<C>\<^sub>B \<B> \<equiv> \<lambda>A. A \<^bold>\<or> \<B>(\<^bold>\<midarrow>A)"

text\<open>\noindent{Closure operator as derived from frontier.}\<close>
definition Cl_fr::"(\<sigma>\<Rightarrow>\<sigma>)\<Rightarrow>(\<sigma>\<Rightarrow>\<sigma>)" ("\<C>\<^sub>F") where "\<C>\<^sub>F \<F> \<equiv> \<lambda>A. A \<^bold>\<or> (\<F> A)"
lemma CF1b: "Fr_1b \<phi> \<Longrightarrow> Fr_2 \<phi> \<Longrightarrow> Cl_1b(\<C>\<^sub>F \<phi>)" using Cl_fr_def Fr_6_def MONO_def MONO_ADDIb PF6 unfolding conn by auto
lemma CF1a: "Fr_1a \<phi> \<Longrightarrow> Fr_2 \<phi> \<Longrightarrow> Cl_1a(\<C>\<^sub>F \<phi>)" proof -
  have aux: "Fr_2 \<phi> \<Longrightarrow> (\<I>\<^sub>F \<phi>)\<^sup>d = (\<C>\<^sub>F \<phi>)" by (simp add: Cl_fr_def Fr_2_def Int_fr_def dual_def conn)
  hence "Fr_1a \<phi> \<Longrightarrow> Fr_2 \<phi> \<Longrightarrow> Cl_1a(\<I>\<^sub>F \<phi>)\<^sup>d" using IC1b IF1b by blast
  thus "Fr_1a \<phi> \<Longrightarrow> Fr_2 \<phi> \<Longrightarrow> Cl_1a(\<C>\<^sub>F \<phi>)" using ADDI_a_def aux unfolding conn by simp
qed
lemma CF1: "Fr_1 \<phi> \<Longrightarrow> Fr_2 \<phi> \<Longrightarrow> Cl_1(\<C>\<^sub>F \<phi>)" by (simp add: CF1a CF1b PC1 PF1)
lemma CF2: "Cl_2(\<C>\<^sub>F \<phi>)" by (simp add: EXP_def Cl_fr_def conn)
lemma CF3: "Fr_3 \<phi> \<Longrightarrow> Cl_3(\<C>\<^sub>F \<phi>)" by (simp add: Cl_fr_def NOR_def conn)
lemma CF4: "Fr_1a \<phi> \<Longrightarrow> Fr_2 \<phi> \<Longrightarrow> Fr_4 \<phi> \<Longrightarrow> Cl_4(\<C>\<^sub>F \<phi>)" proof -
  have aux: "Fr_2 \<phi> \<Longrightarrow> (\<I>\<^sub>F \<phi>)\<^sup>d = (\<C>\<^sub>F \<phi>)"  by (simp add: Cl_fr_def Fr_2_def Int_fr_def dual_def conn)
  hence "Fr_1a \<phi> \<Longrightarrow> Fr_2 \<phi> \<Longrightarrow> Fr_4 \<phi> \<Longrightarrow> Cl_4(\<I>\<^sub>F \<phi>)\<^sup>d" using IC4 IF4 by blast
  thus "Fr_1a \<phi> \<Longrightarrow> Fr_2 \<phi> \<Longrightarrow> Fr_4 \<phi> \<Longrightarrow> Cl_4(\<C>\<^sub>F \<phi>)" by (simp add: aux)
qed

subsubsection \<open>Infinitary conditions\<close>

text\<open>\noindent{We define the essential infinitary conditions for the closure and interior operators (entailing infinite
additivity and multiplicativity resp.). Observe that the other direction is implied by monotonicity (MONO).}\<close>
abbreviation "Cl_inf \<phi> \<equiv> iADDI_a(\<phi>)"
abbreviation "Int_inf \<phi> \<equiv> iMULT_b(\<phi>)"

text\<open>\noindent{There exists indeed a condition on frontier operators responsible for the infinitary conditions above:}\<close>
definition "Fr_inf \<phi> \<equiv> \<forall>S. \<^bold>\<And>S \<^bold>\<and> \<phi>(\<^bold>\<And>S) \<^bold>\<preceq> \<^bold>\<And>S \<^bold>\<and> \<^bold>\<Or>Ra[\<phi>|S]"

lemma CF_inf: "Fr_2 \<phi> \<Longrightarrow> Fr_inf \<phi> \<Longrightarrow> Cl_inf(\<C>\<^sub>F \<phi>)" unfolding iADDI_a_def  Fr_inf_def
  by (smt Cl_fr_def Fr_2_def Ra_restr_ex compl_def dom_compl_def2 iDM_b join_def meet_def supremum_def)
lemma IF_inf: "Fr_inf \<phi> \<Longrightarrow> Int_inf(\<I>\<^sub>F \<phi>)" unfolding Fr_inf_def iMULT_b_def Int_fr_def Ra_restr_all
  by (metis (mono_tags, hide_lams) diff_def infimum_def meet_def pfunRange_restr_def supremum_def)

text\<open>\noindent{This condition is indeed strong enough to entail closure of the fixed-point predicates under infimum/supremum.}\<close>
lemma fp_IF_inf_closed: "Fr_inf \<phi> \<Longrightarrow> infimum_closed (fp (\<I>\<^sub>F \<phi>))" by (metis (full_types) IF2 IF_inf Ra_restr_all dEXP_def iMULT_b_def infimum_def)
lemma fp_CF_sup_closed: "Fr_inf \<phi> \<Longrightarrow> Fr_2 \<phi> \<Longrightarrow> supremum_closed (fp (\<C>\<^sub>F \<phi>))" by (metis (full_types) CF2 CF_inf EXP_def Ra_restr_ex iADDI_a_def supremum_def)

end