413 structure Word_Bitwise_Tac = |
413 structure Word_Bitwise_Tac = |
414 struct |
414 struct |
415 |
415 |
416 val word_ss = simpset_of @{theory_context Word}; |
416 val word_ss = simpset_of @{theory_context Word}; |
417 |
417 |
418 fun mk_nat_clist ns = List.foldr |
418 fun mk_nat_clist ns = |
419 (uncurry (Thm.mk_binop @{cterm "Cons :: nat => _"})) |
419 List.foldr |
420 @{cterm "[] :: nat list"} ns; |
420 (uncurry (Thm.mk_binop @{cterm "Cons :: nat \<Rightarrow> _"})) |
|
421 @{cterm "[] :: nat list"} ns; |
421 |
422 |
422 fun upt_conv ctxt ct = |
423 fun upt_conv ctxt ct = |
423 case Thm.term_of ct of |
424 case Thm.term_of ct of |
424 (@{const upt} $ n $ m) => |
425 (@{const upt} $ n $ m) => |
425 let |
426 let |
426 val (i, j) = apply2 (snd o HOLogic.dest_number) (n, m); |
427 val (i, j) = apply2 (snd o HOLogic.dest_number) (n, m); |
427 val ns = map (Numeral.mk_cnumber @{ctyp nat}) (i upto (j - 1)) |
428 val ns = map (Numeral.mk_cnumber @{ctyp nat}) (i upto (j - 1)) |
428 |> mk_nat_clist; |
429 |> mk_nat_clist; |
429 val prop = Thm.mk_binop @{cterm "op = :: nat list => _"} ct ns |
430 val prop = |
430 |> Thm.apply @{cterm Trueprop}; |
431 Thm.mk_binop @{cterm "op = :: nat list \<Rightarrow> _"} ct ns |
|
432 |> Thm.apply @{cterm Trueprop}; |
431 in |
433 in |
432 try (fn () => |
434 try (fn () => |
433 Goal.prove_internal ctxt [] prop |
435 Goal.prove_internal ctxt [] prop |
434 (K (REPEAT_DETERM (resolve_tac ctxt @{thms upt_eq_list_intros} 1 |
436 (K (REPEAT_DETERM (resolve_tac ctxt @{thms upt_eq_list_intros} 1 |
435 ORELSE simp_tac (put_simpset word_ss ctxt) 1))) |> mk_meta_eq) () |
437 ORELSE simp_tac (put_simpset word_ss ctxt) 1))) |> mk_meta_eq) () |
439 val expand_upt_simproc = |
441 val expand_upt_simproc = |
440 Simplifier.make_simproc @{context} "expand_upt" |
442 Simplifier.make_simproc @{context} "expand_upt" |
441 {lhss = [@{term "upt x y"}], proc = K upt_conv}; |
443 {lhss = [@{term "upt x y"}], proc = K upt_conv}; |
442 |
444 |
443 fun word_len_simproc_fn ctxt ct = |
445 fun word_len_simproc_fn ctxt ct = |
444 case Thm.term_of ct of |
446 (case Thm.term_of ct of |
445 Const (@{const_name len_of}, _) $ t => (let |
447 Const (@{const_name len_of}, _) $ t => |
|
448 (let |
446 val T = fastype_of t |> dest_Type |> snd |> the_single |
449 val T = fastype_of t |> dest_Type |> snd |> the_single |
447 val n = Numeral.mk_cnumber @{ctyp nat} (Word_Lib.dest_binT T); |
450 val n = Numeral.mk_cnumber @{ctyp nat} (Word_Lib.dest_binT T); |
448 val prop = Thm.mk_binop @{cterm "op = :: nat => _"} ct n |
451 val prop = |
449 |> Thm.apply @{cterm Trueprop}; |
452 Thm.mk_binop @{cterm "op = :: nat \<Rightarrow> _"} ct n |
450 in Goal.prove_internal ctxt [] prop (K (simp_tac (put_simpset word_ss ctxt) 1)) |
453 |> Thm.apply @{cterm Trueprop}; |
451 |> mk_meta_eq |> SOME end |
454 in |
452 handle TERM _ => NONE | TYPE _ => NONE) |
455 Goal.prove_internal ctxt [] prop (K (simp_tac (put_simpset word_ss ctxt) 1)) |
453 | _ => NONE; |
456 |> mk_meta_eq |> SOME |
|
457 end handle TERM _ => NONE | TYPE _ => NONE) |
|
458 | _ => NONE); |
454 |
459 |
455 val word_len_simproc = |
460 val word_len_simproc = |
456 Simplifier.make_simproc @{context} "word_len" |
461 Simplifier.make_simproc @{context} "word_len" |
457 {lhss = [@{term "len_of x"}], proc = K word_len_simproc_fn}; |
462 {lhss = [@{term "len_of x"}], proc = K word_len_simproc_fn}; |
458 |
463 |
460 or just 5 (discarding nat) when n_sucs = 0 *) |
465 or just 5 (discarding nat) when n_sucs = 0 *) |
461 |
466 |
462 fun nat_get_Suc_simproc_fn n_sucs ctxt ct = |
467 fun nat_get_Suc_simproc_fn n_sucs ctxt ct = |
463 let |
468 let |
464 val (f $ arg) = Thm.term_of ct; |
469 val (f $ arg) = Thm.term_of ct; |
465 val n = (case arg of @{term nat} $ n => n | n => n) |
470 val n = |
|
471 (case arg of @{term nat} $ n => n | n => n) |
466 |> HOLogic.dest_number |> snd; |
472 |> HOLogic.dest_number |> snd; |
467 val (i, j) = if n > n_sucs then (n_sucs, n - n_sucs) |
473 val (i, j) = if n > n_sucs then (n_sucs, n - n_sucs) else (n, 0); |
468 else (n, 0); |
474 val arg' = |
469 val arg' = List.foldr (op $) (HOLogic.mk_number @{typ nat} j) |
475 List.foldr (op $) (HOLogic.mk_number @{typ nat} j) (replicate i @{term Suc}); |
470 (replicate i @{term Suc}); |
|
471 val _ = if arg = arg' then raise TERM ("", []) else (); |
476 val _ = if arg = arg' then raise TERM ("", []) else (); |
472 fun propfn g = HOLogic.mk_eq (g arg, g arg') |
477 fun propfn g = |
|
478 HOLogic.mk_eq (g arg, g arg') |
473 |> HOLogic.mk_Trueprop |> Thm.cterm_of ctxt; |
479 |> HOLogic.mk_Trueprop |> Thm.cterm_of ctxt; |
474 val eq1 = Goal.prove_internal ctxt [] (propfn I) |
480 val eq1 = |
475 (K (simp_tac (put_simpset word_ss ctxt) 1)); |
481 Goal.prove_internal ctxt [] (propfn I) |
476 in Goal.prove_internal ctxt [] (propfn (curry (op $) f)) |
482 (K (simp_tac (put_simpset word_ss ctxt) 1)); |
|
483 in |
|
484 Goal.prove_internal ctxt [] (propfn (curry (op $) f)) |
477 (K (simp_tac (put_simpset HOL_ss ctxt addsimps [eq1]) 1)) |
485 (K (simp_tac (put_simpset HOL_ss ctxt addsimps [eq1]) 1)) |
478 |> mk_meta_eq |> SOME end |
486 |> mk_meta_eq |> SOME |
479 handle TERM _ => NONE; |
487 end handle TERM _ => NONE; |
480 |
488 |
481 fun nat_get_Suc_simproc n_sucs ts = |
489 fun nat_get_Suc_simproc n_sucs ts = |
482 Simplifier.make_simproc @{context} "nat_get_Suc" |
490 Simplifier.make_simproc @{context} "nat_get_Suc" |
483 {lhss = map (fn t => t $ @{term "n :: nat"}) ts, |
491 {lhss = map (fn t => t $ @{term "n :: nat"}) ts, |
484 proc = K (nat_get_Suc_simproc_fn n_sucs)}; |
492 proc = K (nat_get_Suc_simproc_fn n_sucs)}; |