header{* Reactive processes *}

theory Reactive_Processes
imports Designs "~~/src/HOL/Library/Sublist"
(* isabelle2012 "~~/src/HOL/Library/List_Prefix" *)
begin

text {* Following the way of UTP to describe reactive processes, more observational
variables are needed to record the interaction with the environment. Three observational
variables are defined for this subset of relations: $wait$, $tr$ and $ref$.
The boolean variable $wait$ records if the process is waiting for an interaction
or has terminated. $tr$ records the list (trace) of interactions the process has
performed so far. The variable $ref$ contains the set of interactions (events) the
process may refuse to perform. *}

text {* In this section, we introduce first some preliminary notions, useful for
 trace manipulations. The definitions of reactive process alphabets and healthiness
conditions are also given. Finally, proved lemmas and theorems are listed.*}

subsection {* Preliminaries *}

type_synonym '\<alpha> trace = "'\<alpha> list"

fun list_diff::"'\<alpha> list \<Rightarrow> '\<alpha> list \<Rightarrow> '\<alpha> list option" where
   "list_diff l [] = Some l"
  | "list_diff [] l = None"
  | "list_diff (x#xs) (y#ys) = (if (x = y) then (list_diff xs ys) else None)"

instantiation  list :: (type) minus
begin
definition list_minus : "l1 - l2 \<equiv> the (list_diff l1 l2)"
instance ..
end

lemma list_diff_empty [simp]: "the (list_diff l []) = l"
by (cases l) auto

lemma prefix_diff_empty [simp]: "l  - [] = l"
by (induct l) (auto simp: list_minus)

lemma prefix_diff_eq [simp]: "l - l = []"
by (induct l) (auto simp: list_minus)

lemma prefix_diff [simp]: "(l @ t) - l = t"
by (induct l) (auto simp: list_minus)

lemma prefix_subst [simp]: "l @ t = m \<Longrightarrow> m - l = t"
by (auto)

lemma prefix_subst1 [simp]: "m = l @ t \<Longrightarrow> m - l = t"
by (auto)

lemma prefix_diff1 [simp]: "((l @ m) @ t) - (l @ m) = t"
by (rule prefix_diff)

lemma prefix_diff2 [simp]: "(l @ (m @ t)) - (l @ m) = t"
apply (simp only: append_assoc [symmetric])
apply (rule prefix_diff1)
done

lemma prefix_diff3 [simp]: "(l @ m) - (l @ t) = (m - t)"
by (induct l, auto simp: list_minus)

lemma prefix_diff4 [simp]: "(a # m) - (a # t) = (m - t)"
by (auto simp: list_minus)

class ev_eq =
  fixes ev_eq :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
  assumes refl: "ev_eq a a"
  assumes comm: "ev_eq a b = ev_eq b a"

definition "filter_chan_set a cs = (\<not> (\<exists> e\<in>cs. ev_eq a e))"

lemma in_imp_not_fcs:
"x\<in>S \<Longrightarrow> \<not> filter_chan_set x S"
apply (auto simp: filter_chan_set_def)
apply (rule_tac bexI, auto simp: refl)
done

fun tr_filter::"'a::ev_eq list \<Rightarrow> 'a set \<Rightarrow> 'a list" where
    "tr_filter [] cs = []"
  | "tr_filter (x#xs) cs = (if (filter_chan_set x cs) then (x#(tr_filter xs cs))
                                                                  else (tr_filter xs cs))"

lemma tr_filter_conc: "(tr_filter (a@b) cs) = ((tr_filter a cs) @ (tr_filter b cs))"
by (induct a, auto)

lemma filter_chan_set_hd_tr_filter:
"tr_filter l cs \<noteq> [] --> filter_chan_set (hd (tr_filter l cs)) cs"
by (induct l, auto)

lemma tr_filter_conc_eq1:
"(a@b = (tr_filter (a@c) cs)) \<longrightarrow> (b = (tr_filter c cs))"
apply (induct a, auto)
apply (case_tac "tr_filter (a2 @ c) cs = []", simp_all)
apply (drule filter_chan_set_hd_tr_filter[rule_format])
apply (case_tac "tr_filter (a2 @ c) cs", simp_all)
done

lemma tr_filter_conc_eq2:
"(a@b = (tr_filter (a@c) cs)) \<longrightarrow> (a = (tr_filter a cs))"
apply (induct a, auto)
apply (case_tac "tr_filter (a2 @ c) cs = []", simp_all)
apply (drule filter_chan_set_hd_tr_filter[rule_format])
apply (case_tac "tr_filter (a2 @ c) cs", simp_all)
apply (case_tac "tr_filter (a2 @ c) cs = []", simp_all)
apply (drule filter_chan_set_hd_tr_filter[rule_format])
apply (case_tac "tr_filter (a2 @ c) cs", simp_all)
done

lemma tr_filter_conc_eq:
"(a@b = (tr_filter (a@c) cs)) = (b = (tr_filter c cs) & a = (tr_filter a cs))"
apply (rule, rule)
apply (rule tr_filter_conc_eq1[rule_format, of a], clarsimp)
apply (rule tr_filter_conc_eq2[rule_format, of a b c], clarsimp)
apply (clarsimp simp: tr_filter_conc)
done

lemma tr_filter_conc_eq3:
"(b = (tr_filter (a@c) cs)) = (\<exists> b1 b2. b=b1@b2 & b2 = (tr_filter c cs) & b1 = (tr_filter a cs))"
by (rule, auto simp: tr_filter_conc)

lemma tr_filter_un:
"tr_filter l (s1 \<union> s2) = tr_filter (tr_filter l s1) s2"
by (induct l, auto simp: filter_chan_set_def)

instantiation list :: (ev_eq) ev_eq
begin
fun ev_eq_list where
    "ev_eq_list [] [] = True"
  | "ev_eq_list l [] = False"
  | "ev_eq_list [] l = False"
  | "ev_eq_list (x#xs) (y#ys) = (if (ev_eq x y) then (ev_eq_list xs ys) else False)"
instance
  proof
  fix a::"'a::ev_eq list" show "ev_eq a a"
  by (induct a, auto simp: ev_eq_class.refl)
  next
  fix a b::"'a::ev_eq list" show "ev_eq a b = ev_eq b a"
  apply (cases a)
  apply (cases b, simp_all add: ev_eq_class.comm)
  apply (hypsubst_thin)
  apply (induct b, simp_all add: ev_eq_class.comm)
  apply (case_tac "ev_eq aa a", simp_all add: ev_eq_class.comm)
  apply (case_tac "list = []", simp_all)
  apply (case_tac "b", simp_all)
  apply (atomize)
  apply (erule_tac x="hd list" in allE)
  apply (erule_tac x="tl list" in allE)
  apply (subst (asm) hd_Cons_tl, simp_all)
done
qed
end

subsection {* Definitions *}

(* isabelle 2013 *)

abbreviation subl::"'a list \<Rightarrow> 'a list \<Rightarrow> bool" ("_ \<le> _")
where "l1 \<le> l2 == Sublist.prefixeq l1 l2"

lemma list_diff_empty_eq: "l1 - l2 = [] \<Longrightarrow> l2 \<le> l1 \<Longrightarrow> l1 = l2"
by (auto simp: prefixeq_def)

(* end isabelle 2013 *)

text {* The definitions of reactive process alphabets and healthiness conditions are given
in the following. The healthiness conditions of reactive processes are defined by
$R1$, $R2$, $R3$ and their composition $R$.*}

type_synonym '\<theta> refusal = "'\<theta> set"

record '\<theta> alpha_rp  = alpha_d +
                         wait:: bool
                         tr  :: "'\<theta> trace"
                         ref :: "'\<theta> refusal"

text{* Note that we define here the class of UTP alphabets that contain
$wait$, $tr$ and $ref$, or, in other words, we define here the class of reactive process
alphabets. *}

type_synonym ('\<theta>,'\<sigma>) alphabet_rp  = "('\<theta>,'\<sigma>) alpha_rp_scheme alphabet"
type_synonym ('\<theta>,'\<sigma>) relation_rp  = "('\<theta>,'\<sigma>) alphabet_rp relation"

definition "diff_tr s1 s2 = ((tr s1) - (tr s2))"

definition spec :: "[bool, bool, ('\<theta>,'\<sigma>) relation_rp] \<Rightarrow> ('\<theta>,'\<sigma>) relation_rp"
where "spec b b' P \<equiv> \<lambda> (A, A'). P (A\<lparr>wait := b'\<rparr>, A'\<lparr>ok := b\<rparr>)"

abbreviation Speciftt ("_\<^isup>t\<^isub>t") where "(P)\<^isup>t\<^isub>t \<equiv> spec True True P"

abbreviation Specifff ("_\<^isup>f\<^isub>f") where "(P)\<^isup>f\<^isub>f \<equiv> spec False False P"

abbreviation Speciftf ("_\<^isup>t\<^isub>f") where "(P)\<^isup>t\<^isub>f \<equiv> spec True False P"

abbreviation Specifft ("_\<^isup>f\<^isub>t") where "(P)\<^isup>f\<^isub>t \<equiv> spec False True P"

definition R1::"(('\<theta>,'\<sigma>) alphabet_rp) Healthiness_condition"
where "R1 (P)  \<equiv>  \<lambda>(A, A'). (P (A, A')) \<and> (tr A \<le> tr A')"

definition R2::"(('\<theta>,'\<sigma>) alphabet_rp) Healthiness_condition"
where "R2 (P)  \<equiv> \<lambda>(A, A'). (P (A\<lparr>tr:=[]\<rparr>,A'\<lparr>tr:= tr A' - tr A\<rparr>) \<and> tr A \<le> tr A')"

