section \<open>Writer monad transformer\<close>

theory Writer_Transformer
imports Writer_Monad
begin

subsection \<open>Type definition\<close>

text \<open>Below is the standard Haskell definition of a writer monad
transformer:\<close>

text_raw \<open>
\begin{verbatim}
newtype WriterT w m a = WriterT { runWriterT :: m (a, w) }
\end{verbatim}
\<close>

text \<open>In this development, since a lazy pair type is not pre-defined
in HOLCF, we will use an equivalent formulation in terms of our
previous \texttt{Writer} type:\<close>

text_raw \<open>
\begin{verbatim}
data Writer w a = Writer w a
newtype WriterT w m a = WriterT { runWriterT :: m (Writer w a) }
\end{verbatim}
\<close>

text \<open>We can translate this definition directly into HOLCF using
\<open>tycondef\<close>. \medskip\<close>

tycondef 'a\<cdot>('m::"functor",'w) writerT =
  WriterT (runWriterT :: "('a\<cdot>'w writer)\<cdot>'m")

lemma coerce_writerT_abs [simp]:
  "coerce\<cdot>(writerT_abs\<cdot>x) = writerT_abs\<cdot>(coerce\<cdot>x)"
apply (simp add: writerT_abs_def coerce_def)
apply (simp add: emb_prj_emb prj_emb_prj DEFL_eq_writerT)
done

lemma coerce_WriterT [simp]: "coerce\<cdot>(WriterT\<cdot>k) = WriterT\<cdot>(coerce\<cdot>k)"
unfolding WriterT_def by simp

lemma writerT_cases [case_names WriterT]:
  obtains k where "y = WriterT\<cdot>k"
proof
  show "y = WriterT\<cdot>(runWriterT\<cdot>y)"
    by (cases y, simp_all)
qed

lemma WriterT_runWriterT [simp]: "WriterT\<cdot>(runWriterT\<cdot>m) = m"
by (cases m rule: writerT_cases, simp)

lemma writerT_induct [case_names WriterT]:
  fixes P :: "'a\<cdot>('f::functor,'e) writerT \<Rightarrow> bool"
  assumes "\<And>k. P (WriterT\<cdot>k)"
  shows "P y"
by (cases y rule: writerT_cases, simp add: assms)

lemma writerT_eq_iff:
  "a = b \<longleftrightarrow> runWriterT\<cdot>a = runWriterT\<cdot>b"
apply (cases a rule: writerT_cases)
apply (cases b rule: writerT_cases)
apply simp
done

lemma writerT_below_iff:
  "a \<sqsubseteq> b \<longleftrightarrow> runWriterT\<cdot>a \<sqsubseteq> runWriterT\<cdot>b"
apply (cases a rule: writerT_cases)
apply (cases b rule: writerT_cases)
apply simp
done

lemma writerT_eqI:
  "runWriterT\<cdot>a = runWriterT\<cdot>b \<Longrightarrow> a = b"
by (simp add: writerT_eq_iff)

lemma writerT_belowI:
  "runWriterT\<cdot>a \<sqsubseteq> runWriterT\<cdot>b \<Longrightarrow> a \<sqsubseteq> b"
by (simp add: writerT_below_iff)

lemma runWriterT_coerce [simp]:
  "runWriterT\<cdot>(coerce\<cdot>k) = coerce\<cdot>(runWriterT\<cdot>k)"
by (induct k rule: writerT_induct, simp)

subsection \<open>Functor class instance\<close>

lemma fmap_writer_def: "fmap = writer_map\<cdot>ID"
apply (rule cfun_eqI, rename_tac f)
apply (rule cfun_eqI, rename_tac x)
apply (case_tac x rule: writer.exhaust, simp_all)
apply (simp add: writer_map_def fix_const)
apply (simp add: writer_map_def fix_const Writer_def)
done

lemma fmapU_WriterT [simp]:
  "fmapU\<cdot>f\<cdot>(WriterT\<cdot>m) = WriterT\<cdot>(fmap\<cdot>(fmap\<cdot>f)\<cdot>m)"
unfolding fmapU_writerT_def writerT_map_def fmap_writer_def fix_const
  WriterT_def by simp

lemma runWriterT_fmapU [simp]:
  "runWriterT\<cdot>(fmapU\<cdot>f\<cdot>m) = fmap\<cdot>(fmap\<cdot>f)\<cdot>(runWriterT\<cdot>m)"
by (induct m rule: writerT_induct) simp

instance writerT :: ("functor", "domain") "functor"
proof
  fix f g :: "udom \<rightarrow> udom" and xs :: "udom\<cdot>('a,'b) writerT"
  show "fmapU\<cdot>f\<cdot>(fmapU\<cdot>g\<cdot>xs) = fmapU\<cdot>(\<Lambda> x. f\<cdot>(g\<cdot>x))\<cdot>xs"
    apply (induct xs rule: writerT_induct)
    apply (simp add: fmap_fmap eta_cfun)
    done
qed

subsection \<open>Monad operations\<close>

text \<open>The writer monad transformer does not yield a monad in the
usual sense: We cannot prove a \<open>monad\<close> class instance, because
type \<open>'a\<cdot>('m,'w) writerT\<close> contains values that break the monad
laws. However, it turns out that such values are inaccessible: The
monad laws are satisfied by all values constructible from the abstract
operations.\<close>

text \<open>To explore the properties of the writer monad transformer
operations, we define them all as non-overloaded functions. \medskip
\<close>

definition unitWT :: "'a \<rightarrow> 'a\<cdot>('m::monad,'w::monoid) writerT"
  where "unitWT = (\<Lambda> x. WriterT\<cdot>(return\<cdot>(Writer\<cdot>mempty\<cdot>x)))"

