steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

bit-arrays: re-use utility words from math.bitwise and io.binary to make implementation a bit more elegant

db4
Slava Pestov 2010-05-03 22:38:50 -04:00
parent ad69052a1a
commit 1c6bbf7fd1
2 changed files with 23 additions and 26 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
basis/bit-arrays/bit-arrays-tests.factor
View File

@ -1,4 +1,4 @@
USING: sequences sequences.private arrays bit-arrays kernel USING: alien sequences sequences.private arrays bit-arrays kernel
tools.test math random ; tools.test math random ;
IN: bit-arrays.tests IN: bit-arrays.tests
@ -79,4 +79,8 @@ IN: bit-arrays.tests
[ 49 ] [ 49 <bit-array> dup set-bits [ ] count ] unit-test [ 49 ] [ 49 <bit-array> dup set-bits [ ] count ] unit-test
[ 1 ] [ ?{ f t f t } byte-length ] unit-test
[ HEX: a ] [ ?{ f t f t } bit-array>integer ] unit-test
[ HEX: 100 ] [ ?{ f f f f f f f f t } bit-array>integer ] unit-test [ HEX: 100 ] [ ?{ f f f f f f f f t } bit-array>integer ] unit-test

43
basis/bit-arrays/bit-arrays.factor
View File

@ -1,8 +1,9 @@
! Copyright (C) 2007, 2010 Slava Pestov. ! Copyright (C) 2007, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.data accessors math alien.accessors kernel USING: alien alien.data accessors io.binary math math.bitwise
kernel.private sequences sequences.private byte-arrays alien.accessors kernel kernel.private sequences
parser prettyprint.custom fry ; sequences.private byte-arrays parser prettyprint.custom fry
locals ;
IN: bit-arrays IN: bit-arrays
TUPLE: bit-array TUPLE: bit-array
@ -13,11 +14,10 @@ TUPLE: bit-array
: n>byte ( m -- n ) -3 shift ; inline : n>byte ( m -- n ) -3 shift ; inline
: byte/bit ( n alien -- byte bit ) : bit/byte ( n -- bit byte ) [ 7 bitand ] [ n>byte ] bi ; inline
over n>byte alien-unsigned-1 swap 7 bitand ; inline
: set-bit ( ? byte bit -- byte ) : bit-index ( n bit-array -- bit# byte# byte-array )
2^ rot [ bitor ] [ bitnot bitand ] if ; inline [ >fixnum bit/byte ] [ underlying>> ] bi* ; inline
: bits>cells ( m -- n ) 31 + -5 shift ; inline : bits>cells ( m -- n ) 31 + -5 shift ; inline
@ -25,7 +25,7 @@ TUPLE: bit-array
: (set-bits) ( bit-array n -- ) : (set-bits) ( bit-array n -- )
[ [ length bits>cells ] keep ] dip swap underlying>> [ [ length bits>cells ] keep ] dip swap underlying>>
'[ 2 shift [ _ _ ] dip set-alien-unsigned-4 ] each-integer ; inline '[ [ _ _ ] dip 4 * set-alien-unsigned-4 ] each-integer ; inline
: clean-up ( bit-array -- ) : clean-up ( bit-array -- )
! Zero bits after the end. ! Zero bits after the end.
@ -47,12 +47,13 @@ PRIVATE>
M: bit-array length length>> ; inline M: bit-array length length>> ; inline
M: bit-array nth-unsafe M: bit-array nth-unsafe
[ >fixnum ] [ underlying>> ] bi* byte/bit bit? ; inline bit-index nth-unsafe swap bit? ; inline
:: toggle-bit ( ? n x -- y )
x n ? [ set-bit ] [ clear-bit ] if ; inline
M: bit-array set-nth-unsafe M: bit-array set-nth-unsafe
[ >fixnum ] [ underlying>> ] bi* bit-index [ toggle-bit ] change-nth-unsafe ; inline
[ byte/bit set-bit ] 2keep
swap n>byte set-alien-unsigned-1 ; inline
GENERIC: clear-bits ( bit-array -- ) GENERIC: clear-bits ( bit-array -- )
@ -83,25 +84,17 @@ M: bit-array resize
bit-array boa bit-array boa
dup clean-up ; inline dup clean-up ; inline
M: bit-array byte-length length 7 + -3 shift ; inline M: bit-array byte-length length bits>bytes ; inline
SYNTAX: ?{ \ } [ >bit-array ] parse-literal ; SYNTAX: ?{ \ } [ >bit-array ] parse-literal ;
: integer>bit-array ( n -- bit-array ) : integer>bit-array ( n -- bit-array )
dup 0 = [ dup 0 =
<bit-array> [ <bit-array> ]
] [ [ dup log2 1 + [ nip ] [ bits>bytes >le ] 2bi bit-array boa ] if ;
[ log2 1 + <bit-array> 0 ] keep
[ dup 0 = ] [
[ pick underlying>> pick set-alien-unsigned-1 ] keep
[ 1 + ] [ -8 shift ] bi*
] until 2drop
] if ;
: bit-array>integer ( bit-array -- n ) : bit-array>integer ( bit-array -- n )
0 swap underlying>> dup length iota <reversed> [ underlying>> le> ;
alien-unsigned-1 swap 8 shift bitor
] with each ;
INSTANCE: bit-array sequence INSTANCE: bit-array sequence