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: alien alien.c-types alien.data arrays assocs byte-arrays
   4 combinators combinators.short-circuit kernel kernel.private
   5 layouts math math.bits sequences sequences.private
   6 specialized-arrays words ;
   7 IN: math.bitwise
   8 SPECIALIZED-ARRAY: uchar
   9 IN: math.bitwise
  10
  11 ! utilities
  12 : clear-bit ( x n -- y ) 2^ bitnot bitand ; inline
  13 : set-bit ( x n -- y ) 2^ bitor ; inline
  14 : unmask ( x n -- y ) bitnot bitand ; inline
  15 : unmask? ( x n -- ? ) unmask zero? not ; inline
  16 : mask ( x n -- y ) bitand ; inline
  17 : mask? ( x n -- ? ) [ mask ] [ = ] bi ; inline
  18 : wrap ( m n -- m' ) 1 - bitand ; inline
  19 : on-bits ( m -- n ) dup 0 <= [ drop 0 ] [ 2^ 1 - ] if ; inline
  20 : bits ( m n -- m' ) on-bits mask ; inline
  21 : mask-bit ( m n -- m' ) 2^ mask ; inline
  22 : toggle-bit ( m n -- m' ) 2^ bitxor ; inline
  23 : >signed ( x n -- y )
  24     [ bits ] keep 2dup 1 - bit? [ 2^ - ] [ drop ] if ; inline
  25 : >odd ( m -- n ) 0 set-bit ; foldable
  26 : >even ( m -- n ) 0 clear-bit ; foldable
  27 : next-even ( m -- n ) >even 2 + ; foldable
  28 : next-odd ( m -- n ) dup even? [ 1 + ] [ 2 + ] if ; foldable
  29 : shift-mod ( m s w -- n ) [ shift ] dip 2^ wrap ; inline
  30
  31 ERROR: bit-range-error x high low ;
  32 : bit-range ( x high low -- y )
  33     2dup { [ nip 0 < ] [ < ] } 2|| [ bit-range-error ] when
  34     [ nip neg shift ] [ - 1 + ] 2bi bits ; inline
  35
  36 : bitroll ( x s w -- y )
  37     [ wrap ] keep
  38     [ shift-mod ] [ [ - ] keep shift-mod ] 3bi bitor ; inline
  39
  40 : bitroll-32 ( m s -- n ) 32 bitroll ; inline
  41
  42 : bitroll-64 ( m s -- n ) 64 bitroll ; inline
  43
  44 ! 32-bit arithmetic
  45 : w+ ( x y -- z ) + 32 bits ; inline
  46 : w- ( x y -- z ) - 32 bits ; inline
  47 : w* ( x y -- z ) * 32 bits ; inline
  48
  49 ! 64-bit arithmetic
  50 : W+ ( x y -- z ) + 64 bits ; inline
  51 : W- ( x y -- z ) - 64 bits ; inline
  52 : W* ( x y -- z ) * 64 bits ; inline
  53
  54 : symbols>flags ( symbols assoc -- flag-bits )
  55     '[ _ at ] map 0 [ bitor ] reduce ;
  56
  57 ! bitfield
  58 <PRIVATE
  59
  60 GENERIC: (bitfield-quot) ( spec -- quot )
  61
  62 M: integer (bitfield-quot)
  63     '[ _ shift ] ;
  64
  65 M: pair (bitfield-quot)
  66     first2-unsafe over word? [
  67         '[ _ execute _ shift ]
  68     ] [
  69         '[ _ _ shift ]
  70     ] if ;
  71
  72 : (bitfield) ( bitspec -- quot )
  73     [ [ 0 ] ] [
  74         [ (bitfield-quot) ] [ '[ @ _ dip bitor ] ] map-reduce
  75     ] if-empty ;
  76
  77 PRIVATE>
  78
  79 MACRO: bitfield ( bitspec -- quot ) (bitfield) ;
  80
  81 MACRO: bitfield* ( bitspec -- quot ) reverse (bitfield) ;
  82
  83 ! bit-count
  84 <PRIVATE
  85
  86 DEFER: byte-bit-count
  87
  88 <<
  89
  90 \ byte-bit-count
  91 256 <iota> [
  92     8 <bits> 0 [ [ 1 + ] when ] reduce
  93 ] B{ } map-as '[ 0xff bitand _ nth-unsafe ]
  94 ( byte -- table ) define-declared
  95
  96 \ byte-bit-count make-inline
  97
  98 >>
  99
 100 GENERIC: (bit-count) ( x -- n )
 101
 102 : fixnum-bit-count ( x -- n )
 103     { fixnum } declare
 104     {
 105         [ byte-bit-count ]
 106         [ -8 shift byte-bit-count + ]
 107         [ -16 shift byte-bit-count + ]
 108         [ -24 shift byte-bit-count + ]
 109         [
 110             cell 8 = [
 111                 {
 112                     [ -32 shift byte-bit-count + ]
 113                     [ -40 shift byte-bit-count + ]
 114                     [ -48 shift byte-bit-count + ]
 115                     [ -56 shift byte-bit-count + ]
 116                 } cleave >fixnum
 117             ] [ drop ] if
 118         ]
 119     } cleave ;
 120
 121 M: fixnum (bit-count)
 122     fixnum-bit-count { fixnum } declare ; inline
 123
 124 M: bignum (bit-count)
 125     [ 0 ] [
 126         [ byte-bit-count ] [ -8 shift (bit-count) ] bi +
 127     ] if-zero ;
 128
 129 : byte-array-bit-count ( byte-array -- n )
 130     [ byte-bit-count ] map-sum ; inline
 131
 132 PRIVATE>
 133
 134 GENERIC: bit-count ( obj -- n )
 135
 136 M: integer bit-count
 137     dup 0 < [ non-negative-integer-expected ] when (bit-count) ; inline
 138
 139 M: byte-array bit-count
 140     byte-array-bit-count ;
 141
 142 M: object bit-count
 143     binary-object uchar <c-direct-array> byte-array-bit-count ;
 144
 145 : bit-length ( x -- n )
 146     dup 0 < [ non-negative-integer-expected ] [
 147         dup 1 > [ log2 1 + ] when
 148     ] if ;
 149
 150 : even-parity? ( obj -- ? ) bit-count even? ;
 151
 152 : odd-parity? ( obj -- ? ) bit-count odd? ;
 153
 154 : d>w/w ( d -- w1 w2 )
 155     [ 0xffffffff bitand ] [ -32 shift 0xffffffff bitand ] bi ;
 156
 157 : w>h/h ( w -- h1 h2 )
 158     [ 0xffff bitand ] [ -16 shift 0xffff bitand ] bi ;
 159
 160 : h>b/b ( h -- b1 b2 )
 161     [ 0xff bitand ] [ -8 shift 0xff bitand ] bi ;