1structure utilsLib :> utilsLib = 2struct 3 4open HolKernel boolLib bossLib 5open state_transformerTheory 6open wordsLib integer_wordLib bitstringLib 7 8val ERR = Feedback.mk_HOL_ERR "utilsLib" 9val WARN = Feedback.HOL_WARNING "utilsLib" 10 11structure Parse = 12struct 13 open Parse 14 val (Type,Term) = parse_from_grammars wordsTheory.words_grammars 15end 16open Parse 17 18(* ------------------------------------------------------------------------- *) 19 20fun cache size cmp f = 21 let 22 val d = ref (Redblackmap.mkDict cmp) 23 val k = ref [] 24 val finite = 0 < size 25 in 26 fn v => 27 case Redblackmap.peek (!d, v) of 28 SOME r => r 29 | NONE => 30 let 31 val r = f v 32 in 33 if finite 34 then (k := !k @ [v] 35 ; if size < Redblackmap.numItems (!d) 36 then case List.getItem (!k) of 37 SOME (h, t) => 38 (d := fst (Redblackmap.remove (!d, h)) 39 ; k := t) 40 | NONE => raise ERR "cache" "empty" 41 else ()) 42 else () 43 ; d := Redblackmap.insert (!d, v, r) 44 ; r 45 end 46 end 47 48(* ------------------------------------------------------------------------- *) 49 50fun partitions [] = [] 51 | partitions [x] = [[[x]]] 52 | partitions (h::t) = 53 let 54 val ps = partitions t 55 in 56 List.concat 57 (List.map 58 (fn p => 59 List.tabulate 60 (List.length p, 61 fn i => 62 Lib.mapi (fn j => fn l => 63 if i = j then h :: l else l) p)) ps) @ 64 List.map (fn l => [h] :: l) ps 65 end 66 67fun classes eq = 68 let 69 fun add x = 70 let 71 fun iter a = 72 fn [] => [x] :: a 73 | h :: t => if eq (x, hd h) 74 then a @ ((x :: h) :: t) 75 else iter (h :: a) t 76 in 77 iter [] 78 end 79 fun iter a = 80 fn [] => a 81 | h :: t => iter (add h a) t 82 in 83 iter [] 84 end 85 86(* ------------------------------------------------------------------------- *) 87 88local 89 fun loop a = 90 fn [] => a 91 | r => (case Lib.total (Lib.split_after 8) r of 92 SOME (x, y) => loop (x :: a) y 93 | NONE => r :: a) 94in 95 fun rev_endian l = List.concat (loop [] l) 96end 97 98(* ------------------------------------------------------------------------- *) 99 100local 101 fun find_pos P = 102 let 103 fun iter n [] = n 104 | iter n (h::t) = if P h then n else iter (n + 1) t 105 in 106 iter 0 107 end 108in 109 fun process_option P g s d l f = 110 let 111 val (l, r) = List.partition P l 112 val positions = Lib.mk_set (List.map g l) 113 val result = 114 if List.null positions 115 then d 116 else if List.length positions = 1 117 then f (hd positions) 118 else raise ERR "process_option" ("More than one " ^ s ^ " option.") 119 in 120 (result, r) 121 end 122 fun process_opt opt = process_option (Lib.C Lib.mem (List.concat opt)) 123 (fn option => find_pos (Lib.mem option) opt) 124end 125 126fun print_options bk name l = 127 let 128 val s = " * " ^ name ^ " options:" 129 val s = case bk of SOME w => StringCvt.padRight #" " w s | _ => s ^ "\n\t" 130 in 131 TextIO.print (s ^ String.concat (Lib.commafy (List.map hd l)) ^ "\n") 132 end 133 134(* ------------------------------------------------------------------------- *) 135 136fun maximal (cmp: 'a cmp) f = 137 let 138 fun max_acc (best as (left, vm, m, right)) l = 139 fn [] => (m, List.revAppend (left, right)) 140 | h :: t => 141 let 142 val vh = f h 143 val best' = case cmp (vh, vm) of 144 General.GREATER => (l, vh, h, t) 145 | _ => best 146 in 147 max_acc best' (h :: l) t 148 end 149 in 150 fn [] => raise ERR "maximal" "empty" 151 | h :: t => max_acc ([], f h, h, t) [h] t 152 end 153 154fun minimal cmp = maximal (Lib.flip_cmp cmp) 155 156(* ------------------------------------------------------------------------- *) 157 158fun padLeft c n l = List.tabulate (n - List.length l, fn _ => c) @ l 159(* fun padRight c n l = l @ List.tabulate (n - List.length l, fn _ => c) *) 160 161fun pick [] l2 = (WARN "pick" "not picking"; l2) 162 | pick l1 l2 = 163 let 164 val l = Lib.zip l1 l2 165 in 166 List.mapPartial (fn (a, b) => if a then SOME b else NONE) l 167 end 168 169type cover = {redex: term frag list, residue: term} list list 170 171fun augment (v, l1) l2 = 172 List.concat (List.map (fn x => List.map (fn c => ((v |-> x) :: c)) l2) l1) 173 174fun zipLists f = 175 let 176 fun loop a l = 177 if List.null (hd l) then List.map f (List.rev a) 178 else loop (List.map List.hd l::a) (List.map List.tl l) 179 in 180 loop [] 181 end 182 183fun list_mk_wordii w = List.map (fn i => wordsSyntax.mk_wordii (i, w)) 184 185fun tab_fixedwidth m w = 186 List.tabulate 187 (m, fn n => bitstringSyntax.padded_fixedwidth_of_num (Arbnum.fromInt n, w)) 188 189local 190 fun liftSplit f = (Substring.string ## Substring.string) o f o Substring.full 191in 192 fun splitAtChar P = liftSplit (Substring.splitl (not o P)) 193 fun splitAtPos n = liftSplit (fn s => Substring.splitAt (s, n)) 194end 195 196val lowercase = String.map Char.toLower 197val uppercase = String.map Char.toUpper 198 199val removeSpaces = 200 String.translate (fn c => if Char.isSpace c then "" else String.str c) 201 202val long_term_to_string = 203 Lib.with_flag (Globals.linewidth, 1000) Hol_pp.term_to_string 204 205val strings_to_quote = 206 (Lib.list_of_singleton o QUOTE o String.concat o Lib.separate "\n") 207 : string list -> string frag list 208 209val lhsc = boolSyntax.lhs o Thm.concl 210val rhsc = boolSyntax.rhs o Thm.concl 211val eval = rhsc o bossLib.EVAL 212val dom = fst o Type.dom_rng 213val rng = snd o Type.dom_rng 214 215local 216 val cnv = Conv.QCONV (REWRITE_CONV [boolTheory.DE_MORGAN_THM]) 217in 218 fun mk_negation tm = rhsc (cnv (boolSyntax.mk_neg tm)) 219end 220 221local 222 fun mk_x (s, ty) = Term.mk_var ("x" ^ String.extract (s, 1, NONE), ty) 223 fun rename v = 224 case Lib.total Term.dest_var v of 225 SOME (s_ty as (s, _)) => 226 if String.sub (s, 0) = #"_" then SOME (v |-> mk_x s_ty) else NONE 227 | NONE => NONE 228 val mk_l = String.implode o Lib.separate #";" o String.explode o uppercase 229in 230 fun pattern s = 231 let 232 val tm = Parse.Term [HOLPP.QUOTE ("[" ^ mk_l s ^ "]")] 233 in 234 Term.subst (List.mapPartial rename (Term.free_vars tm)) tm 235 end 236end 237 238val strip_add_or_sub = 239 let 240 fun iter a t = 241 case Lib.total wordsSyntax.dest_word_add t of 242 SOME (l, r) => iter ((true, r) :: a) l 243 | NONE => (case Lib.total wordsSyntax.dest_word_sub t of 244 SOME (l, r) => iter ((false, r) :: a) l 245 | NONE => (t, a)) 246 in 247 iter [] 248 end 249 250val get_function = 251 fst o boolSyntax.strip_comb o boolSyntax.lhs o 252 snd o boolSyntax.strip_forall o List.hd o boolSyntax.strip_conj o Thm.concl 253 254fun vacuous thm = 255 let 256 val (h, c) = Thm.dest_thm thm 257 in 258 c = boolSyntax.T orelse List.exists (Lib.equal boolSyntax.F) h 259 end 260 261fun add_to_rw_net f (thm: thm, n) = LVTermNet.insert (n, ([], f thm), thm) 262 263fun mk_rw_net f = List.foldl (add_to_rw_net f) LVTermNet.empty 264 265fun find_rw net tm = 266 case LVTermNet.match (net, tm) of 267 [] => raise ERR "find_rw" "not found" 268 | l => List.map snd l: thm list 269 270(* ---------------------------- *) 271 272local 273 val cmp = reduceLib.num_compset () 274 val () = computeLib.add_thms 275 [pairTheory.UNCURRY, combinTheory.o_THM, 276 state_transformerTheory.FOR_def, 277 state_transformerTheory.BIND_DEF, 278 state_transformerTheory.UNIT_DEF] cmp 279 val FOR_CONV = computeLib.CBV_CONV cmp 280 fun term_frag_of_int i = [QUOTE (Int.toString i)]: term frag list 281in 282 fun for_thm (h, l) = 283 state_transformerTheory.FOR_def 284 |> Conv.CONV_RULE (Conv.DEPTH_CONV Conv.FUN_EQ_CONV) 285 |> Q.SPECL [term_frag_of_int h, term_frag_of_int l, `a`, `s`] 286 |> Conv.RIGHT_CONV_RULE FOR_CONV 287 |> Drule.GEN_ALL 288end 289 290(* ---------------------------- *) 291 292(* Variant of UNDISCH 293 [..] |- a1 /\ ... /\ aN ==> t |-> 294 [.., a1, .., aN] |- t 295*) 296 297local 298 fun AND_INTRO_CONV n tm = 299 if n = 0 then ALL_CONV tm 300 else (Conv.REWR_CONV satTheory.AND_IMP 301 THENC Conv.RAND_CONV (AND_INTRO_CONV (n - 1))) tm 302in 303 fun STRIP_UNDISCH th = 304 let 305 val ps = 306 boolSyntax.strip_conj (fst (boolSyntax.dest_imp (Thm.concl th))) 307 val th' = Conv.CONV_RULE (AND_INTRO_CONV (List.length ps - 1)) th 308 in 309 Drule.LIST_MP (List.map Thm.ASSUME ps) th' 310 end 311end 312 313val save_as = Lib.curry Theory.save_thm 314fun usave_as s = save_as s o STRIP_UNDISCH 315fun ustore_thm (s, t, tac) = usave_as s (Q.prove (t, tac)) 316 317local 318 val names = ref ([] : string list) 319 fun add (n, th) = (names := n :: !names; Theory.save_thm (n, th)) 320 val add_list = List.map add 321in 322 fun reset_thms () = names := [] 323 fun save_thms name l = 324 add_list 325 (case l of 326 [] => raise ERR "save_thms" "empty" 327 | [th] => [(name, th)] 328 | _ => ListPair.zip 329 (List.tabulate 330 (List.length l, fn i => name ^ "_" ^ Int.toString i), l)) 331 fun adjoin_thms () = 332 Theory.adjoin_to_theory 333 { sig_ps = SOME (fn _ => PP.add_string ("val rwts : string list")), 334 struct_ps = 335 SOME (fn _ => 336 PP.block PP.INCONSISTENT 12 ( 337 [PP.add_string "val rwts = ["] @ 338 PP.pr_list (PP.add_string o Lib.quote) 339 [PP.add_string ",", PP.add_break (1, 0)] 340 (!names) @ 341 [PP.add_string "]", PP.add_newline] 342 ) 343 ) 344 } 345end 346 347 348(* Variant of UNDISCH 349 [..] |- T ==> t |-> [..] |- t 350 [..] |- F ==> t |-> [..] |- T 351 [..] |- p ==> t |-> [.., p] |- t 352*) 353 354local 355 val thms = Drule.CONJUNCTS (Q.SPEC `t` boolTheory.IMP_CLAUSES) 356 val T_imp = Drule.GEN_ALL (hd thms) 357 val F_imp = Drule.GEN_ALL (List.nth (thms, 2)) 358 val NT_imp = DECIDE ``(~F ==> t) = t`` 359 val T_imp_rule = Conv.CONV_RULE (Conv.REWR_CONV T_imp) 360 val F_imp_rule = Conv.CONV_RULE (Conv.REWR_CONV F_imp) 361 val NT_imp_rule = Conv.CONV_RULE (Conv.REWR_CONV NT_imp) 362 fun dest_neg_occ_var tm1 tm2 = 363 case Lib.total boolSyntax.dest_neg tm1 of 364 SOME v => if Term.is_var v andalso not (Term.var_occurs v tm2) 365 then SOME v 366 else NONE 367 | NONE => NONE 368in 369 fun ELIM_UNDISCH thm = 370 case Lib.total boolSyntax.dest_imp (Thm.concl thm) of 371 SOME (l, r) => 372 if l = boolSyntax.T 373 then T_imp_rule thm 374 else if l = boolSyntax.F 375 then F_imp_rule thm 376 else if Term.is_var l andalso not (Term.var_occurs l r) 377 then T_imp_rule (Thm.INST [l |-> boolSyntax.T] thm) 378 else (case dest_neg_occ_var l r of 379 SOME v => F_imp_rule (Thm.INST [v |-> boolSyntax.F] thm) 380 | NONE => Drule.UNDISCH thm) 381 | NONE => raise ERR "ELIM_UNDISCH" "" 382end 383 384fun LIST_DISCH tms thm = List.foldl (Lib.uncurry Thm.DISCH) thm tms 385 386(* ---------------------------- *) 387 388local 389 val rl = 390 REWRITE_RULE [boolTheory.NOT_CLAUSES, GSYM boolTheory.AND_IMP_INTRO, 391 boolTheory.DE_MORGAN_THM] 392 val pats = [``~ ~a: bool``, ``a /\ b``, ``~(a \/ b)``] 393 fun mtch tm = List.exists (fn p => Lib.can (Term.match_term p) tm) pats 394in 395 fun HYP_CANON_RULE thm = 396 let 397 val hs = List.filter mtch (Thm.hyp thm) 398 in 399 List.foldl 400 (fn (h, t) => repeat ELIM_UNDISCH (rl (Thm.DISCH h t))) thm hs 401 end 402end 403 404(* Apply rule to hyphothesis tm *) 405 406fun HYP_RULE r tm = ELIM_UNDISCH o r o Thm.DISCH tm 407 408(* Apply rule to hyphotheses satisfying P *) 409 410fun PRED_HYP_RULE r P thm = 411 List.foldl (Lib.uncurry (HYP_RULE r)) thm (List.filter P (Thm.hyp thm)) 412 413(* Apply rule to hyphotheses matching pat *) 414 415fun MATCH_HYP_RULE r pat = PRED_HYP_RULE r (Lib.can (Term.match_term pat)) 416 417(* Apply conversion c to all hyphotheses *) 418 419fun ALL_HYP_RULE r = PRED_HYP_RULE r (K true) 420 421local 422 fun LAND_RULE c = Conv.CONV_RULE (Conv.LAND_CONV c) 423in 424 fun HYP_CONV_RULE c = HYP_RULE (LAND_RULE c) 425 fun PRED_HYP_CONV_RULE c = PRED_HYP_RULE (LAND_RULE c) 426 fun MATCH_HYP_CONV_RULE c = MATCH_HYP_RULE (LAND_RULE c) 427 fun ALL_HYP_CONV_RULE c = ALL_HYP_RULE (LAND_RULE c) 428 fun FULL_CONV_RULE c = ALL_HYP_CONV_RULE c o Conv.CONV_RULE c 429end 430 431(* ---------------------------- *) 432 433(* CBV_CONV but fail if term unchanged *) 434fun CHANGE_CBV_CONV cmp = Conv.CHANGED_CONV (computeLib.CBV_CONV cmp) 435 436local 437 val rule = PURE_REWRITE_RULE [SYM wordsTheory.WORD_NEG_1] 438 val and_thms = rule wordsTheory.WORD_AND_CLAUSES 439 val or_thms = rule wordsTheory.WORD_OR_CLAUSES 440 val xor_thms = rule wordsTheory.WORD_XOR_CLAUSES 441 val alpha_rwts = 442 [boolTheory.COND_ID, wordsTheory.WORD_SUB_RZERO, 443 wordsTheory.WORD_ADD_0, wordsTheory.WORD_MULT_CLAUSES, 444 and_thms, or_thms, xor_thms, wordsTheory.WORD_EXTRACT_ZERO2, 445 wordsTheory.w2w_0, wordsTheory.WORD_SUB_REFL, wordsTheory.SHIFT_ZERO] 446 val UINT_MAX_LOGIC_CONV = 447 let 448 fun get th = List.take (Drule.CONJUNCTS (Drule.SPEC_ALL th), 2) 449 in 450 (Conv.LAND_CONV wordsLib.UINT_MAX_CONV 451 ORELSEC Conv.RAND_CONV wordsLib.UINT_MAX_CONV) 452 THENC Conv.CHANGED_CONV 453 (PURE_REWRITE_CONV 454 (List.concat (List.map get [and_thms, or_thms, xor_thms]))) 455 end 456 val WALPHA_CONV = REWRITE_CONV alpha_rwts 457in 458 val WGROUND_CONV = 459 WALPHA_CONV 460 THENC Conv.DEPTH_CONV (wordsLib.WORD_GROUND_CONV ORELSEC 461 integer_wordLib.INT_WORD_GROUND_CONV) 462 THENC Conv.DEPTH_CONV UINT_MAX_LOGIC_CONV 463 THENC WALPHA_CONV 464end 465 466fun NCONV n conv = Lib.funpow n (Lib.curry (op THENC) conv) Conv.ALL_CONV 467fun SRW_CONV thms = SIMP_CONV (srw_ss()) thms 468val EXTRACT_CONV = SIMP_CONV (srw_ss()++wordsLib.WORD_EXTRACT_ss) [] 469val SET_CONV = SIMP_CONV (bool_ss++pred_setLib.PRED_SET_ss) [] 470fun SRW_RULE thms = Conv.CONV_RULE (SRW_CONV thms) 471val SET_RULE = Conv.CONV_RULE SET_CONV 472val o_RULE = REWRITE_RULE [combinTheory.o_THM] 473 474fun qm l = Feedback.trace ("metis", 0) (metisLib.METIS_PROVE l) 475fun qm_tac l = Feedback.trace ("metis", 0) (metisLib.METIS_TAC l) 476 477(* ---------------------------- *) 478 479(* mk_cond_exhaustive_thm i 480 generates a theorem of the form: 481 482 |- !x : i word v0 v1 ... v(2^i). 483 (if x = 0w then v0 484 else if x = 1w then v1 485 ... 486 else v(2^i)) = 487 (if x = 0w then v0 488 else if x = 1w then v1 489 ... 490 else v(2^i - 1)) 491 492*) 493 494fun mk_cond_exhaustive_thm i = 495 let 496 val _ = i < 7 orelse 497 raise ERR "mk_cond_exhaustive_thm" "word size must be < 7" 498 val ty = wordsSyntax.mk_int_word_type i 499 val n = Word.toInt (Word.<< (0w1, Word.fromInt i)) 500 val vars = List.tabulate 501 (n + 1, fn j => Term.mk_var ("v" ^ Int.toString j, Type.alpha)) 502 val x = Term.mk_var ("x", ty) 503 val fold = 504 List.foldr 505 (fn (v, (j, t)) => 506 (j - 1, 507 boolSyntax.mk_cond 508 (boolSyntax.mk_eq (x, wordsSyntax.mk_wordii (j, i)), v, t))) 509 val l = fold (n - 1, List.last vars) (Lib.butlast vars) 510 val vars = Lib.butlast vars 511 val r = fold (n - 2, List.last vars) (Lib.butlast vars) 512 val th = Tactical.prove 513 (boolSyntax.mk_eq (snd l, snd r), 514 wordsLib.Cases_on_word_value `^x` THEN bossLib.simp []) 515 in 516 Drule.GEN_ALL th 517 end 518 519(* ---------------------------- *) 520 521 522fun accessor_update_fns ty = 523 let 524 val {Thy, Tyop, ...} = Type.dest_thy_type ty 525 in 526 List.map 527 (fn (s, fld_ty) => 528 let 529 val v = Term.mk_var ("v", fld_ty) 530 val kv = Term.inst [Type.beta |-> fld_ty] 531 (boolSyntax.mk_icomb (combinSyntax.K_tm, v)) 532 in 533 (Term.prim_mk_const {Name = Tyop ^ "_" ^ s, Thy = Thy}, 534 Term.mk_comb 535 (Term.prim_mk_const 536 {Name = Tyop ^ "_" ^ s ^ "_fupd", Thy = Thy}, kv)) 537 end) 538 (TypeBase.fields_of ty) 539 end 540val accessor_fns = List.map fst o accessor_update_fns 541val update_fns = List.map snd o accessor_update_fns 542 543fun map_conv (cnv: conv) = Drule.LIST_CONJ o List.map cnv 544 545local 546 val thm2l = 547 qm [] ``!f:'a -> 'b -> 'c. 548 f (if b then x else y) z = (if b then f x z else f y z)`` 549 val thm2r = 550 qm [] ``!f:'a -> 'b -> 'c. 551 f z (if b then x else y) = (if b then f z x else f z y)`` 552 fun is_binop tm = 553 case boolSyntax.strip_fun (Term.type_of tm) of 554 ([ty1, ty2], ty3) => 555 ty1 = ty2 andalso (ty3 = Type.bool orelse ty3 = ty1) 556 | _ => false 557 fun spec_thm tm = 558 let 559 val rule = Drule.GEN_ALL o o_RULE o Drule.ISPEC tm 560 in 561 if is_binop tm 562 then Thm.CONJ (rule thm2l) (rule thm2r) 563 else rule boolTheory.COND_RAND 564 end 565in 566 val mk_cond_rand_thms = map_conv spec_thm 567end 568 569local 570 val COND_UPDATE0 = Q.prove( 571 `!b s1 : 'a s2. 572 (if b then ((), s1) else ((), s2)) = ((), if b then s1 else s2)`, 573 RW_TAC std_ss []) 574 val COND_UPDATE1 = Q.prove( 575 `!f : ('a -> 'b) -> 'c -> 'd b v1 v2 s1 s2. 576 (if b then f (K v1) s1 else f (K v2) s2) = 577 f (K (if b then v1 else v2)) (if b then s1 else s2)`, 578 Cases_on `b` THEN REWRITE_TAC []) 579 val COND_UPDATE2 = Q.prove( 580 `(!b a x y f : 'a -> 'b. 581 (if b then (a =+ x) f else (a =+ y) f) = 582 (a =+ if b then x else y) f) /\ 583 (!b a y f : 'a -> 'b. 584 (if b then f else (a =+ y) f) = (a =+ if b then f a else y) f) /\ 585 (!b a x f : 'a -> 'b. 586 (if b then (a =+ x) f else f) = (a =+ if b then x else f a) f)`, 587 REPEAT CONJ_TAC 588 THEN Cases 589 THEN REWRITE_TAC [combinTheory.APPLY_UPDATE_ID]) 590 val COND_UPDATE3 = qm [] ``!b. (if b then T else F) = b`` 591 fun mk_cond_update_thm component_equality (t1, t2) = 592 let 593 val thm = Drule.ISPEC (boolSyntax.rator t2) COND_UPDATE1 594 val thm0 = Drule.SPEC_ALL thm 595 val v = hd (Term.free_vars t2) 596 val (v1, v2, s1, s2) = 597 case boolSyntax.strip_forall (Thm.concl thm) of 598 ([_, v1, v2, s1, s2], _) => (v1, v2, s1, s2) 599 | _ => raise ERR "mk_cond_update_thms" "" 600 val s1p = Term.mk_comb (t1, s1) 601 val s2p = Term.mk_comb (t1, s2) 602 val id_thm = 603 Tactical.prove( 604 boolSyntax.mk_eq 605 (Term.subst [v |-> s1p] (Term.mk_comb (t2, s1)), s1), 606 SRW_TAC [] [component_equality]) 607 val rule = Drule.GEN_ALL o REWRITE_RULE [id_thm] 608 val thm1 = rule (Thm.INST [v1 |-> s1p] thm0) 609 val thm2 = rule (Thm.INST [v2 |-> s2p] thm0) 610 in 611 [thm, thm1, thm2] 612 end 613 fun cond_update_thms ty = 614 let 615 val {Thy, Tyop, ...} = Type.dest_thy_type ty 616 val component_equality = DB.fetch Thy (Tyop ^ "_component_equality") 617 in 618 List.concat 619 (List.map (mk_cond_update_thm component_equality) 620 (accessor_update_fns ty)) 621 end 622in 623 fun mk_cond_update_thms l = 624 [boolTheory.COND_ID, COND_UPDATE0, COND_UPDATE2, COND_UPDATE3] @ 625 List.concat (List.map cond_update_thms l) 626end 627 628(* 629 Conversion for rewriting instances of: 630 631 f (case x of .. => y1 | .. => y2 | .. => yn) 632 633 to 634 635 case x of .. => f y1 | .. => f y2 | .. => f yn 636*) 637 638local 639 val case_rng = snd o HolKernel.strip_fun o Term.type_of 640 val term_rng = snd o Type.dom_rng o Term.type_of 641 val tac = 642 CONV_TAC (Conv.FORK_CONV 643 (Conv.RAND_CONV Drule.LIST_BETA_CONV, Drule.LIST_BETA_CONV)) 644 THEN REFL_TAC 645 fun CASE_RAND_CONV1 rand_f tm = 646 let 647 val (f, x) = Term.dest_comb tm 648 val _ = Term.same_const rand_f f orelse Term.term_eq rand_f f orelse 649 raise ERR "CASE_RAND_CONV" "" 650 val (c, x, l) = 651 case boolSyntax.strip_comb x of 652 (c, x :: l) => (c, x, l) 653 | _ => raise ERR "CASE_RAND_CONV" "" 654 val ty = Term.type_of x 655 val case_c = TypeBase.case_const_of ty 656 val l' = 657 List.map 658 (fn t => let 659 val (vs, b) = boolSyntax.strip_abs t 660 in 661 boolSyntax.list_mk_abs (vs, Term.mk_comb (f, b)) 662 end) l 663 val fvs = List.concat (List.map Term.free_vars l') 664 val x' = Term.variant fvs (Term.mk_var ("x", ty)) 665 val th = 666 Tactical.prove 667 (boolSyntax.mk_eq 668 (Term.mk_comb (f, Term.list_mk_comb (c, x' :: l)), 669 boolSyntax.list_mk_icomb (case_c, x' :: l')), 670 Cases_on `^x'` 671 THEN ONCE_REWRITE_TAC [TypeBase.case_def_of ty] 672 THEN tac 673 ) 674 in 675 Conv.REWR_CONV th tm 676 end 677 val literal_case_rand = Q.prove( 678 `!f : 'a -> 'b x : 'c y a b. 679 f (literal_case (\v. if v = x then a else b) y) = 680 literal_case (\v. if v = x then f a else f b) y`, 681 SIMP_TAC std_ss [boolTheory.literal_case_DEF, boolTheory.COND_RAND]) 682in 683 fun CASE_RAND_CONV f = 684 let 685 val cnv = Conv.REWR_CONV (Drule.ISPEC f literal_case_rand) 686 in 687 Conv.TOP_DEPTH_CONV (cnv ORELSEC CASE_RAND_CONV1 f) 688 end 689end 690 691(* Substitution allowing for type match *) 692 693local 694 fun match_residue {redex = a, residue = b} = 695 let 696 val m = Type.match_type (Term.type_of b) (Term.type_of a) 697 in 698 a |-> Term.inst m b 699 end 700in 701 fun match_subst s = Term.subst (List.map match_residue s) 702end 703 704(* 705fun match_mk_eq (a, b) = 706 let 707 val m = Type.match_type (Term.type_of b) (Term.type_of a) 708 in 709 boolSyntax.mk_eq (a, Term.inst m b) 710 end 711 712fun mk_eq_contexts (a, l) = List.map (fn b => [match_mk_eq (a, b)]) l 713*) 714 715fun avoid_name_clashes tm2 tm1 = 716 let 717 val v1 = Term.free_vars tm1 718 val v2 = Term.free_vars tm2 719 val ns = List.map (fst o Term.dest_var) v2 720 val (l, r) = 721 List.partition (fn v => Lib.mem (fst (Term.dest_var v)) ns) v1 722 val v2 = v2 @ r 723 val sb = List.foldl 724 (fn (v, (sb, avoids)) => 725 let 726 val v' = Lib.with_flag (Globals.priming, SOME "_") 727 (Term.variant avoids) v 728 in 729 ((v |-> v') :: sb, v' :: avoids) 730 end) ([], v2) l 731 in 732 Term.subst (fst sb) tm1 733 end 734 735local 736 fun mk_fupd s f = s ^ "_" ^ f ^ "_fupd" 737 val name = fst o Term.dest_const o fst o Term.dest_comb 738in 739 fun mk_state_id_thm eqthm = 740 let 741 val ty = Term.type_of (fst (boolSyntax.dest_forall (Thm.concl eqthm))) 742 fun mk_thm l = 743 let 744 val {Tyop, Thy, ...} = Type.dest_thy_type ty 745 val mk_f = mk_fupd Tyop 746 val fns = update_fns ty 747 fun get s = List.find (fn f => name f = mk_f s) fns 748 val l1 = List.mapPartial get l 749 val s = Term.mk_var ("s", ty) 750 val h = hd l1 751 val id = Term.prim_mk_const {Thy = Thy, Name = Tyop ^ "_" ^ hd l} 752 val id = 753 Term.subst [hd (Term.free_vars h) |-> Term.mk_comb (id, s)] h 754 val after = List.foldr 755 (fn (f, tm) => 756 let 757 val f1 = avoid_name_clashes tm f 758 in 759 Term.mk_comb (f1, tm) 760 end) s (tl l1) 761 val goal = boolSyntax.mk_eq (Term.mk_comb (id, after), after) 762 in 763 Drule.GEN_ALL (Tactical.prove (goal, bossLib.SRW_TAC [] [eqthm])) 764 end 765 in 766 Drule.LIST_CONJ o List.map mk_thm 767 end 768end 769 770(* ---------------------------- *) 771 772(* Rewrite tm using theorem thm, instantiating free variables from hypotheses 773 as required *) 774 775local 776 fun TRY_EQ_FT thm = 777 if boolSyntax.is_eq (Thm.concl thm) 778 then thm 779 else (Drule.EQF_INTRO thm handle HOL_ERR _ => Drule.EQT_INTRO thm) 780in 781 fun INST_REWRITE_CONV1 thm = 782 let 783 val mtch = Term.match_term (boolSyntax.lhs (Thm.concl thm)) 784 in 785 fn tm => PURE_ONCE_REWRITE_CONV [Drule.INST_TY_TERM (mtch tm) thm] tm 786 handle HOL_ERR _ => raise ERR "INST_REWRITE_CONV1" "" 787 end 788 fun INST_REWRITE_CONV l = 789 let 790 val thms = 791 l |> List.map (Drule.CONJUNCTS o Drule.SPEC_ALL) 792 |> List.concat 793 |> List.map (TRY_EQ_FT o Drule.SPEC_ALL) 794 val net = List.partition (List.null o Thm.hyp) o 795 find_rw (mk_rw_net lhsc thms) 796 in 797 Conv.REDEPTH_CONV 798 (fn tm => 799 case net tm of 800 ([], []) => raise Conv.UNCHANGED 801 | (thm :: _, _) => Conv.REWR_CONV thm tm 802 | ([], thm :: _) => INST_REWRITE_CONV1 thm tm) 803 end 804 fun INST_REWRITE_RULE thm = Conv.CONV_RULE (INST_REWRITE_CONV thm) 805end 806 807(* ---------------------------- *) 808 809(* 810 Given two theorems of the form: 811 812 [..., tm, ...] |- a 813 [..., ~tm, ...] |- a 814 815 produce theorem of the form 816 817 [...] |- a 818*) 819 820local 821 val rule = 822 Conv.CONV_RULE 823 (Conv.CHANGED_CONV 824 (REWRITE_CONV [DECIDE ``((b ==> a) /\ (~b ==> a)) <=> a``, 825 DECIDE ``((~b ==> a) /\ (b ==> a)) <=> a``])) 826 fun SMART_DISCH tm thm = 827 let 828 val l = Thm.hyp thm 829 val thm' = Thm.DISCH tm thm 830 val l' = Thm.hyp thm' 831 in 832 if List.length l' < List.length l 833 then thm' 834 else let 835 val thm' = Thm.DISCH (boolSyntax.mk_neg tm) thm 836 val l' = Thm.hyp thm' 837 in 838 if List.length l' < List.length l 839 then thm' 840 else raise ERR "SMART_DISCH" "Term not in hypotheses" 841 end 842 end 843in 844 fun MERGE_CASES tm thm1 thm2 = 845 let 846 val thm3 = SMART_DISCH tm thm1 847 val thm4 = SMART_DISCH tm thm2 848 in 849 rule (Thm.CONJ thm3 thm4) 850 end 851end 852 853(* ---------------------------- *) 854 855local 856 fun base t = 857 case Lib.total boolSyntax.dest_neg t of 858 SOME s => base s 859 | NONE => 860 (case Lib.total boolSyntax.lhs t of 861 SOME s => s 862 | NONE => t) 863 fun find_occurance r t = 864 Lib.can (HolKernel.find_term (Lib.equal (base t))) r 865 val modified = ref 0 866 fun specialize (conv, tms) thm = 867 let 868 val hs = Thm.hyp thm 869 val hs = List.filter (fn h => List.exists (find_occurance h) tms) hs 870 val sthm = thm |> LIST_DISCH hs 871 |> REWRITE_RULE (List.map ASSUME tms) 872 |> Conv.CONV_RULE conv 873 |> Drule.UNDISCH_ALL 874 in 875 if vacuous sthm then NONE else (Portable.inc modified; SOME sthm) 876 end handle Conv.UNCHANGED => SOME thm 877in 878 fun specialized msg ctms thms = 879 let 880 val sz = Int.toString o List.length 881 val () = print ("Specializing " ^ msg ^ ": " ^ sz thms ^ " -> ") 882 val () = modified := 0 883 val r = List.mapPartial (specialize ctms) thms 884 in 885 print (sz r ^ "(" ^ Int.toString (!modified) ^ ")\n"); r 886 end 887end 888 889(* ---------------------------- *) 890 891(* case split theorem. For example: split_conditions applied to 892 893 |- q = ((if b then x else y), c) 894 895 gives theorems 896 897 [[~b] |- q = (y, c), [b] |- q = (x, c)] 898*) 899 900local 901 fun p q = Drule.UNDISCH (Q.prove(q, RW_TAC bool_ss [])) 902 val split_xt = p `b ==> ((if b then x else y) = x: 'a)` 903 val split_yt = p `~b ==> ((if b then x else y) = y: 'a)` 904 val split_zt = p `b ==> ((if ~b then x else y) = y: 'a)` 905 val split_xl = p `b ==> (((if b then x else y), c) = (x, c): 'a # 'b)` 906 val split_yl = p `~b ==> (((if b then x else y), c) = (y, c): 'a # 'b)` 907 val split_zl = p `b ==> (((if ~b then x else y), c) = (y, c): 'a # 'b)` 908 val split_xr = p `b ==> ((c, (if b then x else y)) = (c, x): 'b # 'a)` 909 val split_yr = p `~b ==> ((c, (if b then x else y)) = (c, y): 'b # 'a)` 910 val split_zr = p `b ==> ((c, (if ~b then x else y)) = (c, y): 'b # 'a)` 911 val vb = Term.mk_var ("b", Type.bool) 912 fun REWR_RULE thm = Conv.RIGHT_CONV_RULE (Conv.REWR_CONV thm) 913 fun cond_true b = Thm.INST [vb |-> b] split_xt 914 fun cond_false b = Thm.INST [vb |-> b] split_yt 915 fun split_cond tm = 916 case Lib.total pairSyntax.dest_pair tm of 917 SOME (a, b) => 918 (case Lib.total boolSyntax.dest_cond a of 919 SOME bxy => SOME (split_xl, split_yl, split_zl, bxy) 920 | NONE => (case Lib.total boolSyntax.dest_cond b of 921 SOME bxy => SOME (split_xr, split_yr, split_zr, bxy) 922 | NONE => NONE)) 923 | NONE => Lib.total 924 (fn t => (split_xt, split_yt, split_zt, 925 boolSyntax.dest_cond t)) tm 926in 927 val split_conditions = 928 let 929 fun loop a t = 930 case split_cond (rhsc t) of 931 SOME (splitx, splity, splitz, (b, x, y)) => 932 let 933 val ty = Term.type_of x 934 val vx = Term.mk_var ("x", ty) 935 val vy = Term.mk_var ("y", ty) 936 fun s cb = Drule.INST_TY_TERM 937 ([vb |-> cb, vx |-> x, vy |-> y], 938 [Type.alpha |-> ty]) 939 val (split_yz, nb) = 940 case Lib.total boolSyntax.dest_neg b of 941 SOME nb => (splitz, nb) 942 | NONE => (splity, b) 943 in 944 loop (loop a (REWR_RULE (s b splitx) t)) 945 (REWR_RULE (s nb split_yz) t) 946 end 947 | NONE => t :: a 948 in 949 loop [] 950 end 951 fun paths [] = [] 952 | paths (h :: t) = 953 [[cond_false h]] @ (List.map (fn p => cond_true h :: p) (paths t)) 954end 955 956(* ---------------------------- *) 957 958(* Support for rewriting/evaluation *) 959 960val basic_rewrites = 961 [state_transformerTheory.FOR_def, 962 state_transformerTheory.BIND_DEF, 963 combinTheory.APPLY_UPDATE_THM, 964 combinTheory.K_o_THM, 965 combinTheory.K_THM, 966 combinTheory.o_THM, 967 pairTheory.FST, 968 pairTheory.SND, 969 pairTheory.pair_case_thm, 970 pairTheory.CURRY_DEF, 971 optionTheory.option_case_compute, 972 optionTheory.IS_SOME_DEF, 973 optionTheory.THE_DEF] 974 975local 976 fun in_conv conv tm = 977 case Lib.total pred_setSyntax.dest_in tm of 978 SOME (a1, a2) => 979 if pred_setSyntax.is_set_spec a2 980 then pred_setLib.SET_SPEC_CONV tm 981 else pred_setLib.IN_CONV conv tm 982 | NONE => raise ERR "in_conv" "not an IN term"; 983in 984 fun add_base_datatypes cmp = 985 let 986 val cnv = computeLib.CBV_CONV cmp 987 in 988 computeLib.add_thms basic_rewrites cmp 989 ; List.app (fn x => computeLib.add_conv x cmp) 990 [(pred_setSyntax.in_tm, 2, in_conv cnv), 991 (pred_setSyntax.insert_tm, 2, pred_setLib.INSERT_CONV cnv)] 992 end 993end 994 995local 996 (* Taken from src/datatype/EnumType.sml *) 997 fun gen_triangle l = 998 let 999 fun gen_row i [] acc = acc 1000 | gen_row i (h::t) acc = gen_row i t ((i,h)::acc) 1001 fun doitall [] acc = acc 1002 | doitall (h::t) acc = doitall t (gen_row h t acc) 1003 in 1004 List.rev (doitall l []) 1005 end 1006 fun datatype_rewrites1 ty = 1007 case TypeBase.simpls_of ty of 1008 {convs = [], rewrs = r} => r 1009 | {convs = {conv = c, name = n, ...} :: _, rewrs = r} => 1010 if String.isSuffix "const_eq_CONV" n 1011 then let 1012 val neq = Drule.EQF_ELIM o 1013 c (K Conv.ALL_CONV) [] o 1014 boolSyntax.mk_eq 1015 val l = ty |> TypeBase.constructors_of 1016 |> gen_triangle 1017 |> List.map neq 1018 |> Drule.LIST_CONJ 1019 in 1020 [l, GSYM l] @ r 1021 end 1022 else r 1023in 1024 fun datatype_rewrites extra thy l = 1025 let 1026 fun typ name = Type.mk_thy_type {Thy = thy, Args = [], Tyop = name} 1027 in 1028 (if extra then List.drop (basic_rewrites, 2) else []) @ 1029 List.concat (List.map (datatype_rewrites1 o typ) l) 1030 end 1031end 1032 1033local 1034 fun add_datatype cmp = 1035 computeLib.add_datatype_info cmp o Option.valOf o TypeBase.fetch 1036in 1037 fun add_datatypes l cmp = List.app (add_datatype cmp) l 1038end 1039 1040type inventory = {C: string list, N: int list, T: string list, Thy: string} 1041 1042fun theory_types (i: inventory) = 1043 let 1044 val {Thy = thy, T = l, ...} = i 1045 in 1046 List.map (fn t => Type.mk_thy_type {Thy = thy, Args = [], Tyop = t}) l 1047 end 1048 1049fun filter_inventory names ({Thy = thy, C = l, N = n, T = t}: inventory) = 1050 let 1051 val es = List.map (fn s => s ^ "_def") names 1052 in 1053 {Thy = thy, C = List.filter (fn t => not (Lib.mem t es)) l, N = n, T = t} 1054 end 1055 1056local 1057 fun bool_bit_thms i = 1058 let 1059 val s = Int.toString i 1060 val b = "boolify" ^ s 1061 in 1062 ["bitify" ^ s ^ "_def", b ^ "_n2w", b ^ "_v2w"] 1063 end 1064 val get_name = fst o Term.dest_const o fst o HolKernel.strip_comb o 1065 boolSyntax.lhs o snd o boolSyntax.strip_forall o 1066 List.hd o boolSyntax.strip_conj o Thm.concl 1067in 1068 fun theory_rewrites (thms, i: inventory) = 1069 let 1070 val thm_names = List.map get_name thms 1071 val {Thy = thy, C = l, N = n, ...} = filter_inventory thm_names i 1072 val m = List.concat (List.map bool_bit_thms n) 1073 in 1074 List.map (fn t => DB.fetch thy t) (l @ m) @ thms 1075 end 1076end 1077 1078fun add_theory (x as (_, i)) cmp = 1079 ( add_datatypes (theory_types i) cmp 1080 ; computeLib.add_thms (theory_rewrites x) cmp) 1081 1082fun add_to_the_compset x = computeLib.add_funs (theory_rewrites x) 1083 1084fun theory_compset x = 1085 let 1086 val cmp = wordsLib.words_compset () 1087 in 1088 add_base_datatypes cmp; add_theory x cmp; cmp 1089 end 1090 1091(* ---------------------------- *) 1092 1093(* Help prove theorems of the form: 1094 1095|- rec'r (bit_field_insert h l w (reg'r q)) = q with <| ? := ?; ... |> 1096 1097Where "r" is some register (record) component in the theory "thy". 1098 1099*) 1100 1101local 1102 fun EXTRACT_BIT_CONV tm = 1103 if fcpSyntax.is_fcp_index tm 1104 then blastLib.BBLAST_CONV tm 1105 else Conv.NO_CONV tm 1106 val bit_field_insert_tm = 1107 ``bit_field_insert a b (w: 'a word) : 'b word -> 'b word`` 1108in 1109 fun BIT_FIELD_INSERT_CONV thy r = 1110 let 1111 val s = thy ^ "_state" 1112 val ty1 = Type.mk_thy_type {Thy = thy, Tyop = r, Args = []} 1113 val ty2 = Type.mk_thy_type {Thy = thy, Tyop = s, Args = []} 1114 val au = accessor_update_fns ty1 @ accessor_update_fns ty2 1115 val au = op @ (ListPair.unzip au) 1116 in 1117 REWRITE_CONV 1118 ([boolTheory.COND_ID, 1119 mk_cond_rand_thms (bit_field_insert_tm :: au)] @ 1120 datatype_rewrites true thy [r, s]) 1121 THENC Conv.DEPTH_CONV EXTRACT_BIT_CONV 1122 THENC Conv.DEPTH_CONV (wordsLib.WORD_BIT_INDEX_CONV true) 1123 end 1124 fun REC_REG_BIT_FIELD_INSERT_TAC thy r = 1125 let 1126 val cnv = BIT_FIELD_INSERT_CONV thy r 1127 val f = DB.fetch thy 1128 val reg' = f ("reg'" ^ r ^ "_def") 1129 val rec' = f ("rec'" ^ r ^ "_def") 1130 val eq = f (r ^ "_component_equality") 1131 in 1132 fn q => 1133 Cases_on q 1134 THEN TRY STRIP_TAC 1135 THEN REWRITE_TAC [reg'] 1136 THEN CONV_TAC cnv 1137 THEN BETA_TAC 1138 THEN REWRITE_TAC [rec', eq, wordsTheory.bit_field_insert_def] 1139 THEN CONV_TAC cnv 1140 THEN REPEAT CONJ_TAC 1141 THEN blastLib.BBLAST_TAC 1142 end 1143end 1144 1145(* Make a theorem of the form 1146 1147|- !x. reg'r x = x.? @@ x.? 1148 1149*) 1150 1151local 1152 fun mk_component_subst v = 1153 fn h => 1154 let 1155 val (x, y) = boolSyntax.dest_eq h 1156 in 1157 x |-> Term.mk_comb (Term.rator y, v) 1158 end 1159in 1160 fun mk_reg_thm thy r = 1161 let 1162 val ftch = DB.fetch thy 1163 val reg' = ftch ("reg'" ^ r ^ "_def") 1164 val a = ftch (r ^ "_accessors") 1165 val ((_, v), (vs, m)) = 1166 reg' 1167 |> Drule.SPEC_ALL 1168 |> rhsc 1169 |> Term.dest_comb 1170 |> (Term.dest_comb ## boolSyntax.strip_abs) 1171 val mk_s = mk_component_subst v o Thm.concl o SYM o Drule.SPECL vs 1172 val tm = Term.subst (List.map mk_s (Drule.CONJUNCTS a)) m 1173 in 1174 Tactical.prove 1175 (boolSyntax.mk_eq (Term.mk_comb (get_function reg', v), tm), 1176 REC_REG_BIT_FIELD_INSERT_TAC thy r `^v`) 1177 |> Drule.GEN_ALL 1178 end 1179end 1180 1181(* ---------------------------- *) 1182 1183local 1184 val dr = Type.dom_rng o Term.type_of 1185 val dom = fst o dr 1186 val rng = snd o dr 1187 fun mk_def thy tm = 1188 let 1189 val name = fst (Term.dest_const tm) 1190 val (l, r) = splitAtChar (Lib.equal #"@") name 1191 in 1192 if r = "" orelse 1193 Option.isSome (Int.fromString (String.extract (r, 1, NONE))) 1194 then Term.prim_mk_const {Thy = thy, Name = "dfn'" ^ l} 1195 else raise ERR "mk_def" "" 1196 end 1197 fun buildAst thy ty = 1198 let 1199 val cs = TypeBase.constructors_of ty 1200 val (t0, n) = List.partition (Lib.equal ty o Term.type_of) cs 1201 val (t1, n) = List.partition (Lib.can (mk_def thy)) n 1202 val t1 = 1203 List.map (fn t => Term.mk_comb (t, Term.mk_var ("x", dom t))) t1 1204 val n = 1205 List.map (fn t => 1206 let 1207 val l = buildAst thy (dom t) 1208 in 1209 List.map (fn x => Term.mk_comb (t, x) 1210 handle HOL_ERR {origin_function = "mk_comb", ...} => 1211 (Parse.print_term t; print "\n"; 1212 Parse.print_term x; raise ERR "buildAst" "")) l 1213 end) n 1214 in 1215 t0 @ t1 @ List.concat n 1216 end 1217 fun is_call x tm = 1218 case Lib.total Term.rand tm of 1219 SOME y => x = y 1220 | NONE => false 1221 fun leaf tm = 1222 case Lib.total Term.rand tm of 1223 SOME y => leaf y 1224 | NONE => tm 1225 fun run_thm0 pv thy ast = 1226 let 1227 val tac = SIMP_TAC (srw_ss()) [DB.fetch thy "Run_def"] 1228 val f = mk_def thy (leaf ast) 1229 in 1230 pv (if Term.type_of f = oneSyntax.one_ty orelse 1231 rng f = oneSyntax.one_ty 1232 then `!s. Run ^ast s = s` 1233 else `!s. Run ^ast s = ^f s`) : thm 1234 end 1235 fun run_thm pv thy ast = 1236 let 1237 val tac = SIMP_TAC (srw_ss()) [DB.fetch thy "Run_def"] 1238 val x = hd (Term.free_vars ast) 1239 val tm = Term.rator (HolKernel.find_term (is_call x) ast) 1240 val f = boolSyntax.mk_icomb (mk_def thy tm, x) 1241 in 1242 pv (if Term.type_of f = oneSyntax.one_ty 1243 then `!s. Run ^ast s = s` 1244 else `!s. Run ^ast s = ^f s`) : thm 1245 end 1246 fun run_rwts thy = 1247 let 1248 val ty = Type.mk_thy_type {Thy = thy, Args = [], Tyop = "instruction"} 1249 val (arg0, args) = 1250 List.partition (List.null o Term.free_vars) (buildAst thy ty) 1251 val tac = SIMP_TAC (srw_ss()) [DB.fetch thy "Run_def"] 1252 fun pv q = Q.prove (q, tac) 1253 in 1254 List.map (run_thm0 pv thy) arg0 @ List.map (run_thm pv thy) args 1255 end 1256 fun run_tm thy = Term.prim_mk_const {Thy = thy, Name = "Run"} 1257in 1258 fun mk_run (thy, st) = fn ast => Term.list_mk_comb (run_tm thy, [ast, st]) 1259 fun Run_CONV (thy, st) = 1260 Thm.GEN st o PURE_REWRITE_CONV (run_rwts thy) o mk_run (thy, st) 1261end 1262 1263(* ---------------------------- *) 1264 1265local 1266 val rwts = [pairTheory.UNCURRY, combinTheory.o_THM, combinTheory.K_THM] 1267 val no_hyp = List.partition (List.null o Thm.hyp) 1268 val add_word_eq = 1269 computeLib.add_conv (``$= :'a word -> 'a word -> bool``, 2, 1270 bitstringLib.word_eq_CONV) 1271 fun context_subst tm = 1272 let 1273 val f = Parse.parse_in_context (Term.free_vars tm) 1274 in 1275 List.map (List.map (fn {redex, residue} => f redex |-> residue)) 1276 end 1277 val step_conv = ref Conv.ALL_CONV 1278in 1279 fun resetStepConv () = step_conv := Conv.ALL_CONV 1280 fun setStepConv c = step_conv := c 1281 fun STEP (datatype_thms, st) = 1282 let 1283 val DATATYPE_CONV = REWRITE_CONV (datatype_thms []) 1284 fun fix_datatype tm = rhsc (Conv.QCONV DATATYPE_CONV tm) 1285 val SAFE_ASSUME = Thm.ASSUME o fix_datatype 1286 in 1287 fn l => fn ctms => fn s => fn tm => 1288 let 1289 val (nh, h) = no_hyp l 1290 val c = INST_REWRITE_CONV h 1291 val cmp = reduceLib.num_compset () 1292 val () = ( computeLib.add_thms (rwts @ nh) cmp 1293 ; add_word_eq cmp ) 1294 fun cnv rwt = 1295 Conv.REPEATC 1296 (Conv.TRY_CONV (CHANGE_CBV_CONV cmp) 1297 THENC REWRITE_CONV (datatype_thms (rwt @ h)) 1298 THENC (!step_conv) 1299 THENC c) 1300 val stm = Term.mk_comb (tm, st) handle HOL_ERR _ => tm 1301 val sbst = context_subst stm s 1302 fun cnvs rwt = 1303 if List.null sbst 1304 then [cnv rwt stm] 1305 else List.map (fn sub => cnv rwt (match_subst sub stm)) sbst 1306 val ctxts = List.map (List.map SAFE_ASSUME) ctms 1307 in 1308 if List.null ctxts 1309 then cnvs [] 1310 else List.concat (List.map cnvs ctxts) 1311 end 1312 end 1313end 1314 1315end 1316