src/HOL/Word/WordBitwise.thy
changeset 67120 491fd7f0b5df
parent 66446 aeb8b8fe94d0
child 67121 116968454d70
equal deleted inserted replaced
67119:acb0807ddb56 67120:491fd7f0b5df
   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)};