Commit c0789d50 authored by Lawrence Paulson's avatar Lawrence Paulson
Browse files

new entry ROBDD

parent 4e2a27a6d0a7
This diff is collapsed.
section\<open>Array List\<close>
text\<open>Most of this has been contributed by Peter Lammich.\<close>
theory Array_List
imports
"../Separation_Logic_Imperative_HOL/Examples/Array_Blit"
begin
text\<open>
This implements a datastructure that efficiently supports two operations: appending an element and looking up the nth element.
The implementation is straightforward.
\<close>
text\<open>
As underlying data structure an array is used.
Since changing the length of an array requires copying, we double the size whenever the array needs to be expanded.
We use a counter for the current length to track which elements are used and which are spares.
\<close>
type_synonym 'a array_list = "'a array \<times> nat"
definition "is_array_list l \<equiv> \<lambda>(a,n). \<exists>\<^sub>Al'. a \<mapsto>\<^sub>a l' * \<up>(n \<le> length l' \<and> l = take n l' \<and> length l'>0)"
definition "initial_capacity \<equiv> 16::nat"
definition "arl_empty \<equiv> do {
a \<leftarrow> Array.new initial_capacity default;
return (a,0)
}"
lemma [sep_heap_rules]: "< emp > arl_empty <is_array_list []>"
by (sep_auto simp: arl_empty_def is_array_list_def initial_capacity_def)
definition "arl_nth \<equiv> \<lambda>(a,n) i. do {
Array.nth a i
}"
lemma [sep_heap_rules]: "i<length l \<Longrightarrow> < is_array_list l a > arl_nth a i <\<lambda>x. is_array_list l a * \<up>(x = l!i) >"
by (sep_auto simp: arl_nth_def is_array_list_def split: prod.splits)
definition "arl_append \<equiv> \<lambda>(a,n) x. do {
len \<leftarrow> Array.len a;
if n<len then do {
a \<leftarrow> Array.upd n x a;
return (a,n+1)
} else do {
let newcap = 2 * len;
a \<leftarrow> array_grow a newcap default;
a \<leftarrow> Array.upd n x a;
return (a,n+1)
}
}"
lemma [sep_heap_rules]: "
< is_array_list l a >
arl_append a x
<\<lambda>a. is_array_list (l@[x]) a >\<^sub>t"
by (sep_auto
simp: arl_append_def is_array_list_def take_update_last neq_Nil_conv
split: prod.splits nat.split)
lemma is_array_list_prec: "precise is_array_list"
unfolding is_array_list_def[abs_def]
apply(rule preciseI)
apply(simp split: prod.splits)
using preciseD snga_prec by fastforce
lemma is_array_list_lengthIA: "is_array_list l li \<Longrightarrow>\<^sub>A \<up>(snd li = length l) * true"
by(sep_auto simp: is_array_list_def split: prod.splits)
find_consts "assn \<Rightarrow> bool"
lemma is_array_list_lengthI: "x \<Turnstile> is_array_list l li \<Longrightarrow> snd li = length l"
using is_array_list_lengthIA by (metis (full_types) ent_pure_post_iff star_aci(2))
end
section\<open>Code export\<close>
theory BDD_Code
imports Level_Collapse
begin
text\<open>For convenience reasons, the code export is in a separate theory. For Haskell, we only have to reactivate the original equation for @{term blit}. Other languages might need an implementation for it.\<close>
lemma [code del]:
"blit src si dst di len
= blit' src (integer_of_nat si) dst (integer_of_nat di)
(integer_of_nat len)" by (simp add: blit'_def)
declare blit_def[code]
export_code open iteci_lu notci andci orci nandci norci biimpci xorci ifci tci fci tautci emptyci graphifyci litci eqci checking Haskell
end
section\<open>Tests and examples\<close>
theory BDD_Examples
imports Level_Collapse
begin
text\<open>Just two simple examples:\<close>
lemma "<emp> do {
s \<leftarrow> emptyci;
(t,s) \<leftarrow> tci s;
tautci t s
} <\<lambda>r. \<up>(r = True)>\<^sub>t"
by sep_auto
lemma "<emp> do {
s \<leftarrow> emptyci;
(a,s) \<leftarrow> litci 0 s;
(b,s) \<leftarrow> litci 1 s;
(c,s) \<leftarrow> litci 2 s;
(t1i,s) \<leftarrow> orci a b s;
(t1,s) \<leftarrow> andci t1i c s;
(t2i1,s) \<leftarrow> andci a c s;
(t2i2,s) \<leftarrow> andci b c s;
(t2,s) \<leftarrow> orci t2i1 t2i2 s;
eqci t1 t2
} <\<up>>\<^sub>t"
by sep_auto
end
\ No newline at end of file
This diff is collapsed.
section\<open>Boolean functions\<close>
theory Bool_Func
imports Main
begin
text\<open>
The end result of our implementation is verified against these functions:
\<close>
type_synonym 'a boolfunc = "('a \<Rightarrow> bool) \<Rightarrow> bool"
text\<open>if-then-else on boolean functions.\<close>
definition "bf_ite i t e \<equiv> (\<lambda>l. if i l then t l else e l)"
text\<open>if-then-else is interesting because we can, together with constant true and false, represent all binary boolean functions using maximally two applications of it.\<close>
abbreviation "bf_True \<equiv> (\<lambda>l. True)"
abbreviation "bf_False \<equiv> (\<lambda>l. False)"
text\<open>A quick demonstration:\<close>
definition "bf_and a b \<equiv> bf_ite a b bf_False"
lemma "(bf_and a b) as \<longleftrightarrow> a as \<and> b as" unfolding bf_and_def bf_ite_def by meson
definition "bf_not b \<equiv> bf_ite b bf_False bf_True"
lemma bf_not_alt: "bf_not a as \<longleftrightarrow> \<not>a as" unfolding bf_not_def bf_ite_def by meson
text\<open>For convenience, we want a few functions more:\<close>
definition "bf_or a b \<equiv> bf_ite a bf_True b"
definition "bf_lit v \<equiv> (\<lambda>l. l v)"
definition "bf_if v t e \<equiv> bf_ite (bf_lit v) t e"
lemma bf_if_alt: "bf_if v t e = (\<lambda>l. if l v then t l else e l)" unfolding bf_if_def bf_ite_def bf_lit_def ..
definition "bf_nand a b = bf_not (bf_and a b)"
definition "bf_nor a b = bf_not (bf_or a b)"
definition "bf_biimp a b = (bf_ite a b (bf_not b))"
lemma bf_biimp_alt: "bf_biimp a b = (\<lambda>l. a l \<longleftrightarrow> b l)" unfolding bf_biimp_def bf_not_def bf_ite_def by(simp add: fun_eq_iff)
definition "bf_xor a b = bf_not (bf_biimp a b)"
lemma bf_xor_alt: "bf_xor a b = (bf_ite a (bf_not b) b)" (* two application version *)
unfolding bf_xor_def bf_biimp_def bf_not_def
unfolding bf_ite_def
by simp
text\<open>All of these are implemented and had their implementation verified.\<close>
definition "bf_imp a b = bf_ite a b bf_True"
lemma bf_imp_alt: "bf_imp a b = bf_or (bf_not a) b" unfolding bf_or_def bf_not_def bf_imp_def unfolding bf_ite_def unfolding fun_eq_iff by simp
lemma [dest!,elim!]: "bf_False = bf_True \<Longrightarrow> False" "bf_True = bf_False \<Longrightarrow> False" unfolding fun_eq_iff by simp_all (* Occurs here and there as goal for sep_auto *)
lemmas [simp] = bf_and_def bf_or_def bf_nand_def bf_biimp_def bf_xor_alt bf_nor_def bf_not_def
subsection\<open>Shannon decomposition\<close>
text\<open>
A restriction of a boolean function on a variable is creating the boolean function that evaluates as if that variable was set to a fixed value:
\<close>
definition "bf_restrict (i::'a) (val::bool) (f::'a boolfunc) \<equiv> (\<lambda>v. f (v(i:=val)))"
text \<open>
Restrictions are useful, because they remove variables from the set of significant variables:
\<close>
definition "bf_vars bf = {v. \<exists>as. bf_restrict v True bf as \<noteq> bf_restrict v False bf as}"
lemma "var \<notin> bf_vars (bf_restrict var val ex)"
unfolding bf_vars_def bf_restrict_def by(simp)
text\<open>
We can decompose calculating if-then-else into computing if-then-else of two triples of functions with one variable restricted to true / false.
Given that the functions have finite arity, we can use this to construct a recursive definition.
\<close>
lemma brace90shannon: "bf_ite F G H ass =
bf_ite (\<lambda>l. l i)
(bf_ite (bf_restrict i True F) (bf_restrict i True G) (bf_restrict i True H))
(bf_ite (bf_restrict i False F) (bf_restrict i False G) (bf_restrict i False H)) ass"
unfolding bf_ite_def bf_restrict_def by (auto simp add: fun_upd_idem)
end
section\<open>Imparative implementation\<close>
theory Conc_Impl
imports Pointer_Map_Impl Middle_Impl
begin
record bddi =
dpmi :: "(nat \<times> nat \<times> nat) pointermap_impl"
dcli :: "((nat \<times> nat \<times> nat),nat) hashtable"
lemma bdd_exhaust: "dpm a = dpm b \<Longrightarrow> dcl a = dcl b \<Longrightarrow> a = (b :: bdd)" by simp
instantiation prod :: (default, default) default
begin
definition "default_prod :: ('a \<times> 'b) \<equiv> (default, default)"
instance ..
end
(* can be found in "~~/src/HOL/Proofs/Extraction/Greatest_Common_Divisor" or "~~/src/HOL/Proofs/Lambda/WeakNorm" *)
instantiation nat :: default
begin
definition "default_nat \<equiv> 0 :: nat"
instance ..
end
definition "is_bdd_impl (bdd::bdd) (bddi::bddi) = is_pointermap_impl (dpm bdd) (dpmi bddi) * is_hashmap (dcl bdd) (dcli bddi)"
lemma is_bdd_impl_prec: "precise is_bdd_impl"
apply(rule preciseI)
apply(unfold is_bdd_impl_def)
apply(clarsimp)
apply(rename_tac a a' x y p F F')
apply(rule bdd_exhaust)
apply(rule_tac p = "dpmi p" and h = "(x,y)" in preciseD[OF is_pointermap_impl_prec])
apply(unfold star_aci(1))
apply blast
apply(rule_tac p = "dcli p" and h = "(x,y)" in preciseD[OF is_hashmap_prec])
apply(unfold star_aci(2)[symmetric])
apply(unfold star_aci(1)[symmetric]) (* black unfold magic *)
apply(unfold star_aci(2)[symmetric])
apply blast
(* This proof is exactly the same as for pointermap. One could make a rule from it. *)
done
definition "emptyci :: bddi Heap \<equiv> do { ep \<leftarrow> pointermap_empty; ehm \<leftarrow> hm_new; return \<lparr>dpmi=ep, dcli=ehm\<rparr> }"
definition "tci bdd \<equiv> return (1::nat,bdd::bddi)"
definition "fci bdd \<equiv> return (0::nat,bdd::bddi)"
definition "ifci v t e bdd \<equiv> (if t = e then return (t, bdd) else do {
(p,u) \<leftarrow> pointermap_getmki (v, t, e) (dpmi bdd);
return (Suc (Suc p), dpmi_update (const u) bdd)
})"
definition destrci :: "nat \<Rightarrow> bddi \<Rightarrow> (nat, nat) IFEXD Heap" where
"destrci n bdd \<equiv> (case n of
0 \<Rightarrow> return FD |
Suc 0 \<Rightarrow> return TD |
Suc (Suc p) \<Rightarrow> pm_pthi (dpmi bdd) p \<bind> (\<lambda>(v,t,e). return (IFD v t e)))"
term "mi.les"
lemma emptyci_rule[sep_heap_rules]: "<emp> emptyci <is_bdd_impl emptymi>\<^sub>t"
by(sep_auto simp: is_bdd_impl_def emptyci_def emptymi_def)
lemma [sep_heap_rules]: "tmi' bdd = Some (p,bdd')
\<Longrightarrow> <is_bdd_impl bdd bddi>
tci bddi
<\<lambda>(pi,bddi'). is_bdd_impl bdd' bddi' * \<up>(pi = p)>"
by (sep_auto simp: tci_def tmi'_def split: Option.bind_splits)
lemma [sep_heap_rules]: "fmi' bdd = Some (p,bdd')
\<Longrightarrow> <is_bdd_impl bdd bddi>
fci bddi
<\<lambda>(pi,bddi'). is_bdd_impl bdd' bddi' * \<up>(pi = p)>"
by(sep_auto simp: fci_def fmi'_def split: Option.bind_splits)
lemma [sep_heap_rules]: "ifmi' v t e bdd = Some (p, bdd') \<Longrightarrow>
<is_bdd_impl bdd bddi> ifci v t e bddi
<\<lambda>(pi,bddi'). is_bdd_impl bdd' bddi' * \<up>(pi = p)>\<^sub>t"
apply(clarsimp simp: is_bdd_impl_def ifmi'_def simp del: ifmi.simps)
by (sep_auto simp: ifci_def apfst_def map_prod_def is_bdd_impl_def bdd_sane_def
split: prod.splits if_splits Option.bind_splits)
lemma destrci_rule[sep_heap_rules]: "
destrmi' n bdd = Some r \<Longrightarrow>
<is_bdd_impl bdd bddi> destrci n bddi
<\<lambda>r'. is_bdd_impl bdd bddi * \<up>(r' = r)>"
unfolding destrmi'_def apply (clarsimp split: Option.bind_splits)
apply(cases "(n, bdd)" rule: destrmi.cases)
by (sep_auto simp: destrci_def bdd_node_valid_def is_bdd_impl_def ifexd_valid_def bdd_sane_def
dest: p_valid_RmiI)+
term mi.restrict_top_impl
thm mi.case_ifexi_def
definition "case_ifexici fti ffi fii ni bddi \<equiv> do {
dest \<leftarrow> destrci ni bddi;
case dest of TD \<Rightarrow> fti | FD \<Rightarrow> ffi | IFD v ti ei \<Rightarrow> fii v ti ei
}"
lemma [sep_decon_rules]:
assumes S: "mi.case_ifexi fti ffi fii ni bdd = Some r"
assumes [sep_heap_rules]:
"destrmi' ni bdd = Some TD \<Longrightarrow> fti bdd = Some r \<Longrightarrow> <is_bdd_impl bdd bddi> ftci <Q>"
"destrmi' ni bdd = Some FD \<Longrightarrow> ffi bdd = Some r \<Longrightarrow> <is_bdd_impl bdd bddi> ffci <Q>"
"\<And>v t e. destrmi' ni bdd = Some (IFD v t e) \<Longrightarrow> fii v t e bdd = Some r
\<Longrightarrow> <is_bdd_impl bdd bddi> fici v t e <Q> "
shows "<is_bdd_impl bdd bddi> case_ifexici ftci ffci fici ni bddi <Q>"
using S unfolding mi.case_ifexi_def apply (clarsimp split: Option.bind_splits IFEXD.splits)
by (sep_auto simp: case_ifexici_def)+
definition "restrict_topci p vr vl bdd =
case_ifexici
(return p)
(return p)
(\<lambda>v te ee. return (if v = vr then (if vl then te else ee) else p))
p bdd"
lemma [sep_heap_rules]:
assumes "mi.restrict_top_impl p var val bdd = Some (r,bdd')"
shows "<is_bdd_impl bdd bddi> restrict_topci p var val bddi
<\<lambda>ri. is_bdd_impl bdd bddi * \<up>(ri = r)>"
using assms unfolding mi.restrict_top_impl_def restrict_topci_def by sep_auto
fun lowest_topsci where
"lowest_topsci [] s = return None" |
"lowest_topsci (e#es) s =
case_ifexici
(lowest_topsci es s)
(lowest_topsci es s)
(\<lambda>v t e. do {
(rec) \<leftarrow> lowest_topsci es s;
(case rec of
Some u \<Rightarrow> return ((Some (min u v))) |
None \<Rightarrow> return ((Some v)))
}) e s"
declare lowest_topsci.simps[simp del]
lemma [sep_heap_rules]:
assumes "mi.lowest_tops_impl es bdd = Some (r,bdd')"
shows "<is_bdd_impl bdd bddi> lowest_topsci es bddi
<\<lambda>(ri). is_bdd_impl bdd bddi * \<up>(ri = r \<and> bdd'=bdd)>"
proof -
note [simp] = lowest_topsci.simps mi.lowest_tops_impl.simps
show ?thesis using assms
apply (induction es arbitrary: bdd r bdd' bddi)
apply (sep_auto)
(* Unfortunately, we have to split on destrmi'-cases manually, else sep-aut introduces schematic before case-split is done *)
apply (clarsimp simp: mi.case_ifexi_def split: Option.bind_splits IFEXD.splits)
apply (sep_auto simp: mi.case_ifexi_def)
apply (sep_auto simp: mi.case_ifexi_def)
apply (sep_auto simp: mi.case_ifexi_def)
done
qed
partial_function(heap) iteci where
"iteci i t e s = do {
(lt) \<leftarrow> lowest_topsci [i, t, e] s;
case lt of
Some a \<Rightarrow> do {
ti \<leftarrow> restrict_topci i a True s;
tt \<leftarrow> restrict_topci t a True s;
te \<leftarrow> restrict_topci e a True s;
fi \<leftarrow> restrict_topci i a False s;
ft \<leftarrow> restrict_topci t a False s;
fe \<leftarrow> restrict_topci e a False s;
(tb,s') \<leftarrow> iteci ti tt te s;
(fb,s'') \<leftarrow> iteci fi ft fe s';
(ifci a tb fb s'')
}
| None \<Rightarrow> do {
case_ifexici (return (t,s)) (return (e,s)) (\<lambda>_ _ _. raise ''Cannot happen'') i s
}
}"
declare iteci.simps[code]
lemma iteci_rule: "
( mi.ite_impl i t e bdd = Some (p,bdd')) \<longrightarrow>
<is_bdd_impl bdd bddi>
iteci i t e bddi
<\<lambda>(pi,bddi'). is_bdd_impl bdd' bddi' * \<up>(pi=p )>\<^sub>t"
apply (induction arbitrary: i t e bddi bdd p bdd' rule: mi.ite_impl.fixp_induct)
subgoal
apply simp (* Warning: Dragons ahead! *)
using option_admissible[where P=
"\<lambda>(((x1,x2),x3),x4) (r1,r2). \<forall>bddi.
<is_bdd_impl x4 bddi>
iteci x1 x2 x3 bddi
<\<lambda>r. case r of (pi, bddi') \<Rightarrow> is_bdd_impl r2 bddi' * \<up> (pi = r1)>\<^sub>t"]
apply auto[1]
apply (fo_rule subst[rotated])
apply (assumption)
by auto
subgoal by simp
subgoal
apply clarify
apply (clarsimp split: option.splits Option.bind_splits prod.splits)
apply (subst iteci.simps)
apply (sep_auto)
apply (subst iteci.simps)
apply (sep_auto)
unfolding imp_to_meta apply rprems
apply simp
apply sep_auto
apply (rule fi_rule)
apply rprems
apply simp
apply frame_inference
by sep_auto
done
declare iteci_rule[THEN mp, sep_heap_rules]
definition param_optci where
"param_optci i t e bdd = do {
(tr, bdd) \<leftarrow> tci bdd;
(fl, bdd) \<leftarrow> fci bdd;
id \<leftarrow> destrci i bdd;
td \<leftarrow> destrci t bdd;
ed \<leftarrow> destrci e bdd;
return (
if id = TD then Some t else
if id = FD then Some e else
if td = TD \<and> ed = FD then Some i else
if t = e then Some t else
if ed = TD \<and> i = t then Some tr else
if td = FD \<and> i = e then Some fl else
None, bdd)
}"
lemma param_optci_rule: "
( mi.param_opt_impl i t e bdd = Some (p,bdd')) \<Longrightarrow>
<is_bdd_impl bdd bddi>
param_optci i t e bddi
<\<lambda>(pi,bddi'). is_bdd_impl bdd' bddi' * \<up>(pi=p)>\<^sub>t"
by (sep_auto simp add: mi.param_opt_impl.simps param_optci_def tmi'_def fmi'_def
split: Option.bind_splits)
lemma bdd_hm_lookup_rule: "
(dcl bdd (i,t,e) = p) \<Longrightarrow>
<is_bdd_impl bdd bddi>
hm_lookup (i, t, e) (dcli bddi)
<\<lambda>(pi). is_bdd_impl bdd bddi * \<up>(pi = p)>\<^sub>t"
unfolding is_bdd_impl_def by (sep_auto)
lemma bdd_hm_update_rule'[sep_heap_rules]:
"<is_bdd_impl bdd bddi>
hm_update k v (dcli bddi)
<\<lambda>r. is_bdd_impl (updS bdd k v) (dcli_update (const r) bddi) * true>"
unfolding is_bdd_impl_def updS_def by (sep_auto)
partial_function(heap) iteci_lu where
"iteci_lu i t e s = do {
lu \<leftarrow> ht_lookup (i,t,e) (dcli s);
(case lu of Some b \<Rightarrow> return (b,s)
| None \<Rightarrow> do {
(po,s) \<leftarrow> param_optci i t e s;
(case po of Some b \<Rightarrow> do {
return (b,s)}
| None \<Rightarrow> do {
(lt) \<leftarrow> lowest_topsci [i, t, e] s;
(case lt of Some a \<Rightarrow> do {
ti \<leftarrow> restrict_topci i a True s;
tt \<leftarrow> restrict_topci t a True s;
te \<leftarrow> restrict_topci e a True s;
fi \<leftarrow> restrict_topci i a False s;
ft \<leftarrow> restrict_topci t a False s;
fe \<leftarrow> restrict_topci e a False s;
(tb,s) \<leftarrow> iteci_lu ti tt te s;
(fb,s) \<leftarrow> iteci_lu fi ft fe s;
(r,s) \<leftarrow> ifci a tb fb s;
cl \<leftarrow> hm_update (i,t,e) r (dcli s);
return (r,dcli_update (const cl) s)
}
| None \<Rightarrow> raise ''Cannot happen'' )})
})}"
term ht_lookup
declare iteci_lu.simps[code]
thm iteci_lu.simps[unfolded restrict_topci_def case_ifexici_def param_optci_def lowest_topsci.simps]
partial_function(heap) iteci_lu_code where "iteci_lu_code i t e s = do {
lu \<leftarrow> hm_lookup (i, t, e) (dcli s);
case lu of None \<Rightarrow> let po = if i = 1 then Some t
else if i = 0 then Some e else if t = 1 \<and> e = 0 then Some i else if t = e then Some t else if e = 1 \<and> i = t then Some 1 else if t = 0 \<and> i = e then Some 0 else None
in case po of None \<Rightarrow> do {
id \<leftarrow> destrci i s;
td \<leftarrow> destrci t s;
ed \<leftarrow> destrci e s;
let a = (case id of IFD v t e \<Rightarrow> v);
let a = (case td of IFD v t e \<Rightarrow> min a v | _ \<Rightarrow> a);
let a = (case ed of IFD v t e \<Rightarrow> min a v | _ \<Rightarrow> a);
let ti = (case id of IFD v ti ei \<Rightarrow> if v = a then ti else i | _ \<Rightarrow> i);
let tt = (case td of IFD v ti ei \<Rightarrow> if v = a then ti else t | _ \<Rightarrow> t);
let te = (case ed of IFD v ti ei \<Rightarrow> if v = a then ti else e | _ \<Rightarrow> e);
let fi = (case id of IFD v ti ei \<Rightarrow> if v = a then ei else i | _ \<Rightarrow> i);
let ft = (case td of IFD v ti ei \<Rightarrow> if v = a then ei else t | _ \<Rightarrow> t);
let fe = (case ed of IFD v ti ei \<Rightarrow> if v = a then ei else e | _ \<Rightarrow> e);
(tb, s) \<leftarrow> iteci_lu_code ti tt te s;
(fb, s) \<leftarrow> iteci_lu_code fi ft fe s;
(r, s) \<leftarrow> ifci a tb fb s;
cl \<leftarrow> hm_update (i, t, e) r (dcli s);
return (r, dcli_update (const cl) s)
}
| Some b \<Rightarrow> return (b, s)
| Some b \<Rightarrow> return (b, s)
}"
declare iteci_lu_code.simps[code]
(* reduced the run-time of our examples by around 30%.
But we would need some efficient automated machinery to show this,
and I'm not even sure how to correctly use induction correctly for this.
Thus: Future work.*)
lemma iteci_lu_code[code_unfold]: "iteci_lu i t e s = iteci_lu_code i t e s"
oops
(* Proof by copy-paste *)
lemma iteci_lu_rule: "
( mi.ite_impl_lu i t e bdd = Some (p,bdd')) \<longrightarrow>
<is_bdd_impl bdd bddi>
iteci_lu i t e bddi
<\<lambda>(pi,bddi'). is_bdd_impl bdd' bddi' * \<up>(pi=p )>\<^sub>t"
apply (induction arbitrary: i t e bddi bdd p bdd' rule: mi.ite_impl_lu.fixp_induct)
subgoal
apply simp (* More Dragons *)
using option_admissible[where P=
"\<lambda>(((x1,x2),x3),x4) (r1,r2). \<forall>bddi.
<is_bdd_impl x4 bddi>
iteci_lu x1 x2 x3 bddi
<\<lambda>r. case r of (pi, bddi') \<Rightarrow> is_bdd_impl r2 bddi' * \<up> (pi = r1)>\<^sub>t"]
apply auto[1]
apply (fo_rule subst[rotated])
apply (assumption)
by auto
subgoal by simp
subgoal
apply clarify
apply (clarsimp split: option.splits Option.bind_splits prod.splits)
subgoal
unfolding updS_def
apply (subst iteci_lu.simps)
apply (sep_auto)
using bdd_hm_lookup_rule apply(blast)
apply(sep_auto)
apply(rule fi_rule)
apply(rule param_optci_rule)
apply(sep_auto)
apply(sep_auto)
apply(sep_auto)
unfolding imp_to_meta
apply(rule fi_rule)
apply(rprems)
apply(simp; fail)
apply(sep_auto)
apply(sep_auto)
apply(rule fi_rule)
apply(rprems)
apply(simp; fail)
apply(sep_auto)
apply(sep_auto)
unfolding updS_def by (sep_auto)
subgoal
apply(subst iteci_lu.simps)
apply(sep_auto)
using bdd_hm_lookup_rule apply(blast)
apply(sep_auto)
apply(rule fi_rule)
apply(rule param_optci_rule)
apply(sep_auto)
apply(sep_auto)
by (sep_auto)
subgoal
apply(subst iteci_lu.simps)
apply(sep_auto)
using bdd_hm_lookup_rule apply(blast)
by(sep_auto)
done
done
subsection\<open>A standard library of functions\<close>
declare iteci_rule[THEN mp, sep_heap_rules]
definition "notci e s \<equiv> do {
(f,s) \<leftarrow> fci s;
(t,s) \<leftarrow> tci s;
iteci_lu e f t s
}"
definition "orci e1 e2 s \<equiv> do {
(t,s) \<leftarrow> tci s;
iteci_lu e1 t e2 s
}"
definition "andci e1 e2 s \<equiv> do {
(f,s) \<leftarrow> fci s;
iteci_lu e1 e2 f s
}"
definition "norci e1 e2 s \<equiv> do {
(r,s) \<leftarrow> orci e1 e2 s;
notci r s
}"
definition "nandci e1 e2 s \<equiv> do {
(r,s) \<leftarrow> andci e1 e2 s;
notci r s
}"
definition "biimpci a b s \<equiv> do {
(nb,s) \<leftarrow> notci b s;
iteci_lu a b nb s
}"
definition "xorci a b s \<equiv> do {
(nb,s) \<leftarrow> notci b s;
iteci_lu a nb b s
}"
definition "litci v bdd \<equiv> do {
(t,bdd) \<leftarrow> tci bdd;
(f,bdd) \<leftarrow> fci bdd;
ifci v t f bdd
}"
definition "tautci v bdd \<equiv> do {
d \<leftarrow> destrci v bdd;
return (d = TD)
}"
subsection\<open>Printing\<close>
text\<open>The following functions are exported unverified. They are intended for BDD debugging purposes.\<close>
partial_function(heap) serializeci :: "nat \<Rightarrow> bddi \<Rightarrow> ((nat \<times> nat) \<times> nat) list Heap" where
"serializeci p s = do {
d \<leftarrow> destrci p s;
(case d of
IFD v t e \<Rightarrow> do {
r \<leftarrow> serializeci t s;
l \<leftarrow> serializeci e s;
return (remdups ([((p,t),1),((p,e),0)] @ r @ l))
} |
_ \<Rightarrow> return []
)
}"
declare serializeci.simps[code]
(* This snaps to heap as a Monad, which is not intended, but irrelevant. *)
fun mapM where
"mapM f [] = return []" |
"mapM f (a#as) = do {
r \<leftarrow> f a;
rs \<leftarrow> mapM f as;
return (r#rs)
}"
definition "liftM f ma = do { a \<leftarrow> ma; return (f a) }"
definition "sequence = mapM id"
term "liftM (map f)"
lemma "liftM (map f) (sequence l) = sequence (map (liftM f) l)"
apply(induction l)
apply(simp add: sequence_def liftM_def)
apply(simp)
oops