src/HOL/Quickcheck_Examples/Hotel_Example.thy
author haftmann
Fri Feb 15 08:31:31 2013 +0100 (2013-02-15)
changeset 51143 0a2371e7ced3
parent 48255 968602739b54
child 51272 9c8d63b4b6be
permissions -rw-r--r--
two target language numeral types: integer and natural, as replacement for code_numeral;
former theory HOL/Library/Code_Numeral_Types replaces HOL/Code_Numeral;
refined stack of theories implementing int and/or nat by target language numerals;
reduced number of target language numeral types to exactly one
     1 theory Hotel_Example
     2 imports Main "~~/src/HOL/Library/Predicate_Compile_Quickcheck"
     3 begin
     4 
     5 datatype guest = Guest0 | Guest1
     6 datatype key = Key0 | Key1 | Key2 | Key3
     7 datatype room = Room0
     8 
     9 type_synonym card = "key * key"
    10 
    11 datatype event =
    12    Check_in guest room card | Enter guest room card | Exit guest room
    13 
    14 definition initk :: "room \<Rightarrow> key"
    15   where "initk = (%r. Key0)"
    16 
    17 declare initk_def[code_pred_def, code]
    18 
    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)"
    26 
    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)"
    34 
    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> {})"
    40 
    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)"
    49 
    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)"
    57 
    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)"
    65 
    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))"
    73 
    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)"
    76 
    77 definition feels_safe :: "event list \<Rightarrow> room \<Rightarrow> bool"
    78 where
    79   "feels_safe s r = (\<exists>s\<^isub>1 s\<^isub>2 s\<^isub>3 g c c'.
    80    s = s\<^isub>3 @ [Enter g r c] @ s\<^isub>2 @ [Check_in g r c'] @ s\<^isub>1 \<and>
    81    no_Check_in (s\<^isub>3 @ s\<^isub>2) r \<and> isin (s\<^isub>2 @ [Check_in g r c] @ s\<^isub>1) r = {})"
    82 
    83 
    84 section {* Some setup *}
    85 
    86 lemma issued_nil: "issued [] = {Key0}"
    87 by (auto simp add: initk_def)
    88 
    89 lemmas issued_simps[code] = issued_nil issued.simps(2)
    90 
    91 
    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 {* Core_Data.force_modes_and_compilations *}
    96 
    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)"
   101 
   102 consts cps_of_set :: "'a set => ('a => term list option) => term list option"
   103 
   104 lemma
   105   [code]: "cps_of_set (set xs) f = find_first f xs"
   106 sorry
   107 
   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"
   110 
   111 lemma
   112   [code]: "pos_cps_of_set (set xs) f i = find_first f xs"
   113 sorry
   114 
   115 consts find_first' :: "('b Quickcheck_Exhaustive.unknown => 'a Quickcheck_Exhaustive.three_valued)
   116     => 'b list => 'a Quickcheck_Exhaustive.three_valued"
   117 
   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
   122 
   123 lemma
   124   [code]: "neg_cps_of_set (set xs) f i = find_first' f xs"
   125 sorry
   126 
   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))))
   143  
   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 *}
   150 
   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
   155 
   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
   160 
   161 section {* Refinement *}
   162 
   163 fun split_list
   164 where
   165   "split_list [] = [([], [])]"
   166 | "split_list (z # zs) = (([], z # zs) # [(z # xs', ys'). (xs', ys') <- split_list zs])"
   167 
   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
   174 
   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
   181 
   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)+
   186 
   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
   192 
   193 end