definition \<Pi>rea
where "\<Pi>rea  \<equiv> \<lambda>(A, A'). (\<not>ok A \<and> tr A \<le> tr A') \<or> (ok A' \<and> tr A = tr A'
                            \<and> (wait A = wait A') \<and> ref A = ref A' \<and> more A = more A')"

definition R3::"(('\<theta>,'\<sigma>) alphabet_rp) Healthiness_condition"
where "R3 (P)  \<equiv> (\<Pi>rea \<triangleleft> wait o fst \<triangleright> P)"

definition R::"(('\<theta>,'\<sigma>) alphabet_rp) Healthiness_condition"
where "R  \<equiv> R3 o R2 o R1"

lemmas rp_defs = R1_def R2_def \<Pi>rea_def R3_def R_def spec_def

subsection {* Proofs *}

lemma tr_filter_empty [simp]: "tr_filter l {} = l"
by (induct l) (auto simp: filter_chan_set_def)

lemma trf_imp_filtercs: "\<lbrakk>xs = tr_filter ys cs; xs \<noteq> []\<rbrakk> \<Longrightarrow> filter_chan_set (hd xs) cs"
apply (induct xs, auto)
apply (induct ys, auto)
apply (case_tac "filter_chan_set a cs", auto)
done

lemma filtercs_imp_trf:
"\<lbrakk>filter_chan_set x cs; xs = tr_filter ys cs\<rbrakk> \<Longrightarrow> x#xs = tr_filter (x#ys) cs"
by (induct xs) auto

lemma alpha_d_more_eqI:
  assumes "tr r = tr r'" "wait r = wait r'" "ref r = ref r'" "more r = more r'"
  shows "alpha_d.more r = alpha_d.more r'"
  using assms by (cases r, cases r') auto

lemma alpha_d_more_eqE:
  assumes "alpha_d.more r = alpha_d.more r'"
  obtains "tr r = tr r'" "wait r = wait r'" "ref r = ref r'" "more r = more r'"
  using assms by (cases r, cases r') auto

lemma alpha_rp_eqE:
  assumes "r = r'"
  obtains "ok r = ok r'" "tr r = tr r'" "wait r = wait r'" "ref r = ref r'" "more r = more r'"
  using assms by (cases r, cases r') auto

lemma R_idem: "R o R = R"
by (auto simp: rp_defs design_defs fun_eq_iff split: cond_splits)

lemma R_idem2: "R (R P) = R P"
by (auto simp: rp_defs design_defs fun_eq_iff split: cond_splits)

lemma R1_idem: "R1 o R1 = R1"
by (auto simp: rp_defs design_defs)

lemma R1_idem2: "R1 (R1 x) = R1 x"
by (auto simp: rp_defs design_defs)

lemma R2_idem: "R2 o R2 = R2"
by (auto simp: rp_defs design_defs fun_eq_iff prefixeq_def)

lemma R2_idem2: "R2 (R2 x) = R2 x"
by (auto simp: rp_defs design_defs fun_eq_iff prefixeq_def)

lemma R3_idem: "R3 o R3 = R3"
by (auto simp: rp_defs design_defs fun_eq_iff split: cond_splits)

lemma R3_idem2: "R3 (R3 x) = R3 x"
by (auto simp: R3_idem[simplified Fun.comp_def fun_eq_iff] fun_eq_iff)

lemma R1_R2_commute: "(R1 o R2) = (R2 o R1)"
by (auto simp: rp_defs design_defs fun_eq_iff prefixeq_def)

lemma R1_R3_commute: "(R1 o R3) = (R3 o R1)"
by (auto simp: rp_defs design_defs fun_eq_iff split: cond_splits)

lemma R2_R3_commute: "R2 o R3 = R3 o R2"
by (auto simp: rp_defs design_defs fun_eq_iff prefixeq_def split: cond_splits elim: prefixE)

lemma R_abs_R1: "R o R1 = R"
apply (auto simp: R_def)
apply (subst R1_idem[symmetric]) back back
apply (auto)
done

lemma R_abs_R2: "R o R2 = R"
by (auto simp: rp_defs design_defs fun_eq_iff)

lemma R_abs_R3: "R o R3 = R"
by (auto simp: rp_defs design_defs fun_eq_iff split: cond_splits elim: prefixE)

lemma R_is_R1:
  assumes A: "P is R healthy"
  shows  "P is R1 healthy"
proof -
  have "R P = P"
    using assms by (simp_all only: Healthy_def)
  moreover
  have "(R P) is R1 healthy"
    by (auto simp add: design_defs rp_defs fun_eq_iff split: cond_splits)
  ultimately show ?thesis by simp
qed

lemma R_is_R2:
  assumes A: "P is R healthy"
  shows  "P is R2 healthy"
proof -
  have "R P = P"
    using assms by (simp_all only: Healthy_def)
  moreover
  have "(R P) is R2 healthy"
    by (auto simp add: design_defs rp_defs fun_eq_iff prefixeq_def prefix_def split: cond_splits)
  ultimately show ?thesis by simp
qed

lemma R_is_R3:
  assumes A: "P is R healthy"
  shows  "P is R3 healthy"
proof -
  have "R P = P"
    using assms by (simp_all only: Healthy_def)
  moreover
  have "(R P) is R3 healthy"
    by (auto simp add: design_defs rp_defs fun_eq_iff split: cond_splits)
  ultimately show ?thesis by simp
qed

lemma R_disj:
  assumes A: "P is R healthy"
  assumes B: "Q is R healthy"
  shows  "(P \<or> Q) is R healthy"
proof -
  have "R P = P" and "R Q = Q"
    using assms by (simp_all only: Healthy_def)
  moreover
  have "((R P) \<or> (R Q)) is R healthy"
    by (auto simp add: design_defs rp_defs fun_eq_iff split: cond_splits)
  ultimately show ?thesis by simp
qed

lemma R_disj2:  "R (P \<or> Q) = (R P \<or> R Q)"
apply (subst R_disj[simplified Healthy_def, where P="R P"])
apply (simp_all add: R_idem2)
apply (auto simp: fun_eq_iff rp_defs split: cond_splits)
done

lemma R1_comp:
  assumes "P is R1 healthy"
    and "Q is R1 healthy"
  shows "(P;;Q) is R1 healthy"
proof -
  have "R1 P = P" and "R1 Q = Q"
    using assms by (simp_all only: Healthy_def)
  moreover
  have "((R1 P) ;; (R1 Q)) is R1 healthy"
    by (auto simp add: design_defs rp_defs fun_eq_iff split: cond_splits)
  ultimately show ?thesis by simp
qed

lemma R1_comp2:
  assumes A: "P is R1 healthy"
  assumes B: "Q is R1 healthy"
  shows  "R1 (P;;Q) = ((R1 P);;Q)"
using A B
apply (subst R1_comp[simplified Healthy_def, symmetric])
apply (auto simp: fun_eq_iff rp_defs design_defs)
done

lemma J_is_R1: "J is R1 healthy"
  by (auto simp: rp_defs design_defs fun_eq_iff elim: alpha_d_more_eqE)

lemma J_is_R2: "J is R2 healthy"
  by (auto simp: rp_defs design_defs fun_eq_iff prefix_def prefixeq_def
    elim!: alpha_d_more_eqE intro!: alpha_d_more_eqI)

lemma R1_H2_commute2: "R1 (H2 P) = H2 (R1 P)"
  by (auto simp add: H2_def R1_def J_def fun_eq_iff
    elim!: alpha_d_more_eqE intro!: alpha_d_more_eqI)

lemma R1_H2_commute: "R1 o H2 = H2 o R1"
by (auto simp: R1_H2_commute2)

lemma R2_H2_commute2: "R2 (H2 P) = H2 (R2 P)"
apply (auto simp add: fun_eq_iff rp_defs design_defs prefix_def)
apply (rule_tac b="ba\<lparr>tr := tr a @ tr ba\<rparr>" in comp_intro)
apply (auto simp: fun_eq_iff prefix_def prefixeq_def
  elim!: alpha_d_more_eqE alpha_rp_eqE intro!: alpha_d_more_eqI alpha_rp.equality)
apply (rule_tac b="ba\<lparr>tr := tr a @ tr ba\<rparr>" in comp_intro,
  auto simp: elim: alpha_d_more_eqE alpha_rp_eqE intro: alpha_d_more_eqI alpha_rp.equality)
apply (rule_tac b="ba\<lparr>tr := tr a @ tr ba\<rparr>" in comp_intro,
  auto simp: elim: alpha_d_more_eqE alpha_rp_eqE intro: alpha_d_more_eqI alpha_rp.equality)
apply (rule_tac x=zs in exI, auto)+

done

lemma R2_H2_commute: "R2 o H2 = H2 o R2"
by (auto simp: R2_H2_commute2)

lemma R3_H2_commute2: "R3 (H2 P) = H2 (R3 P)"
apply (auto simp: fun_eq_iff rp_defs design_defs prefix_def
            elim: alpha_d_more_eqE split: cond_splits)
done

lemma R3_H2_commute: "R3 o H2 = H2 o R3"
by (auto simp: R3_H2_commute2)

lemma R_join:
  assumes "x is R healthy"
  and "y is R healthy"
  shows "(x \<sqinter> y) is R healthy"
proof -
  have "R x = x" and "R y = y"
    using assms by (simp_all only: Healthy_def)
  moreover
  have "((R x) \<sqinter> (R y)) is R healthy"
    by (auto simp add: design_defs rp_defs fun_eq_iff split: cond_splits)
  ultimately show ?thesis by simp
qed

lemma R_meet:
  assumes A: "x is R healthy"
  and B:"y is R healthy"
  shows "(x \<squnion> y) is R healthy"
proof -
  have "R x = x" and "R y = y"
    using assms by (simp_all only: Healthy_def)
  moreover
  have "((R x) \<squnion> (R y)) is R healthy"
    by (auto simp add: design_defs rp_defs fun_eq_iff split: cond_splits)
  ultimately show ?thesis by simp
qed

lemma R_H2_commute: "R o H2 = H2 o R"
apply (auto simp add: rp_defs design_defs fun_eq_iff split: cond_splits
                     elim: alpha_d_more_eqE)
apply (rule_tac b="ba\<lparr>tr := tr b\<rparr>" in comp_intro, auto split: cond_splits
  elim!: alpha_d_more_eqE alpha_rp_eqE intro!: alpha_d_more_eqI alpha_rp.equality)
apply (rule_tac s=ba in subst, auto intro!: alpha_d_more_eqI alpha_rp.equality)
apply (rule_tac s=ba in subst, auto intro!: alpha_d_more_eqI alpha_rp.equality)
apply (rule_tac b="ba\<lparr>tr := tr b\<rparr>" in comp_intro, auto split: cond_splits)
apply (rule_tac s=ba in subst,
  auto elim: alpha_d_more_eqE alpha_rp_eqE intro: alpha_d_more_eqI alpha_rp.equality)
apply (rule_tac b="ba\<lparr>tr := tr b\<rparr>" in comp_intro,
  auto elim: alpha_d_more_eqE alpha_rp_eqE intro: alpha_d_more_eqI alpha_rp.equality split: cond_splits)
apply (rule_tac s=ba in subst,
  auto elim: alpha_d_more_eqE alpha_rp_eqE intro: alpha_d_more_eqI alpha_rp.equality)
done

lemma R_H2_commute2: "R (H2 P) = H2 (R P)"
by (auto simp: fun_eq_iff R_H2_commute[simplified fun_eq_iff Fun.comp_def])

end


(*  Title: L3_Lib.thy
    Original author: Anthony Fox, University of Cambridge
    Contributions by: Kyndylan Nienhuis <kyndylan@mutlus.nl>

L3 operations.
*)

theory L3_Lib
imports "HOL-Word.Word"
        "HOL-Library.Code_Target_Numeral"
        "HOL-Library.Monad_Syntax"
begin

translations
  "_do_block (_do_cons (_do_bind p t) (_do_final e))"
    <= "CONST bind t (\<lambda>p. e)"

(* avoid syntax clash with shift-right operation *)
no_syntax
  "_thenM" :: "['a, 'b] \<Rightarrow> 'c" (infixr ">>" 54)

(* basic state Monad *)
definition "return = Pair"

definition bind :: "('state \<Rightarrow> ('a \<times> 'state)) \<Rightarrow>
                    ('a \<Rightarrow> 'state \<Rightarrow> ('b \<times> 'state)) \<Rightarrow>
                    ('state \<Rightarrow> ('b \<times> 'state))" where
  "bind f g = (\<lambda>s. let (a, s') = f s in g a s')"

(* use do syntax for this state monad *)
adhoc_overloading
  Monad_Syntax.bind L3_Lib.bind

definition read_state :: "('state \<Rightarrow> 'a) \<Rightarrow> 'state \<Rightarrow> 'a \<times> 'state" where
  "read_state f = (\<lambda>s. (f s, s))"

definition update_state :: "('state \<Rightarrow> 'state) \<Rightarrow> 'state \<Rightarrow> unit \<times> 'state" where
  "update_state f = (\<lambda>s. ((), f s))"

definition extend_state :: "'b \<Rightarrow> ('b \<times> 'state \<Rightarrow> 'a \<times> 'b \<times> 'state) \<Rightarrow> 'state \<Rightarrow> 'a \<times> 'state" where
  "extend_state v f = (\<lambda>s. let (a, s') = f (v, s) in (a, snd s'))"

definition trim_state :: "('state \<Rightarrow> 'a \<times> 'state) \<Rightarrow> 'b \<times> 'state \<Rightarrow> 'a \<times> 'b \<times> 'state" where
  "trim_state f = (\<lambda>(s1, s2). let (a, s') = f s2 in (a, s1, s'))"

fun foreach_loop :: "'a list \<times> ('a \<Rightarrow> 'state \<Rightarrow> unit \<times> 'state) \<Rightarrow> 'state \<Rightarrow> unit \<times> 'state" where
  "foreach_loop ([], _) = return ()" |
  "foreach_loop (h # t, a) = bind (a h) (\<lambda>u. foreach_loop (t, a))"

function for_loop :: "nat \<times> nat \<times> (nat \<Rightarrow> 'state \<Rightarrow> unit \<times> 'state) \<Rightarrow> 'state \<Rightarrow> unit \<times> 'state" where
  "for_loop (i, j, a) =
   (if i = j then
      a i
    else
      bind (a i) (\<lambda>u. for_loop ((if i < j then i + 1 else i - 1), j, a)))"
  by auto
  termination by (relation "measure (\<lambda>(i, j, _). if i < j then j - i else i - j)") auto

(* Because there are no constraints on i, j and a on the left-hand side of the definition, every
occurrence of for_loop can be simplified by for_loop.simps, and since the definition is recursive
the simplifier might diverge. For this reason we remove for_loop.simps from the simp set. *)

declare for_loop.simps [simp del]

(* Monad laws *)

lemma bind_left_identity [simp]:
  shows "bind (return a) f = f a"
unfolding return_def bind_def
by auto

lemma bind_right_identity [simp]:
  shows "bind m return = m"
unfolding return_def bind_def
by auto

lemma bind_associativity:
  shows "bind (bind m f) g = bind m (\<lambda>a. bind (f a) g)"
        (is "?l = ?r")
proof
  fix s
  show "?l s = ?r s"
    unfolding return_def bind_def
    by (cases "m s") auto
qed

(* Projections *)

lemma project_return [simp]:
  shows "fst (return a s) = a"
    and "snd (return a s) = s"
unfolding return_def
by auto

lemma project_read_state [simp]:
  shows "fst (read_state f s) = f s"
    and "snd (read_state f s) = s"
unfolding read_state_def
by auto

lemma project_update_state [simp]:
  shows "fst (update_state f s) = ()"
    and "snd (update_state f s) = f s"
unfolding update_state_def
by auto

(* Other monad simplifications *)

lemma read_state_constant [simp]:
  shows "read_state (\<lambda>s. a) = return a"
unfolding read_state_def return_def
..

lemma update_state_id [simp]:
  shows "update_state (\<lambda>s. s) = return ()"
unfolding update_state_def return_def
..

lemma foreach_loop_return [simp]:
  shows "foreach_loop (l, \<lambda>_. return a) = return ()"
by (induct l) simp_all

lemma extend_state_return [simp]:
  shows "extend_state v (return a) = return a"
unfolding extend_state_def return_def
by simp

lemma extend_state_trim_state [simp]:
  shows "extend_state v (trim_state m) = m"
        (is "?l = ?r")
proof
  fix s
  show "?l s = ?r s"
    unfolding extend_state_def trim_state_def
    by (cases "m s") auto
qed

(* extra character operations *)

definition Ord :: "char \<Rightarrow> nat" where
   "Ord = nat_of_char"

definition Chr :: "nat \<Rightarrow> char" where
   "Chr = char_of_nat"

definition is_lower :: "char \<Rightarrow> bool" where
   "is_lower c = (Ord (CHR ''a'') \<le> Ord c \<and> Ord c \<le> Ord (CHR ''z''))"

definition is_upper :: "char \<Rightarrow> bool" where
   "is_upper c = (Ord (CHR ''A'') \<le> Ord c \<and> Ord c \<le> Ord (CHR ''Z''))"

definition is_space :: "char \<Rightarrow> bool" where
   "is_space c = (Ord (CHR '' '') = Ord c \<or> 9 \<le> Ord c \<and> Ord c \<le> 13)"

definition is_digit :: "char \<Rightarrow> bool" where
   "is_digit c = (Ord (CHR ''0'') \<le> Ord c \<and> Ord c \<le> Ord (CHR ''9''))"

definition is_hex_digit :: "char \<Rightarrow> bool" where
   "is_hex_digit c = (is_digit c \<or> Ord (CHR ''a'') \<le> Ord c \<and> Ord c \<le> Ord (CHR ''f'') \<or>
                                   Ord (CHR ''A'') \<le> Ord c \<and> Ord c \<le> Ord (CHR ''F''))"

definition is_alpha :: "char \<Rightarrow> bool" where
   "is_alpha c = (is_lower c \<or> is_upper c)"

definition is_alpha_num :: "char \<Rightarrow> bool" where
   "is_alpha_num c = (is_alpha c \<or> is_digit c)"

definition to_lower :: "char \<Rightarrow> char" where
   "to_lower c = (if is_upper c then Chr (Ord c + 32) else c)"

definition to_upper :: "char \<Rightarrow> char" where
   "to_upper c = (if is_lower c then Chr (Ord c - 32) else c)"

(* numeric strings *)

fun list_to_nat :: "nat \<Rightarrow> nat list \<Rightarrow> nat" where
  "list_to_nat _ [] = 0" |
  "list_to_nat base (h # t) = h mod base + base * list_to_nat base t"

fun nat_to_list :: "nat \<Rightarrow> nat \<Rightarrow> nat list" where
  "nat_to_list base n =
   (if n < base \<or> base < 2 then [n mod base] else n mod base # nat_to_list base (n div base))"

(* Because there are no constraints on n on the left-hand side of the definition, every occurrence
of nat_to_list can be simplified by nat_to_list.simps, and since the definition is recursive the
simplifier might diverge. For this reason we remove nat_to_list.simps from the simp set. *)

declare nat_to_list.simps [simp del]

definition hex :: "nat \<Rightarrow> char" where
  "hex n = (if n = 0 then CHR ''0''
            else if n = 1 then CHR ''1''
            else if n = 2 then CHR ''2''
            else if n = 3 then CHR ''3''
            else if n = 4 then CHR ''4''
            else if n = 5 then CHR ''5''
            else if n = 6 then CHR ''6''
            else if n = 7 then CHR ''7''
            else if n = 8 then CHR ''8''
            else if n = 9 then CHR ''9''
            else if n = 10 then CHR ''A''
            else if n = 11 then CHR ''B''
            else if n = 12 then CHR ''C''
            else if n = 13 then CHR ''D''
            else if n = 14 then CHR ''E''
            else if n = 15 then CHR ''F''
            else undefined)"

definition unhex :: "char \<Rightarrow> nat" where
  "unhex c = (if c = CHR ''0'' then 0
              else if c = CHR ''1'' then 1
              else if c = CHR ''2'' then 2
              else if c = CHR ''3'' then 3
              else if c = CHR ''4'' then 4
              else if c = CHR ''5'' then 5
              else if c = CHR ''6'' then 6
              else if c = CHR ''7'' then 7
              else if c = CHR ''8'' then 8
              else if c = CHR ''9'' then 9
              else if c = CHR ''a'' \<or> c = CHR ''A'' then 10
              else if c = CHR ''b'' \<or> c = CHR ''B'' then 11
              else if c = CHR ''c'' \<or> c = CHR ''C'' then 12
              else if c = CHR ''d'' \<or> c = CHR ''D'' then 13
              else if c = CHR ''e'' \<or> c = CHR ''E'' then 14
              else if c = CHR ''f'' \<or> c = CHR ''F'' then 15
              else undefined)"

definition string_to_nat :: "nat \<Rightarrow> string \<Rightarrow> nat" where
  "string_to_nat base s = list_to_nat base (map unhex (rev s))"

definition nat_to_string :: "nat \<Rightarrow> nat \<Rightarrow> string" where
  "nat_to_string base n = rev (map hex (nat_to_list base n))"

definition "bin_string_to_nat \<equiv> string_to_nat 2"
definition "nat_to_bin_string \<equiv> nat_to_string 2"
definition "dec_string_to_nat \<equiv> string_to_nat 10"
definition "nat_to_dec_string \<equiv> nat_to_string 10"
definition "hex_string_to_nat \<equiv> string_to_nat 16"
definition "nat_to_hex_string \<equiv> nat_to_string 16"

definition nat_from_bin_string :: "string \<Rightarrow> nat option" where
  "nat_from_bin_string s =
   (if s \<noteq> '''' \<and> list_all (\<lambda>c. c = CHR ''0'' \<or> c = CHR ''1'') s then
      Some (bin_string_to_nat s)
    else None)"

definition nat_from_dec_string :: "string \<Rightarrow> nat option" where
  "nat_from_dec_string s =
   (if s \<noteq> '''' \<and> list_all is_digit s then Some (dec_string_to_nat s) else None)"

definition nat_from_hex_string :: "string \<Rightarrow> nat option" where
  "nat_from_hex_string s =
   (if s \<noteq> '''' \<and> list_all is_hex_digit s then Some (hex_string_to_nat s) else None)"

definition dec_string_to_int :: "string \<Rightarrow> int" where
  "dec_string_to_int r =
   (case r of []    \<Rightarrow> 0 |
              h # t \<Rightarrow> (if h = CHR ''-'' \<or> h = CHR ''~''
                        then -int (dec_string_to_nat t)
                        else  int (dec_string_to_nat r)))"

definition int_to_dec_string :: "int \<Rightarrow> string" where
  "int_to_dec_string i =
   (if i < 0 then CHR ''~'' # nat_to_dec_string (nat (-i)) else nat_to_dec_string (nat i))"

definition string_to_bool :: "string \<Rightarrow> bool" where
  "string_to_bool s = (if s = ''true'' then True
                       else if s = ''false'' then False
                       else undefined)"

definition string_to_char :: "string \<Rightarrow> char" where
  "string_to_char s = (case s of [c] \<Rightarrow> c | _ \<Rightarrow> undefined)"

(* extra Nat operation *)

fun log2 :: "nat \<Rightarrow> nat" where
  "log2 n = (if n = 0 then undefined else if n = 1 then 0 else Suc (log2 (n div 2)))"

(* Because there are no constraints on n on the left-hand side of the definition, every occurrence
of log2 can be simplified by log2.simps, and since the definition is recursive the simplifier might
diverge. For this reason we remove log2.simps from the simp set. *)

declare log2.simps [simp del]

lemma log2_bounds:
  assumes "n \<noteq> 0"
  shows   "2 ^ (log2 n) \<le> n"
    and   "n < 2 ^ (Suc (log2 n))"
proof -
  (* "The induction works better if we prove one goal instead of two goals" *)
  have "2 ^ (log2 n) \<le> n \<and> n < 2 ^ (Suc (log2 n))"
    using assms
    proof (induct "log2 n" arbitrary: n)
      case 0
      hence "n = 1"
        by (simp add: log2.simps) (meson nat.simps(3))
      thus ?case by (simp add: log2.simps)
    next
      case (Suc k)
      show ?case
        proof (cases "n = 1")
          case True
          thus ?thesis by (simp add: log2.simps)
        next
          case False
          hence "1 < n" using Suc(3) by simp
          hence "(n div 2) \<noteq> 0" by auto
          have log2: "log2 n = Suc (log2 (n div 2))"
            using `1 < n` by (simp add: log2.simps)
          hence "k = log2 (n div 2)" using Suc(2) by simp
          note Suc(1)[OF this `(n div 2) \<noteq> 0`]
          thus ?thesis
            using log2 by auto
        qed
    qed
  thus "2 ^ (log2 n) \<le> n" "n < 2 ^ (Suc (log2 n))" by auto
qed

lemma log2_unat_bounds:
  fixes x :: "('a :: len) word"
  assumes "x \<noteq> 0"
  shows "log2 (unat x) < len_of TYPE('a)"
proof -
  have "unat x \<noteq> 0"
    using assms
    by (simp add: unat_eq_zero)
  have "unat x < 2 ^ len_of TYPE('a)"
    by simp
  note le_less_trans[OF log2_bounds(1)[OF `unat x \<noteq> 0`] this]
  thus ?thesis by auto
qed

(* extra int operations *)

definition quot :: "int \<Rightarrow> int \<Rightarrow> int" (infixl "quot" 70) where
  "i quot j = (if j = 0 then undefined
               else if 0 < j then if 0 \<le> i then i div j else -(-i div j)
               else if 0 \<le> i then -(i div -j)
               else -i div -j)"

definition rem :: "int \<Rightarrow> int \<Rightarrow> int" (infixl "rem" 70) where
  "i rem j = (if j = 0 then undefined else i - i quot j * j)"

definition quot_rem :: "int * int \<Rightarrow> int * int" where
  "quot_rem p = (case p of (i, j) \<Rightarrow> (i div j, i rem j))"

(* extra option operations *)

definition is_some :: "'a option \<Rightarrow> bool" where
  "is_some x = (case x of Some _ \<Rightarrow> True | _ \<Rightarrow> False)"

lemma is_some_alt:
  shows "is_some x = (x \<noteq> None)"
unfolding is_some_def
using option.disc_eq_case(2)
by auto

lemma is_some_simps [simp]:
  shows "\<not> (is_some None)"
    and "is_some (Some x)"
unfolding is_some_def by simp_all

(* extra list operations *)

fun splitl :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'a list \<times> 'a list" where
  "splitl _ [] = ([], [])" |
  "splitl P (h # t) = (if P h then let (l, r) = splitl P t in (h # l, r) else ([], h # t))"

definition splitr :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'a list \<times> 'a list" where
  "splitr P x = (let (l, r) = splitl P (rev x) in (rev r, rev l))"

definition pad_left :: "'a \<Rightarrow> nat \<Rightarrow> 'a list \<Rightarrow> 'a list" where
  "pad_left c n s = replicate (n - length s) c @ s"

definition pad_right :: "'a \<Rightarrow> nat \<Rightarrow> 'a list \<Rightarrow> 'a list" where
  "pad_right c n s = s @ replicate (n - length s) c"

fun index_find :: "nat \<Rightarrow> 'a \<times> 'a list \<Rightarrow> nat option" where
  "index_find _ (_, []) = None" |
  "index_find i (v, h # t) = (if v = h then Some i else index_find (Suc i) (v, t))"

definition "index_of = index_find 0"

definition remove :: "'a list * 'a list \<Rightarrow> 'a list" where
  "remove p = (case p of (l1, l2) \<Rightarrow> filter (\<lambda>x. x \<notin> set l1) l2)"

definition remove_except :: "'a list * 'a list \<Rightarrow> 'a list" where
  "remove_except p = (case p of (l1, l2) \<Rightarrow> filter (\<lambda>x. x \<in> set l1) l2)"

fun remove_duplicates :: "'a list \<Rightarrow> 'a list" where
  "remove_duplicates [] = []" |
  "remove_duplicates (h # t) = (if h \<in> set t then remove_duplicates t else h # remove_duplicates t)"

lemma splitl_length:
  shows "length (fst (splitl P l)) + length (snd (splitl P l)) = length l"
by (induct l, auto simp add: case_prod_beta)

lemma splitl_fst_length [simp]:
  shows "length (fst (splitl P x)) \<le> length x"
using splitl_length
by (metis order_refl trans_le_add1)

lemma splitl_snd_length [simp]:
  shows "length (snd (splitl P x)) \<le> length x"
using splitl_length
by (metis order_refl trans_le_add2)

lemma pad_left_length [simp]:
  shows "length (pad_left e n l) = max (length l) n"
unfolding pad_left_def
by auto

lemma pad_right_length [simp]:
  shows "length (pad_right e n l) = max (length l) n"
unfolding pad_right_def
by auto

lemma pad_left_nth:
  shows "pad_left e n l ! m =
         (if m < n - List.length l
          then e
          else l ! (m - (n - List.length l)))"
unfolding pad_left_def nth_append
by simp

(* extra string operations *)

lemma fields_termination_lem [simp]:
  assumes "a \<noteq> []" and "length a \<le> length c"
  shows "length a - b < Suc (length c)"
  by (simp add: assms(2) le_imp_less_Suc less_imp_diff_less)

function (sequential) tokens :: "(char \<Rightarrow> bool) \<Rightarrow> string \<Rightarrow> string list" where
  "tokens _ '''' = []" |
  "tokens P x =
   (let (l, r) = splitl (\<lambda>e. ~P e) x in if l = [] then tokens P (tl r) else l # tokens P r)"
  by pat_completeness auto
  termination tokens
  apply (relation "measure (length o snd)")
  apply auto
  apply (case_tac "~ P v", auto simp add: case_prod_beta le_imp_less_Suc)
  apply (case_tac "~ P v", auto simp add: case_prod_beta le_imp_less_Suc)
  done

function (sequential) fields :: "(char \<Rightarrow> bool) \<Rightarrow> string \<Rightarrow> string list" where
  "fields _ '''' = [[]]" |
  "fields P x =
   (let (l, r) = splitl (\<lambda>e. ~P e) x in if l = [] then [] # fields P (tl r)
                                        else if r = [] then [l]
                                        else l # fields P (tl r))"
  by pat_completeness auto
  termination fields
  apply (relation "measure (length o snd)")
  apply auto
  apply (case_tac "~ P v", auto simp add: case_prod_beta le_imp_less_Suc)
  apply (case_tac "~ P v", auto simp add: case_prod_beta)
  done

(* bit-string operations - extends Bool_List_Representation.thy *)

definition nat_to_bitstring :: "nat \<Rightarrow> bool list" where
  "nat_to_bitstring n =
   (if n = 0 then [False] else bin_to_bl (log2 n + 1) (int n))"

definition "bitstring_to_nat = nat o bl_to_bin"

definition fixwidth :: "nat \<Rightarrow> bool list \<Rightarrow> bool list" where
  "fixwidth n v = (let l = length v in if l < n then pad_left False n v else drop (l - n) v)"

definition bitwise :: "(bool \<Rightarrow> bool \<Rightarrow> bool) \<Rightarrow> bool list \<Rightarrow> bool list \<Rightarrow> bool list" where
  "bitwise f v1 v2 =
   (let m = max (length v1) (length v2) in map (case_prod f) (zip (fixwidth m v1) (fixwidth m v2)))"

definition "bor  = bitwise (\<or>)"
definition "band = bitwise (\<and>)"
definition "bxor = bitwise (\<noteq>)"

definition bitstring_shiftl :: "bool list \<Rightarrow> nat \<Rightarrow> bool list" where
  "bitstring_shiftl v m = pad_right False (length v + m) v"

definition bitstring_shiftr :: "bool list \<Rightarrow> nat \<Rightarrow> bool list" where
  "bitstring_shiftr v m = take (length v - m) v"

definition bitstring_field :: "nat \<Rightarrow> nat \<Rightarrow> bool list \<Rightarrow> bool list" where
  "bitstring_field h l v = fixwidth (Suc h - l) (bitstring_shiftr v l)"

definition bitstring_rotate :: "bool list \<Rightarrow> nat \<Rightarrow> bool list" where
  "bitstring_rotate v m =
   (let l = length v in
    let x = m mod l in
      if l = 0 \<or> x = 0 then v else bitstring_field (x - 1) 0 v @ bitstring_field (l - 1) x v)"

definition bitstring_test_bit :: "bool list \<Rightarrow> nat \<Rightarrow> bool" where
  "bitstring_test_bit v n = (bitstring_field n n v = [True])"

definition bitstring_modify ::  "(nat \<times> bool \<Rightarrow> bool) \<times> bool list \<Rightarrow> bool list" where
  "bitstring_modify p = (case p of (f, l) \<Rightarrow> map f (zip (rev (upt 0 (length l))) l))"

definition bitstring_field_insert :: "nat \<Rightarrow> nat \<Rightarrow> bool list \<Rightarrow> bool list \<Rightarrow> bool list" where
  "bitstring_field_insert h l v1 v2 =
   bitstring_modify (\<lambda>(i, b). if l \<le> i \<and> i \<le> h then bitstring_test_bit v1 (i - l) else b, v2)"

lemma nat_to_bitstring_zero [simp]:
  shows "nat_to_bitstring 0 = [False]"
unfolding nat_to_bitstring_def by simp

(* We do not add the following rule to the simp set, because n occurs twice at the right hand side,
and therefore the state might not become simpler when applying this rule. *)

lemma nat_to_bitstring_length:
  shows "length (nat_to_bitstring n) = (if n = 0 then 1 else log2 n + 1)"
unfolding nat_to_bitstring_def
by (simp del: bin_to_bl_def)

lemma fixwidth_length [simp]:
  shows "length (fixwidth n l) = n"
unfolding fixwidth_def Let_def
by auto

lemma bitwise_length [simp]:
  shows "length (bitwise f v1 v2) = max (length v1) (length v2)"
unfolding bitwise_def Let_def
by auto

(* extra word operations *)

definition unsigned_min :: "'a::len word \<times> 'a::len word \<Rightarrow> 'a::len word" where
  "unsigned_min p = (case p of (w1, w2) \<Rightarrow> (if w1 \<le> w2 then w1 else w2))"

definition unsigned_max :: "'a::len word \<times> 'a::len word \<Rightarrow> 'a::len word" where
  "unsigned_max p = (case p of (w1, w2) \<Rightarrow> (if w1 \<le> w2 then w2 else w1))"

definition word_log2 :: "'a::len word \<Rightarrow> 'a::len word" where
  "word_log2 w = of_nat (log2 (unat w))"

definition word_quot :: "'a::len word \<Rightarrow> 'a::len word \<Rightarrow> 'a::len word" where
  "word_quot i j = of_int (sint i quot sint j)"

definition word_rem :: "'a::len word \<Rightarrow> 'a::len word \<Rightarrow> 'a::len word" where
  "word_rem i j = of_int (sint i rem sint j)"

definition word_sdiv :: "'a::len word \<Rightarrow> 'a::len word \<Rightarrow> 'a::len word" where
  "word_sdiv i j = of_int (sint i div sint j)"

definition word_smod :: "'a::len word \<Rightarrow> 'a::len word \<Rightarrow> 'a::len word" where
  "word_smod i j = of_int (sint i mod sint j)"

definition word_modify :: "(nat \<times> bool \<Rightarrow> bool) \<times> 'a::len word \<Rightarrow> 'a::len word" where
  "word_modify p = (case p of (f, w) \<Rightarrow> of_bl (bitstring_modify (f, to_bl w)))"

definition word_bit_field_insert :: "nat \<Rightarrow> nat \<Rightarrow> 'a::len word \<Rightarrow> 'b::len word \<Rightarrow> 'b::len word" where
  "word_bit_field_insert h l w1 w2 =
   word_modify (\<lambda>(i, b). if l \<le> i \<and> i \<le> h then test_bit w1 (i - l) else b, w2)"

definition word_bits :: "nat \<Rightarrow> nat \<Rightarrow> 'a::len word \<Rightarrow> 'a::len word" where
  "word_bits h l w = (w >> l) AND mask (Suc h - l)"

definition word_extract :: "nat \<Rightarrow> nat \<Rightarrow> 'a::len word \<Rightarrow> 'b::len word" where
  "word_extract h l w = ucast (word_bits h l w)"

definition word_replicate :: "nat \<Rightarrow> 'a::len word \<Rightarrow> 'b::len word" where
  "word_replicate n a = word_rcat (replicate n a)"

(* floating-point stubs *)

datatype ieee_rounding =
  roundTiesToEven | roundTowardPositive | roundTowardNegative | roundTowardZero

datatype ieee_compare = LT | EQ | GT | UN

record ieee_flags =
  DivideByZero :: bool
  InvalidOp :: bool
  Overflow :: bool
  Precision :: bool
  Underflow :: bool

consts
  fp32_abs :: "32 word \<Rightarrow> 32 word"
  fp32_add :: "ieee_rounding \<Rightarrow> 32 word \<Rightarrow> 32 word \<Rightarrow> 32 word"
  fp32_add_with_flags :: "ieee_rounding \<Rightarrow> 32 word \<Rightarrow> 32 word \<Rightarrow> ieee_flags \<times> 32 word"
  fp32_compare :: "32 word \<Rightarrow> 32 word \<Rightarrow> ieee_compare"
  fp32_div :: "ieee_rounding \<Rightarrow> 32 word \<Rightarrow> 32 word \<Rightarrow> 32 word"
  fp32_div_with_flags :: "ieee_rounding \<Rightarrow> 32 word \<Rightarrow> 32 word \<Rightarrow> ieee_flags \<times> 32 word"
  fp32_equal :: "32 word \<Rightarrow> 32 word \<Rightarrow> bool"
  fp32_from_int :: "ieee_rounding \<Rightarrow> int \<Rightarrow> 32 word"
  fp32_greater :: "32 word \<Rightarrow> 32 word \<Rightarrow> bool"
  fp32_greater_equal :: "32 word \<Rightarrow> 32 word \<Rightarrow> bool"
  fp32_is_integral :: "32 word \<Rightarrow> bool"
  fp32_is_finite :: "32 word \<Rightarrow> bool"
  fp32_is_nan :: "32 word \<Rightarrow> bool"
  fp32_is_normal :: "32 word \<Rightarrow> bool"
  fp32_is_signalling_nan :: "32 word \<Rightarrow> bool"
  fp32_is_subnormal :: "32 word \<Rightarrow> bool"
  fp32_less :: "32 word \<Rightarrow> 32 word \<Rightarrow> bool"
  fp32_less_equal :: "32 word \<Rightarrow> 32 word \<Rightarrow> bool"
  fp32_mul :: "ieee_rounding \<Rightarrow> 32 word \<Rightarrow> 32 word \<Rightarrow> 32 word"
  fp32_mul_with_flags :: "ieee_rounding \<Rightarrow> 32 word \<Rightarrow> 32 word \<Rightarrow> ieee_flags \<times> 32 word"
  fp32_mul_add :: "ieee_rounding \<Rightarrow> 32 word \<Rightarrow> 32 word \<Rightarrow> 32 word \<Rightarrow> 32 word"
  fp32_mul_add_with_flags :: "ieee_rounding \<Rightarrow> 32 word \<Rightarrow> 32 word \<Rightarrow> 32 word \<Rightarrow> ieee_flags \<times> 32 word"
  fp32_mul_sub :: "ieee_rounding \<Rightarrow> 32 word \<Rightarrow> 32 word \<Rightarrow> 32 word \<Rightarrow> 32 word"
  fp32_mul_sub_with_flags :: "ieee_rounding \<Rightarrow> 32 word \<Rightarrow> 32 word \<Rightarrow> 32 word \<Rightarrow> ieee_flags \<times> 32 word"
  fp32_neg_inf :: "32 word"
  fp32_neg_max :: "32 word"
  fp32_neg_min :: "32 word"
  fp32_neg_zero :: "32 word"
  fp32_negate :: "32 word \<Rightarrow> 32 word"
  fp32_pos_inf :: "32 word"
  fp32_pos_max :: "32 word"
  fp32_pos_min :: "32 word"
  fp32_pos_zero :: "32 word"
  fp32_round_to_integral :: "ieee_rounding \<Rightarrow> 32 word \<Rightarrow> 32 word"
  fp32_snan :: "32 word"
  fp32_sqrt :: "ieee_rounding \<Rightarrow> 32 word \<Rightarrow> 32 word"
  fp32_sqrt_with_flags :: "ieee_rounding \<Rightarrow> 32 word \<Rightarrow> ieee_flags \<times> 32 word"
  fp32_sub :: "ieee_rounding \<Rightarrow> 32 word \<Rightarrow> 32 word \<Rightarrow> 32 word"
  fp32_sub_with_flags :: "ieee_rounding \<Rightarrow> 32 word \<Rightarrow> 32 word \<Rightarrow> ieee_flags \<times> 32 word"
  fp32_qnan :: "32 word"
  fp32_to_int :: "ieee_rounding \<Rightarrow> 32 word \<Rightarrow> int option"

consts
  fp64_abs :: "64 word \<Rightarrow> 64 word"
  fp64_add :: "ieee_rounding \<Rightarrow> 64 word \<Rightarrow> 64 word \<Rightarrow> 64 word"
  fp64_add_with_flags :: "ieee_rounding \<Rightarrow> 64 word \<Rightarrow> 64 word \<Rightarrow> ieee_flags \<times> 64 word"
  fp64_compare :: "64 word \<Rightarrow> 64 word \<Rightarrow> ieee_compare"
  fp64_div :: "ieee_rounding \<Rightarrow> 64 word \<Rightarrow> 64 word \<Rightarrow> 64 word"
  fp64_div_with_flags :: "ieee_rounding \<Rightarrow> 64 word \<Rightarrow> 64 word \<Rightarrow> ieee_flags \<times> 64 word"
  fp64_equal :: "64 word \<Rightarrow> 64 word \<Rightarrow> bool"
  fp64_from_int :: "ieee_rounding \<Rightarrow> int \<Rightarrow> 64 word"
  fp64_greater :: "64 word \<Rightarrow> 64 word \<Rightarrow> bool"
  fp64_greater_equal :: "64 word \<Rightarrow> 64 word \<Rightarrow> bool"
  fp64_is_integral :: "64 word \<Rightarrow> bool"
  fp64_is_finite :: "64 word \<Rightarrow> bool"
  fp64_is_nan :: "64 word \<Rightarrow> bool"
  fp64_is_normal :: "64 word \<Rightarrow> bool"
  fp64_is_signalling_nan :: "64 word \<Rightarrow> bool"
  fp64_is_subnormal :: "64 word \<Rightarrow> bool"
  fp64_less :: "64 word \<Rightarrow> 64 word \<Rightarrow> bool"
  fp64_less_equal :: "64 word \<Rightarrow> 64 word \<Rightarrow> bool"
  fp64_mul :: "ieee_rounding \<Rightarrow> 64 word \<Rightarrow> 64 word \<Rightarrow> 64 word"
  fp64_mul_with_flags :: "ieee_rounding \<Rightarrow> 64 word \<Rightarrow> 64 word \<Rightarrow> ieee_flags \<times> 64 word"
  fp64_mul_add :: "ieee_rounding \<Rightarrow> 64 word \<Rightarrow> 64 word \<Rightarrow> 64 word \<Rightarrow> 64 word"
  fp64_mul_add_with_flags :: "ieee_rounding \<Rightarrow> 64 word \<Rightarrow> 64 word \<Rightarrow> 64 word \<Rightarrow> ieee_flags \<times> 64 word"
  fp64_mul_sub :: "ieee_rounding \<Rightarrow> 64 word \<Rightarrow> 64 word \<Rightarrow> 64 word \<Rightarrow> 64 word"
  fp64_mul_sub_with_flags :: "ieee_rounding \<Rightarrow> 64 word \<Rightarrow> 64 word \<Rightarrow> 64 word \<Rightarrow> ieee_flags \<times> 64 word"
  fp64_neg_inf :: "64 word"
  fp64_neg_min :: "64 word"
  fp64_neg_max :: "64 word"
  fp64_neg_zero :: "64 word"
  fp64_negate :: "64 word \<Rightarrow> 64 word"
  fp64_pos_inf :: "64 word"
  fp64_pos_min :: "64 word"
  fp64_pos_max :: "64 word"
  fp64_pos_zero :: "64 word"
  fp64_round_to_integral :: "ieee_rounding \<Rightarrow> 64 word \<Rightarrow> 64 word"
  fp64_snan :: "64 word"
  fp64_sqrt :: "ieee_rounding \<Rightarrow> 64 word \<Rightarrow> 64 word"
  fp64_sqrt_with_flags :: "ieee_rounding \<Rightarrow> 64 word \<Rightarrow> ieee_flags \<times> 64 word"
  fp64_sub :: "ieee_rounding \<Rightarrow> 64 word \<Rightarrow> 64 word \<Rightarrow> 64 word"
  fp64_sub_with_flags :: "ieee_rounding \<Rightarrow> 64 word \<Rightarrow> 64 word \<Rightarrow> ieee_flags \<times> 64 word"
  fp64_qnan :: "64 word"
  fp64_to_int :: "ieee_rounding \<Rightarrow> 64 word \<Rightarrow> int option"

consts
  fp32_to_fp64 :: "32 word \<Rightarrow> 64 word"
  fp64_to_fp32 :: "ieee_rounding \<Rightarrow> 64 word \<Rightarrow> 32 word"

code_printing
    constant "fp32_abs" \<rightharpoonup>
      (SML) "!(fn '_ => raise Fail \"fp32'_abs\")"
      and (OCaml) "!(fun '_ -> failwith \"fp32'_abs\")"
      and (Haskell) "!(\\ '_ -> error \"fp32'_abs\")"
  | constant "fp32_add" \<rightharpoonup>
      (SML) "!(fn '_ => fn '_ => fn '_ => raise Fail \"fp32'_add\")"
      and (OCaml) "!(fun '_ '_ '_ -> failwith \"fp32'_add\")"
      and (Haskell) "!(\\ '_ '_ '_ -> error \"fp32'_add\")"
  | constant "fp32_add_with_flags" \<rightharpoonup>
      (SML) "!(fn '_ => fn '_ => fn '_ => raise Fail \"fp32'_add'_with'_flags\")"
      and (OCaml) "!(fun '_ '_ '_ -> failwith \"fp32'_add'_with'_flag\")"
      and (Haskell) "!(\\ '_ '_ '_ -> error \"fp32'_add'_with'_flag\")"
  | constant "fp32_compare" \<rightharpoonup>
      (SML) "!(fn '_ => fn '_ => raise Fail \"fp32'_compare\")"
      and (OCaml) "!(fun '_ '_ -> failwith \"fp32'_compare\")"
      and (Haskell) "!(\\ '_ '_ -> error \"fp32'_compare\")"
  | constant "fp32_div" \<rightharpoonup>
      (SML) "!(fn '_ => fn '_ => fn '_ => raise Fail \"fp32'_div\")"
      and (OCaml) "!(fun '_ '_ '_ -> failwith \"fp32'_div\")"
      and (Haskell) "!(\\ '_ '_ '_ -> error \"fp32'_div\")"
  | constant "fp32_div_with_flags" \<rightharpoonup>
      (SML) "!(fn '_ => fn '_ => fn '_ => raise Fail \"fp32'_div'_with'_flags\")"
      and (OCaml) "!(fun '_ '_ '_ -> failwith \"fp32'_div'_with'_flag\")"
      and (Haskell) "!(\\ '_ '_ '_ -> error \"fp32'_div'_with'_flag\")"
  | constant "fp32_equal" \<rightharpoonup>
      (SML) "!(fn '_ => fn '_ => raise Fail \"fp32'_equal\")"
      and (OCaml) "!(fun '_ '_ -> failwith \"fp32'_equal\")"
      and (Haskell) "!(\\ '_ '_ -> error \"fp32'_equal\")"
  | constant "fp32_from_int" \<rightharpoonup>
      (SML) "!(fn '_ => fn '_ => raise Fail \"fp32'_from'_int\")"
      and (OCaml) "!(fun '_ '_ -> failwith \"fp32'_from'_int\")"
      and (Haskell) "!(\\ '_ '_ -> error \"fp32'_from'_int\")"
  | constant "fp32_greater" \<rightharpoonup>
      (SML) "!(fn '_ => fn '_ => raise Fail \"fp32'_greater\")"
      and (OCaml) "!(fun '_ '_ -> failwith \"fp32'_greater\")"
      and (Haskell) "!(\\ '_ '_ -> error \"fp32'_greater\")"
  | constant "fp32_greater_equal" \<rightharpoonup>
      (SML) "!(fn '_ => fn '_ => raise Fail \"fp32'_greater'_equal\")"
      and (OCaml) "!(fun '_ '_ -> failwith \"fp32'_greater'_equal\")"
      and (Haskell) "!(\\ '_ '_ -> error \"fp32'_greater'_equal\")"
  | constant "fp32_is_integral" \<rightharpoonup>
      (SML) "!(fn '_ => raise Fail \"fp32'_is'_integral\")"
      and (OCaml) "!(fun '_ -> failwith \"fp32'_is'_integral\")"
      and (Haskell) "!(\\ '_ -> error \"fp32'_is'_intagral\")"
  | constant "fp32_is_finite" \<rightharpoonup>
      (SML) "!(fn '_ => raise Fail \"fp32'_is'_finite\")"
      and (OCaml) "!(fun '_ -> failwith \"fp32'_is'_finite\")"
      and (Haskell) "!(\\ '_ -> error \"fp32'_is'_finite\")"
  | constant "fp32_is_nan" \<rightharpoonup>
      (SML) "!(fn '_ => raise Fail \"fp32'_is'_nan\")"
      and (OCaml) "!(fun '_ -> failwith \"fp32'_is'_nan\")"
      and (Haskell) "!(\\ '_ -> error \"fp32'_is'_nan\")"
  | constant "fp32_is_normal" \<rightharpoonup>
      (SML) "!(fn '_ => raise Fail \"fp32'_is'_normal\")"
      and (OCaml) "!(fun '_ -> failwith \"fp32'_is'_normal\")"
      and (Haskell) "!(\\ '_ -> error \"fp32'_is'_normal\")"
  | constant "fp32_is_signalling_nan" \<rightharpoonup>
      (SML) "!(fn '_ => raise Fail \"fp32'_is'_signalling'_nan\")"
      and (OCaml) "!(fun '_ -> failwith \"fp32'_is'_signalling'_nan\")"
      and (Haskell) "!(\\ '_ -> error \"fp32'_is'_signalling'_nan\")"
  | constant "fp32_is_subnormal" \<rightharpoonup>
      (SML) "!(fn '_ => raise Fail \"fp32'_is'_subnormal\")"
      and (OCaml) "!(fun '_ -> failwith \"fp32'_is'_subnormal\")"
      and (Haskell) "!(\\ '_ -> error \"fp32'_is'_subnormal\")"
  | constant "fp32_less" \<rightharpoonup>
      (SML) "!(fn '_ => fn '_ => raise Fail \"fp32'_less\")"
      and (OCaml) "!(fun '_ '_ -> failwith \"fp32'_less\")"
      and (Haskell) "!(\\ '_ '_ -> error \"fp32'_less\")"
  | constant "fp32_less_equal" \<rightharpoonup>
      (SML) "!(fn '_ => fn '_ => raise Fail \"fp32'_less'_equal\")"
      and (OCaml) "!(fun '_ '_ -> failwith \"fp32'_less'_equal\")"
      and (Haskell) "!(\\ '_ '_ -> error \"fp32'_less'_equal\")"
  | constant "fp32_mul" \<rightharpoonup>
      (SML) "!(fn '_ => fn '_ => fn '_ => raise Fail \"fp32'_mul\")"
      and (OCaml) "!(fun '_ '_ '_ -> failwith \"fp32'_mul\")"
      and (Haskell) "!(\\ '_ '_ '_ -> error \"fp32'_mul\")"
  | constant "fp32_mul_with_flags" \<rightharpoonup>
      (SML) "!(fn '_ => fn '_ => fn '_ => raise Fail \"fp32'_mul'_with'_flags\")"
      and (OCaml) "!(fun '_ '_ '_ -> failwith \"fp32'_mul'_with'_flag\")"
      and (Haskell) "!(\\ '_ '_ '_ -> error \"fp32'_mul'_with'_flag\")"
  | constant "fp32_mul_add" \<rightharpoonup>
      (SML) "!(fn '_ => fn '_ => fn '_ => fn '_ => raise Fail \"fp32'_mul'_add\")"
      and (OCaml) "!(fun '_ '_ '_ '_ -> failwith \"fp32'_mul'_add\")"
      and (Haskell) "!(\\ '_ '_ '_ '_ -> error \"fp32'_mul'_add\")"
  | constant "fp32_mul_add_with_flags" \<rightharpoonup>
      (SML) "!(fn '_ => fn '_ => fn '_ => raise Fail \"fp32'_mul'_add'_with'_flags\")"
      and (OCaml) "!(fun '_ '_ '_ -> failwith \"fp32'_mul'_add'_with'_flag\")"
      and (Haskell) "!(\\ '_ '_ '_ -> error \"fp32'_mul'_add'_with'_flag\")"
  | constant "fp32_mul_sub" \<rightharpoonup>
      (SML) "!(fn '_ => fn '_ => fn '_ => fn '_ => raise Fail \"fp32'_mul'_sub\")"
      and (OCaml) "!(fun '_ '_ '_ '_ -> failwith \"fp32'_mul'_sub\")"
      and (Haskell) "!(\\ '_ '_ '_ '_ -> error \"fp32'_mul'_sub\")"
  | constant "fp32_mul_sub_with_flags" \<rightharpoonup>
      (SML) "!(fn '_ => fn '_ => fn '_ => raise Fail \"fp32'_sub'_add'_with'_flags\")"
      and (OCaml) "!(fun '_ '_ '_ -> failwith \"fp32'_mul'_sub'_with'_flag\")"
      and (Haskell) "!(\\ '_ '_ '_ -> error \"fp32'_mul'_sub'_with'_flag\")"
  | constant "fp32_neg_inf" \<rightharpoonup>
      (SML) "!(raise Fail \"fp32'_neg'_inf\")"
      and (OCaml) "!(failwith \"fp32'_neg'_inf\")"
      and (Haskell) "!(error \"fp32'_neg'_inf\")"
  | constant "fp32_neg_min" \<rightharpoonup>
      (SML) "!(raise Fail \"fp32'_neg'_min\")"
      and (OCaml) "!(failwith \"fp32'_neg'_min\")"
      and (Haskell) "!(error \"fp32'_neg'_min\")"
  | constant "fp32_neg_max" \<rightharpoonup>
      (SML) "!(raise Fail \"fp32'_neg'_max\")"
      and (OCaml) "!(failwith \"fp32'_neg'_max\")"
      and (Haskell) "!(error \"fp32'_neg'_min\")"
  | constant "fp32_neg_zero" \<rightharpoonup>
      (SML) "!(raise Fail \"fp32'_neg'_zero\")"
      and (OCaml) "!(failwith \"fp32'_neg'_zero\")"
      and (Haskell) "!(error \"fp32'_neg'_zero\")"
  | constant "fp32_negate" \<rightharpoonup>
      (SML) "!(fn '_ => raise Fail \"fp32'_negate\")"
      and (OCaml) "!(fun '_ -> failwith \"fp32'_negate\")"
      and (Haskell) "!(\\ '_ -> error \"fp32'_negate\")"
  | constant "fp32_pos_inf" \<rightharpoonup>
      (SML) "!(raise Fail \"fp32'_pos'_inf\")"
      and (OCaml) "!(failwith \"fp32'_pos'_inf\")"
      and (Haskell) "!(error \"fp32'_pos'_inf\")"
  | constant "fp32_pos_min" \<rightharpoonup>
      (SML) "!(raise Fail \"fp32'_pos'_min\")"
      and (OCaml) "!(failwith \"fp32'_pos'_min\")"
      and (Haskell) "!(error \"fp32'_pos'_min\")"
  | constant "fp32_pos_max" \<rightharpoonup>
      (SML) "!(raise Fail \"fp32'_pos'_max\")"
      and (OCaml) "!(failwith \"fp32'_pos'_max\")"
      and (Haskell) "!(error \"fp32'_pos'_max\")"
  | constant "fp32_pos_zero" \<rightharpoonup>
      (SML) "!(raise Fail \"fp32'_pos'_zero\")"
      and (OCaml) "!(failwith \"fp32'_pos'_zero\")"
      and (Haskell) "!(error \"fp32'_pos'_zero\")"
  | constant "fp32_snan" \<rightharpoonup>
      (SML) "!(raise Fail \"fp32'_snan\")"
      and (OCaml) "!(failwith \"fp32'_snan\")"
      and (Haskell) "!(error \"fp32'_snan\")"
  | constant "fp32_round_to_integral" \<rightharpoonup>
      (SML) "!(fn '_ => fn '_ => raise Fail \"fp32'_round'_to'_integral\")"
      and (OCaml) "!(fun '_ '_ -> failwith \"fp32'_round'_to'_integral\")"
      and (Haskell) "!(\\ '_ '_ -> error \"fp32'_to'_integral\")"
  | constant "fp32_sqrt" \<rightharpoonup>
      (SML) "!(fn '_ => fn '_ => raise Fail \"fp32'_sqrt\")"
      and (OCaml) "!(fun '_ '_ -> failwith \"fp32'_sqrt\")"
      and (Haskell) "!(\\ '_ '_ -> error \"fp32'_sqrt\")"
  | constant "fp32_sqrt_with_flags" \<rightharpoonup>
      (SML) "!(fn '_ => fn '_ => fn '_ => raise Fail \"fp32'_sqrt'_with'_flags\")"
      and (OCaml) "!(fun '_ '_ '_ -> failwith \"fp32'_sqrt'_with'_flag\")"
      and (Haskell) "!(\\ '_ '_ '_ -> error \"fp32'_sqrt'_with'_flag\")"
  | constant "fp32_sub" \<rightharpoonup>
      (SML) "!(fn '_ => fn '_ => fn '_ => raise Fail \"fp32'_sub\")"
      and (OCaml) "!(fun '_ '_ '_ -> failwith \"fp32'_sub\")"
      and (Haskell) "!(\\ '_ '_ '_ -> error \"fp32'_sub\")"
  | constant "fp32_sub_with_flags" \<rightharpoonup>
      (SML) "!(fn '_ => fn '_ => fn '_ => raise Fail \"fp32'_sub'_with'_flags\")"
      and (OCaml) "!(fun '_ '_ '_ -> failwith \"fp32'_sub'_with'_flag\")"
      and (Haskell) "!(\\ '_ '_ '_ -> error \"fp32'_sub'_with'_flag\")"
  | constant "fp32_qnan" \<rightharpoonup>
      (SML) "!(raise Fail \"fp32'_qnan\")"
      and (OCaml) "!(failwith \"fp32'_qnan\")"
      and (Haskell) "!(error \"fp32'_qnan\")"
  | constant "fp32_to_int" \<rightharpoonup>
      (SML) "!(fn '_ => fn '_ => raise Fail \"fp32'_to'_int\")"
      and (OCaml) "!(fun '_ '_ -> failwith \"fp32'_to'_int\")"
      and (Haskell) "!(\\ '_ '_ -> error \"fp32'_to'_int\")"
  | constant "fp64_abs" \<rightharpoonup>
      (SML) "!(fn '_ => raise Fail \"fp64'_abs\")"
      and (OCaml) "!(fun '_ -> failwith \"fp64'_abs\")"
      and (Haskell) "!(\\ '_ -> error \"fp64'_abs\")"
  | constant "fp64_add" \<rightharpoonup>
      (SML) "!(fn '_ => fn '_ => fn '_ => raise Fail \"fp64'_add\")"
      and (OCaml) "!(fun '_ '_ '_ -> failwith \"fp64'_add\")"
      and (Haskell) "!(\\ '_ '_ '_ -> error \"fp64'_add\")"
  | constant "fp64_add_with_flags" \<rightharpoonup>
      (SML) "!(fn '_ => fn '_ => fn '_ => raise Fail \"fp64'_add'_with'_flags\")"
      and (OCaml) "!(fun '_ '_ '_ -> failwith \"fp64'_add'_with'_flag\")"
      and (Haskell) "!(\\ '_ '_ '_ -> error \"fp64'_add'_with'_flag\")"
  | constant "fp64_compare" \<rightharpoonup>
      (SML) "!(fn '_ => fn '_ => raise Fail \"fp64'_compare\")"
      and (OCaml) "!(fun '_ '_ -> failwith \"fp64'_compare\")"
      and (Haskell) "!(\\ '_ '_ -> error \"fp64'_compare\")"
  | constant "fp64_div" \<rightharpoonup>
      (SML) "!(fn '_ => fn '_ => fn '_ => raise Fail \"fp64'_div\")"
      and (OCaml) "!(fun '_ '_ '_ -> failwith \"fp64'_div\")"
      and (Haskell) "!(\\ '_ '_ '_ -> error \"fp64'_div\")"
  | constant "fp64_div_with_flags" \<rightharpoonup>
      (SML) "!(fn '_ => fn '_ => fn '_ => raise Fail \"fp64'_div'_with'_flags\")"
      and (OCaml) "!(fun '_ '_ '_ -> failwith \"fp64'_div'_with'_flag\")"
      and (Haskell) "!(\\ '_ '_ '_ -> error \"fp64'_div'_with'_flag\")"
  | constant "fp64_equal" \<rightharpoonup>
      (SML) "!(fn '_ => fn '_ => raise Fail \"fp64'_equal\")"
      and (OCaml) "!(fun '_ '_ -> failwith \"fp64'_equal\")"
      and (Haskell) "!(\\ '_ '_ -> error \"fp64'_equal\")"
  | constant "fp64_from_int" \<rightharpoonup>
      (SML) "!(fn '_ => fn '_ => raise Fail \"fp64'_from'_int\")"
      and (OCaml) "!(fun '_ '_ -> failwith \"fp64'_from'_int\")"
      and (Haskell) "!(\\ '_ '_ -> error \"fp64'_from'_int\")"
  | constant "fp64_greater" \<rightharpoonup>
      (SML) "!(fn '_ => fn '_ => raise Fail \"fp64'_greater\")"
      and (OCaml) "!(fun '_ '_ -> failwith \"fp64'_greater\")"
      and (Haskell) "!(\\ '_ '_ -> error \"fp64'_greater\")"
  | constant "fp64_greater_equal" \<rightharpoonup>
      (SML) "!(fn '_ => fn '_ => raise Fail \"fp64'_greater'_equal\")"
      and (OCaml) "!(fun '_ '_ -> failwith \"fp64'_greater'_equal\")"
      and (Haskell) "!(\\ '_ '_ -> error \"fp64'_greater'_equal\")"
  | constant "fp64_is_integral" \<rightharpoonup>
      (SML) "!(fn '_ => raise Fail \"fp64'_is'_integral\")"
      and (OCaml) "!(fun '_ -> failwith \"fp64'_is'_integral\")"
      and (Haskell) "!(\\ '_ -> error \"fp64'_is'_intagral\")"
  | constant "fp64_is_finite" \<rightharpoonup>
      (SML) "!(fn '_ => raise Fail \"fp64'_is'_finite\")"
      and (OCaml) "!(fun '_ -> failwith \"fp64'_is'_finite\")"
      and (Haskell) "!(\\ '_ -> error \"fp64'_is'_finite\")"
  | constant "fp64_is_nan" \<rightharpoonup>
      (SML) "!(fn '_ => raise Fail \"fp64'_is'_nan\")"
      and (OCaml) "!(fun '_ -> failwith \"fp64'_is'_nan\")"
      and (Haskell) "!(\\ '_ -> error \"fp64'_is'_nan\")"
  | constant "fp64_is_normal" \<rightharpoonup>
      (SML) "!(fn '_ => raise Fail \"fp64'_is'_normal\")"
      and (OCaml) "!(fun '_ -> failwith \"fp64'_is'_normal\")"
      and (Haskell) "!(\\ '_ -> error \"fp64'_is'_normal\")"
  | constant "fp64_is_signalling_nan" \<rightharpoonup>
      (SML) "!(fn '_ => raise Fail \"fp64'_is'_signalling'_nan\")"
      and (OCaml) "!(fun '_ -> failwith \"fp64'_is'_signalling'_nan\")"
      and (Haskell) "!(\\ '_ -> error \"fp64'_is'_signalling'_nan\")"
  | constant "fp64_is_subnormal" \<rightharpoonup>
      (SML) "!(fn '_ => raise Fail \"fp64'_is'_subnormal\")"
      and (OCaml) "!(fun '_ -> failwith \"fp64'_is'_subnormal\")"
      and (Haskell) "!(\\ '_ -> error \"fp64'_is'_subnormal\")"
  | constant "fp64_less" \<rightharpoonup>
      (SML) "!(fn '_ => fn '_ => raise Fail \"fp64'_less\")"
      and (OCaml) "!(fun '_ '_ -> failwith \"fp64'_less\")"
      and (Haskell) "!(\\ '_ '_ -> error \"fp64'_less\")"
  | constant "fp64_less_equal" \<rightharpoonup>
      (SML) "!(fn '_ => fn '_ => raise Fail \"fp64'_less'_equal\")"
      and (OCaml) "!(fun '_ '_ -> failwith \"fp64'_less'_equal\")"
      and (Haskell) "!(\\ '_ '_ -> error \"fp64'_less'_equal\")"
  | constant "fp64_mul" \<rightharpoonup>
      (SML) "!(fn '_ => fn '_ => fn '_ => raise Fail \"fp64'_mul\")"
      and (OCaml) "!(fun '_ '_ '_ -> failwith \"fp64'_mul\")"
      and (Haskell) "!(\\ '_ '_ '_ -> error \"fp64'_mul\")"
  | constant "fp64_mul_with_flags" \<rightharpoonup>
      (SML) "!(fn '_ => fn '_ => fn '_ => raise Fail \"fp64'_mul'_with'_flags\")"
      and (OCaml) "!(fun '_ '_ '_ -> failwith \"fp64'_mul'_with'_flag\")"
      and (Haskell) "!(\\ '_ '_ '_ -> error \"fp64'_mul'_with'_flag\")"
  | constant "fp64_mul_add" \<rightharpoonup>
      (SML) "!(fn '_ => fn '_ => fn '_ => fn '_ => raise Fail \"fp64'_mul'_add\")"
      and (OCaml) "!(fun '_ '_ '_ '_ -> failwith \"fp64'_mul'_add\")"
      and (Haskell) "!(\\ '_ '_ '_ '_ -> error \"fp64'_mul'_add\")"
  | constant "fp64_mul_add_with_flags" \<rightharpoonup>
      (SML) "!(fn '_ => fn '_ => fn '_ => raise Fail \"fp64'_mul'_add'_with'_flags\")"
      and (OCaml) "!(fun '_ '_ '_ -> failwith \"fp64'_mul'_add'_with'_flag\")"
      and (Haskell) "!(\\ '_ '_ '_ -> error \"fp64'_mul'_add'_with'_flag\")"
  | constant "fp64_mul_sub" \<rightharpoonup>
      (SML) "!(fn '_ => fn '_ => fn '_ => fn '_ => raise Fail \"fp64'_mul'_sub\")"
      and (OCaml) "!(fun '_ '_ '_ '_ -> failwith \"fp64'_mul'_sub\")"
      and (Haskell) "!(\\ '_ '_ '_ '_ -> error \"fp64'_mul'_sub\")"
  | constant "fp64_mul_sub_with_flags" \<rightharpoonup>
      (SML) "!(fn '_ => fn '_ => fn '_ => raise Fail \"fp64'_sub'_add'_with'_flags\")"
      and (OCaml) "!(fun '_ '_ '_ -> failwith \"fp64'_mul'_sub'_with'_flag\")"
      and (Haskell) "!(\\ '_ '_ '_ -> error \"fp64'_mul'_sub'_with'_flag\")"
  | constant "fp64_neg_inf" \<rightharpoonup>
      (SML) "!(raise Fail \"fp64'_neg'_inf\")"
      and (OCaml) "!(failwith \"fp64'_neg'_inf\")"
      and (Haskell) "!(error \"fp64'_neg'_inf\")"
  | constant "fp64_neg_min" \<rightharpoonup>
      (SML) "!(raise Fail \"fp64'_neg'_min\")"
      and (OCaml) "!(failwith \"fp64'_neg'_min\")"
      and (Haskell) "!(error \"fp64'_neg'_min\")"
  | constant "fp64_neg_max" \<rightharpoonup>
      (SML) "!(raise Fail \"fp64'_neg'_max\")"
      and (OCaml) "!(failwith \"fp64'_neg'_max\")"
      and (Haskell) "!(error \"fp64'_neg'_max\")"
  | constant "fp64_neg_zero" \<rightharpoonup>
      (SML) "!(raise Fail \"fp64'_neg'_zero\")"
      and (OCaml) "!(failwith \"fp64'_neg'_zero\")"
      and (Haskell) "!(error \"fp64'_neg'_zero\")"
  | constant "fp64_negate" \<rightharpoonup>
      (SML) "!(fn '_ => raise Fail \"fp64'_negate\")"
      and (OCaml) "!(fun '_ -> failwith \"fp64'_negate\")"
      and (Haskell) "!(\\ '_ -> error \"fp64'_negate\")"
  | constant "fp64_pos_inf" \<rightharpoonup>
      (SML) "!(raise Fail \"fp64'_pos'_inf\")"
      and (OCaml) "!(failwith \"fp64'_pos'_inf\")"
      and (Haskell) "!(error \"fp64'_pos'_inf\")"
  | constant "fp64_pos_min" \<rightharpoonup>
      (SML) "!(raise Fail \"fp64'_pos'_min\")"
      and (OCaml) "!(failwith \"fp64'_pos'_min\")"
      and (Haskell) "!(error \"fp64'_pos'_min\")"
  | constant "fp64_pos_max" \<rightharpoonup>
      (SML) "!(raise Fail \"fp64'_pos'_max\")"
      and (OCaml) "!(failwith \"fp64'_pos'_max\")"
      and (Haskell) "!(error \"fp64'_pos'_max\")"
  | constant "fp64_pos_zero" \<rightharpoonup>
      (SML) "!(raise Fail \"fp64'_pos'_zero\")"
      and (OCaml) "!(failwith \"fp64'_pos'_zero\")"
      and (Haskell) "!(error \"fp64'_pos'_zero\")"
  | constant "fp64_snan" \<rightharpoonup>
      (SML) "!(raise Fail \"fp64'_snan\")"
      and (OCaml) "!(failwith \"fp64'_snan\")"
      and (Haskell) "!(error \"fp64'_snan\")"
  | constant "fp64_round_to_integral" \<rightharpoonup>
      (SML) "!(fn '_ => fn '_ => raise Fail \"fp64'_round'_to'_integral\")"
      and (OCaml) "!(fun '_ '_ -> failwith \"fp64'_round'_to'_integral\")"
      and (Haskell) "!(\\ '_ '_ -> error \"fp64'_to'_integral\")"
  | constant "fp64_sqrt" \<rightharpoonup>
      (SML) "!(fn '_ => fn '_ => raise Fail \"fp64'_sqrt\")"
      and (OCaml) "!(fun '_ '_ -> failwith \"fp64'_sqrt\")"
      and (Haskell) "!(\\ '_ '_ -> error \"fp64'_sqrt\")"
  | constant "fp64_sqrt_with_flags" \<rightharpoonup>
      (SML) "!(fn '_ => fn '_ => fn '_ => raise Fail \"fp64'_sqrt'_with'_flags\")"
      and (OCaml) "!(fun '_ '_ '_ -> failwith \"fp64'_sqrt'_with'_flag\")"
      and (Haskell) "!(\\ '_ '_ '_ -> error \"fp64'_sqrt'_with'_flag\")"
  | constant "fp64_qnan" \<rightharpoonup>
      (SML) "!(raise Fail \"fp64'_qnan\")"
      and (OCaml) "!(failwith \"fp64'_qnan\")"
      and (Haskell) "!(error \"fp64'_qnan\")"
  | constant "fp64_sub" \<rightharpoonup>
      (SML) "!(fn '_ => fn '_ => fn '_ => raise Fail \"fp64'_sub\")"
      and (OCaml) "!(fun '_ '_ '_ -> failwith \"fp64'_sub\")"
      and (Haskell) "!(\\ '_ '_ '_ -> error \"fp64'_sub\")"
  | constant "fp64_sub_with_flags" \<rightharpoonup>
      (SML) "!(fn '_ => fn '_ => fn '_ => raise Fail \"fp64'_sub'_with'_flags\")"
      and (OCaml) "!(fun '_ '_ '_ -> failwith \"fp64'_sub'_with'_flag\")"
      and (Haskell) "!(\\ '_ '_ '_ -> error \"fp64'_sub'_with'_flag\")"
  | constant "fp64_to_int" \<rightharpoonup>
      (SML) "!(fn '_ => fn '_ => raise Fail \"fp64'_to'_int\")"
      and (OCaml) "!(fun '_ '_ -> failwith \"fp64'_to'_int\")"
      and (Haskell) "!(\\ '_ '_ -> error \"fp64'_to'_int\")"
  | constant "fp32_to_fp64" \<rightharpoonup>
      (SML) "!(fn '_ => raise Fail \"fp32'_to'_fp64\")"
      and (OCaml) "!(fun '_ -> failwith \"fp32'_to'_fp64\")"
      and (Haskell) "!(\\ '_ -> error \"fp32'_to'_fp64\")"
  | constant "fp64_to_fp32" \<rightharpoonup>
      (SML) "!(fn '_ => fn '_ => raise Fail \"fp64'_to'_fp32\")"
      and (OCaml) "!(fun '_ '_ -> failwith \"fp64'_to'_fp32\")"
      and (Haskell) "!(\\ '_ '_ -> error \"fp64'_to'_fp32\")"

end


theory WTBreak
  imports PermEnvMisc
begin

    (* - define the notion of "environment completion" *)

definition complete_use_env where
  "complete_use_env r_x r_s = (\<lambda> x. if r_x x = NoPerm then NoPerm else r_s x)"

lemma self_compl_leq_use_env: "leq_use_env (complete_use_env r_x r_s) r_s"
  apply (simp add: leq_use_env_def)
  apply (simp add: complete_use_env_def)
  apply (auto)
  apply (case_tac "r_s x")
    apply (auto)
  done

lemma compl_leq_use_env: "\<lbrakk> leq_use_env r_x r_s \<rbrakk> \<Longrightarrow> leq_use_env (complete_use_env r_ex r_x) r_s"
  apply (rule_tac r_sb="r_x" in trans_leq_use_env)
   apply (simp)
  apply (rule_tac self_compl_leq_use_env)
  done

lemma dist_compl_leq_use_env: "\<lbrakk> leq_use_env r_x r_s \<rbrakk> \<Longrightarrow> leq_use_env (complete_use_env r_x r_ex) (complete_use_env r_s r_ex)"
  apply (simp add: leq_use_env_def)
  apply (simp add: complete_use_env_def)
  apply (auto)
   apply (erule_tac x="x" in allE)
   apply (case_tac "r_x x")
     apply (auto)
  apply (case_tac "r_ex x")
    apply (auto)
  done

lemma diff_compl_leq_use_env: "\<lbrakk> leq_use_env r_x (diff_use_env r_s r_ex) \<rbrakk> \<Longrightarrow> leq_use_env (complete_use_env r_x r_s) (diff_use_env r_s r_ex)"
  apply (simp add: diff_use_env_def)
  apply (simp add: minus_use_env_def)
  apply (simp add: neg_use_env_def)
  apply (simp add: complete_use_env_def)
  apply (simp add: leq_use_env_def)
  apply (auto)
  apply (erule_tac x="x" in allE)
  apply (case_tac "r_s x")
    apply (auto)
   apply (case_tac "r_x x")
     apply (auto)
   apply (case_tac "r_ex x")
     apply (auto)
  apply (case_tac "r_x x")
    apply (auto)
  apply (case_tac "r_ex x")
    apply (auto)
  done

lemma spec_compl_leq_use_env: "\<lbrakk> leq_use_env r_x (diff_use_env r_s r_ex) \<rbrakk> \<Longrightarrow> leq_use_env (complete_use_env r_x r_c) (diff_use_env (complete_use_env r_s r_c) r_ex)"
  apply (simp add: diff_use_env_def)
  apply (simp add: minus_use_env_def)
  apply (simp add: neg_use_env_def)
  apply (simp add: complete_use_env_def)
  apply (simp add: leq_use_env_def)
  apply (auto)
   apply (erule_tac x="x" in allE)
   apply (case_tac "r_x x")
     apply (auto)
   apply (erule_tac x="x" in allE)
  apply (case_tac "r_ex x")
    apply (auto)
    apply (case_tac "r_c x")
      apply (auto)
   apply (case_tac "r_c x")
     apply (auto)
  apply (case_tac "r_x x")
    apply (auto)
   apply (case_tac "r_s x")
     apply (auto)
  apply (case_tac "r_s x")
    apply (auto)
  done

lemma rhs_self_compl_leq_use_env: "\<lbrakk> leq_use_env r_x r_s \<rbrakk> \<Longrightarrow> leq_use_env r_x (complete_use_env r_x r_s)"
  apply (simp add: leq_use_env_def)
  apply (simp add: complete_use_env_def)
  done

lemma rhs_compl_leq_use_env: "\<lbrakk> leq_use_env r_x r_s; leq_use_env r_s r_ex \<rbrakk> \<Longrightarrow> leq_use_env r_x (complete_use_env r_s r_ex)"
  apply (rule_tac r_sb="r_s" in trans_leq_use_env)
   apply (rule_tac rhs_self_compl_leq_use_env)
   apply (auto)
  done

lemma sub_complete_use_env: "\<lbrakk> leq_use_env r_x r_s \<rbrakk> \<Longrightarrow> complete_use_env r_x (complete_use_env r_s r_c) = complete_use_env r_x r_c"
  apply (case_tac "\<forall> x. complete_use_env r_x (complete_use_env r_s r_c) x = complete_use_env r_x r_c x")
   apply (auto)
  apply (simp add: leq_use_env_def)
  apply (simp add: complete_use_env_def)
  apply (erule_tac x="x" in allE)
  apply (case_tac "r_x x")
    apply (auto)
   apply (case_tac "r_s x")
     apply (auto)
  apply (case_tac "r_s x")
    apply (auto)
  done

lemma dist_comp_compl_use_env: "complete_use_env (comp_use_env r_x r_s) r_c = comp_use_env (complete_use_env r_x r_c) (complete_use_env r_s r_c)"
  apply (case_tac "\<forall> x. complete_use_env (comp_use_env r_x r_s) r_c x = comp_use_env (complete_use_env r_x r_c) (complete_use_env r_s r_c) x")
   apply (auto)
  apply (simp add: comp_use_env_def)
  apply (simp add: complete_use_env_def)
  apply (case_tac "r_s x")
    apply (auto)
    apply (case_tac "r_x x")
      apply (auto)
     apply (case_tac "r_c x")
       apply (auto)
    apply (case_tac "r_c x")
      apply (auto)
   apply (case_tac "r_x x")
     apply (auto)
     apply (case_tac "r_c x")
       apply (auto)
    apply (case_tac "r_c x")
      apply (auto)
   apply (case_tac "r_c x")
     apply (auto)
  apply (case_tac "r_x x")
    apply (auto)
    apply (case_tac "r_c x")
      apply (auto)
   apply (case_tac "r_c x")
     apply (auto)
  apply (case_tac "r_c x")
    apply (auto)
  done

definition strong_use_env where
  "strong_use_env r_s = (\<forall> x. r_s x \<noteq> UsePerm)"

  (* the issue is that if r_s contains a use, then there is no way to remove it using r_ex, if it is not present in r_x
    in practice, this is describing if the original permissions had a use, but the end permissions + reqs do not have one.
  *)

lemma ex_complete_use_env: "\<lbrakk> leq_use_env r_x r_s \<rbrakk> \<Longrightarrow> (\<exists> r_ex. strong_use_env r_ex \<and> complete_use_env r_x r_s = diff_use_env r_s r_ex)"
  apply (rule_tac x="\<lambda> x. if r_s x \<noteq> NoPerm \<and> r_x x = NoPerm then OwnPerm else NoPerm" in exI)
  apply (auto)
   apply (simp add: strong_use_env_def)
  apply (case_tac "\<forall> x. complete_use_env r_x r_s x = diff_use_env r_s (\<lambda>x. if r_s x \<noteq> NoPerm \<and> r_x x = NoPerm then OwnPerm else NoPerm) x")
   apply (auto)
  apply (simp add: leq_use_env_def)
  apply (simp add: complete_use_env_def)
  apply (simp add: diff_use_env_def)
  apply (simp add: minus_use_env_def)
  apply (simp add: neg_use_env_def)
  apply (erule_tac x="x" in allE)
  apply (case_tac "r_x x")
    apply (auto)
    apply (case_tac "r_s x")
      apply (auto)
   apply (case_tac "r_s x")
     apply (auto)
  apply (case_tac "r_s x")
    apply (auto)
  done

end


(*<*)
theory MFOTL
  imports Interval Trace Abstract_Monitor
begin
(*>*)

section \<open>Metric first-order temporal logic\<close>

context begin

subsection \<open>Formulas and satisfiability\<close>

qualified type_synonym name = string
qualified type_synonym 'a event = "name \<times> 'a list"
qualified type_synonym 'a database = "'a event set"
qualified type_synonym 'a prefix = "'a database prefix"
qualified type_synonym 'a trace = "'a database trace"

qualified type_synonym 'a env = "'a list"

qualified datatype 'a trm = Var nat | is_Const: Const 'a

qualified primrec fvi_trm :: "nat \<Rightarrow> 'a trm \<Rightarrow> nat set" where
  "fvi_trm b (Var x) = (if b \<le> x then {x - b} else {})"
| "fvi_trm b (Const _) = {}"

abbreviation "fv_trm \<equiv> fvi_trm 0"

qualified primrec eval_trm :: "'a env \<Rightarrow> 'a trm \<Rightarrow> 'a" where
  "eval_trm v (Var x) = v ! x"
| "eval_trm v (Const x) = x"

lemma eval_trm_cong: "\<forall>x\<in>fv_trm t. v ! x = v' ! x \<Longrightarrow> eval_trm v t = eval_trm v' t"
  by (cases t) simp_all

qualified datatype (discs_sels) 'a formula = Pred name "'a trm list" | Eq "'a trm" "'a trm"
  | Neg "'a formula" | Or "'a formula" "'a formula" | Exists "'a formula"
  | Prev \<I> "'a formula" | Next \<I> "'a formula"
  | Since "'a formula" \<I> "'a formula" | Until "'a formula" \<I> "'a formula"

qualified primrec fvi :: "nat \<Rightarrow> 'a formula \<Rightarrow> nat set" where
  "fvi b (Pred r ts) = (\<Union>t\<in>set ts. fvi_trm b t)"
| "fvi b (Eq t1 t2) = fvi_trm b t1 \<union> fvi_trm b t2"
| "fvi b (Neg \<phi>) = fvi b \<phi>"
| "fvi b (Or \<phi> \<psi>) = fvi b \<phi> \<union> fvi b \<psi>"
| "fvi b (Exists \<phi>) = fvi (Suc b) \<phi>"
| "fvi b (Prev I \<phi>) = fvi b \<phi>"
| "fvi b (Next I \<phi>) = fvi b \<phi>"
| "fvi b (Since \<phi> I \<psi>) = fvi b \<phi> \<union> fvi b \<psi>"
| "fvi b (Until \<phi> I \<psi>) = fvi b \<phi> \<union> fvi b \<psi>"

abbreviation "fv \<equiv> fvi 0"

lemma finite_fvi_trm[simp]: "finite (fvi_trm b t)"
  by (cases t) simp_all

lemma finite_fvi[simp]: "finite (fvi b \<phi>)"
  by (induction \<phi> arbitrary: b) simp_all

lemma fvi_trm_Suc: "x \<in> fvi_trm (Suc b) t \<longleftrightarrow> Suc x \<in> fvi_trm b t"
  by (cases t) auto

lemma fvi_Suc: "x \<in> fvi (Suc b) \<phi> \<longleftrightarrow> Suc x \<in> fvi b \<phi>"
  by (induction \<phi> arbitrary: b) (simp_all add: fvi_trm_Suc)

lemma fvi_Suc_bound:
  assumes "\<forall>i\<in>fvi (Suc b) \<phi>. i < n"
  shows "\<forall>i\<in>fvi b \<phi>. i < Suc n"
proof
  fix i
  assume "i \<in> fvi b \<phi>"
  with assms show "i < Suc n" by (cases i) (simp_all add: fvi_Suc)
qed

qualified definition nfv :: "'a formula \<Rightarrow> nat" where
  "nfv \<phi> = Max (insert 0 (Suc ` fv \<phi>))"

qualified definition envs :: "'a formula \<Rightarrow> 'a env set" where
  "envs \<phi> = {v. length v = nfv \<phi>}"

lemma nfv_simps[simp]:
  "nfv (Neg \<phi>) = nfv \<phi>"
  "nfv (Or \<phi> \<psi>) = max (nfv \<phi>) (nfv \<psi>)"
  "nfv (Prev I \<phi>) = nfv \<phi>"
  "nfv (Next I \<phi>) = nfv \<phi>"
  "nfv (Since \<phi> I \<psi>) = max (nfv \<phi>) (nfv \<psi>)"
  "nfv (Until \<phi> I \<psi>) = max (nfv \<phi>) (nfv \<psi>)"
  unfolding nfv_def by (simp_all add: image_Un Max_Un[symmetric])

lemma fvi_less_nfv: "\<forall>i\<in>fv \<phi>. i < nfv \<phi>"
  unfolding nfv_def
  by (auto simp add: Max_gr_iff intro: max.strict_coboundedI2)

qualified primrec future_bounded :: "'a formula \<Rightarrow> bool" where
  "future_bounded (Pred _ _) = True"
| "future_bounded (Eq _ _) = True"
| "future_bounded (Neg \<phi>) = future_bounded \<phi>"
| "future_bounded (Or \<phi> \<psi>) = (future_bounded \<phi> \<and> future_bounded \<psi>)"
| "future_bounded (Exists \<phi>) = future_bounded \<phi>"
| "future_bounded (Prev I \<phi>) = future_bounded \<phi>"
| "future_bounded (Next I \<phi>) = future_bounded \<phi>"
| "future_bounded (Since \<phi> I \<psi>) = (future_bounded \<phi> \<and> future_bounded \<psi>)"
| "future_bounded (Until \<phi> I \<psi>) = (future_bounded \<phi> \<and> future_bounded \<psi> \<and> bounded I)"

qualified primrec sat :: "'a trace \<Rightarrow> 'a env \<Rightarrow> nat \<Rightarrow> 'a formula \<Rightarrow> bool" where
  "sat \<sigma> v i (Pred r ts) = ((r, map (eval_trm v) ts) \<in> \<Gamma> \<sigma> i)"
| "sat \<sigma> v i (Eq t1 t2) = (eval_trm v t1 = eval_trm v t2)"
| "sat \<sigma> v i (Neg \<phi>) = (\<not> sat \<sigma> v i \<phi>)"
| "sat \<sigma> v i (Or \<phi> \<psi>) = (sat \<sigma> v i \<phi> \<or> sat \<sigma> v i \<psi>)"
| "sat \<sigma> v i (Exists \<phi>) = (\<exists>z. sat \<sigma> (z # v) i \<phi>)"
| "sat \<sigma> v i (Prev I \<phi>) = (case i of 0 \<Rightarrow> False | Suc j \<Rightarrow> mem I (\<tau> \<sigma> i - \<tau> \<sigma> j) \<and> sat \<sigma> v j \<phi>)"
| "sat \<sigma> v i (Next I \<phi>) = (mem I (\<tau> \<sigma> (Suc i) - \<tau> \<sigma> i) \<and> sat \<sigma> v (Suc i) \<phi>)"
| "sat \<sigma> v i (Since \<phi> I \<psi>) = (\<exists>j\<le>i. mem I (\<tau> \<sigma> i - \<tau> \<sigma> j) \<and> sat \<sigma> v j \<psi> \<and> (\<forall>k \<in> {j <.. i}. sat \<sigma> v k \<phi>))"
| "sat \<sigma> v i (Until \<phi> I \<psi>) = (\<exists>j\<ge>i. mem I (\<tau> \<sigma> j - \<tau> \<sigma> i) \<and> sat \<sigma> v j \<psi> \<and> (\<forall>k \<in> {i ..< j}. sat \<sigma> v k \<phi>))"

lemma sat_Until_rec: "sat \<sigma> v i (Until \<phi> I \<psi>) \<longleftrightarrow>
  (memL I 0 \<and> sat \<sigma> v i \<psi> \<or>
  memR I (\<Delta> \<sigma> (i + 1)) \<and> sat \<sigma> v i \<phi> \<and> sat \<sigma> v (i + 1) (Until \<phi> (subtract (\<Delta> \<sigma> (i + 1)) I) \<psi>))"
  (is "?L \<longleftrightarrow> ?R")
proof (rule iffI; (elim disjE conjE)?)
  assume ?L
  then obtain j where j: "i \<le> j" "mem I (\<tau> \<sigma> j - \<tau> \<sigma> i)" "sat \<sigma> v j \<psi>" "\<forall>k \<in> {i ..< j}. sat \<sigma> v k \<phi>"
    by auto
  then show ?R
  proof (cases "i = j")
    case False
    with j(1,2) have "memR I (\<Delta> \<sigma> (i + 1))"
      by (auto simp: diff_le_mono)
    moreover from False j(1,4) have "sat \<sigma> v i \<phi>" by auto
    moreover from False j have "sat \<sigma> v (i + 1) (Until \<phi> (subtract (\<Delta> \<sigma> (i + 1)) I) \<psi>)"
      by (auto intro!: exI[of _ j])
    ultimately show ?thesis by blast
  qed simp
next
  assume \<Delta>: "memR I (\<Delta> \<sigma> (i + 1))" and now: "sat \<sigma> v i \<phi>" and
   "next": "sat \<sigma> v (i + 1) (Until \<phi> (subtract (\<Delta> \<sigma> (i + 1)) I) \<psi>)"
  from "next" obtain j where j: "i + 1 \<le> j" "mem ((subtract (\<Delta> \<sigma> (i + 1)) I)) (\<tau> \<sigma> j - \<tau> \<sigma> (i + 1))"
      "sat \<sigma> v j \<psi>" "\<forall>k \<in> {i + 1 ..< j}. sat \<sigma> v k \<phi>"
    by (auto simp: diff_le_mono memL_mono)
  from \<Delta> j(1,2) have "mem I (\<tau> \<sigma> j - \<tau> \<sigma> i)"
    by auto
  with now j(1,3,4) show ?L by (auto simp: le_eq_less_or_eq[of i] intro!: exI[of _ j])
qed auto

lemma sat_Since_rec: "sat \<sigma> v i (Since \<phi> I \<psi>) \<longleftrightarrow>
  memL I 0 \<and> sat \<sigma> v i \<psi> \<or>
  (i > 0 \<and> memR I (\<Delta> \<sigma> i) \<and> sat \<sigma> v i \<phi> \<and> sat \<sigma> v (i - 1) (Since \<phi> (subtract (\<Delta> \<sigma> i) I) \<psi>))"
  (is "?L \<longleftrightarrow> ?R")
proof (rule iffI; (elim disjE conjE)?)
  assume ?L
  then obtain j where j: "j \<le> i" "mem I (\<tau> \<sigma> i - \<tau> \<sigma> j)" "sat \<sigma> v j \<psi>" "\<forall>k \<in> {j <.. i}. sat \<sigma> v k \<phi>"
    by auto
  then show ?R
  proof (cases "i = j")
    case False
    with j(1) obtain k where [simp]: "i = k + 1"
      by (cases i) auto
    with j(1,2) False have "memR I (\<Delta> \<sigma> i)"
      by (auto simp: diff_le_mono2)
    moreover from False j(1,4) have "sat \<sigma> v i \<phi>" by auto
    moreover from False j have "sat \<sigma> v (i - 1) (Since \<phi> (subtract (\<Delta> \<sigma> i) I) \<psi>)"
      by (auto intro!: exI[of _ j])
    ultimately show ?thesis by auto
  qed simp
next
  assume i: "0 < i" and \<Delta>: "memR I (\<Delta> \<sigma> i)" and now: "sat \<sigma> v i \<phi>" and
   "prev": "sat \<sigma> v (i - 1) (Since \<phi> (subtract (\<Delta> \<sigma> i) I) \<psi>)"
  from "prev" obtain j where j: "j \<le> i - 1" "mem ((subtract (\<Delta> \<sigma> i) I)) (\<tau> \<sigma> (i - 1) - \<tau> \<sigma> j)"
      "sat \<sigma> v j \<psi>" "\<forall>k \<in> {j <.. i - 1}. sat \<sigma> v k \<phi>"
    by (auto simp: diff_le_mono2 memL_mono)
  from \<Delta> i j(1,2) have "mem I (\<tau> \<sigma> i - \<tau> \<sigma> j)"
    by auto
  with now i j(1,3,4) show ?L by (auto simp: le_Suc_eq gr0_conv_Suc intro!: exI[of _ j])
qed auto

lemma sat_Since_0: "sat \<sigma> v 0 (Since \<phi> I \<psi>) \<longleftrightarrow> memL I 0 \<and> sat \<sigma> v 0 \<psi>"
  by auto

lemma sat_Since_point: "sat \<sigma> v i (Since \<phi> I \<psi>) \<Longrightarrow>
    (\<And>j. j \<le> i \<Longrightarrow> mem I (\<tau> \<sigma> i - \<tau> \<sigma> j) \<Longrightarrow> sat \<sigma> v i (Since \<phi> (point (\<tau> \<sigma> i - \<tau> \<sigma> j)) \<psi>) \<Longrightarrow> P) \<Longrightarrow> P"
  by (auto intro: diff_le_self)

lemma sat_Since_pointD: "sat \<sigma> v i (Since \<phi> (point t) \<psi>) \<Longrightarrow> mem I t \<Longrightarrow> sat \<sigma> v i (Since \<phi> I \<psi>)"
  by auto

lemma eval_trm_fvi_cong: "\<forall>x\<in>fv_trm t. v!x = v'!x \<Longrightarrow> eval_trm v t = eval_trm v' t"
  by (cases t) simp_all

lemma sat_fvi_cong: "\<forall>x\<in>fv \<phi>. v!x = v'!x \<Longrightarrow> sat \<sigma> v i \<phi> = sat \<sigma> v' i \<phi>"
proof (induct \<phi> arbitrary: v v' i)
  case (Pred n ts)
  show ?case by (simp cong: map_cong eval_trm_fvi_cong[OF Pred[simplified, THEN bspec]])
next
  case (Eq x1 x2)
  then show ?case  unfolding fvi.simps sat.simps by (metis UnCI eval_trm_fvi_cong)
next
  case (Exists \<phi>)
  then show ?case unfolding sat.simps by (intro iff_exI) (simp add: fvi_Suc nth_Cons')
qed (auto 8 0 simp add: nth_Cons' split: nat.splits intro!: iff_exI)

subsection \<open>Defined connectives\<close>

qualified definition "And \<phi> \<psi> = Neg (Or (Neg \<phi>) (Neg \<psi>))"

lemma fvi_And: "fvi b (And \<phi> \<psi>) = fvi b \<phi> \<union> fvi b \<psi>"
  unfolding And_def by simp

lemma nfv_And[simp]: "nfv (And \<phi> \<psi>) = max (nfv \<phi>) (nfv \<psi>)"
  unfolding nfv_def by (simp add: fvi_And image_Un Max_Un[symmetric])

lemma future_reach_And: "future_bounded (And \<phi> \<psi>) = (future_bounded \<phi> \<and> future_bounded \<psi>)"
  unfolding And_def by simp

lemma sat_And: "sat \<sigma> v i (And \<phi> \<psi>) = (sat \<sigma> v i \<phi> \<and> sat \<sigma> v i \<psi>)"
  unfolding And_def by simp

qualified definition "And_Not \<phi> \<psi> = Neg (Or (Neg \<phi>) \<psi>)"

lemma fvi_And_Not: "fvi b (And_Not \<phi> \<psi>) = fvi b \<phi> \<union> fvi b \<psi>"
  unfolding And_Not_def by simp

lemma nfv_And_Not[simp]: "nfv (And_Not \<phi> \<psi>) = max (nfv \<phi>) (nfv \<psi>)"
  unfolding nfv_def by (simp add: fvi_And_Not image_Un Max_Un[symmetric])

lemma future_reach_And_Not: "future_bounded (And_Not \<phi> \<psi>) = (future_bounded \<phi> \<and> future_bounded \<psi>)"
  unfolding And_Not_def by simp

lemma sat_And_Not: "sat \<sigma> v i (And_Not \<phi> \<psi>) = (sat \<sigma> v i \<phi> \<and> \<not> sat \<sigma> v i \<psi>)"
  unfolding And_Not_def by simp

subsection \<open>Safe formulas\<close>

fun safe_formula :: "'a MFOTL.formula \<Rightarrow> bool" where
  "safe_formula (MFOTL.Eq t1 t2) = (MFOTL.is_Const t1 \<or> MFOTL.is_Const t2)"
| "safe_formula (MFOTL.Neg (MFOTL.Eq (MFOTL.Const x) (MFOTL.Const y))) = True"
| "safe_formula (MFOTL.Neg (MFOTL.Eq (MFOTL.Var x) (MFOTL.Var y))) = (x = y)"
| "safe_formula (MFOTL.Pred e ts) = True"
| "safe_formula (MFOTL.Neg (MFOTL.Or (MFOTL.Neg \<phi>) \<psi>)) = (safe_formula \<phi> \<and>
    (safe_formula \<psi> \<and> MFOTL.fv \<psi> \<subseteq> MFOTL.fv \<phi> \<or> (case \<psi> of MFOTL.Neg \<psi>' \<Rightarrow> safe_formula \<psi>' | _ \<Rightarrow> False)))"
| "safe_formula (MFOTL.Or \<phi> \<psi>) = (MFOTL.fv \<psi> = MFOTL.fv \<phi> \<and> safe_formula \<phi> \<and> safe_formula \<psi>)"
| "safe_formula (MFOTL.Exists \<phi>) = (safe_formula \<phi>)"
| "safe_formula (MFOTL.Prev I \<phi>) = (safe_formula \<phi>)"
| "safe_formula (MFOTL.Next I \<phi>) = (safe_formula \<phi>)"
| "safe_formula (MFOTL.Since \<phi> I \<psi>) = (MFOTL.fv \<phi> \<subseteq> MFOTL.fv \<psi> \<and>
    (safe_formula \<phi> \<or> (case \<phi> of MFOTL.Neg \<phi>' \<Rightarrow> safe_formula \<phi>' | _ \<Rightarrow> False)) \<and> safe_formula \<psi>)"
| "safe_formula (MFOTL.Until \<phi> I \<psi>) = (MFOTL.fv \<phi> \<subseteq> MFOTL.fv \<psi> \<and>
    (safe_formula \<phi> \<or> (case \<phi> of MFOTL.Neg \<phi>' \<Rightarrow> safe_formula \<phi>' | _ \<Rightarrow> False)) \<and> safe_formula \<psi>)"
| "safe_formula _ = False"

lemma safe_formula_induct[consumes 1]:
  assumes "safe_formula \<phi>"
    and "\<And>t1 t2. MFOTL.is_Const t1 \<Longrightarrow> P (MFOTL.Eq t1 t2)"
    and "\<And>t1 t2. MFOTL.is_Const t2 \<Longrightarrow> P (MFOTL.Eq t1 t2)"
    and "\<And>x y. P (MFOTL.Neg (MFOTL.Eq (MFOTL.Const x) (MFOTL.Const y)))"
    and "\<And>x y. x = y \<Longrightarrow> P (MFOTL.Neg (MFOTL.Eq (MFOTL.Var x) (MFOTL.Var y)))"
    and "\<And>e ts. P (MFOTL.Pred e ts)"
    and "\<And>\<phi> \<psi>. \<not> (safe_formula (MFOTL.Neg \<psi>) \<and> MFOTL.fv \<psi> \<subseteq> MFOTL.fv \<phi>) \<Longrightarrow> P \<phi> \<Longrightarrow> P \<psi> \<Longrightarrow> P (MFOTL.And \<phi> \<psi>)"
    and "\<And>\<phi> \<psi>. safe_formula \<psi> \<Longrightarrow> MFOTL.fv \<psi> \<subseteq> MFOTL.fv \<phi> \<Longrightarrow> P \<phi> \<Longrightarrow> P \<psi> \<Longrightarrow> P (MFOTL.And_Not \<phi> \<psi>)"
    and "\<And>\<phi> \<psi>. MFOTL.fv \<psi> = MFOTL.fv \<phi> \<Longrightarrow> P \<phi> \<Longrightarrow> P \<psi> \<Longrightarrow> P (MFOTL.Or \<phi> \<psi>)"
    and "\<And>\<phi>. P \<phi> \<Longrightarrow> P (MFOTL.Exists \<phi>)"
    and "\<And>I \<phi>. P \<phi> \<Longrightarrow> P (MFOTL.Prev I \<phi>)"
    and "\<And>I \<phi>. P \<phi> \<Longrightarrow> P (MFOTL.Next I \<phi>)"
    and "\<And>\<phi> I \<psi>. MFOTL.fv \<phi> \<subseteq> MFOTL.fv \<psi> \<Longrightarrow> safe_formula \<phi> \<Longrightarrow> P \<phi> \<Longrightarrow> P \<psi> \<Longrightarrow> P (MFOTL.Since \<phi> I \<psi>)"
    and "\<And>\<phi> I \<psi>. MFOTL.fv (MFOTL.Neg \<phi>) \<subseteq> MFOTL.fv \<psi> \<Longrightarrow>
      \<not> safe_formula (MFOTL.Neg \<phi>) \<Longrightarrow> P \<phi> \<Longrightarrow> P \<psi> \<Longrightarrow> P (MFOTL.Since (MFOTL.Neg \<phi>) I \<psi> )"
    and "\<And>\<phi> I \<psi>. MFOTL.fv \<phi> \<subseteq> MFOTL.fv \<psi> \<Longrightarrow> safe_formula \<phi> \<Longrightarrow> P \<phi> \<Longrightarrow> P \<psi> \<Longrightarrow> P (MFOTL.Until \<phi> I \<psi>)"
    and "\<And>\<phi> I \<psi>. MFOTL.fv (MFOTL.Neg \<phi>) \<subseteq> MFOTL.fv \<psi> \<Longrightarrow>
      \<not> safe_formula (MFOTL.Neg \<phi>) \<Longrightarrow> P \<phi> \<Longrightarrow> P \<psi> \<Longrightarrow> P (MFOTL.Until (MFOTL.Neg \<phi>) I \<psi>)"
  shows "P \<phi>"
  using assms(1)
proof (induction rule: safe_formula.induct)
  case (5 \<phi> \<psi>)
  then show ?case
    by (cases \<psi>)
      (auto 0 3 elim!: disjE_Not2 intro: assms[unfolded MFOTL.And_def MFOTL.And_Not_def])
next
  case (10 \<phi> I \<psi>)
  then show ?case
    by (cases \<phi>) (auto 0 3 elim!: disjE_Not2 intro: assms)
next
  case (11 \<phi> I \<psi>)
  then show ?case
    by (cases \<phi>) (auto 0 3 elim!: disjE_Not2 intro: assms)
qed (auto intro: assms)

subsection \<open>Slicing traces\<close>

qualified primrec matches :: "'a env \<Rightarrow> 'a formula \<Rightarrow> name \<times> 'a list \<Rightarrow> bool" where
  "matches v (Pred r ts) e = (r = fst e \<and> map (eval_trm v) ts = snd e)"
| "matches v (Eq _ _) e = False"
| "matches v (Neg \<phi>) e = matches v \<phi> e"
| "matches v (Or \<phi> \<psi>) e = (matches v \<phi> e \<or> matches v \<psi> e)"
| "matches v (Exists \<phi>) e = (\<exists>z. matches (z # v) \<phi> e)"
| "matches v (Prev I \<phi>) e = matches v \<phi> e"
| "matches v (Next I \<phi>) e = matches v \<phi> e"
| "matches v (Since \<phi> I \<psi>) e = (matches v \<phi> e \<or> matches v \<psi> e)"
| "matches v (Until \<phi> I \<psi>) e = (matches v \<phi> e \<or> matches v \<psi> e)"

lemma matches_fvi_cong: "\<forall>x\<in>fv \<phi>. v!x = v'!x \<Longrightarrow> matches v \<phi> e = matches v' \<phi> e"
proof (induct \<phi> arbitrary: v v')
  case (Pred n ts)
  show ?case by (simp cong: map_cong eval_trm_fvi_cong[OF Pred[simplified, THEN bspec]])
next
  case (Exists \<phi>)
  then show ?case unfolding matches.simps by (intro iff_exI) (simp add: fvi_Suc nth_Cons')
qed (auto 5 0 simp add: nth_Cons')

abbreviation relevant_events where "relevant_events \<phi> S \<equiv> {e. S \<inter> {v. matches v \<phi> e} \<noteq> {}}"

end (*context*)

interpretation MFOTL_slicer: abstract_slicer "relevant_events \<phi>" for \<phi> .

lemma sat_slice_iff:
  assumes "v \<in> S"
  shows "MFOTL.sat \<sigma> v i \<phi> \<longleftrightarrow> MFOTL.sat (MFOTL_slicer.slice \<phi> S \<sigma>) v i \<phi>"
  by (rule sat_slice_strong[of S, OF subset_refl assms])

lemma slice_replace_prefix:
  "prefix_of (MFOTL_slicer.pslice \<phi> R \<pi>) \<sigma> \<Longrightarrow>
    MFOTL_slicer.slice \<phi> R (replace_prefix \<pi> \<sigma>) = MFOTL_slicer.slice \<phi> R \<sigma>"
  by (rule map_\<Gamma>_replace_prefix) auto

(*<*)
end
(*>*)


theory MonoHelper
  imports
    Cogent.Mono
    ValueSemHelper
begin

section "Renaming and Monomorphisation Helpers"

context value_sem begin

lemma no_vfuns_rename_val:
  "no_vfuns x \<longleftrightarrow> no_vfuns (rename_val rename' x)"
  apply (induct x; clarsimp)
  apply (clarsimp simp: find_None_iff)
  done

lemma no_vfuns_rename_monoval:
  "no_vfuns v \<Longrightarrow> rename_val rename (monoval v) = v"
  apply (induct v; clarsimp split: if_splits)
  apply (clarsimp simp: list_eq_iff_nth_eq find_None_iff_nth)
  done

lemma rename_monoval_no_vfuns:
  "no_vfuns (rename_val rename' (monoval v)) \<Longrightarrow> no_vfuns v"
  apply (induct v; clarsimp split: if_splits simp: find_None_iff_nth)
  done
end (* context *)

end


(* Author: Alexander Maletzky *)

section \<open>Sample Computations of Reduced Gr\"obner Bases\<close>

theory Reduced_GB_Examples
  imports Buchberger Reduced_GB Polynomials.MPoly_Type_Class_OAlist Code_Target_Rat
begin

context gd_term
begin

definition rgb :: "('t \<Rightarrow>\<^sub>0 'b) list \<Rightarrow> ('t \<Rightarrow>\<^sub>0 'b::field) list"
  where "rgb bs = comp_red_monic_basis (map fst (gb (map (\<lambda>b. (b, ())) bs) ()))"

definition rgb_punit :: "('a \<Rightarrow>\<^sub>0 'b) list \<Rightarrow> ('a \<Rightarrow>\<^sub>0 'b::field) list"
  where "rgb_punit bs = punit.comp_red_monic_basis (map fst (gb_punit (map (\<lambda>b. (b, ())) bs) ()))"

lemma compute_trd_aux [code]:
  "trd_aux fs p r =
    (if is_zero p then
      r
    else
      case find_adds fs (lt p) of
        None   \<Rightarrow> trd_aux fs (tail p) (plus_monomial_less r (lc p) (lt p))
      | Some f \<Rightarrow> trd_aux fs (tail p - monom_mult (lc p / lc f) (lp p - lp f) (tail f)) r
    )"
  by (simp only: trd_aux.simps[of fs p r] plus_monomial_less_def is_zero_def)

end

text \<open>We only consider scalar polynomials here, but vector-polynomials could be handled, too.\<close>

global_interpretation punit': gd_powerprod "ord_pp_punit cmp_term" "ord_pp_strict_punit cmp_term"
  rewrites "punit.adds_term = (adds)"
  and "punit.pp_of_term = (\<lambda>x. x)"
  and "punit.component_of_term = (\<lambda>_. ())"
  and "punit.monom_mult = monom_mult_punit"
  and "punit.mult_scalar = mult_scalar_punit"
  and "punit'.punit.min_term = min_term_punit"
  and "punit'.punit.lt = lt_punit cmp_term"
  and "punit'.punit.lc = lc_punit cmp_term"
  and "punit'.punit.tail = tail_punit cmp_term"
  and "punit'.punit.ord_p = ord_p_punit cmp_term"
  and "punit'.punit.ord_strict_p = ord_strict_p_punit cmp_term"
  for cmp_term :: "('a::nat, 'b::{nat,add_wellorder}) pp nat_term_order"

  defines find_adds_punit = punit'.punit.find_adds
  and trd_aux_punit = punit'.punit.trd_aux
  and trd_punit = punit'.punit.trd
  and spoly_punit = punit'.punit.spoly
  and count_const_lt_components_punit = punit'.punit.count_const_lt_components
  and count_rem_components_punit = punit'.punit.count_rem_components
  and const_lt_component_punit = punit'.punit.const_lt_component
  and full_gb_punit = punit'.punit.full_gb
  and add_pairs_single_sorted_punit = punit'.punit.add_pairs_single_sorted
  and add_pairs_punit = punit'.punit.add_pairs
  and canon_pair_order_aux_punit = punit'.punit.canon_pair_order_aux
  and canon_basis_order_punit = punit'.punit.canon_basis_order
  and new_pairs_sorted_punit = punit'.punit.new_pairs_sorted
  and product_crit_punit = punit'.punit.product_crit
  and chain_ncrit_punit = punit'.punit.chain_ncrit
  and chain_ocrit_punit = punit'.punit.chain_ocrit
  and apply_icrit_punit = punit'.punit.apply_icrit
  and apply_ncrit_punit = punit'.punit.apply_ncrit
  and apply_ocrit_punit = punit'.punit.apply_ocrit
  and trdsp_punit = punit'.punit.trdsp
  and gb_sel_punit = punit'.punit.gb_sel
  and gb_red_aux_punit = punit'.punit.gb_red_aux
  and gb_red_punit = punit'.punit.gb_red
  and gb_aux_punit = punit'.punit.gb_aux_punit
  and gb_punit = punit'.punit.gb_punit \<comment>\<open>Faster, because incorporates product criterion.\<close>
  and comp_min_basis_punit = punit'.punit.comp_min_basis
  and comp_red_basis_aux_punit = punit'.punit.comp_red_basis_aux
  and comp_red_basis_punit = punit'.punit.comp_red_basis
  and monic_punit = punit'.punit.monic
  and comp_red_monic_basis_punit = punit'.punit.comp_red_monic_basis
  and rgb_punit = punit'.punit.rgb_punit
  subgoal by (fact gd_powerprod_ord_pp_punit)
  subgoal by (fact punit_adds_term)
  subgoal by (simp add: id_def)
  subgoal by (fact punit_component_of_term)
  subgoal by (simp only: monom_mult_punit_def)
  subgoal by (simp only: mult_scalar_punit_def)
  subgoal using min_term_punit_def by fastforce
  subgoal by (simp only: lt_punit_def ord_pp_punit_alt)
  subgoal by (simp only: lc_punit_def ord_pp_punit_alt)
  subgoal by (simp only: tail_punit_def ord_pp_punit_alt)
  subgoal by (simp only: ord_p_punit_def ord_pp_strict_punit_alt)
  subgoal by (simp only: ord_strict_p_punit_def ord_pp_strict_punit_alt)
  done

lemma compute_spoly_punit [code]:
  "spoly_punit to p q = (let t1 = lt_punit to p; t2 = lt_punit to q; l = lcs t1 t2 in
         (monom_mult_punit (1 / lc_punit to p) (l - t1) p) - (monom_mult_punit (1 / lc_punit to q) (l - t2) q))"
  by (simp add: punit'.punit.spoly_def Let_def punit'.punit.lc_def)

lemma compute_trd_punit [code]: "trd_punit to fs p = trd_aux_punit to fs p (change_ord to 0)"
  by (simp only: punit'.punit.trd_def change_ord_def)

experiment begin interpretation trivariate\<^sub>0_rat .

lemma
  "rgb_punit DRLEX
    [
     X ^ 3 - X * Y * Z\<^sup>2,
     Y\<^sup>2 * Z - 1
    ] =
    [
     X ^ 3 * Y - X * Z,
     - (X ^ 3) + X * Y * Z\<^sup>2,
     Y\<^sup>2 * Z - 1,
     - (X * Z ^ 3) + X ^ 5
    ]"
  by eval

lemma
  "rgb_punit DRLEX
    [
     X\<^sup>2 + Y\<^sup>2 + Z\<^sup>2 - 1,
     X * Y - Z - 1,
     Y\<^sup>2 + X,
     Z\<^sup>2 + X
    ] =
    [
     1
    ]"
  by eval

text \<open>Note: The above computations have been cross-checked with Mathematica 11.1.\<close>

end

end (* theory *)


theory State_Ops
imports Sep_Generic_Wp
begin

section \<open>Generic State Ops\<close>

datatype ('c, 'r) state_op =
    Read "'c \<Rightarrow> 'r" | Update "'c \<Rightarrow> 'c"
  | Maybe "'r option" | ReadMaybe "'c \<Rightarrow> 'r option" | UpdateMaybe "'c \<Rightarrow> 'c option"
  | ReadUpdate "'c \<Rightarrow> 'c \<times> 'r"

definition "r_dummy \<equiv> undefined"

fun wp_stateop where
  "wp_stateop (Read f) Q s = Q (f s) s"
| "wp_stateop (Update f) Q s = Q r_dummy (f s)"
| "wp_stateop (Maybe opt) Q s = (case opt of Some r \<Rightarrow> Q r s | None \<Rightarrow> False)"
| "wp_stateop (ReadMaybe f) Q s = (case f s of Some r \<Rightarrow> Q r s | None \<Rightarrow> False)"
| "wp_stateop (UpdateMaybe f) Q s = (case f s of Some s' \<Rightarrow> Q r_dummy s' | None \<Rightarrow> False)"
| "wp_stateop (ReadUpdate f) Q s = (case f s of (s', r) \<Rightarrow> Q r s')"

lemma wp_stateopI:
  "\<And>f. Q (f s) s \<Longrightarrow> wp_stateop (Read f) Q s"
  "\<And>f. Q r_dummy (f s) \<Longrightarrow> wp_stateop (Update f) Q s"
  "\<And>opt r. opt = Some r \<Longrightarrow> Q r s \<Longrightarrow> wp_stateop (Maybe opt) Q s"
  "\<And>f r. f s = Some r \<Longrightarrow> Q r s \<Longrightarrow> wp_stateop (ReadMaybe f) Q s"
  "\<And>f s'. f s = Some s' \<Longrightarrow> Q r_dummy s' \<Longrightarrow> wp_stateop (UpdateMaybe f) Q s"
  "\<And>f s' r. f s = (s', r) \<Longrightarrow> Q r s' \<Longrightarrow> wp_stateop (ReadUpdate f) Q s"
  by (auto)

lemma wp_stateopE[elim!]:
  assumes "wp_stateop c Q s"
  obtains
    ("Read") f r where "c = Read f" and "r = f s" and "Q r s"
  | ("Update") f s' where "c = Update f" and "s' = f s" and "Q r_dummy s'"
  | ("Maybe") opt r where "c = Maybe opt" and "opt = Some r" and "Q r s"
  | ("ReadMaybe") f r where "c = ReadMaybe f" and "f s = Some r" and "Q r s"
  | ("UpdateMaybe") f s' where "c = UpdateMaybe f" and "f s = Some s'" and "Q r_dummy s'"
  | ("ReadUpdate") f s' r where "c = ReadUpdate f" and "f s = (s', r)" and "Q r s'"
  apply (rule wp_stateop.elims(2)[OF assms])
  by (auto split: option.splits)

interpretation state_op: generic_wp "\<lambda>_. wp_stateop"
  apply standard
  subgoal for e c Q Q'
    apply (cases c; standard+)
    by (auto split: option.splits)
  done

abbreviation "state_ht \<equiv> state_op.htriple ()"

lemmas state_htI = state_op.htripleI

inductive readonly_op where
  "readonly_op (Read f)" | "readonly_op (Maybe opt)" | "readonly_op (ReadMaybe f)"
declare readonly_op.cases[elim]
declare readonly_op.intros[intro]

inductive_simps [iff]: "readonly_op (Read f)"
inductive_simps [iff]: "readonly_op (Maybe opt)"
inductive_simps [iff]: "readonly_op (ReadMaybe f)"

lemma wp_readonly_op:
  "readonly_op c \<Longrightarrow> wp_stateop c Q s \<longleftrightarrow> wp_stateop c (\<lambda>r _. Q r s) s"
  apply (erule readonly_op.cases)
  by auto

end