definition bindWT :: "'a\<cdot>('m::monad,'w::monoid) writerT \<rightarrow> ('a \<rightarrow> 'b\<cdot>('m,'w) writerT) \<rightarrow> 'b\<cdot>('m,'w) writerT"
  where "bindWT = (\<Lambda> m k. WriterT\<cdot>(bind\<cdot>(runWriterT\<cdot>m)\<cdot>
    (\<Lambda>(Writer\<cdot>w\<cdot>x). bind\<cdot>(runWriterT\<cdot>(k\<cdot>x))\<cdot>(\<Lambda>(Writer\<cdot>w'\<cdot>y).
      return\<cdot>(Writer\<cdot>(mappend\<cdot>w\<cdot>w')\<cdot>y)))))"

definition liftWT :: "'a\<cdot>'m \<rightarrow> 'a\<cdot>('m::monad,'w::monoid) writerT"
  where "liftWT = (\<Lambda> m. WriterT\<cdot>(fmap\<cdot>(Writer\<cdot>mempty)\<cdot>m))"

definition tellWT :: "'a \<rightarrow> 'w \<rightarrow> 'a\<cdot>('m::monad,'w::monoid) writerT"
  where "tellWT = (\<Lambda> x w. WriterT\<cdot>(return\<cdot>(Writer\<cdot>w\<cdot>x)))"

definition fmapWT :: "('a \<rightarrow> 'b) \<rightarrow> 'a\<cdot>('m::monad,'w::monoid) writerT \<rightarrow> 'b\<cdot>('m,'w) writerT"
  where "fmapWT = (\<Lambda> f m. bindWT\<cdot>m\<cdot>(\<Lambda> x. unitWT\<cdot>(f\<cdot>x)))"

lemma runWriterT_fmap [simp]:
  "runWriterT\<cdot>(fmap\<cdot>f\<cdot>m) = fmap\<cdot>(fmap\<cdot>f)\<cdot>(runWriterT\<cdot>m)"
by (subst fmap_def, simp add: coerce_simp eta_cfun)

lemma runWriterT_unitWT [simp]:
  "runWriterT\<cdot>(unitWT\<cdot>x) = return\<cdot>(Writer\<cdot>mempty\<cdot>x)"
unfolding unitWT_def by simp

lemma runWriterT_liftWT [simp]:
  "runWriterT\<cdot>(liftWT\<cdot>m) = fmap\<cdot>(Writer\<cdot>mempty)\<cdot>m"
unfolding liftWT_def by simp

lemma runWriterT_tellWT [simp]:
  "runWriterT\<cdot>(tellWT\<cdot>x\<cdot>w) = return\<cdot>(Writer\<cdot>w\<cdot>x)"
unfolding tellWT_def by simp

lemma runWriterT_fmapWT [simp]:
  "runWriterT\<cdot>(fmapWT\<cdot>f\<cdot>m) =
    runWriterT\<cdot>m \<bind> (\<Lambda> (Writer\<cdot>w\<cdot>x). return\<cdot>(Writer\<cdot>w\<cdot>(f\<cdot>x)))"
by (simp add: fmapWT_def bindWT_def mempty_right)

subsection \<open>Laws\<close>

text \<open>The \<open>liftWT\<close> function maps \<open>return\<close> and
\<open>bind\<close> on the inner monad to \<open>unitWT\<close> and \<open>bindWT\<close>, as expected. \medskip\<close>

lemma liftWT_return:
  "liftWT\<cdot>(return\<cdot>x) = unitWT\<cdot>x"
by (rule writerT_eqI, simp add: fmap_return)

lemma liftWT_bind:
  "liftWT\<cdot>(bind\<cdot>m\<cdot>k) = bindWT\<cdot>(liftWT\<cdot>m)\<cdot>(liftWT oo k)"
by (rule writerT_eqI)
   (simp add: monad_fmap bind_bind mempty_left)

text \<open>The composition rule holds unconditionally for fmap. The fmap
function also interacts as expected with unit and bind. \medskip\<close>

lemma fmapWT_fmapWT:
  "fmapWT\<cdot>f\<cdot>(fmapWT\<cdot>g\<cdot>m) = fmapWT\<cdot>(\<Lambda> x. f\<cdot>(g\<cdot>x))\<cdot>m"
apply (simp add: writerT_eq_iff bind_bind)
apply (rule cfun_arg_cong, rule cfun_eqI, simp)
apply (case_tac x, simp add: bind_strict, simp add: mempty_right)
done

lemma fmapWT_unitWT:
  "fmapWT\<cdot>f\<cdot>(unitWT\<cdot>x) = unitWT\<cdot>(f\<cdot>x)"
by (simp add: writerT_eq_iff mempty_right)

lemma fmapWT_bindWT:
  "fmapWT\<cdot>f\<cdot>(bindWT\<cdot>m\<cdot>k) = bindWT\<cdot>m\<cdot>(\<Lambda> x. fmapWT\<cdot>f\<cdot>(k\<cdot>x))"
apply (simp add: writerT_eq_iff bind_bind)
apply (rule cfun_arg_cong, rule cfun_eqI, rename_tac x, simp)
apply (case_tac x, simp add: bind_strict, simp add: bind_bind)
apply (rule cfun_arg_cong, rule cfun_eqI, rename_tac y, simp)
apply (case_tac y, simp add: bind_strict, simp add: mempty_right)
done

lemma bindWT_fmapWT:
  "bindWT\<cdot>(fmapWT\<cdot>f\<cdot>m)\<cdot>k = bindWT\<cdot>m\<cdot>(\<Lambda> x. k\<cdot>(f\<cdot>x))"
apply (simp add: writerT_eq_iff bind_bind)
apply (rule cfun_arg_cong, rule cfun_eqI, rename_tac x, simp)
apply (case_tac x, simp add: bind_strict, simp add: mempty_right)
done

text \<open>The left unit monad law is not satisfied in general. \medskip\<close>

lemma bindWT_unitWT_counterexample:
  fixes k :: "'a \<rightarrow> 'b\<cdot>('m::monad,'w::monoid) writerT"
  assumes 1: "k\<cdot>x = WriterT\<cdot>(return\<cdot>\<bottom>)"
  assumes 2: "return\<cdot>\<bottom> \<noteq> (\<bottom> :: ('b\<cdot>'w writer)\<cdot>'m::monad)"
  shows "bindWT\<cdot>(unitWT\<cdot>x)\<cdot>k \<noteq> k\<cdot>x"
by (simp add: writerT_eq_iff mempty_left assms)

text \<open>However, left unit is satisfied for inner monads with a strict
\<open>return\<close> function.\<close>

lemma bindWT_unitWT_restricted:
  fixes k :: "'a \<rightarrow> 'b\<cdot>('m::monad,'w::monoid) writerT"
  assumes "return\<cdot>\<bottom> = (\<bottom> :: ('b\<cdot>'w writer)\<cdot>'m)"
  shows "bindWT\<cdot>(unitWT\<cdot>x)\<cdot>k = k\<cdot>x"
unfolding writerT_eq_iff
apply (simp add: mempty_left)
apply (rule trans [OF _ monad_right_unit])
apply (rule cfun_arg_cong)
apply (rule cfun_eqI)
apply (case_tac x, simp_all add: assms)
done

text \<open>The associativity of \<open>bindWT\<close> holds
unconditionally. \medskip\<close>

lemma bindWT_bindWT:
  "bindWT\<cdot>(bindWT\<cdot>m\<cdot>h)\<cdot>k = bindWT\<cdot>m\<cdot>(\<Lambda> x. bindWT\<cdot>(h\<cdot>x)\<cdot>k)"
apply (rule writerT_eqI)
apply simp
apply (simp add: bind_bind)
apply (rule cfun_arg_cong)
apply (rule cfun_eqI, simp)
apply (case_tac x)
apply (simp add: bind_strict)
apply (simp add: bind_bind)
apply (rule cfun_arg_cong)
apply (rule cfun_eqI, simp, rename_tac y)
apply (case_tac y)
apply (simp add: bind_strict)
apply (simp add: bind_bind)
apply (rule cfun_arg_cong)
apply (rule cfun_eqI, simp, rename_tac z)
apply (case_tac z)
apply (simp add: bind_strict)
apply (simp add: mappend_assoc)
done

text \<open>The right unit monad law is not satisfied in general. \medskip\<close>

lemma bindWT_unitWT_right_counterexample:
  fixes m :: "'a\<cdot>('m::monad,'w::monoid) writerT"
  assumes "m = WriterT\<cdot>(return\<cdot>\<bottom>)"
  assumes "return\<cdot>\<bottom> \<noteq> (\<bottom> :: ('a\<cdot>'w writer)\<cdot>'m)"
  shows "bindWT\<cdot>m\<cdot>unitWT \<noteq> m"
by (simp add: writerT_eq_iff assms)

text \<open>Right unit is satisfied for inner monads with a strict \<open>return\<close> function. \medskip\<close>

lemma bindWT_unitWT_right_restricted:
  fixes m :: "'a\<cdot>('m::monad,'w::monoid) writerT"
  assumes "return\<cdot>\<bottom> = (\<bottom> :: ('a\<cdot>'w writer)\<cdot>'m)"
  shows "bindWT\<cdot>m\<cdot>unitWT = m"
unfolding writerT_eq_iff
apply simp
apply (rule trans [OF _ monad_right_unit])
apply (rule cfun_arg_cong)
apply (rule cfun_eqI)
apply (case_tac x, simp_all add: assms mempty_right)
done

subsection \<open>Writer monad transformer invariant\<close>

text \<open>We inductively define a predicate that includes all values
that can be constructed from the standard \<open>writerT\<close> operations.
\medskip\<close>

inductive invar :: "'a\<cdot>('m::monad, 'w::monoid) writerT \<Rightarrow> bool"
  where invar_bottom: "invar \<bottom>"
  | invar_lub: "\<And>Y. \<lbrakk>chain Y; \<And>i. invar (Y i)\<rbrakk> \<Longrightarrow> invar (\<Squnion>i. Y i)"
  | invar_unitWT: "\<And>x. invar (unitWT\<cdot>x)"
  | invar_bindWT: "\<And>m k. \<lbrakk>invar m; \<And>x. invar (k\<cdot>x)\<rbrakk> \<Longrightarrow> invar (bindWT\<cdot>m\<cdot>k)"
  | invar_tellWT: "\<And>x w. invar (tellWT\<cdot>x\<cdot>w)"
  | invar_liftWT: "\<And>m. invar (liftWT\<cdot>m)"

text \<open>Right unit is satisfied for arguments built from standard
functions. \medskip\<close>

lemma bindWT_unitWT_right_invar:
  fixes m :: "'a\<cdot>('m::monad,'w::monoid) writerT"
  assumes "invar m"
  shows "bindWT\<cdot>m\<cdot>unitWT = m"
using assms proof (induct set: invar)
  case invar_bottom thus ?case
    by (rule writerT_eqI, simp add: bind_strict)
next
  case invar_lub thus ?case
    by - (rule admD, simp, assumption, assumption)
next
  case invar_unitWT thus ?case
    by (rule writerT_eqI, simp add: bind_bind mempty_left)
next
  case invar_bindWT thus ?case
    apply (simp add: writerT_eq_iff bind_bind)
    apply (rule cfun_arg_cong, rule cfun_eqI, simp)
    apply (case_tac x, simp add: bind_strict, simp add: bind_bind)
    apply (rule cfun_arg_cong, rule cfun_eqI, simp, rename_tac y)
    apply (case_tac y, simp add: bind_strict, simp add: mempty_right)
    done
next
  case invar_tellWT thus ?case
    by (simp add: writerT_eq_iff mempty_right)
next
  case invar_liftWT thus ?case
    by (rule writerT_eqI, simp add: monad_fmap bind_bind mempty_right)
qed

text \<open>Left unit is also satisfied for arguments built from standard
functions. \medskip\<close>

lemma writerT_left_unit_invar_lemma:
  assumes "invar m"
  shows "runWriterT\<cdot>m \<bind> (\<Lambda> (Writer\<cdot>w\<cdot>x). return\<cdot>(Writer\<cdot>w\<cdot>x)) = runWriterT\<cdot>m"
using assms proof (induct m set: invar)
  case invar_bottom thus ?case
    by (simp add: bind_strict)
next
  case invar_lub thus ?case
    by - (rule admD, simp, assumption, assumption)
next
  case invar_unitWT thus ?case
    by simp
next
  case invar_bindWT thus ?case
    apply (simp add: bind_bind)
    apply (rule cfun_arg_cong)
    apply (rule cfun_eqI, simp, rename_tac n)
    apply (case_tac n, simp add: bind_strict)
    apply (simp add: bind_bind)
    apply (rule cfun_arg_cong)
    apply (rule cfun_eqI, simp, rename_tac p)
    apply (case_tac p, simp add: bind_strict)
    apply simp
    done
next
  case invar_tellWT thus ?case
    by simp
next
  case invar_liftWT thus ?case
    by (simp add: monad_fmap bind_bind)
qed

lemma bindWT_unitWT_invar:
  assumes "invar (k\<cdot>x)"
  shows "bindWT\<cdot>(unitWT\<cdot>x)\<cdot>k = k\<cdot>x"
apply (simp add: writerT_eq_iff mempty_left)
apply (rule writerT_left_unit_invar_lemma [OF assms])
done

subsection \<open>Invariant expressed as a deflation\<close>

definition invar' :: "'a\<cdot>('m::monad, 'w::monoid) writerT \<Rightarrow> bool"
  where "invar' m \<longleftrightarrow> fmapWT\<cdot>ID\<cdot>m = m"

text \<open>All standard operations preserve the invariant.\<close>

lemma invar'_bottom: "invar' \<bottom>"
  unfolding invar'_def by (simp add: writerT_eq_iff bind_strict)

lemma adm_invar': "adm invar'"
  unfolding invar'_def [abs_def] by simp

lemma invar'_unitWT: "invar' (unitWT\<cdot>x)"
  unfolding invar'_def by (simp add: writerT_eq_iff)

lemma invar'_bindWT: "\<lbrakk>invar' m; \<And>x. invar' (k\<cdot>x)\<rbrakk> \<Longrightarrow> invar' (bindWT\<cdot>m\<cdot>k)"
  unfolding invar'_def
  apply (erule subst)
  apply (simp add: writerT_eq_iff)
  apply (simp add: bind_bind)
  apply (rule cfun_arg_cong)
  apply (rule cfun_eqI, case_tac x)
  apply (simp add: bind_strict)
  apply simp
  apply (simp add: bind_bind)
  apply (rule cfun_arg_cong)
  apply (rule cfun_eqI, rename_tac x, case_tac x)
  apply (simp add: bind_strict)
  apply simp
  done

lemma invar'_tellWT: "invar' (tellWT\<cdot>x\<cdot>w)"
  unfolding invar'_def by (simp add: writerT_eq_iff)

lemma invar'_liftWT: "invar' (liftWT\<cdot>m)"
  unfolding invar'_def by (simp add: writerT_eq_iff monad_fmap bind_bind)

text \<open>Left unit is satisfied for arguments built from fmap.\<close>

lemma bindWT_unitWT_fmapWT:
  "bindWT\<cdot>(unitWT\<cdot>x)\<cdot>(\<Lambda> x. fmapWT\<cdot>f\<cdot>(k\<cdot>x))
    = fmapWT\<cdot>f\<cdot>(k\<cdot>x)"
apply (simp add: fmapWT_def writerT_eq_iff bind_bind)
apply (rule cfun_arg_cong, rule cfun_eqI, simp)
apply (case_tac x, simp_all add: bind_strict mempty_left)
done

text \<open>Right unit is satisfied for arguments built from fmap.\<close>

lemma bindWT_fmapWT_unitWT:
  shows "bindWT\<cdot>(fmapWT\<cdot>f\<cdot>m)\<cdot>unitWT = fmapWT\<cdot>f\<cdot>m"
apply (simp add: bindWT_fmapWT)
apply (simp add: fmapWT_def)
done

text \<open>All monad laws are preserved by values satisfying the invariant.\<close>

lemma invar'_right_unit: "invar' m \<Longrightarrow> bindWT\<cdot>m\<cdot>unitWT = m"
unfolding invar'_def by (erule subst, rule bindWT_fmapWT_unitWT)

lemma invar'_monad_fmap:
  "invar' m \<Longrightarrow> fmapWT\<cdot>f\<cdot>m = bindWT\<cdot>m\<cdot>(\<Lambda> x. unitWT\<cdot>(f\<cdot>x))"
  unfolding invar'_def
  by (erule subst, simp add: writerT_eq_iff mempty_right)

lemma invar'_bind_assoc:
  "\<lbrakk>invar' m; \<And>x. invar' (f\<cdot>x); \<And>y. invar' (g\<cdot>y)\<rbrakk>
    \<Longrightarrow> bindWT\<cdot>(bindWT\<cdot>m\<cdot>f)\<cdot>g = bindWT\<cdot>m\<cdot>(\<Lambda> x. bindWT\<cdot>(f\<cdot>x)\<cdot>g)"
  by (rule bindWT_bindWT)

end


theory Iterator
imports
  It_to_It
  SetIteratorOperations
  SetIteratorGA
  Proper_Iterator
  Gen_Iterator
  Idx_Iterator
begin

  text {* Folding over a list created by a proper iterator can be replaced
    by a single iteration *}
  lemma proper_it_to_list_opt[refine_transfer_post_subst]:
    assumes PR: "proper_it' it it'"
    shows "foldli o it_to_list it \<equiv> it'"
  proof (rule eq_reflection, intro ext)
    fix s c f \<sigma>

    obtain l where "it s = foldli l" and "it' s = foldli l"
      by (rule proper_itE[OF PR[THEN proper_it'D[where s=s]]])
    thus "(foldli o it_to_list it) s c f \<sigma> = it' s c f \<sigma>"
      by (simp add: comp_def it_to_list_def)
  qed

  lemma iterator_cnv_to_comp[refine_transfer_post_simp]:
    "foldli (it_to_list it x) = (foldli o it_to_list it) x"
    by auto

  declare idx_iteratei_eq_foldli[autoref_rules]

end


theory flash97Bra  imports flash97Rev

  begin
lemma onInv97:

   assumes

     b1:"r \<in> rules N" and b2:"invf=inv97 "
   shows  "invHoldForRule' s invf r (invariants   N)"
   proof -
have c1:"ex1P N (% iRule1 .  r=NI_Local_GetX_PutX1 N  iRule1 )\<or>ex1P N (% iRule1 .  r=NI_Local_GetX_GetX  iRule1 )\<or>ex1P N (% iRule1 .  r=NI_Replace  iRule1 )\<or>ex0P N (  r=NI_ShWb N )\<or>ex0P N (  r=PI_Local_GetX_GetX2 )\<or>ex0P N (  r=NI_Local_PutXAcksDone )\<or>ex1P N (% iRule1 .  r=NI_Local_GetX_PutX7 N  iRule1 )\<or>ex1P N (% iRule1 .  r=NI_Local_Get_Nak2  iRule1 )\<or>ex0P N (  r=NI_ReplaceHomeShrVld )\<or>ex1P N (% iRule1 .  r=NI_Remote_Put  iRule1 )\<or>ex1P N (% iRule1 .  r=NI_Local_GetX_PutX5 N  iRule1 )\<or>ex0P N (  r=NI_Wb )\<or>ex1P N (% iRule1 .  r=NI_Local_Get_Get  iRule1 )\<or>ex0P N (  r=PI_Local_Replace )\<or>ex1P N (% iRule1 .  r=NI_ReplaceShrVld  iRule1 )\<or>ex2P N (% iRule1  iRule2 .  r=NI_Local_GetX_PutX8 N  iRule1  iRule2 )\<or>ex1P N (% iRule1 .  r=NI_InvAck_2 N  iRule1 )\<or>ex2P N (% iRule1  iRule2 .  r=NI_Remote_Get_Nak2  iRule1  iRule2 )\<or>ex1P N (% iRule1 .  r=PI_Remote_Replace  iRule1 )\<or>ex0P N (  r=NI_Nak_Home )\<or>ex1P N (% iRule1 .  r=NI_Local_Get_Put2  iRule1 )\<or>ex2P N (% iRule1  iRule2 .  r=NI_InvAck_1  iRule1  iRule2 )\<or>ex1P N (% iRule1 .  r=NI_Local_GetX_PutX11 N  iRule1 )\<or>ex1P N (% iRule1 .  r=NI_Local_GetX_PutX6 N  iRule1 )\<or>ex2P N (% iRule1  iRule2 .  r=NI_Remote_Get_Put2  iRule1  iRule2 )\<or>ex0P N (  r=PI_Local_Get_Put )\<or>ex0P N (  r=PI_Local_GetX_PutX1 N )\<or>ex1P N (% iRule1 .  r=NI_InvAck_1_Home  iRule1 )\<or>ex1P N (% iRule1 .  r=NI_Remote_Get_Nak1  iRule1 )\<or>ex1P N (% iRule1 .  r=NI_Local_Get_Nak1  iRule1 )\<or>ex1P N (% iRule1 .  r=NI_Local_GetX_Nak2  iRule1 )\<or>ex1P N (% iRule1 .  r=NI_Local_GetX_PutX10_home N  iRule1 )\<or>ex1P N (% iRule1 .  r=PI_Remote_Get  iRule1 )\<or>ex1P N (% iRule1 .  r=NI_Local_GetX_Nak3  iRule1 )\<or>ex2P N (% iRule1  iRule2 .  r=NI_Local_GetX_PutX10 N  iRule1  iRule2 )\<or>ex1P N (% iRule1 .  r=NI_Local_GetX_PutX2 N  iRule1 )\<or>ex1P N (% iRule1 .  r=NI_Remote_Get_Put1  iRule1 )\<or>ex1P N (% iRule1 .  r=NI_Remote_PutX  iRule1 )\<or>ex1P N (% iRule1 .  r=Store  iRule1 )\<or>ex0P N (  r=NI_FAck )\<or>ex1P N (% iRule1 .  r=NI_Local_GetX_PutX3 N  iRule1 )\<or>ex0P N (  r=PI_Local_GetX_PutX3 )\<or>ex2P N (% iRule1  iRule2 .  r=NI_Remote_GetX_PutX  iRule1  iRule2 )\<or>ex1P N (% iRule1 .  r=NI_Local_GetX_PutX8_home N  iRule1 )\<or>ex1P N (% iRule1 .  r=NI_Local_Get_Put1 N  iRule1 )\<or>ex0P N (  r=PI_Local_GetX_GetX1 )\<or>ex0P N (  r=StoreHome )\<or>ex2P N (% iRule1  iRule2 .  r=NI_Remote_GetX_Nak  iRule1  iRule2 )\<or>ex1P N (% iRule1 .  r=NI_Inv  iRule1 )\<or>ex1P N (% iRule1 .  r=PI_Remote_PutX  iRule1 )\<or>ex0P N (  r=PI_Local_GetX_PutX4 )\<or>ex1P N (% iRule1 .  r=NI_Local_GetX_PutX4 N  iRule1 )\<or>ex1P N (% iRule1 .  r=NI_Nak  iRule1 )\<or>ex0P N (  r=PI_Local_GetX_PutX2 N )\<or>ex0P N (  r=NI_Local_Put )\<or>ex1P N (% iRule1 .  r=NI_Local_GetX_Nak1  iRule1 )\<or>ex0P N (  r=NI_Nak_Clear )\<or>ex0P N (  r=PI_Local_PutX )\<or>ex1P N (% iRule1 .  r=NI_Local_Get_Nak3  iRule1 )\<or>ex1P N (% iRule1 .  r=NI_Remote_GetX_Nak_Home  iRule1 )\<or>ex0P N (  r=PI_Local_Get_Get )\<or>ex1P N (% iRule1 .  r=NI_Local_GetX_PutX9 N  iRule1 )\<or>ex1P N (% iRule1 .  r=PI_Remote_GetX  iRule1 )\<or>ex0P N (  r=NI_ReplaceHome )\<or>ex1P N (% iRule1 .  r=NI_Remote_GetX_PutX_Home  iRule1 )\<or>ex1P N (% iRule1 .  r=NI_Local_Get_Put3  iRule1 )"

        apply(cut_tac  b1)
        apply auto
        done      moreover
        {assume c1: "ex1P N (% iRule1 .  r= NI_Local_GetX_PutX1 N  iRule1 )
"

         from c1 obtain  iRule1  where c2:"  iRule1 \<le> N \<and>  r= NI_Local_GetX_PutX1 N  iRule1 "
         by (auto simp add: ex1P_def)

         have "invHoldForRule' s (inv97 ) (NI_Local_GetX_PutX1 N  iRule1 ) (invariants N) "
            apply(cut_tac  c2  )
            by (metis NI_Local_GetX_PutX1VsInv97 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
        }      moreover
        {assume c1: "ex1P N (% iRule1 .  r= NI_Local_GetX_GetX  iRule1 )
"

         from c1 obtain  iRule1  where c2:"  iRule1 \<le> N \<and>  r= NI_Local_GetX_GetX  iRule1 "
         by (auto simp add: ex1P_def)

         have "invHoldForRule' s (inv97 ) (NI_Local_GetX_GetX  iRule1 ) (invariants N) "
            apply(cut_tac  c2  )
            by (metis NI_Local_GetX_GetXVsInv97 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
        }      moreover
        {assume c1: "ex1P N (% iRule1 .  r= NI_Replace  iRule1 )
"

         from c1 obtain  iRule1  where c2:"  iRule1 \<le> N \<and>  r= NI_Replace  iRule1 "
         by (auto simp add: ex1P_def)

         have "invHoldForRule' s (inv97 ) (NI_Replace  iRule1 ) (invariants N) "
            apply(cut_tac  c2  )
            by (metis NI_ReplaceVsInv97 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
        }      moreover
        {assume c1: "ex0P N (  r= NI_ShWb N )
"

         from c1 have c2:" r= NI_ShWb N "
         by (auto simp add: ex0P_def)

         have "invHoldForRule' s (inv97 ) (NI_ShWb N ) (invariants N) "
            apply(cut_tac    b2 c2 )
            by (metis NI_ShWbVsInv97 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
	}      moreover
        {assume c1: "ex0P N (  r= PI_Local_GetX_GetX2 )
"

         from c1 have c2:" r= PI_Local_GetX_GetX2 "
         by (auto simp add: ex0P_def)

         have "invHoldForRule' s (inv97 ) (PI_Local_GetX_GetX2 ) (invariants N) "
            apply(cut_tac    b2 c2 )
            by (metis PI_Local_GetX_GetX2VsInv97 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
	}      moreover
        {assume c1: "ex0P N (  r= NI_Local_PutXAcksDone )
"

         from c1 have c2:" r= NI_Local_PutXAcksDone "
         by (auto simp add: ex0P_def)

         have "invHoldForRule' s (inv97 ) (NI_Local_PutXAcksDone ) (invariants N) "
            apply(cut_tac    b2 c2 )
            by (metis NI_Local_PutXAcksDoneVsInv97 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
	}      moreover
        {assume c1: "ex1P N (% iRule1 .  r= NI_Local_GetX_PutX7 N  iRule1 )
"

         from c1 obtain  iRule1  where c2:"  iRule1 \<le> N \<and>  r= NI_Local_GetX_PutX7 N  iRule1 "
         by (auto simp add: ex1P_def)

         have "invHoldForRule' s (inv97 ) (NI_Local_GetX_PutX7 N  iRule1 ) (invariants N) "
            apply(cut_tac  c2  )
            by (metis NI_Local_GetX_PutX7VsInv97 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
        }      moreover
        {assume c1: "ex1P N (% iRule1 .  r= NI_Local_Get_Nak2  iRule1 )
"

         from c1 obtain  iRule1  where c2:"  iRule1 \<le> N \<and>  r= NI_Local_Get_Nak2  iRule1 "
         by (auto simp add: ex1P_def)

         have "invHoldForRule' s (inv97 ) (NI_Local_Get_Nak2  iRule1 ) (invariants N) "
            apply(cut_tac  c2  )
            by (metis NI_Local_Get_Nak2VsInv97 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
        }      moreover
        {assume c1: "ex0P N (  r= NI_ReplaceHomeShrVld )
"

         from c1 have c2:" r= NI_ReplaceHomeShrVld "
         by (auto simp add: ex0P_def)

         have "invHoldForRule' s (inv97 ) (NI_ReplaceHomeShrVld ) (invariants N) "
            apply(cut_tac    b2 c2 )
            by (metis NI_ReplaceHomeShrVldVsInv97 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
	}      moreover
        {assume c1: "ex1P N (% iRule1 .  r= NI_Remote_Put  iRule1 )
"

         from c1 obtain  iRule1  where c2:"  iRule1 \<le> N \<and>  r= NI_Remote_Put  iRule1 "
         by (auto simp add: ex1P_def)

         have "invHoldForRule' s (inv97 ) (NI_Remote_Put  iRule1 ) (invariants N) "
            apply(cut_tac  c2  )
            by (metis NI_Remote_PutVsInv97 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
        }      moreover
        {assume c1: "ex1P N (% iRule1 .  r= NI_Local_GetX_PutX5 N  iRule1 )
"

         from c1 obtain  iRule1  where c2:"  iRule1 \<le> N \<and>  r= NI_Local_GetX_PutX5 N  iRule1 "
         by (auto simp add: ex1P_def)

         have "invHoldForRule' s (inv97 ) (NI_Local_GetX_PutX5 N  iRule1 ) (invariants N) "
            apply(cut_tac  c2  )
            by (metis NI_Local_GetX_PutX5VsInv97 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
        }      moreover
        {assume c1: "ex0P N (  r= NI_Wb )
"

         from c1 have c2:" r= NI_Wb "
         by (auto simp add: ex0P_def)

         have "invHoldForRule' s (inv97 ) (NI_Wb ) (invariants N) "
            apply(cut_tac    b2 c2 )
            by (metis NI_WbVsInv97 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
	}      moreover
        {assume c1: "ex1P N (% iRule1 .  r= NI_Local_Get_Get  iRule1 )
"

         from c1 obtain  iRule1  where c2:"  iRule1 \<le> N \<and>  r= NI_Local_Get_Get  iRule1 "
         by (auto simp add: ex1P_def)

         have "invHoldForRule' s (inv97 ) (NI_Local_Get_Get  iRule1 ) (invariants N) "
            apply(cut_tac  c2  )
            by (metis NI_Local_Get_GetVsInv97 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
        }      moreover
        {assume c1: "ex0P N (  r= PI_Local_Replace )
"

         from c1 have c2:" r= PI_Local_Replace "
         by (auto simp add: ex0P_def)

         have "invHoldForRule' s (inv97 ) (PI_Local_Replace ) (invariants N) "
            apply(cut_tac    b2 c2 )
            by (metis PI_Local_ReplaceVsInv97 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
	}      moreover
        {assume c1: "ex1P N (% iRule1 .  r= NI_ReplaceShrVld  iRule1 )
"

         from c1 obtain  iRule1  where c2:"  iRule1 \<le> N \<and>  r= NI_ReplaceShrVld  iRule1 "
         by (auto simp add: ex1P_def)

         have "invHoldForRule' s (inv97 ) (NI_ReplaceShrVld  iRule1 ) (invariants N) "
            apply(cut_tac  c2  )
            by (metis NI_ReplaceShrVldVsInv97 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
        }      moreover
        {assume c1: "ex2P N (% iRule1  iRule2 .  r= NI_Local_GetX_PutX8 N  iRule1  iRule2 )
"

         from c1 obtain  iRule1  iRule2  where c2:"  iRule1~=iRule2    \<and>   iRule1 \<le> N \<and>   iRule2 \<le> N \<and>  r= NI_Local_GetX_PutX8 N  iRule1  iRule2 "
         by (auto simp add: ex2P_def)

         have "invHoldForRule' s (inv97 ) (NI_Local_GetX_PutX8 N  iRule1  iRule2 ) (invariants N) "
            apply(cut_tac  c2  )
            by (metis NI_Local_GetX_PutX8VsInv97 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
        }      moreover
        {assume c1: "ex1P N (% iRule1 .  r= NI_InvAck_2 N  iRule1 )
"

         from c1 obtain  iRule1  where c2:"  iRule1 \<le> N \<and>  r= NI_InvAck_2 N  iRule1 "
         by (auto simp add: ex1P_def)

         have "invHoldForRule' s (inv97 ) (NI_InvAck_2 N  iRule1 ) (invariants N) "
            apply(cut_tac  c2  )
            by (metis NI_InvAck_2VsInv97 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
        }      moreover
        {assume c1: "ex2P N (% iRule1  iRule2 .  r= NI_Remote_Get_Nak2  iRule1  iRule2 )
"

         from c1 obtain  iRule1  iRule2  where c2:"  iRule1~=iRule2    \<and>   iRule1 \<le> N \<and>   iRule2 \<le> N \<and>  r= NI_Remote_Get_Nak2  iRule1  iRule2 "
         by (auto simp add: ex2P_def)

         have "invHoldForRule' s (inv97 ) (NI_Remote_Get_Nak2  iRule1  iRule2 ) (invariants N) "
            apply(cut_tac  c2  )
            by (metis NI_Remote_Get_Nak2VsInv97 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
        }      moreover
        {assume c1: "ex1P N (% iRule1 .  r= PI_Remote_Replace  iRule1 )
"

         from c1 obtain  iRule1  where c2:"  iRule1 \<le> N \<and>  r= PI_Remote_Replace  iRule1 "
         by (auto simp add: ex1P_def)

         have "invHoldForRule' s (inv97 ) (PI_Remote_Replace  iRule1 ) (invariants N) "
            apply(cut_tac  c2  )
            by (metis PI_Remote_ReplaceVsInv97 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
        }      moreover
        {assume c1: "ex0P N (  r= NI_Nak_Home )
"

         from c1 have c2:" r= NI_Nak_Home "
         by (auto simp add: ex0P_def)

         have "invHoldForRule' s (inv97 ) (NI_Nak_Home ) (invariants N) "
            apply(cut_tac    b2 c2 )
            by (metis NI_Nak_HomeVsInv97 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
	}      moreover
        {assume c1: "ex1P N (% iRule1 .  r= NI_Local_Get_Put2  iRule1 )
"

         from c1 obtain  iRule1  where c2:"  iRule1 \<le> N \<and>  r= NI_Local_Get_Put2  iRule1 "
         by (auto simp add: ex1P_def)

         have "invHoldForRule' s (inv97 ) (NI_Local_Get_Put2  iRule1 ) (invariants N) "
            apply(cut_tac  c2  )
            by (metis NI_Local_Get_Put2VsInv97 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
        }      moreover
        {assume c1: "ex2P N (% iRule1  iRule2 .  r= NI_InvAck_1  iRule1  iRule2 )
"

         from c1 obtain  iRule1  iRule2  where c2:"  iRule1~=iRule2    \<and>   iRule1 \<le> N \<and>   iRule2 \<le> N \<and>  r= NI_InvAck_1  iRule1  iRule2 "
         by (auto simp add: ex2P_def)

         have "invHoldForRule' s (inv97 ) (NI_InvAck_1  iRule1  iRule2 ) (invariants N) "
            apply(cut_tac  c2  )
            by (metis NI_InvAck_1VsInv97 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
        }      moreover
        {assume c1: "ex1P N (% iRule1 .  r= NI_Local_GetX_PutX11 N  iRule1 )
"

         from c1 obtain  iRule1  where c2:"  iRule1 \<le> N \<and>  r= NI_Local_GetX_PutX11 N  iRule1 "
         by (auto simp add: ex1P_def)

         have "invHoldForRule' s (inv97 ) (NI_Local_GetX_PutX11 N  iRule1 ) (invariants N) "
            apply(cut_tac  c2  )
            by (metis NI_Local_GetX_PutX11VsInv97 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
        }      moreover
        {assume c1: "ex1P N (% iRule1 .  r= NI_Local_GetX_PutX6 N  iRule1 )
"

         from c1 obtain  iRule1  where c2:"  iRule1 \<le> N \<and>  r= NI_Local_GetX_PutX6 N  iRule1 "
         by (auto simp add: ex1P_def)

         have "invHoldForRule' s (inv97 ) (NI_Local_GetX_PutX6 N  iRule1 ) (invariants N) "
            apply(cut_tac  c2  )
            by (metis NI_Local_GetX_PutX6VsInv97 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
        }      moreover
        {assume c1: "ex2P N (% iRule1  iRule2 .  r= NI_Remote_Get_Put2  iRule1  iRule2 )
"

         from c1 obtain  iRule1  iRule2  where c2:"  iRule1~=iRule2    \<and>   iRule1 \<le> N \<and>   iRule2 \<le> N \<and>  r= NI_Remote_Get_Put2  iRule1  iRule2 "
         by (auto simp add: ex2P_def)

         have "invHoldForRule' s (inv97 ) (NI_Remote_Get_Put2  iRule1  iRule2 ) (invariants N) "
            apply(cut_tac  c2  )
            by (metis NI_Remote_Get_Put2VsInv97 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
        }      moreover
        {assume c1: "ex0P N (  r= PI_Local_Get_Put )
"

         from c1 have c2:" r= PI_Local_Get_Put "
         by (auto simp add: ex0P_def)

         have "invHoldForRule' s (inv97 ) (PI_Local_Get_Put ) (invariants N) "
            apply(cut_tac    b2 c2 )
            by (metis PI_Local_Get_PutVsInv97 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
	}      moreover
        {assume c1: "ex0P N (  r= PI_Local_GetX_PutX1 N )
"

         from c1 have c2:" r= PI_Local_GetX_PutX1 N "
         by (auto simp add: ex0P_def)

         have "invHoldForRule' s (inv97 ) (PI_Local_GetX_PutX1 N ) (invariants N) "
            apply(cut_tac    b2 c2 )
            by (metis PI_Local_GetX_PutX1VsInv97 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
	}      moreover
        {assume c1: "ex1P N (% iRule1 .  r= NI_InvAck_1_Home  iRule1 )
"

         from c1 obtain  iRule1  where c2:"  iRule1 \<le> N \<and>  r= NI_InvAck_1_Home  iRule1 "
         by (auto simp add: ex1P_def)

         have "invHoldForRule' s (inv97 ) (NI_InvAck_1_Home  iRule1 ) (invariants N) "
            apply(cut_tac  c2  )
            by (metis NI_InvAck_1_HomeVsInv97 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
        }      moreover
        {assume c1: "ex1P N (% iRule1 .  r= NI_Remote_Get_Nak1  iRule1 )
"

         from c1 obtain  iRule1  where c2:"  iRule1 \<le> N \<and>  r= NI_Remote_Get_Nak1  iRule1 "
         by (auto simp add: ex1P_def)

         have "invHoldForRule' s (inv97 ) (NI_Remote_Get_Nak1  iRule1 ) (invariants N) "
            apply(cut_tac  c2  )
            by (metis NI_Remote_Get_Nak1VsInv97 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
        }      moreover
        {assume c1: "ex1P N (% iRule1 .  r= NI_Local_Get_Nak1  iRule1 )
"

         from c1 obtain  iRule1  where c2:"  iRule1 \<le> N \<and>  r= NI_Local_Get_Nak1  iRule1 "
         by (auto simp add: ex1P_def)

         have "invHoldForRule' s (inv97 ) (NI_Local_Get_Nak1  iRule1 ) (invariants N) "
            apply(cut_tac  c2  )
            by (metis NI_Local_Get_Nak1VsInv97 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
        }      moreover
        {assume c1: "ex1P N (% iRule1 .  r= NI_Local_GetX_Nak2  iRule1 )
"

         from c1 obtain  iRule1  where c2:"  iRule1 \<le> N \<and>  r= NI_Local_GetX_Nak2  iRule1 "
         by (auto simp add: ex1P_def)

         have "invHoldForRule' s (inv97 ) (NI_Local_GetX_Nak2  iRule1 ) (invariants N) "
            apply(cut_tac  c2  )
            by (metis NI_Local_GetX_Nak2VsInv97 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
        }      moreover
        {assume c1: "ex1P N (% iRule1 .  r= NI_Local_GetX_PutX10_home N  iRule1 )
"

         from c1 obtain  iRule1  where c2:"  iRule1 \<le> N \<and>  r= NI_Local_GetX_PutX10_home N  iRule1 "
         by (auto simp add: ex1P_def)

         have "invHoldForRule' s (inv97 ) (NI_Local_GetX_PutX10_home N  iRule1 ) (invariants N) "
            apply(cut_tac  c2  )
            by (metis NI_Local_GetX_PutX10_homeVsInv97 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
        }      moreover
        {assume c1: "ex1P N (% iRule1 .  r= PI_Remote_Get  iRule1 )
"

         from c1 obtain  iRule1  where c2:"  iRule1 \<le> N \<and>  r= PI_Remote_Get  iRule1 "
         by (auto simp add: ex1P_def)

         have "invHoldForRule' s (inv97 ) (PI_Remote_Get  iRule1 ) (invariants N) "
            apply(cut_tac  c2  )
            by (metis PI_Remote_GetVsInv97 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
        }      moreover
        {assume c1: "ex1P N (% iRule1 .  r= NI_Local_GetX_Nak3  iRule1 )
"

         from c1 obtain  iRule1  where c2:"  iRule1 \<le> N \<and>  r= NI_Local_GetX_Nak3  iRule1 "
         by (auto simp add: ex1P_def)

         have "invHoldForRule' s (inv97 ) (NI_Local_GetX_Nak3  iRule1 ) (invariants N) "
            apply(cut_tac  c2  )
            by (metis NI_Local_GetX_Nak3VsInv97 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
        }      moreover
        {assume c1: "ex2P N (% iRule1  iRule2 .  r= NI_Local_GetX_PutX10 N  iRule1  iRule2 )
"

         from c1 obtain  iRule1  iRule2  where c2:"  iRule1~=iRule2    \<and>   iRule1 \<le> N \<and>   iRule2 \<le> N \<and>  r= NI_Local_GetX_PutX10 N  iRule1  iRule2 "
         by (auto simp add: ex2P_def)

         have "invHoldForRule' s (inv97 ) (NI_Local_GetX_PutX10 N  iRule1  iRule2 ) (invariants N) "
            apply(cut_tac  c2  )
            by (metis NI_Local_GetX_PutX10VsInv97 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
        }      moreover
        {assume c1: "ex1P N (% iRule1 .  r= NI_Local_GetX_PutX2 N  iRule1 )
"

         from c1 obtain  iRule1  where c2:"  iRule1 \<le> N \<and>  r= NI_Local_GetX_PutX2 N  iRule1 "
         by (auto simp add: ex1P_def)

         have "invHoldForRule' s (inv97 ) (NI_Local_GetX_PutX2 N  iRule1 ) (invariants N) "
            apply(cut_tac  c2  )
            by (metis NI_Local_GetX_PutX2VsInv97 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
        }      moreover
        {assume c1: "ex1P N (% iRule1 .  r= NI_Remote_Get_Put1  iRule1 )
"

         from c1 obtain  iRule1  where c2:"  iRule1 \<le> N \<and>  r= NI_Remote_Get_Put1  iRule1 "
         by (auto simp add: ex1P_def)

         have "invHoldForRule' s (inv97 ) (NI_Remote_Get_Put1  iRule1 ) (invariants N) "
            apply(cut_tac  c2  )
            by (metis NI_Remote_Get_Put1VsInv97 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
        }      moreover
        {assume c1: "ex1P N (% iRule1 .  r= NI_Remote_PutX  iRule1 )
"

         from c1 obtain  iRule1  where c2:"  iRule1 \<le> N \<and>  r= NI_Remote_PutX  iRule1 "
         by (auto simp add: ex1P_def)

         have "invHoldForRule' s (inv97 ) (NI_Remote_PutX  iRule1 ) (invariants N) "
            apply(cut_tac  c2  )
            by (metis NI_Remote_PutXVsInv97 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
        }      moreover
        {assume c1: "ex1P N (% iRule1 .  r= Store  iRule1 )
"

         from c1 obtain  iRule1  where c2:"  iRule1 \<le> N \<and>  r= Store  iRule1 "
         by (auto simp add: ex1P_def)

         have "invHoldForRule' s (inv97 ) (Store  iRule1 ) (invariants N) "
            apply(cut_tac  c2  )
            by (metis StoreVsInv97 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
        }      moreover
        {assume c1: "ex0P N (  r= NI_FAck )
"

         from c1 have c2:" r= NI_FAck "
         by (auto simp add: ex0P_def)

         have "invHoldForRule' s (inv97 ) (NI_FAck ) (invariants N) "
            apply(cut_tac    b2 c2 )
            by (metis NI_FAckVsInv97 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
	}      moreover
        {assume c1: "ex1P N (% iRule1 .  r= NI_Local_GetX_PutX3 N  iRule1 )
"

         from c1 obtain  iRule1  where c2:"  iRule1 \<le> N \<and>  r= NI_Local_GetX_PutX3 N  iRule1 "
         by (auto simp add: ex1P_def)

         have "invHoldForRule' s (inv97 ) (NI_Local_GetX_PutX3 N  iRule1 ) (invariants N) "
            apply(cut_tac  c2  )
            by (metis NI_Local_GetX_PutX3VsInv97 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
        }      moreover
        {assume c1: "ex0P N (  r= PI_Local_GetX_PutX3 )
"

         from c1 have c2:" r= PI_Local_GetX_PutX3 "
         by (auto simp add: ex0P_def)

         have "invHoldForRule' s (inv97 ) (PI_Local_GetX_PutX3 ) (invariants N) "
            apply(cut_tac    b2 c2 )
            by (metis PI_Local_GetX_PutX3VsInv97 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
	}      moreover
        {assume c1: "ex2P N (% iRule1  iRule2 .  r= NI_Remote_GetX_PutX  iRule1  iRule2 )
"

         from c1 obtain  iRule1  iRule2  where c2:"  iRule1~=iRule2    \<and>   iRule1 \<le> N \<and>   iRule2 \<le> N \<and>  r= NI_Remote_GetX_PutX  iRule1  iRule2 "
         by (auto simp add: ex2P_def)

         have "invHoldForRule' s (inv97 ) (NI_Remote_GetX_PutX  iRule1  iRule2 ) (invariants N) "
            apply(cut_tac  c2  )
            by (metis NI_Remote_GetX_PutXVsInv97 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
        }      moreover
        {assume c1: "ex1P N (% iRule1 .  r= NI_Local_GetX_PutX8_home N  iRule1 )
"

         from c1 obtain  iRule1  where c2:"  iRule1 \<le> N \<and>  r= NI_Local_GetX_PutX8_home N  iRule1 "
         by (auto simp add: ex1P_def)

         have "invHoldForRule' s (inv97 ) (NI_Local_GetX_PutX8_home N  iRule1 ) (invariants N) "
            apply(cut_tac  c2  )
            by (metis NI_Local_GetX_PutX8_homeVsInv97 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
        }      moreover
        {assume c1: "ex1P N (% iRule1 .  r= NI_Local_Get_Put1 N  iRule1 )
"

         from c1 obtain  iRule1  where c2:"  iRule1 \<le> N \<and>  r= NI_Local_Get_Put1 N  iRule1 "
         by (auto simp add: ex1P_def)

         have "invHoldForRule' s (inv97 ) (NI_Local_Get_Put1 N  iRule1 ) (invariants N) "
            apply(cut_tac  c2  )
            by (metis NI_Local_Get_Put1VsInv97 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
        }      moreover
        {assume c1: "ex0P N (  r= PI_Local_GetX_GetX1 )
"

         from c1 have c2:" r= PI_Local_GetX_GetX1 "
         by (auto simp add: ex0P_def)

         have "invHoldForRule' s (inv97 ) (PI_Local_GetX_GetX1 ) (invariants N) "
            apply(cut_tac    b2 c2 )
            by (metis PI_Local_GetX_GetX1VsInv97 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
	}      moreover
        {assume c1: "ex0P N (  r= StoreHome )
"

         from c1 have c2:" r= StoreHome "
         by (auto simp add: ex0P_def)

         have "invHoldForRule' s (inv97 ) (StoreHome ) (invariants N) "
            apply(cut_tac    b2 c2 )
            by (metis StoreHomeVsInv97 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
	}      moreover
        {assume c1: "ex2P N (% iRule1  iRule2 .  r= NI_Remote_GetX_Nak  iRule1  iRule2 )
"

         from c1 obtain  iRule1  iRule2  where c2:"  iRule1~=iRule2    \<and>   iRule1 \<le> N \<and>   iRule2 \<le> N \<and>  r= NI_Remote_GetX_Nak  iRule1  iRule2 "
         by (auto simp add: ex2P_def)

         have "invHoldForRule' s (inv97 ) (NI_Remote_GetX_Nak  iRule1  iRule2 ) (invariants N) "
            apply(cut_tac  c2  )
            by (metis NI_Remote_GetX_NakVsInv97 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
        }      moreover
        {assume c1: "ex1P N (% iRule1 .  r= NI_Inv  iRule1 )
"

         from c1 obtain  iRule1  where c2:"  iRule1 \<le> N \<and>  r= NI_Inv  iRule1 "
         by (auto simp add: ex1P_def)

         have "invHoldForRule' s (inv97 ) (NI_Inv  iRule1 ) (invariants N) "
            apply(cut_tac  c2  )
            by (metis NI_InvVsInv97 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
        }      moreover
        {assume c1: "ex1P N (% iRule1 .  r= PI_Remote_PutX  iRule1 )
"

         from c1 obtain  iRule1  where c2:"  iRule1 \<le> N \<and>  r= PI_Remote_PutX  iRule1 "
         by (auto simp add: ex1P_def)

         have "invHoldForRule' s (inv97 ) (PI_Remote_PutX  iRule1 ) (invariants N) "
            apply(cut_tac  c2  )
            by (metis PI_Remote_PutXVsInv97 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
        }      moreover
        {assume c1: "ex0P N (  r= PI_Local_GetX_PutX4 )
"

         from c1 have c2:" r= PI_Local_GetX_PutX4 "
         by (auto simp add: ex0P_def)

         have "invHoldForRule' s (inv97 ) (PI_Local_GetX_PutX4 ) (invariants N) "
            apply(cut_tac    b2 c2 )
            by (metis PI_Local_GetX_PutX4VsInv97 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
	}      moreover
        {assume c1: "ex1P N (% iRule1 .  r= NI_Local_GetX_PutX4 N  iRule1 )
"

         from c1 obtain  iRule1  where c2:"  iRule1 \<le> N \<and>  r= NI_Local_GetX_PutX4 N  iRule1 "
         by (auto simp add: ex1P_def)

         have "invHoldForRule' s (inv97 ) (NI_Local_GetX_PutX4 N  iRule1 ) (invariants N) "
            apply(cut_tac  c2  )
            by (metis NI_Local_GetX_PutX4VsInv97 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
        }      moreover
        {assume c1: "ex1P N (% iRule1 .  r= NI_Nak  iRule1 )
"

         from c1 obtain  iRule1  where c2:"  iRule1 \<le> N \<and>  r= NI_Nak  iRule1 "
         by (auto simp add: ex1P_def)

         have "invHoldForRule' s (inv97 ) (NI_Nak  iRule1 ) (invariants N) "
            apply(cut_tac  c2  )
            by (metis NI_NakVsInv97 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
        }      moreover
        {assume c1: "ex0P N (  r= PI_Local_GetX_PutX2 N )
"

         from c1 have c2:" r= PI_Local_GetX_PutX2 N "
         by (auto simp add: ex0P_def)

         have "invHoldForRule' s (inv97 ) (PI_Local_GetX_PutX2 N ) (invariants N) "
            apply(cut_tac    b2 c2 )
            by (metis PI_Local_GetX_PutX2VsInv97 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
	}      moreover
        {assume c1: "ex0P N (  r= NI_Local_Put )
"

         from c1 have c2:" r= NI_Local_Put "
         by (auto simp add: ex0P_def)

         have "invHoldForRule' s (inv97 ) (NI_Local_Put ) (invariants N) "
            apply(cut_tac    b2 c2 )
            by (metis NI_Local_PutVsInv97 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
	}      moreover
        {assume c1: "ex1P N (% iRule1 .  r= NI_Local_GetX_Nak1  iRule1 )
"

         from c1 obtain  iRule1  where c2:"  iRule1 \<le> N \<and>  r= NI_Local_GetX_Nak1  iRule1 "
         by (auto simp add: ex1P_def)

         have "invHoldForRule' s (inv97 ) (NI_Local_GetX_Nak1  iRule1 ) (invariants N) "
            apply(cut_tac  c2  )
            by (metis NI_Local_GetX_Nak1VsInv97 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
        }      moreover
        {assume c1: "ex0P N (  r= NI_Nak_Clear )
"

         from c1 have c2:" r= NI_Nak_Clear "
         by (auto simp add: ex0P_def)

         have "invHoldForRule' s (inv97 ) (NI_Nak_Clear ) (invariants N) "
            apply(cut_tac    b2 c2 )
            by (metis NI_Nak_ClearVsInv97 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
	}      moreover
        {assume c1: "ex0P N (  r= PI_Local_PutX )
"

         from c1 have c2:" r= PI_Local_PutX "
         by (auto simp add: ex0P_def)

         have "invHoldForRule' s (inv97 ) (PI_Local_PutX ) (invariants N) "
            apply(cut_tac    b2 c2 )
            by (metis PI_Local_PutXVsInv97 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
	}      moreover
        {assume c1: "ex1P N (% iRule1 .  r= NI_Local_Get_Nak3  iRule1 )
"

         from c1 obtain  iRule1  where c2:"  iRule1 \<le> N \<and>  r= NI_Local_Get_Nak3  iRule1 "
         by (auto simp add: ex1P_def)

         have "invHoldForRule' s (inv97 ) (NI_Local_Get_Nak3  iRule1 ) (invariants N) "
            apply(cut_tac  c2  )
            by (metis NI_Local_Get_Nak3VsInv97 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
        }      moreover
        {assume c1: "ex1P N (% iRule1 .  r= NI_Remote_GetX_Nak_Home  iRule1 )
"

         from c1 obtain  iRule1  where c2:"  iRule1 \<le> N \<and>  r= NI_Remote_GetX_Nak_Home  iRule1 "
         by (auto simp add: ex1P_def)

         have "invHoldForRule' s (inv97 ) (NI_Remote_GetX_Nak_Home  iRule1 ) (invariants N) "
            apply(cut_tac  c2  )
            by (metis NI_Remote_GetX_Nak_HomeVsInv97 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
        }      moreover
        {assume c1: "ex0P N (  r= PI_Local_Get_Get )
"

         from c1 have c2:" r= PI_Local_Get_Get "
         by (auto simp add: ex0P_def)

         have "invHoldForRule' s (inv97 ) (PI_Local_Get_Get ) (invariants N) "
            apply(cut_tac    b2 c2 )
            by (metis PI_Local_Get_GetVsInv97 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
	}      moreover
        {assume c1: "ex1P N (% iRule1 .  r= NI_Local_GetX_PutX9 N  iRule1 )
"

         from c1 obtain  iRule1  where c2:"  iRule1 \<le> N \<and>  r= NI_Local_GetX_PutX9 N  iRule1 "
         by (auto simp add: ex1P_def)

         have "invHoldForRule' s (inv97 ) (NI_Local_GetX_PutX9 N  iRule1 ) (invariants N) "
            apply(cut_tac  c2  )
            by (metis NI_Local_GetX_PutX9VsInv97 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
        }      moreover
        {assume c1: "ex1P N (% iRule1 .  r= PI_Remote_GetX  iRule1 )
"

         from c1 obtain  iRule1  where c2:"  iRule1 \<le> N \<and>  r= PI_Remote_GetX  iRule1 "
         by (auto simp add: ex1P_def)

         have "invHoldForRule' s (inv97 ) (PI_Remote_GetX  iRule1 ) (invariants N) "
            apply(cut_tac  c2  )
            by (metis PI_Remote_GetXVsInv97 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
        }      moreover
        {assume c1: "ex0P N (  r= NI_ReplaceHome )
"

         from c1 have c2:" r= NI_ReplaceHome "
         by (auto simp add: ex0P_def)

         have "invHoldForRule' s (inv97 ) (NI_ReplaceHome ) (invariants N) "
            apply(cut_tac    b2 c2 )
            by (metis NI_ReplaceHomeVsInv97 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
	}      moreover
        {assume c1: "ex1P N (% iRule1 .  r= NI_Remote_GetX_PutX_Home  iRule1 )
"

         from c1 obtain  iRule1  where c2:"  iRule1 \<le> N \<and>  r= NI_Remote_GetX_PutX_Home  iRule1 "
         by (auto simp add: ex1P_def)

         have "invHoldForRule' s (inv97 ) (NI_Remote_GetX_PutX_Home  iRule1 ) (invariants N) "
            apply(cut_tac  c2  )
            by (metis NI_Remote_GetX_PutX_HomeVsInv97 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
        }      moreover
        {assume c1: "ex1P N (% iRule1 .  r= NI_Local_Get_Put3  iRule1 )
"

         from c1 obtain  iRule1  where c2:"  iRule1 \<le> N \<and>  r= NI_Local_Get_Put3  iRule1 "
         by (auto simp add: ex1P_def)

         have "invHoldForRule' s (inv97 ) (NI_Local_Get_Put3  iRule1 ) (invariants N) "
            apply(cut_tac  c2  )
            by (metis NI_Local_Get_Put3VsInv97 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
        }ultimately show "invHoldForRule' s invf r (invariants N) "
          by blast
     qed
end


(* Title:     Xml
   Author:    Christian Sternagel
   Author:    René Thiemann
*)

header \<open>XML Transformers for Extracting Data from XML Nodes\<close>

theory Xmlt
imports
  Xml
  "../Certification_Monads/Strict_Sum"
  "~~/src/HOL/Rat"
begin

type_synonym
  tag = string

text \<open>The type of transformers on xml nodes.\<close>
type_synonym
  'a xmlt = "xml \<Rightarrow> string +\<^sub>\<bottom> 'a"

definition map :: "(xml \<Rightarrow> ('e +\<^sub>\<bottom> 'a)) \<Rightarrow> xml list \<Rightarrow> 'e +\<^sub>\<bottom> 'a list"
where
  [code_unfold]: "map = map_sum_bot"

lemma map_mono [partial_function_mono]:
  fixes C :: "xml \<Rightarrow> ('b \<Rightarrow> ('e +\<^sub>\<bottom> 'c)) \<Rightarrow> 'e +\<^sub>\<bottom> 'd"
  assumes C: "\<And>y. y \<in> set B \<Longrightarrow> mono_sum_bot (C y)"
  shows "mono_sum_bot (\<lambda>f. map (\<lambda>y. C y f) B)"
  unfolding map_def by (auto intro: partial_function_mono C)

hide_const (open) map

fun "text" :: "tag \<Rightarrow> string xmlt"
where
  "text tag (XML n atts [XML_text t]) =
    (if n = tag \<and> atts = [] then return t
    else error (concat
      [''could not extract text for '', tag,'' from '', ''\<newline>'', show (XML n atts [XML_text t])]))"
| "text tag xml = error (concat [''could not extract text for '', tag,'' from '', ''\<newline>'', show xml])"
hide_const (open) "text"

definition bool_of_string :: "string \<Rightarrow> string +\<^sub>\<bottom> bool"
where
  "bool_of_string s =
    (if s = ''true'' then return True
    else if s = ''false'' then return False
    else error (''cannot convert '' @ s @ '' into Boolean''))"

fun bool :: "tag \<Rightarrow> bool xmlt"
where
  "bool tag node = Xmlt.text tag node \<guillemotright>= bool_of_string"
hide_const (open) bool

definition fail :: "tag \<Rightarrow> 'a xmlt"
where
  "fail tag xml =
    error (concat
      [''could not transform the following xml element (expected '', tag, '')'', ''\<newline>'', show xml])"
hide_const (open) fail

definition guard :: "(xml \<Rightarrow> bool) \<Rightarrow> 'a xmlt \<Rightarrow> 'a xmlt \<Rightarrow> 'a xmlt"
where
  "guard p p1 p2 x = (if p x then p1 x else p2 x)"
hide_const (open) guard

lemma guard_mono [partial_function_mono]:
  assumes p1: "\<And>y. mono_sum_bot (p1 y)"
    and p2: "\<And>y. mono_sum_bot (p2 y)"
  shows "mono_sum_bot (\<lambda>g. Xmlt.guard p (\<lambda>y. p1 y g) (\<lambda>y. p2 y g) x)"
  by (cases x) (auto intro!: partial_function_mono p1 p2 simp: Xmlt.guard_def)

fun leaf :: "tag \<Rightarrow> 'a \<Rightarrow> 'a xmlt"
where
  "leaf tag x (XML name atts cs) =
    (if name = tag \<and> atts = [] \<and> cs = [] then return x
    else Xmlt.fail tag (XML name atts cs))" |
  "leaf tag x xml = Xmlt.fail tag xml"
hide_const (open) leaf

fun list1element :: "'a list \<Rightarrow> 'a option"
where
  "list1element [x] = Some x" |
  "list1element _ = None"

fun singleton :: "tag \<Rightarrow> 'a xmlt \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> 'b xmlt"
where
  "singleton tag p1 f xml =
    (case xml of
      XML name atts cs \<Rightarrow>
      (if name = tag \<and> atts = [] then
        (case list1element cs of
          Some (cs1) \<Rightarrow> p1 cs1 \<guillemotright>= return \<circ> f
        | None \<Rightarrow> Xmlt.fail tag xml)
      else Xmlt.fail tag xml)
    | _ \<Rightarrow> Xmlt.fail tag xml)"
hide_const (open) singleton

lemma singleton_mono [partial_function_mono]:
  assumes p: "\<And>y. mono_sum_bot (p1 y)"
  shows "mono_sum_bot (\<lambda>g. Xmlt.singleton t (\<lambda>y. p1 y g) f x)"
    by (cases x, cases "list1element (Xml.children x)") (auto intro!: partial_function_mono p)

fun list2elements :: "'a list \<Rightarrow> ('a \<times> 'a) option"
where
  "list2elements [x, y] = Some (x, y)" |
  "list2elements _ = None"

fun pair :: "tag \<Rightarrow> 'a xmlt \<Rightarrow> 'b xmlt \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> 'c xmlt"
where
  "pair tag p1 p2 f xml =
    (case xml of
      XML name atts cs \<Rightarrow>
      (if name = tag \<and> atts = [] then
        (case list2elements cs of
          Some (cs1, cs2) \<Rightarrow>
          do {
            a \<leftarrow> p1 cs1;
            b \<leftarrow> p2 cs2;
            return (f a b)
          }
        | None \<Rightarrow> Xmlt.fail tag xml)
      else Xmlt.fail tag xml)
    | _ \<Rightarrow> Xmlt.fail tag xml)"
hide_const (open) pair

lemma pair_mono [partial_function_mono]:
  assumes "\<And>y. mono_sum_bot (p1 y)"
    and "\<And>y. mono_sum_bot (p2 y)"
  shows "mono_sum_bot (\<lambda>g. Xmlt.pair t (\<lambda>y. p1 y g) (\<lambda> y. p2 y g) f x)"
  using assms
  by (cases x, cases "list2elements (Xml.children x)") (auto intro!: partial_function_mono)

fun list3elements :: "'a list \<Rightarrow> ('a \<times> 'a \<times> 'a) option"
where
  "list3elements [x, y, z] = Some (x, y, z)" |
  "list3elements _ = None"

fun triple :: "string \<Rightarrow> 'a xmlt \<Rightarrow> 'b xmlt \<Rightarrow> 'c xmlt \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> 'c \<Rightarrow> 'd) \<Rightarrow> 'd xmlt"
where
  "triple tag p1 p2 p3 f xml = (case xml of XML name atts cs \<Rightarrow>
    (if name = tag \<and> atts = [] then
      (case list3elements cs of
        Some (cs1, cs2, cs3) \<Rightarrow>
        do {
          a \<leftarrow> p1 cs1;
          b \<leftarrow> p2 cs2;
          c \<leftarrow> p3 cs3;
          return (f a b c)
        }
      | None \<Rightarrow> Xmlt.fail tag xml)
    else Xmlt.fail tag xml)
  | _ \<Rightarrow> Xmlt.fail tag xml)"

lemma triple_mono [partial_function_mono]:
  assumes "\<And>y. mono_sum_bot (p1 y)"
    and "\<And>y. mono_sum_bot (p2 y)"
    and "\<And>y. mono_sum_bot (p3 y)"
  shows "mono_sum_bot (\<lambda>g. Xmlt.triple t (\<lambda>y. p1 y g) (\<lambda> y. p2 y g) (\<lambda> y. p3 y g) f x)"
  using assms
  by (cases x, cases "list3elements (Xml.children x)", auto intro!: partial_function_mono)

fun list4elements :: "'a list \<Rightarrow> ('a \<times> 'a \<times> 'a \<times> 'a) option"
where
  "list4elements [x, y, z, u] = Some (x, y, z, u)" |
  "list4elements _ = None"

fun
  tuple4 ::
    "string \<Rightarrow> 'a xmlt \<Rightarrow> 'b xmlt \<Rightarrow> 'c xmlt \<Rightarrow> 'd xmlt \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> 'c \<Rightarrow> 'd \<Rightarrow> 'e) \<Rightarrow> 'e xmlt"
where
  "tuple4 tag p1 p2 p3 p4 f xml =
    (case xml of
      XML name atts cs \<Rightarrow>
        (if name = tag \<and> atts = [] then
          (case list4elements cs of
            Some (cs1, cs2, cs3, cs4) \<Rightarrow>
            do {
              a \<leftarrow> p1 cs1;
              b \<leftarrow> p2 cs2;
              c \<leftarrow> p3 cs3;
              d \<leftarrow> p4 cs4;
              return (f a b c d)
            }
          | None \<Rightarrow> Xmlt.fail tag xml)
        else Xmlt.fail tag xml)
   | _ \<Rightarrow> Xmlt.fail tag xml)"

lemma tuple4_mono [partial_function_mono]:
  assumes "\<And>y. mono_sum_bot (p1 y)"
    and "\<And>y. mono_sum_bot (p2 y)"
    and "\<And>y. mono_sum_bot (p3 y)"
    and"\<And>y. mono_sum_bot (p4 y)"
  shows "mono_sum_bot (\<lambda>g. Xmlt.tuple4 t (\<lambda>y. p1 y g) (\<lambda> y. p2 y g) (\<lambda> y. p3 y g) (\<lambda> y. p4 y g) f x)"
  using assms
  by (cases x, cases "list4elements (Xml.children x)") (auto intro!: partial_function_mono)

fun list5elements :: "'a list \<Rightarrow> ('a \<times> 'a \<times> 'a \<times> 'a \<times> 'a) option"
where
  "list5elements [x, y, z, u, v] = Some (x, y, z, u, v)" |
  "list5elements _ = None"

fun
  tuple5 ::
    "string \<Rightarrow> 'a xmlt \<Rightarrow> 'b xmlt \<Rightarrow> 'c xmlt \<Rightarrow> 'd xmlt \<Rightarrow> 'e xmlt \<Rightarrow>
      ('a \<Rightarrow> 'b \<Rightarrow> 'c \<Rightarrow> 'd \<Rightarrow> 'e \<Rightarrow> 'f) \<Rightarrow> 'f xmlt"
where
  "tuple5 tag p1 p2 p3 p4 p5 f xml =
    (case xml of
      XML name atts cs \<Rightarrow>
        (if name = tag \<and> atts = [] then
          (case list5elements cs of
            Some (cs1,cs2,cs3,cs4,cs5) \<Rightarrow>
            do {
              a \<leftarrow> p1 cs1;
              b \<leftarrow> p2 cs2;
              c \<leftarrow> p3 cs3;
              d \<leftarrow> p4 cs4;
              e \<leftarrow> p5 cs5;
              return (f a b c d e)
            }
          | None \<Rightarrow> Xmlt.fail tag xml)
        else Xmlt.fail tag xml)
    | _ \<Rightarrow> Xmlt.fail tag xml)"

lemma tuple5_mono [partial_function_mono]:
  assumes "\<And>y. mono_sum_bot (p1 y)"
    and "\<And>y. mono_sum_bot (p2 y)"
    and "\<And>y. mono_sum_bot (p3 y)"
    and "\<And>y. mono_sum_bot (p4 y)"
    and "\<And>y. mono_sum_bot (p5 y)"
  shows "mono_sum_bot (\<lambda>g. Xmlt.tuple5 t (\<lambda>y. p1 y g) (\<lambda> y. p2 y g) (\<lambda> y. p3 y g) (\<lambda> y. p4 y g) (\<lambda> y. p5 y g) f x)"
  using assms
  by (cases x, cases "list5elements (Xml.children x)") (auto intro!: partial_function_mono)

fun list6elements :: "'a list \<Rightarrow> ('a \<times> 'a \<times> 'a \<times> 'a \<times> 'a \<times> 'a) option"
where
  "list6elements [x, y, z, u, v, w] = Some (x, y, z, u, v, w)" |
  "list6elements _ = None"

fun
  tuple6 ::
    "string \<Rightarrow> 'a xmlt \<Rightarrow> 'b xmlt \<Rightarrow> 'c xmlt \<Rightarrow> 'd xmlt \<Rightarrow> 'e xmlt \<Rightarrow> 'f xmlt \<Rightarrow>
      ('a \<Rightarrow> 'b \<Rightarrow> 'c \<Rightarrow> 'd \<Rightarrow> 'e \<Rightarrow> 'f \<Rightarrow> 'g) \<Rightarrow> 'g xmlt"
where
  "tuple6 tag p1 p2 p3 p4 p5 p6 f xml =
    (case xml of
      XML name atts cs  \<Rightarrow>
        (if name = tag \<and> atts = [] then
          (case list6elements cs of
            Some (cs1,cs2,cs3,cs4,cs5,cs6) \<Rightarrow>
            do {
              a \<leftarrow> p1 cs1;
              b \<leftarrow> p2 cs2;
              c \<leftarrow> p3 cs3;
              d \<leftarrow> p4 cs4;
              e \<leftarrow> p5 cs5;
              ff \<leftarrow> p6 cs6;
              return (f a b c d e ff)
            }
          | None \<Rightarrow> Xmlt.fail tag xml)
        else Xmlt.fail tag xml)
    | _ \<Rightarrow> Xmlt.fail tag xml)"

lemma tuple6_mono [partial_function_mono]:
  assumes "\<And>y. mono_sum_bot (p1 y)"
    and "\<And>y. mono_sum_bot (p2 y)"
    and "\<And>y. mono_sum_bot (p3 y)"
    and "\<And>y. mono_sum_bot (p4 y)"
    and "\<And>y. mono_sum_bot (p5 y)"
    and "\<And>y. mono_sum_bot (p6 y)"
  shows "mono_sum_bot (\<lambda>g. Xmlt.tuple6 t (\<lambda>y. p1 y g) (\<lambda> y. p2 y g) (\<lambda> y. p3 y g) (\<lambda> y. p4 y g) (\<lambda> y. p5 y g) (\<lambda> y. p6 y g) f x)"
  using assms
  by (cases x, cases "list6elements (Xml.children x)") (auto intro!: partial_function_mono)

fun optional :: "tag \<Rightarrow> 'a xmlt \<Rightarrow> ('a option \<Rightarrow> 'b) \<Rightarrow> 'b xmlt"
where
  "optional tag p1 f (XML name atts cs) =
    (let l = length cs in
    (if name = tag \<and> atts = [] \<and> l \<ge> 0 \<and> l \<le> 1 then do {
      if l = 1 then do {
        x1 \<leftarrow> p1 (cs ! 0);
        return (f (Some x1))
      } else return (f None)
    } else Xmlt.fail tag (XML name atts cs)))" |
  "optional tag p1 f xml = Xmlt.fail tag xml"

lemma optional_mono [partial_function_mono]:
  assumes "\<And>y. mono_sum_bot (p1 y)"
  shows "mono_sum_bot (\<lambda>g. Xmlt.optional t (\<lambda>y. p1 y g) f x)"
  using assms by (cases x) (auto intro!: partial_function_mono)

fun xml1to2elements :: "string \<Rightarrow> 'a xmlt \<Rightarrow> 'b xmlt \<Rightarrow> ('a \<Rightarrow> 'b option \<Rightarrow> 'c) \<Rightarrow> 'c xmlt"
where
  "xml1to2elements tag p1 p2 f (XML name atts cs) = (
     let l = length cs in
     (if name = tag \<and> atts = [] \<and> l \<ge> 1 \<and> l \<le> 2
       then do {
         x1 \<leftarrow> p1 (cs ! 0);
         (if l = 2
           then do {
             x2 \<leftarrow> p2 (cs ! 1);
             return (f x1 (Some x2))
           } else return (f x1 None))
       } else Xmlt.fail tag (XML name atts cs)))" |
  "xml1to2elements tag p1 p2 f xml = Xmlt.fail tag xml"

lemma xml1to2elements_mono[partial_function_mono]:
  assumes p1: "\<And>y. mono_sum_bot (p1 y)"
              "\<And>y. mono_sum_bot (p2 y)"
  shows "mono_sum_bot (\<lambda>g. xml1to2elements t (\<lambda>y. p1 y g) (\<lambda>y. p2 y g) f x)"
  by (cases x, auto intro!: partial_function_mono p1)

text \<open>
  Apply the first transformer to the first child-node, then check the second child-node,
  which is must be a Boolean. If the Boolean is true, then apply the second transformer
  to the last child-node.
\<close>
fun xml2nd_choice :: "tag \<Rightarrow> 'a xmlt \<Rightarrow> tag \<Rightarrow> 'b xmlt \<Rightarrow> ('a \<Rightarrow> 'b option \<Rightarrow> 'c) \<Rightarrow> 'c xmlt"
where
  "xml2nd_choice tag p1 cn p2 f (XML name atts cs) = (
    let l = length cs in
    (if name = tag \<and> atts = [] \<and> l \<ge> 2 then do {
      x1 \<leftarrow> p1 (cs ! 0);
      b \<leftarrow> Xmlt.bool cn (cs ! 1);
      (if b then do {
        x2 \<leftarrow> p2 (cs ! (l - 1));
        return (f x1 (Some x2))
      } else return (f x1 None))
    } else Xmlt.fail tag (XML name atts cs)))" |
  "xml2nd_choice tag p1 cn p2 f xml = Xmlt.fail tag xml"

lemma xml2nd_choice_mono [partial_function_mono]:
  assumes p1: "\<And>y. mono_sum_bot (p1 y)"
              "\<And>y. mono_sum_bot (p2 y)"
  shows "mono_sum_bot (\<lambda>g. xml2nd_choice t (\<lambda>y. p1 y g) h (\<lambda>y. p2 y g) f x)"
  by (cases x, auto intro!: partial_function_mono p1)

fun
  xml2to3elements ::
    "string \<Rightarrow> 'a xmlt \<Rightarrow> 'b xmlt \<Rightarrow> 'c xmlt \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> 'c option \<Rightarrow> 'd) \<Rightarrow> 'd xmlt"
where
  "xml2to3elements tag p1 p2 p3 f (XML name atts cs) = (
     let l = length cs in
     (if name = tag \<and> atts = [] \<and> l \<ge> 2 \<and> l \<le> 3 then do {
       x1 \<leftarrow> p1 (cs ! 0);
       x2 \<leftarrow> p2 (cs ! 1);
       (if l = 3 then do {
         x3 \<leftarrow> p3 (cs ! 2);
         return (f x1 x2 (Some x3))
       } else return (f x1 x2 None))
     } else Xmlt.fail tag (XML name atts cs)))" |
  "xml2to3elements tag p1 p2 p3 f xml = Xmlt.fail tag xml"

lemma xml2to3elements_mono [partial_function_mono]:
  assumes p1: "\<And>y. mono_sum_bot (p1 y)"
              "\<And>y. mono_sum_bot (p2 y)"
              "\<And>y. mono_sum_bot (p3 y)"
  shows "mono_sum_bot (\<lambda>g. xml2to3elements t (\<lambda>y. p1 y g) (\<lambda>y. p2 y g) (\<lambda>y. p3 y g) f x)"
  by (cases x, auto intro!: partial_function_mono p1)

fun
  xml3to4elements ::
    "string \<Rightarrow> 'a xmlt \<Rightarrow> 'b xmlt \<Rightarrow> 'c xmlt \<Rightarrow> 'd xmlt \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> 'c option \<Rightarrow> 'd \<Rightarrow> 'e) \<Rightarrow>
      'e xmlt"
where
  "xml3to4elements tag p1 p2 p3 p4 f (XML name atts cs) = (
     let l = length cs in
     (if name = tag \<and> atts = [] \<and> l \<ge> 3 \<and> l \<le> 4 then do {
       x1 \<leftarrow> p1 (cs ! 0);
       x2 \<leftarrow> p2 (cs ! 1);
       (if l = 4 then do {
         x3 \<leftarrow> p3 (cs ! 2);
         x4 \<leftarrow> p4 (cs ! 3);
         return (f x1 x2 (Some x3) x4)
       } else do {
         x4 \<leftarrow> p4 (cs ! 2);
         return (f x1 x2 None x4)
       } )
     } else Xmlt.fail tag (XML name atts cs)))" |
  "xml3to4elements tag p1 p2 p3 p4 f xml = Xmlt.fail tag xml"

lemma xml3to4elements_mono [partial_function_mono]:
  assumes p1: "\<And>y. mono_sum_bot (p1 y)"
              "\<And>y. mono_sum_bot (p2 y)"
              "\<And>y. mono_sum_bot (p3 y)"
              "\<And>y. mono_sum_bot (p4 y)"
  shows "mono_sum_bot (\<lambda>g. xml3to4elements t (\<lambda>y. p1 y g) (\<lambda>y. p2 y g) (\<lambda>y. p3 y g) (\<lambda>y. p4 y g) f x)"
  by (cases x, auto intro!: partial_function_mono p1)

fun many :: "tag \<Rightarrow> 'a xmlt \<Rightarrow> ('a list \<Rightarrow> 'b) \<Rightarrow> 'b xmlt"
where
  "many tag p f (XML name atts cs) =
    (if name = tag \<and> atts = [] then (Xmlt.map p cs \<guillemotright>= (return \<circ> f))
    else Xmlt.fail tag (XML name atts cs))" |
  "many tag p f xml = Xmlt.fail tag xml"
hide_const (open) many

lemma many_mono [partial_function_mono]:
  fixes p1 :: "xml \<Rightarrow> ('b \<Rightarrow> (string +\<^sub>\<bottom> 'c)) \<Rightarrow> string +\<^sub>\<bottom> 'd"
  assumes "\<And>y. y \<in> set (Xml.children x) \<Longrightarrow> mono_sum_bot (p1 y)"
  shows "mono_sum_bot (\<lambda>g. Xmlt.many t (\<lambda>y. p1 y g) f x)"
  using assms by (cases x) (auto intro!: partial_function_mono)

fun many1_gen :: "tag \<Rightarrow> 'a xmlt \<Rightarrow> ('a \<Rightarrow> 'b xmlt) \<Rightarrow> ('a \<Rightarrow> 'b list \<Rightarrow> 'c) \<Rightarrow> 'c xmlt"
where
  "many1_gen tag p1 p2 f (XML name atts cs) =
    (if name = tag \<and> atts = [] \<and> cs \<noteq> [] then
      (case cs of h # t \<Rightarrow> do {
        x \<leftarrow> p1 h;
        xs \<leftarrow> Xmlt.map (p2 x) t;
        return (f x xs)
      })
    else Xmlt.fail tag (XML name atts cs))" |
  "many1_gen tag p1 p2 f xml = Xmlt.fail tag xml"

(* TODO
lemma Xmlt.many1_gen_mono[partial_function_mono]:
  fixes p1 :: "xml \<Rightarrow> ('b \<Rightarrow> 'c sum_bot) \<Rightarrow> 'd sum_bot"
  assumes p1: "\<And>y. mono_sum_bot (p1 y)"
              "\<And>y. mono_sum_bot (p2 y)"
  shows "mono_sum_bot (\<lambda>g. Xmlt.many1_gen t (\<lambda>y. p1 y g) (\<lambda>y. p2 y g) f x)"
  by (cases x, auto intro!: partial_function_mono p1)
*)

definition many1 :: "string \<Rightarrow> 'a xmlt \<Rightarrow> 'b xmlt \<Rightarrow> ('a \<Rightarrow> 'b list \<Rightarrow> 'c) \<Rightarrow> 'c xmlt"
where
  "many1 tag p1 p2 = Xmlt.many1_gen tag p1 (\<lambda>_. p2)"
hide_const (open) many1

lemma many1_mono [partial_function_mono]:
  fixes p1 :: "xml \<Rightarrow> ('b \<Rightarrow> (string +\<^sub>\<bottom> 'c)) \<Rightarrow> string +\<^sub>\<bottom> 'd"
  assumes "\<And>y. mono_sum_bot (p1 y)"
    and "\<And>y. y \<in> set (tl (Xml.children x)) \<Longrightarrow> mono_sum_bot (p2 y)"
  shows "mono_sum_bot (\<lambda>g. Xmlt.many1 t (\<lambda>y. p1 y g) (\<lambda>y. p2 y g) f x)"
  unfolding Xmlt.many1_def using assms
  by (cases x, cases "Xml.children x") (auto intro!: partial_function_mono)

fun length_ge_2 :: "'a list \<Rightarrow> bool"
where
  "length_ge_2 (_ # _ # _) = True" |
  "length_ge_2 _ = False"

fun many2 :: "tag \<Rightarrow> 'a xmlt \<Rightarrow> 'b xmlt \<Rightarrow> 'c xmlt \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> 'c list \<Rightarrow> 'd) \<Rightarrow> 'd xmlt"
where
  "many2 tag p1 p2 p3 f (XML name atts cs) =
    (if name = tag \<and> atts = [] \<and> length_ge_2 cs then
      (case cs of cs0 # cs1 # t \<Rightarrow> do {
        x \<leftarrow> p1 cs0;
        y \<leftarrow> p2 cs1;
        xs \<leftarrow> Xmlt.map p3 t;
        return (f x y xs)
      })
    else Xmlt.fail tag (XML name atts cs))" |
  "many2 tag p1 p2 p3 f xml = Xmlt.fail tag xml"

lemma many2_mono [partial_function_mono]:
  fixes p1 :: "xml \<Rightarrow> ('b \<Rightarrow> (string +\<^sub>\<bottom> 'c)) \<Rightarrow> string +\<^sub>\<bottom> 'd"
  assumes "\<And>y. mono_sum_bot (p1 y)"
    and "\<And>y. mono_sum_bot (p2 y)"
    and "\<And>y. mono_sum_bot (p3 y)"
  shows "mono_sum_bot (\<lambda>g. Xmlt.many2 t (\<lambda>y. p1 y g) (\<lambda>y. p2 y g) (\<lambda>y. p3 y g) f x)"
  using assms
  by (cases x, cases "Xml.children x", (auto intro!: partial_function_mono)[1], cases "tl (Xml.children x)", auto intro!: partial_function_mono)

fun
  xml1or2many_elements ::
    "string \<Rightarrow> 'a xmlt \<Rightarrow> 'b xmlt \<Rightarrow> 'c xmlt \<Rightarrow> ('a \<Rightarrow> 'b option \<Rightarrow> 'c list \<Rightarrow> 'd) \<Rightarrow> 'd xmlt"
where
  "xml1or2many_elements tag p1 p2 p3 f (XML name atts cs) =
    (if name = tag \<and> atts = [] \<and> cs \<noteq> [] then
      (case cs of
        cs0 # tt \<Rightarrow>
        do {
          x \<leftarrow> p1 cs0;
          (case tt of
            cs1 # t \<Rightarrow>
            do {
              try do {
                y \<leftarrow> p2 cs1;
                xs \<leftarrow> Xmlt.map p3 t;
                return (f x (Some y) xs)
              } catch (\<lambda> _. do {
                xs \<leftarrow> Xmlt.map p3 tt;
                return (f x None xs)
              })
            }
          | [] \<Rightarrow> return (f x None []))})
     else Xmlt.fail tag (XML name atts cs))" |
  "xml1or2many_elements tag p1 p2 p3 f  xml = Xmlt.fail tag xml"

fun
  xml1many2elements_gen ::
    "string \<Rightarrow> 'a xmlt \<Rightarrow> ('a \<Rightarrow> 'b xmlt) \<Rightarrow> 'c xmlt \<Rightarrow> 'd xmlt \<Rightarrow>
      ('a \<Rightarrow> 'b list \<Rightarrow> 'c \<Rightarrow> 'd \<Rightarrow> 'e) \<Rightarrow> 'e xmlt"
where
  "xml1many2elements_gen tag p1 p2 p3 p4 f (XML name atts cs) = (
     let ds = List.rev cs; l = length cs in
     (if name = tag \<and> atts = [] \<and> l \<ge> 3 then do {
       x \<leftarrow> p1 (cs ! 0);
       xs \<leftarrow> Xmlt.map (p2 x) (tl (take (l - 2) cs));
       y \<leftarrow> p3 (ds ! 1);
       z \<leftarrow> p4 (ds ! 0);
       return (f x xs y z)
     } else Xmlt.fail tag (XML name atts cs)))" |
  "xml1many2elements_gen tag p1 p2 p3 p4 f xml = Xmlt.fail tag xml"

lemma xml1many2elements_gen_mono [partial_function_mono]:
  fixes p1 :: "xml \<Rightarrow> ('b \<Rightarrow> (string +\<^sub>\<bottom> 'c)) \<Rightarrow> string +\<^sub>\<bottom> 'd"
  assumes p1: "\<And>y. mono_sum_bot (p1 y)"
              "\<And>y. mono_sum_bot (p3 y)"
              "\<And>y. mono_sum_bot (p4 y)"
  shows "mono_sum_bot (\<lambda>g. xml1many2elements_gen t (\<lambda>y. p1 y g) p2 (\<lambda>y. p3 y g) (\<lambda>y. p4 y g) f x)"
  by (cases x, auto intro!: partial_function_mono p1)

fun
  xml1many2elements ::
    "string \<Rightarrow> 'a xmlt \<Rightarrow> 'b xmlt \<Rightarrow> 'c xmlt \<Rightarrow> 'd xmlt \<Rightarrow> ('a \<Rightarrow> 'b list \<Rightarrow> 'c \<Rightarrow> 'd \<Rightarrow> 'e) \<Rightarrow>
      'e xmlt"
where
  "xml1many2elements tag p1 p2 = xml1many2elements_gen tag p1 (\<lambda>_. p2)"

fun
  xml_many2elements ::
    "string \<Rightarrow> 'a xmlt \<Rightarrow> 'b xmlt \<Rightarrow> 'c xmlt \<Rightarrow> ('a list \<Rightarrow> 'b \<Rightarrow> 'c \<Rightarrow> 'd) \<Rightarrow> 'd xmlt"
where
  "xml_many2elements tag p1 p2 p3 f (XML name atts cs) = (
     let ds = List.rev cs in
     (if name = tag \<and> atts = [] \<and> length_ge_2 cs then do {
       xs \<leftarrow> Xmlt.map p1 (List.rev (tl (tl ds)));
       y \<leftarrow> p2 (ds ! 1);
       z \<leftarrow> p3 (ds ! 0);
       return (f xs y z)
     } else Xmlt.fail tag (XML name atts cs)))" |
  "xml_many2elements tag p1 p2 p3 f xml = Xmlt.fail tag xml"

definition options :: "(string \<times> 'a xmlt) list \<Rightarrow> 'a xmlt"
where
  "options ps x =
    (case map_of ps (Xml.tag x) of
      None \<Rightarrow> error (concat
        [''expected one of: '', concat (map (\<lambda>p. fst p @ '' '') ps), ''\<newline>'', ''but found'', ''\<newline>'', show x])
    | Some p \<Rightarrow> p x)"
hide_const (open) options

lemma options_mono_gen [partial_function_mono]:
  assumes p: "\<And> k p. (k, p) \<in> set ps \<Longrightarrow> mono_sum_bot (p x)"
  shows "mono_sum_bot (\<lambda> g. Xmlt.options (map (\<lambda> (k, p). (k, (\<lambda> y. p y g))) ps) x)"
proof -
  {
    fix g
    have "(map (\<lambda>p. fst p @ '' '') (map (\<lambda>(k, p). (k, \<lambda>y. p y g)) ps)) =
      map (\<lambda>p. fst p @ '' '') ps"
      by (induct ps) (auto)
  } note id = this
  {
    fix z
    have "mono_sum_bot
      (\<lambda>g. case map_of (map (\<lambda>(k, p). (k, \<lambda>y. p y g)) ps) (Xml.tag x) of
        None \<Rightarrow> z
      | Some p \<Rightarrow> p x)"
      using p
    proof (induct ps)
      case Nil
      show ?case by (auto intro: partial_function_mono)
    next
      case (Cons kp ps)
      obtain k p where kp: "kp = (k,p)" by force
      note Cons = Cons[unfolded kp]
      from Cons(2) have monop: "mono_sum_bot (p x)" and mono: "\<And> k p. (k,p) \<in> set ps \<Longrightarrow> mono_sum_bot (p x)" by auto
      show ?case
      proof (cases "Xml.tag x = k")
        case True
        thus ?thesis unfolding kp using monop by auto
      next
        case False
        thus ?thesis using Cons(1) mono unfolding kp by auto
      qed
    qed
  } note main = this
  show ?thesis unfolding Xmlt.options_def
    unfolding id
    by (rule main)
qed

(* instantiate this lemma to have the monotonicity lemmas for lists of variable lengths which
   are then applicable, e.g., for lists of length 3 it would be

mono_sum_bot (p1 x) \<Longrightarrow> mono_sum_bot (p2 x) \<Longrightarrow> mono_sum_bot (p3 x)
\<Longrightarrow> mono_sum_bot (\<lambda>g. Xmlt.options [(k1, \<lambda>y. p1 y g), (k2, \<lambda>y. p2 y g), (k3, \<lambda>y. p3 y g)] x)

*)
local_setup \<open>fn lthy =>
  let
    val N = 30 (* we require monotonicity lemmas for xml-options for lists up to length N *)
    val thy = Proof_Context.theory_of lthy
    val options = @{term "Xmlt.options :: (string \<times> (xml \<Rightarrow> (string +\<^sub>\<bottom> 'd))) list \<Rightarrow> xml \<Rightarrow> string +\<^sub>\<bottom> 'd"}
    val mono_sum_bot = @{term "mono_sum_bot :: (('a \<Rightarrow> ('b +\<^sub>\<bottom> 'c)) \<Rightarrow> string +\<^sub>\<bottom> 'd) \<Rightarrow> bool"}
    val ktyp = @{typ string}
    val x = @{term "x :: xml"}
    val y = @{term "y :: xml"}
    val g = @{term "g :: 'a \<Rightarrow> 'b +\<^sub>\<bottom> 'c"}
    val ptyp = @{typ "xml \<Rightarrow> ('a \<Rightarrow> ('b +\<^sub>\<bottom> 'c)) \<Rightarrow> string +\<^sub>\<bottom> 'd"}
    fun k i = Free ("k" ^ string_of_int i,ktyp)
    fun p i = Free ("p" ^ string_of_int i,ptyp)
    fun prem i = HOLogic.mk_Trueprop (mono_sum_bot $ (p i $ x))
    fun prems n = 1 upto n |> map prem
    fun pair i = HOLogic.mk_prod (k i, lambda y (p i $ y $ g))
    fun pair2 i = HOLogic.mk_prod (k i, p i)
    fun list n = 1 upto n |> map pair |> HOLogic.mk_list @{typ "(string \<times> (xml \<Rightarrow> string +\<^sub>\<bottom> 'd))"}
    fun list2 n = 1 upto n |> map pair2 |> HOLogic.mk_list (HOLogic.mk_prodT (ktyp,ptyp))
    fun concl n = HOLogic.mk_Trueprop (mono_sum_bot $ lambda g (options $ (list n) $ x))
    fun xs n = x :: (1 upto n |> map (fn i => [p i, k i]) |> List.concat)
       |> map (fst o dest_Free)
    fun tac n pc =
      let
        val {prems = prems, context = ctxt} = pc
        val mono_thm = Drule.instantiate'
            (map (SOME o ctyp_of thy) [@{typ 'a},@{typ 'b},@{typ 'c},@{typ 'd}])
            (map (SOME o cterm_of thy) [list2 n,x]) @{thm Xmlt.options_mono_gen}
      in
        Method.insert_tac (mono_thm :: prems) 1 THEN force_tac ctxt 1
      end
    fun thm n = Goal.prove lthy (xs n) (prems n) (concl n) (tac n)
    val thms = map thm (0 upto N)
  in Local_Theory.note ((@{binding "options_mono_thms"}, []), thms) lthy |> snd end
\<close>

declare Xmlt.options_mono_thms [partial_function_mono]

fun choice :: "string \<Rightarrow> 'a xmlt list \<Rightarrow> 'a xmlt"
where
  "choice e [] x = error (concat [''error in parsing choice for '', e, ''\<newline>'', show x])" |
  "choice e (p # ps) x = (try p x catch (\<lambda>_. choice e ps x))"
hide_const (open) choice

lemma choice_mono_2 [partial_function_mono]:
  assumes p: "mono_sum_bot (p1 x)"
             "mono_sum_bot (p2 x)"
  shows "mono_sum_bot (\<lambda> g. Xmlt.choice e [(\<lambda> y. p1 y g), (\<lambda> y. p2 y g)] x)"
  using p by (auto intro!: partial_function_mono)

lemma choice_mono_3 [partial_function_mono]:
  assumes p: "mono_sum_bot (p1 x)"
             "mono_sum_bot (p2 x)"
             "mono_sum_bot (p3 x)"
  shows "mono_sum_bot (\<lambda> g. Xmlt.choice e [(\<lambda> y. p1 y g), (\<lambda> y. p2 y g), (\<lambda> y. p3 y g)] x)"
  using p by (auto intro!: partial_function_mono)

fun change :: "'a xmlt \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> 'b xmlt"
where
  "change p f x = p x \<guillemotright>= return \<circ> f"
hide_const (open) change

lemma change_mono [partial_function_mono]:
  assumes p: "\<And>y. mono_sum_bot (p1 y)"
  shows "mono_sum_bot (\<lambda>g. Xmlt.change (\<lambda>y. p1 y g) f x)"
  by (cases x, insert p, auto intro!: partial_function_mono)

fun int_of_digit :: "char \<Rightarrow> string +\<^sub>\<bottom> int"
where
  "int_of_digit x =
    (if x = CHR ''0'' then return 0
    else if x = CHR ''1'' then return 1
    else if x = CHR ''2'' then return 2
    else if x = CHR ''3'' then return 3
    else if x = CHR ''4'' then return 4
    else if x = CHR ''5'' then return 5
    else if x = CHR ''6'' then return 6
    else if x = CHR ''7'' then return 7
    else if x = CHR ''8'' then return 8
    else if x = CHR ''9'' then return 9
    else error (x # '' is not a digit''))"

fun int_of_string_aux :: "int \<Rightarrow> string \<Rightarrow> string +\<^sub>\<bottom> int"
where
  "int_of_string_aux n [] = return n" |
  "int_of_string_aux n (d # s) = (int_of_digit d \<guillemotright>= (\<lambda>m. int_of_string_aux (10 * n + m) s))"

definition int_of_string :: "string \<Rightarrow> string +\<^sub>\<bottom> int"
where
  "int_of_string s =
    (if s = [] then error ''cannot convert empty string into number''
    else if take 1 s = ''-'' then int_of_string_aux 0 (tl s) \<guillemotright>= (\<lambda> i. return (0 - i))
    else int_of_string_aux 0 s)"

hide_const int_of_string_aux

fun int :: "tag \<Rightarrow> int xmlt"
where
  "int tag x = (Xmlt.text tag x \<guillemotright>= int_of_string)"
hide_const (open) int

fun nat :: "tag \<Rightarrow> nat xmlt"
where
  "nat tag x = do {
    txt \<leftarrow> Xmlt.text tag x;
    i \<leftarrow> int_of_string txt;
    return (Int.nat i)
  }"
hide_const (open) nat

definition rat :: "rat xmlt"
where
  "rat = Xmlt.options [
    (''integer'', Xmlt.change (Xmlt.int ''integer'') of_int),
    (''rational'',
      Xmlt.pair ''rational'' (Xmlt.int ''numerator'') (Xmlt.int ''denominator'')
        (\<lambda> x y. of_int x / of_int y))]"
hide_const (open) rat

end