src/HOL/Quickcheck_Examples/Hotel_Example.thy
 author wenzelm Tue Aug 13 16:25:47 2013 +0200 (2013-08-13) changeset 53015 a1119cf551e8 parent 51272 9c8d63b4b6be child 57544 8840fa17e17c permissions -rw-r--r--
standardized symbols via "isabelle update_sub_sup", excluding src/Pure and src/Tools/WWW_Find;
1 theory Hotel_Example
2 imports Main "~~/src/HOL/Library/Predicate_Compile_Quickcheck"
3 begin
5 datatype guest = Guest0 | Guest1
6 datatype key = Key0 | Key1 | Key2 | Key3
7 datatype room = Room0
9 type_synonym card = "key * key"
11 datatype event =
12    Check_in guest room card | Enter guest room card | Exit guest room
14 definition initk :: "room \<Rightarrow> key"
15   where "initk = (%r. Key0)"
17 declare initk_def[code_pred_def, code]
19 primrec owns :: "event list \<Rightarrow> room \<Rightarrow> guest option"
20 where
21   "owns [] r = None"
22 | "owns (e#s) r = (case e of
23     Check_in g r' c \<Rightarrow> if r' = r then Some g else owns s r |
24     Enter g r' c \<Rightarrow> owns s r |
25     Exit g r' \<Rightarrow> owns s r)"
27 primrec currk :: "event list \<Rightarrow> room \<Rightarrow> key"
28 where
29   "currk [] r = initk r"
30 | "currk (e#s) r = (let k = currk s r in
31     case e of Check_in g r' (k1, k2) \<Rightarrow> if r' = r then k2 else k
32             | Enter g r' c \<Rightarrow> k
33             | Exit g r \<Rightarrow> k)"
35 primrec issued :: "event list \<Rightarrow> key set"
36 where
37   "issued [] = range initk"
38 | "issued (e#s) = issued s \<union>
39   (case e of Check_in g r (k1, k2) \<Rightarrow> {k2} | Enter g r c \<Rightarrow> {} | Exit g r \<Rightarrow> {})"
41 primrec cards :: "event list \<Rightarrow> guest \<Rightarrow> card set"
42 where
43   "cards [] g = {}"
44 | "cards (e#s) g = (let C = cards s g in
45                     case e of Check_in g' r c \<Rightarrow> if g' = g then insert c C
46                                                 else C
47                             | Enter g r c \<Rightarrow> C
48                             | Exit g r \<Rightarrow> C)"
50 primrec roomk :: "event list \<Rightarrow> room \<Rightarrow> key"
51 where
52   "roomk [] r = initk r"
53 | "roomk (e#s) r = (let k = roomk s r in
54     case e of Check_in g r' c \<Rightarrow> k
55             | Enter g r' (x,y) \<Rightarrow> if r' = r (*& x = k*) then y else k
56             | Exit g r \<Rightarrow> k)"
58 primrec isin :: "event list \<Rightarrow> room \<Rightarrow> guest set"
59 where
60   "isin [] r = {}"
61 | "isin (e#s) r = (let G = isin s r in
62                  case e of Check_in g r c \<Rightarrow> G
63                  | Enter g r' c \<Rightarrow> if r' = r then {g} \<union> G else G
64                  | Exit g r' \<Rightarrow> if r'=r then G - {g} else G)"
66 primrec hotel :: "event list \<Rightarrow> bool"
67 where
68   "hotel []  = True"
69 | "hotel (e # s) = (hotel s & (case e of
70   Check_in g r (k,k') \<Rightarrow> k = currk s r \<and> k' \<notin> issued s |
71   Enter g r (k,k') \<Rightarrow> (k,k') : cards s g & (roomk s r : {k, k'}) |
72   Exit g r \<Rightarrow> g : isin s r))"
74 definition no_Check_in :: "event list \<Rightarrow> room \<Rightarrow> bool" where(*>*)
75 [code del]: "no_Check_in s r \<equiv> \<not>(\<exists>g c. Check_in g r c \<in> set s)"
77 definition feels_safe :: "event list \<Rightarrow> room \<Rightarrow> bool"
78 where
79   "feels_safe s r = (\<exists>s\<^sub>1 s\<^sub>2 s\<^sub>3 g c c'.
80    s = s\<^sub>3 @ [Enter g r c] @ s\<^sub>2 @ [Check_in g r c'] @ s\<^sub>1 \<and>
81    no_Check_in (s\<^sub>3 @ s\<^sub>2) r \<and> isin (s\<^sub>2 @ [Check_in g r c] @ s\<^sub>1) r = {})"
84 section {* Some setup *}
86 lemma issued_nil: "issued [] = {Key0}"
87 by (auto simp add: initk_def)
89 lemmas issued_simps[code] = issued_nil issued.simps(2)
92 setup {*  Predicate_Compile_Data.ignore_consts [@{const_name Set.member},
93   @{const_name "issued"}, @{const_name "cards"}, @{const_name "isin"},
94   @{const_name Collect}, @{const_name insert}] *}
95 ML_val {* Core_Data.force_modes_and_compilations *}
97 fun find_first :: "('a => 'b option) => 'a list => 'b option"
98 where
99   "find_first f [] = None"
100 | "find_first f (x # xs) = (case f x of Some y => Some y | None => find_first f xs)"
102 consts cps_of_set :: "'a set => ('a => term list option) => term list option"
104 lemma
105   [code]: "cps_of_set (set xs) f = find_first f xs"
106 sorry
108 consts pos_cps_of_set :: "'a set => ('a => (bool * term list) option) => natural => (bool * term list) option"
109 consts neg_cps_of_set :: "'a set => ('a Quickcheck_Exhaustive.unknown => term list Quickcheck_Exhaustive.three_valued) => natural => term list Quickcheck_Exhaustive.three_valued"
111 lemma
112   [code]: "pos_cps_of_set (set xs) f i = find_first f xs"
113 sorry
115 consts find_first' :: "('b Quickcheck_Exhaustive.unknown => 'a Quickcheck_Exhaustive.three_valued)
116     => 'b list => 'a Quickcheck_Exhaustive.three_valued"
118 lemma [code]:
119   "find_first' f [] = Quickcheck_Exhaustive.No_value"
120   "find_first' f (x # xs) = (case f (Quickcheck_Exhaustive.Known x) of Quickcheck_Exhaustive.No_value => find_first' f xs | Quickcheck_Exhaustive.Value x => Quickcheck_Exhaustive.Value x | Quickcheck_Exhaustive.Unknown_value => (case find_first' f xs of Quickcheck_Exhaustive.Value x => Quickcheck_Exhaustive.Value x | _ => Quickcheck_Exhaustive.Unknown_value))"
121 sorry
123 lemma
124   [code]: "neg_cps_of_set (set xs) f i = find_first' f xs"
125 sorry
127 setup {*
128 let
129   val Fun = Predicate_Compile_Aux.Fun
130   val Input = Predicate_Compile_Aux.Input
131   val Output = Predicate_Compile_Aux.Output
132   val Bool = Predicate_Compile_Aux.Bool
133   val oi = Fun (Output, Fun (Input, Bool))
134   val ii = Fun (Input, Fun (Input, Bool))
135   fun of_set compfuns (Type ("fun", [T, _])) =
136     case body_type (Predicate_Compile_Aux.mk_monadT compfuns T) of
137       Type ("Quickcheck_Exhaustive.three_valued", _) =>
138         Const(@{const_name neg_cps_of_set}, HOLogic.mk_setT T --> (Predicate_Compile_Aux.mk_monadT compfuns T))
139     | _ => Const(@{const_name pos_cps_of_set}, HOLogic.mk_setT T --> (Predicate_Compile_Aux.mk_monadT compfuns T))
140   fun member compfuns (U as Type ("fun", [T, _])) =
141     (absdummy T (absdummy (HOLogic.mk_setT T) (Predicate_Compile_Aux.mk_if compfuns
142       (Const (@{const_name "Set.member"}, T --> HOLogic.mk_setT T --> @{typ bool}) \$ Bound 1 \$ Bound 0))))
144 in
145   Core_Data.force_modes_and_compilations @{const_name Set.member}
146     [(oi, (of_set, false)), (ii, (member, false))]
147 end
148 *}
149 section {* Property *}
151 lemma "\<lbrakk> hotel s; g \<in> isin s r \<rbrakk> \<Longrightarrow> owns s r = Some g"
152 quickcheck[tester = exhaustive, size = 6, expect = counterexample]
153 quickcheck[tester = smart_exhaustive, depth = 6, expect = counterexample]
154 oops
156 lemma
157   "hotel s ==> feels_safe s r ==> g \<in> isin s r ==> owns s r = Some g"
158 quickcheck[smart_exhaustive, depth = 10, allow_function_inversion, expect = counterexample]
159 oops
161 section {* Refinement *}
163 fun split_list
164 where
165   "split_list [] = [([], [])]"
166 | "split_list (z # zs) = (([], z # zs) # [(z # xs', ys'). (xs', ys') <- split_list zs])"
168 lemma split_list: "((xs, ys) \<in> set (split_list zs)) = (zs = xs @ ys)"
169 apply (induct zs arbitrary: xs ys)
170 apply fastforce
171 apply (case_tac xs)
172 apply auto
173 done
175 lemma [code]: "no_Check_in s r = list_all (%x. case x of Check_in g r' c => r \<noteq> r' | _ => True) s"
176 unfolding no_Check_in_def list_all_iff
177 apply auto
178 apply (case_tac x)
179 apply auto
180 done
182 lemma [code]: "feels_safe s r = list_ex (%(s3, s2, s1, g, c, c'). no_Check_in (s3 @ s2) r &
183     isin (s2 @ [Check_in g r c] @ s1) r = {}) ([(s3, s2, s1, g, c, c'). (s3, Enter g' r' c # r3) <- split_list s, r' = r, (s2, Check_in g r'' c' # s1) <- split_list r3, r'' = r, g = g'])"
184 unfolding feels_safe_def list_ex_iff
185 by auto (metis split_list)+
187 lemma
188   "hotel s ==> feels_safe s r ==> g \<in> isin s r ==> owns s r = Some g"
189 (* quickcheck[exhaustive, size = 9, timeout = 2000] -- maybe possible with a lot of time *)
190 quickcheck[narrowing, size = 7, expect = counterexample]
191 oops
193 end