basis/math/bitwise/bitwise.factor

   1 ! Copyright (C) 2007, 2008 Slava Pestov, Doug Coleman.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: arrays assocs combinators combinators.smart fry kernel
   4 macros math math.bits sequences sequences.private words ;
   5 IN: math.bitwise
   6
   7 ! utilities
   8 : clear-bit ( x n -- y ) 2^ bitnot bitand ; inline
   9 : set-bit ( x n -- y ) 2^ bitor ; inline
  10 : bit-clear? ( x n -- ? ) 2^ bitand 0 = ; inline
  11 : unmask ( x n -- ? ) bitnot bitand ; inline
  12 : unmask? ( x n -- ? ) unmask 0 > ; inline
  13 : mask ( x n -- ? ) bitand ; inline
  14 : mask? ( x n -- ? ) mask 0 > ; inline
  15 : wrap ( m n -- m' ) 1 - bitand ; inline
  16 : bits ( m n -- m' ) 2^ wrap ; inline
  17 : mask-bit ( m n -- m' ) 2^ mask ; inline
  18 : on-bits ( n -- m ) 2^ 1 - ; inline
  19 : toggle-bit ( m n -- m' ) 2^ bitxor ; inline
  20
  21 : shift-mod ( n s w -- n )
  22     [ shift ] dip 2^ wrap ; inline
  23
  24 : bitroll ( x s w -- y )
  25     [ wrap ] keep
  26     [ shift-mod ] [ [ - ] keep shift-mod ] 3bi bitor ; inline
  27
  28 : bitroll-32 ( n s -- n' ) 32 bitroll ; inline
  29
  30 : bitroll-64 ( n s -- n' ) 64 bitroll ; inline
  31
  32 ! 32-bit arithmetic
  33 : w+ ( int int -- int ) + 32 bits ; inline
  34 : w- ( int int -- int ) - 32 bits ; inline
  35 : w* ( int int -- int ) * 32 bits ; inline
  36
  37 ! 64-bit arithmetic
  38 : W+ ( int int -- int ) + 64 bits ; inline
  39 : W- ( int int -- int ) - 64 bits ; inline
  40 : W* ( int int -- int ) * 64 bits ; inline
  41
  42 ! flags
  43 MACRO: flags ( values -- )
  44     [ 0 ] [ [ ?execute bitor ] curry compose ] reduce ;
  45
  46 : symbols>flags ( symbols assoc -- flag-bits )
  47     [ at ] curry map
  48     0 [ bitor ] reduce ;
  49
  50 ! bitfield
  51 <PRIVATE
  52
  53 GENERIC: (bitfield-quot) ( spec -- quot )
  54
  55 M: integer (bitfield-quot) ( spec -- quot )
  56     [ swapd shift bitor ] curry ;
  57
  58 M: pair (bitfield-quot) ( spec -- quot )
  59     first2 over word? [ [ swapd execute ] dip ] [ ] ?
  60     [ shift bitor ] append 2curry ;
  61
  62 PRIVATE>
  63
  64 MACRO: bitfield ( bitspec -- )
  65     [ 0 ] [ (bitfield-quot) compose ] reduce ;
  66
  67 ! bit-count
  68 <PRIVATE
  69
  70 DEFER: byte-bit-count
  71
  72 <<
  73
  74 \ byte-bit-count
  75 256 iota [
  76     8 <bits> 0 [ [ 1 + ] when ] reduce
  77 ] B{ } map-as '[ HEX: ff bitand _ nth-unsafe ]
  78 (( byte -- table )) define-declared
  79
  80 \ byte-bit-count make-inline
  81
  82 >>
  83
  84 GENERIC: (bit-count) ( x -- n )
  85
  86 M: fixnum (bit-count)
  87     [
  88         {
  89             [           byte-bit-count ]
  90             [ -8  shift byte-bit-count ]
  91             [ -16 shift byte-bit-count ]
  92             [ -24 shift byte-bit-count ]
  93         } cleave
  94     ] sum-outputs ;
  95
  96 M: bignum (bit-count)
  97     dup 0 = [ drop 0 ] [
  98         [ byte-bit-count ] [ -8 shift (bit-count) ] bi +
  99     ] if ;
 100
 101 PRIVATE>
 102
 103 : bit-count ( x -- n )
 104     dup 0 < [ bitnot ] when (bit-count) ; inline
 105
 106 : >signed ( x n -- y )
 107     2dup neg 1 + shift 1 = [ 2^ - ] [ drop ] if ;
 108
 109 : >odd ( n -- int ) 0 set-bit ; foldable
 110
 111 : >even ( n -- int ) 0 clear-bit ; foldable
 112
 113 : next-even ( m -- n ) >even 2 + ; foldable
 114
 115 : next-odd ( m -- n ) dup even? [ 1 + ] [ 2 + ] if ; foldable