Merge branch 'master' of git://factorcode.org/git/factor
Joe Groff
commit
1bb8a99368
|
|
@ -2,31 +2,35 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays assocs fry
|
||||
hashtables io kernel locals math math.order math.parser
|
||||
math.ranges multiline sequences ;
|
||||
math.ranges multiline sequences bitstreams bit-arrays ;
|
||||
IN: compression.huffman
|
||||
|
||||
QUALIFIED-WITH: bitstreams bs
|
||||
|
||||
<PRIVATE
|
||||
|
||||
! huffman codes
|
||||
|
||||
TUPLE: huffman-code
|
||||
{ value }
|
||||
{ size }
|
||||
{ code } ;
|
||||
{ value fixnum }
|
||||
{ size fixnum }
|
||||
{ code fixnum } ;
|
||||
|
||||
: <huffman-code> ( -- code ) 0 0 0 huffman-code boa ;
|
||||
: next-size ( code -- ) [ 1 + ] change-size [ 2 * ] change-code drop ;
|
||||
: next-code ( code -- ) [ 1 + ] change-code drop ;
|
||||
: <huffman-code> ( -- huffman-code )
|
||||
0 0 0 huffman-code boa ; inline
|
||||
|
||||
:: all-patterns ( huff n -- seq )
|
||||
n log2 huff size>> - :> free-bits
|
||||
: next-size ( huffman-code -- )
|
||||
[ 1 + ] change-size
|
||||
[ 2 * ] change-code drop ; inline
|
||||
|
||||
: next-code ( huffman-code -- )
|
||||
[ 1 + ] change-code drop ; inline
|
||||
|
||||
:: all-patterns ( huffman-code n -- seq )
|
||||
n log2 huffman-code size>> - :> free-bits
|
||||
free-bits 0 >
|
||||
[ free-bits 2^ [0,b) [ huff code>> free-bits 2^ * + ] map ]
|
||||
[ huff code>> free-bits neg 2^ /i 1array ] if ;
|
||||
[ free-bits 2^ iota [ huffman-code code>> free-bits 2^ * + ] map ]
|
||||
[ huffman-code code>> free-bits neg 2^ /i 1array ] if ;
|
||||
|
||||
:: huffman-each ( tdesc quot: ( huff -- ) -- )
|
||||
:: huffman-each ( tdesc quot: ( huffman-code -- ) -- )
|
||||
<huffman-code> :> code
|
||||
tdesc
|
||||
[
|
||||
|
|
@ -34,7 +38,7 @@ TUPLE: huffman-code
|
|||
[ code (>>value) code clone quot call code next-code ] each
|
||||
] each ; inline
|
||||
|
||||
: update-reverse-table ( huff n table -- )
|
||||
: update-reverse-table ( huffman-code n table -- )
|
||||
[ drop all-patterns ]
|
||||
[ nip '[ _ swap _ set-at ] each ] 3bi ;
|
||||
|
||||
|
|
@ -43,49 +47,29 @@ TUPLE: huffman-code
|
|||
tdesc [ n table update-reverse-table ] huffman-each
|
||||
table seq>> ;
|
||||
|
||||
:: huffman-table ( tdesc max -- table )
|
||||
max f <array> :> table
|
||||
tdesc [ [ ] [ value>> ] bi table set-nth ] huffman-each
|
||||
table ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
! decoder
|
||||
|
||||
TUPLE: huffman-decoder
|
||||
{ bs }
|
||||
{ tdesc }
|
||||
{ rtable }
|
||||
{ bits/level } ;
|
||||
{ bs bit-reader }
|
||||
{ tdesc array }
|
||||
{ rtable array }
|
||||
{ bits/level fixnum } ;
|
||||
|
||||
: <huffman-decoder> ( bs tdesc -- decoder )
|
||||
: <huffman-decoder> ( bs tdesc -- huffman-decoder )
|
||||
huffman-decoder new
|
||||
swap >>tdesc
|
||||
swap >>bs
|
||||
16 >>bits/level
|
||||
[ ] [ tdesc>> ] [ bits/level>> 2^ ] tri reverse-table >>rtable ;
|
||||
dup [ tdesc>> ] [ bits/level>> 2^ ] bi reverse-table >>rtable ; inline
|
||||
|
||||
: read1-huff ( decoder -- elt )
|
||||
16 over [ bs>> bs:peek ] [ rtable>> nth ] bi ! first/last
|
||||
[ size>> swap bs>> bs:seek ] [ value>> ] bi ;
|
||||
: read1-huff ( huffman-decoder -- elt )
|
||||
16 over [ bs>> bs:peek ] [ rtable>> nth ] bi
|
||||
[ size>> swap bs>> bs:seek ] [ value>> ] bi ; inline
|
||||
|
||||
! %remove
|
||||
: reverse-bits ( value bits -- value' )
|
||||
[ >bin ] [ CHAR: 0 pad-head <reversed> bin> ] bi* ;
|
||||
[ integer>bit-array ] dip
|
||||
f pad-tail reverse bit-array>integer ; inline
|
||||
|
||||
: read1-huff2 ( decoder -- elt )
|
||||
16 over [ bs>> bs:peek 16 reverse-bits ] [ rtable>> nth ] bi ! first/last
|
||||
[ size>> swap bs>> bs:seek ] [ value>> ] bi ;
|
||||
|
||||
/*
|
||||
: huff>string ( code -- str )
|
||||
[ value>> number>string ]
|
||||
[ [ code>> ] [ size>> bits>string ] bi ] bi
|
||||
" = " glue ;
|
||||
|
||||
: huff. ( code -- ) huff>string print ;
|
||||
|
||||
:: rtable. ( rtable -- )
|
||||
rtable length>> log2 :> n
|
||||
rtable <enum> [ swap n bits. [ huff. ] each ] assoc-each ;
|
||||
*/
|
||||
: read1-huff2 ( huffman-decoder -- elt )
|
||||
16 over [ bs>> bs:peek 16 reverse-bits ] [ rtable>> nth ] bi
|
||||
[ size>> swap bs>> bs:seek ] [ value>> ] bi ; inline
|
||||
|
|
|
|||
|
|
@ -0,0 +1,102 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: tools.test compression.inflate ;
|
||||
IN: compression.inflate.tests
|
||||
|
||||
[
|
||||
BV{
|
||||
1 255 255 255 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
|
||||
0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 122 121 94 119
|
||||
239 237 227 88 16 16 10 5 16 17 26 172 3 20 19 245 22 54 55
|
||||
70 245 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
|
||||
0 0 0 0 0 0 0 0 0 0 139 138 112 127 12 6 234 132 254 250 9
|
||||
24 16 19 38 182 25 27 40 154 2 240 239 235 25 0 0 0 0 0 0 0
|
||||
0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
|
||||
163 163 154 57 223 218 192 128 6 4 39 87 13 9 22 63 245 239
|
||||
239 242 240 240 242 243 4 17 17 25 21 0 0 0 0 0 0 0 0 0 0 0
|
||||
0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 223 219
|
||||
197 140 26 21 26 221 108 117 136 170 0 0 0 0 0 0 0 194 148
|
||||
147 138 6 4 4 5 4 33 176 175 161 5 80 81 95 251 0 0 0 0 0 0
|
||||
0 0 0 0 0 0 0 0 0 0 122 121 105 33 246 246 234 80 241 240
|
||||
226 77 28 25 4 58 29 30 68 108 0 0 0 0 0 0 0 0 0 0 0 0 108
|
||||
109 118 250 2 24 24 39 230 225 221 203 107 0 0 0 0 0 0 0 0
|
||||
0 0 0 0 0 0 0 0 103 102 80 101 249 245 214 208 13 6 240 142
|
||||
44 37 29 65 11 13 22 250 11 15 30 180 0 0 0 0 0 0 0 0 0 0 0
|
||||
0 0 0 0 0 1 200 201 196 1 208 195 176 132 224 223 207 50
|
||||
253 6 15 181 251 253 0 6 240 241 239 77 14 10 246 64 33 24
|
||||
13 0 7 252 20 0 247 1 249 0 241 253 1 205 129 132 173 52
|
||||
124 123 107 32 17 16 6 15 115 117 143 209 0 0 0 0 1 255 255
|
||||
255 0 0 0 0 0 128 118 95 119 221 222 204 136 1 3 0 0 22 27
|
||||
35 0 249 239 239 0 30 22 3 0 247 4 18 0 250 248 247 0 29 26
|
||||
31 222 239 249 6 164 241 241 230 48 19 19 28 209 29 30 35
|
||||
154 87 88 109 228 1 255 255 255 0 0 0 0 0 0 0 0 0 136 136
|
||||
116 39 227 224 218 110 245 245 242 61 238 238 237 36 11 1
|
||||
254 9 32 37 20 213 7 14 40 151 2 0 246 36 6 8 20 210 8 8 5
|
||||
4 33 32 41 184 10 11 17 232 69 70 80 251 0 255 255 255 0
|
||||
255 255 255 0 255 255 255 0 255 255 255 0 255 255 255 0 255
|
||||
255 255 0 107 104 82 144 88 81 34 255 162 159 134 122 255
|
||||
255 255 0 255 255 255 0 255 255 255 0 255 255 255 0 195 194
|
||||
184 2 255 255 255 0 255 255 255 0 0 255 255 255 0 255 255
|
||||
255 0 255 255 255 0 255 255 255 0 255 255 255 0 174 171 167
|
||||
15 102 99 63 233 132 129 99 133 255 255 255 0 255 255 255 0
|
||||
255 255 255 0 255 255 255 0 255 255 255 0 255 255 255 0 255
|
||||
255 255 0 255 255 255 0 2 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
|
||||
119 119 116 4 240 239 217 143 28 28 30 228 34 36 45 232 0 0
|
||||
0 0 0 0 0 0 38 38 38 4 28 28 28 2 0 0 0 0 0 0 0 0 0 0 0 0 0
|
||||
0 0 0 4 0 0 0 0 0 0 0 0 33 33 33 3 38 38 38 9 243 243 243
|
||||
252 14 12 44 24 233 235 4 89 250 251 216 126 92 91 76 241 8
|
||||
9 21 235 69 69 70 2 250 250 249 214 0 0 0 223 0 0 0 0 0 0 0
|
||||
0 0 0 0 0 2 0 0 0 0 0 0 0 0 247 247 247 255 25 25 25 11 45
|
||||
46 48 26 239 239 251 219 3 4 1 114 233 236 1 254 21 21 20
|
||||
113 12 11 2 54 1 2 2 215 206 206 206 230 0 0 0 0 0 0 0 0 0
|
||||
0 0 0 0 0 0 0 1 255 255 255 0 0 0 0 0 0 0 0 0 0 0 0 0 46 46
|
||||
47 8 56 56 49 70 23 21 9 145 237 239 248 180 247 247 2 148
|
||||
225 225 224 234 241 241 240 248 205 205 205 247 0 0 0 0 0 0
|
||||
0 0 0 0 0 0 0 0 0 0 0 255 255 255 0 255 255 255 0 255 255
|
||||
255 0 255 255 255 0 255 255 255 0 255 255 255 0 107 106 96
|
||||
75 90 89 73 75 255 255 255 0 255 255 255 0 255 255 255 0
|
||||
255 255 255 0 255 255 255 0 255 255 255 0 255 255 255 0 255
|
||||
255 255 0
|
||||
}
|
||||
] [
|
||||
B{
|
||||
56 141 99 252 255 255 63 3 41 160 170 50 174 252 253 219
|
||||
199 17 2 2 92 172 2 130 82 107 152 69 132 191 138 153 153
|
||||
187 125 37 70 115 119 87 65 61 15 219 171 150 127 191 56 37
|
||||
4 132 213 182 73 74 107 204 98 250 240 254 181 36 49 154 23
|
||||
47 158 101 121 255 214 129 6 54 22 245 112 94 78 49 251 175
|
||||
239 223 127 250 240 225 211 103 22 65 65 73 81 98 12 184
|
||||
127 251 104 143 148 168 212 221 156 210 142 85 80 161 67 83
|
||||
38 119 177 177 176 176 178 40 110 88 191 144 53 32 48 254
|
||||
55 166 127 51 21 191 125 123 21 240 241 195 35 95 25 73 22
|
||||
43 89 57 151 28 100 249 156 220 178 95 76 18 18 234 207 30
|
||||
222 61 157 141 174 57 61 45 32 245 231 215 107 23 120 217
|
||||
62 244 233 168 202 58 114 243 138 253 226 230 151 219 130
|
||||
174 142 241 196 201 35 140 23 14 111 104 121 112 255 188
|
||||
209 95 54 254 173 191 255 50 176 125 248 248 222 151 143
|
||||
235 155 131 162 4 47 3 251 31 17 134 239 140 63 25 62 254
|
||||
101 60 219 216 178 214 164 166 58 91 65 80 128 141 191 184
|
||||
180 255 34 3 3 3 3 35 44 26 27 202 226 203 239 222 59 211
|
||||
193 200 204 192 32 38 173 204 240 243 253 123 6 57 49 102
|
||||
134 239 44 66 12 191 126 124 103 144 149 146 191 247 254 39
|
||||
219 146 143 31 159 25 8 11 203 92 148 149 83 158 21 30 145
|
||||
251 132 17 57 29 116 116 148 168 63 126 112 43 239 235 215
|
||||
79 182 239 222 189 85 225 102 252 199 169 160 42 114 149
|
||||
157 79 99 58 19 195 55 21 54 14 145 75 28 28 172 44 138 10
|
||||
154 59 184 184 5 95 184 186 5 252 102 248 255 255 63 86 156
|
||||
157 17 52 33 34 80 233 255 162 249 109 85 232 114 135 15
|
||||
237 96 130 177 177 106 94 183 122 57 127 90 178 253 203 150
|
||||
198 228 86 92 22 192 48 19 122 168 150 151 151 176 124 120
|
||||
127 179 95 70 70 238 137 146 138 238 11 152 184 154 154 26
|
||||
139 140 140 12 134 122 22 24 67 81 81 145 89 77 77 141 243
|
||||
243 231 207 127 248 120 116 36 94 190 102 137 252 245 251
|
||||
70 93 76 180 207 71 14 78 209 215 174 174 110 76 191 126
|
||||
253 188 198 192 192 112 31 217 0 184 137 223 191 127 255 47
|
||||
41 41 201 173 171 103 32 245 254 253 239 219 204 44 140 69
|
||||
47 223 48 254 19 21 21 41 228 225 102 50 99 100 98 186 126
|
||||
238 220 185 103 24 233 0 61 55 234 233 233 115 88 88 24 186
|
||||
137 139 114 78 124 251 254 199 150 239 223 153 166 60 124
|
||||
248 224 213 199 143 31 126 156 61 123 246 59 186 1 184 99
|
||||
33 43 193 59 42 210 211 155 80 32 2 0 2 32 94 128
|
||||
} zlib-inflate
|
||||
] unit-test
|
||||
|
|
@ -1,19 +1,14 @@
|
|||
! Copyright (C) 2009 Marc Fauconneau.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays assocs byte-vectors combinators
|
||||
compression.huffman fry hashtables io.binary kernel locals math
|
||||
math.bitwise math.order math.ranges sequences sorting ;
|
||||
combinators.smart compression.huffman fry hashtables io.binary
|
||||
kernel literals locals math math.bitwise math.order math.ranges
|
||||
sequences sorting memoize combinators.short-circuit ;
|
||||
QUALIFIED-WITH: bitstreams bs
|
||||
IN: compression.inflate
|
||||
|
||||
QUALIFIED-WITH: bitstreams bs
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: enum>seq ( assoc -- seq )
|
||||
dup keys [ ] [ max ] map-reduce 1 + f <array>
|
||||
[ '[ swap _ set-nth ] assoc-each ] keep ;
|
||||
|
||||
ERROR: zlib-unimplemented ;
|
||||
ERROR: bad-zlib-data ;
|
||||
ERROR: bad-zlib-header ;
|
||||
|
|
@ -25,35 +20,28 @@ ERROR: bad-zlib-header ;
|
|||
4 data bs:read ! log2(max length)-8, 32K max
|
||||
7 <= [ bad-zlib-header ] unless
|
||||
5 data bs:seek ! drop check bits
|
||||
1 data bs:read 0 assert= ! dictionnary - not allowed in png
|
||||
1 data bs:read 0 assert= ! dictionary - not allowed in png
|
||||
2 data bs:seek ! compression level; ignore
|
||||
;
|
||||
|
||||
:: default-table ( -- table )
|
||||
0 <hashtable> :> table
|
||||
0 143 [a,b] 280 287 [a,b] append 8 table set-at
|
||||
144 255 [a,b] >array 9 table set-at
|
||||
256 279 [a,b] >array 7 table set-at
|
||||
table enum>seq 1 tail ;
|
||||
|
||||
CONSTANT: clen-shuffle { 16 17 18 0 8 7 9 6 10 5 11 4 12 3 13 2 14 1 15 }
|
||||
|
||||
: get-table ( values size -- table )
|
||||
16 f <array> clone <enum>
|
||||
[ '[ _ push-at ] 2each ] keep seq>> 1 tail [ natural-sort ] map ;
|
||||
16 f <array> <enum>
|
||||
[ '[ _ push-at ] 2each ] keep
|
||||
seq>> rest-slice [ natural-sort ] map ; inline
|
||||
|
||||
:: decode-huffman-tables ( bitstream -- tables )
|
||||
5 bitstream bs:read 257 +
|
||||
5 bitstream bs:read 1 +
|
||||
4 bitstream bs:read 4 +
|
||||
clen-shuffle swap head
|
||||
dup [ drop 3 bitstream bs:read ] map
|
||||
4 bitstream bs:read 4 + clen-shuffle swap head
|
||||
|
||||
dup length iota [ 3 bitstream bs:read ] replicate
|
||||
get-table
|
||||
bitstream swap <huffman-decoder>
|
||||
[ 2dup + ] dip swap :> k!
|
||||
'[
|
||||
_ read1-huff2
|
||||
{
|
||||
_ read1-huff2 {
|
||||
{ [ dup 16 = ] [ 2 bitstream bs:read 3 + 2array ] }
|
||||
{ [ dup 17 = ] [ 3 bitstream bs:read 3 + 2array ] }
|
||||
{ [ dup 18 = ] [ 7 bitstream bs:read 11 + 2array ] }
|
||||
|
|
@ -61,92 +49,85 @@ CONSTANT: clen-shuffle { 16 17 18 0 8 7 9 6 10 5 11 4 12 3 13 2 14 1 15 }
|
|||
} cond
|
||||
dup array? [ dup second ] [ 1 ] if
|
||||
k swap - dup k! 0 >
|
||||
]
|
||||
[ ] produce swap suffix
|
||||
{ } [ dup array? [ dup first 16 = ] [ f ] if [ [ unclip-last ] [ second 1 + swap <repetition> append ] bi* ] [ suffix ] if ] reduce
|
||||
] [ ] produce swap suffix
|
||||
{ } [
|
||||
dup { [ array? ] [ first 16 = ] } 1&& [
|
||||
[ unclip-last-slice ]
|
||||
[ second 1 + swap <repetition> append ] bi*
|
||||
] [
|
||||
suffix
|
||||
] if
|
||||
] reduce
|
||||
[ dup array? [ second 0 <repetition> ] [ 1array ] if ] map concat
|
||||
nip swap cut 2array [ [ length>> [0,b) ] [ ] bi get-table ] map ;
|
||||
nip swap cut 2array
|
||||
[ [ length>> iota ] [ ] bi get-table ] map ;
|
||||
|
||||
MEMO: static-huffman-tables ( -- obj )
|
||||
[
|
||||
0 143 [a,b] [ 8 ] replicate
|
||||
144 255 [a,b] [ 9 ] replicate append
|
||||
256 279 [a,b] [ 7 ] replicate append
|
||||
280 287 [a,b] [ 8 ] replicate append
|
||||
] append-outputs
|
||||
0 31 [a,b] [ 5 ] replicate 2array
|
||||
[ [ length>> [0,b) ] [ ] bi get-table ] map ;
|
||||
|
||||
CONSTANT: length-table
|
||||
{
|
||||
3 4 5 6 7 8 9 10
|
||||
11 13 15 17
|
||||
19 23 27 31
|
||||
35 43 51 59
|
||||
67 83 99 115
|
||||
131 163 195 227 258
|
||||
3 4 5 6 7 8 9 10 11 13 15 17 19 23 27 31
|
||||
35 43 51 59 67 83 99 115 131 163 195 227 258
|
||||
}
|
||||
|
||||
CONSTANT: dist-table
|
||||
{
|
||||
1 2 3 4
|
||||
5 7 9 13
|
||||
17 25 33 49
|
||||
65 97 129 193
|
||||
257 385 513 769
|
||||
1025 1537 2049 3073
|
||||
4097 6145 8193 12289
|
||||
16385 24577
|
||||
1 2 3 4 5 7 9 13 17 25 33 49
|
||||
65 97 129 193 257 385 513 769 1025 1537 2049 3073
|
||||
4097 6145 8193 12289 16385 24577
|
||||
}
|
||||
|
||||
: nth* ( n seq -- elt )
|
||||
[ length 1 - swap - ] [ nth ] bi ;
|
||||
[ length 1 - swap - ] [ nth ] bi ; inline
|
||||
|
||||
:: inflate-lz77 ( seq -- bytes )
|
||||
1000 <byte-vector> :> bytes
|
||||
seq
|
||||
[
|
||||
seq [
|
||||
dup array?
|
||||
[ first2 '[ _ 1 - bytes nth* bytes push ] times ]
|
||||
[ bytes push ] if
|
||||
] each
|
||||
bytes ;
|
||||
|
||||
:: inflate-dynamic ( bitstream -- bytes )
|
||||
bitstream decode-huffman-tables
|
||||
bitstream '[ _ swap <huffman-decoder> ] map :> tables
|
||||
:: inflate-huffman ( bitstream tables -- bytes )
|
||||
bitstream tables [ <huffman-decoder> ] with map :> tables
|
||||
[
|
||||
tables first read1-huff2
|
||||
dup 256 >
|
||||
[
|
||||
dup 285 =
|
||||
[ ]
|
||||
[
|
||||
dup 264 >
|
||||
[
|
||||
dup 261 - 4 /i dup 5 >
|
||||
[ bad-zlib-data ] when
|
||||
dup 256 > [
|
||||
dup 285 = [
|
||||
dup 264 > [
|
||||
dup 261 - 4 /i
|
||||
dup 5 > [ bad-zlib-data ] when
|
||||
bitstream bs:read 2array
|
||||
]
|
||||
when
|
||||
] if
|
||||
! 5 bitstream read-bits ! distance
|
||||
] when
|
||||
] unless
|
||||
|
||||
tables second read1-huff2
|
||||
dup 3 >
|
||||
[
|
||||
|
||||
dup 3 > [
|
||||
dup 2 - 2 /i dup 13 >
|
||||
[ bad-zlib-data ] when
|
||||
bitstream bs:read 2array
|
||||
]
|
||||
when
|
||||
2array
|
||||
]
|
||||
when
|
||||
dup 256 = not
|
||||
]
|
||||
[ ] produce nip
|
||||
] when 2array
|
||||
] when dup 256 = not
|
||||
] [ ] produce nip
|
||||
[
|
||||
dup array? [
|
||||
first2
|
||||
[
|
||||
first2 [
|
||||
dup array? [ first2 ] [ 0 ] if
|
||||
[ 257 - length-table nth ] [ + ] bi*
|
||||
]
|
||||
[
|
||||
] [
|
||||
dup array? [ first2 ] [ 0 ] if
|
||||
[ dist-table nth ] [ + ] bi*
|
||||
] bi*
|
||||
2array
|
||||
] bi* 2array
|
||||
] when
|
||||
] map ;
|
||||
|
||||
|
|
@ -154,17 +135,23 @@ CONSTANT: dist-table
|
|||
8 bitstream bs:align
|
||||
16 bitstream bs:read :> len
|
||||
16 bitstream bs:read :> nlen
|
||||
len nlen + 16 >signed -1 assert= ! len + ~len = -1
|
||||
|
||||
! len + ~len = -1
|
||||
len nlen + 16 >signed -1 assert=
|
||||
|
||||
bitstream byte-pos>>
|
||||
bitstream byte-pos>> len +
|
||||
bitstream bytes>> <slice>
|
||||
len 8 * bitstream bs:seek ;
|
||||
|
||||
: inflate-static ( bitstream -- bytes ) zlib-unimplemented ;
|
||||
: inflate-dynamic ( bitstream -- array )
|
||||
dup decode-huffman-tables inflate-huffman ;
|
||||
|
||||
:: inflate-loop ( bitstream -- bytes )
|
||||
[ 1 bitstream bs:read 0 = ]
|
||||
[
|
||||
: inflate-static ( bitstream -- array )
|
||||
static-huffman-tables inflate-huffman ;
|
||||
|
||||
:: inflate-loop ( bitstream -- array )
|
||||
[ 1 bitstream bs:read 0 = ] [
|
||||
bitstream
|
||||
2 bitstream bs:read
|
||||
{
|
||||
|
|
@ -172,10 +159,8 @@ CONSTANT: dist-table
|
|||
{ 1 [ inflate-static ] }
|
||||
{ 2 [ inflate-dynamic ] }
|
||||
{ 3 [ bad-zlib-data f ] }
|
||||
}
|
||||
case
|
||||
]
|
||||
[ produce ] keep call suffix concat ;
|
||||
} case
|
||||
] [ produce ] keep call suffix concat ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
|
|
|
|||
|
|
@ -324,6 +324,46 @@ HOOK: %shr-vector-reps cpu ( -- reps )
|
|||
HOOK: %horizontal-shl-vector-reps cpu ( -- reps )
|
||||
HOOK: %horizontal-shr-vector-reps cpu ( -- reps )
|
||||
|
||||
M: object %zero-vector-reps { } ;
|
||||
M: object %fill-vector-reps { } ;
|
||||
M: object %gather-vector-2-reps { } ;
|
||||
M: object %gather-vector-4-reps { } ;
|
||||
M: object %shuffle-vector-reps { } ;
|
||||
M: object %merge-vector-reps { } ;
|
||||
M: object %signed-pack-vector-reps { } ;
|
||||
M: object %unsigned-pack-vector-reps { } ;
|
||||
M: object %unpack-vector-head-reps { } ;
|
||||
M: object %unpack-vector-tail-reps { } ;
|
||||
M: object %integer>float-vector-reps { } ;
|
||||
M: object %float>integer-vector-reps { } ;
|
||||
M: object %compare-vector-reps drop { } ;
|
||||
M: object %compare-vector-ccs 2drop { } f ;
|
||||
M: object %test-vector-reps { } ;
|
||||
M: object %add-vector-reps { } ;
|
||||
M: object %saturated-add-vector-reps { } ;
|
||||
M: object %add-sub-vector-reps { } ;
|
||||
M: object %sub-vector-reps { } ;
|
||||
M: object %saturated-sub-vector-reps { } ;
|
||||
M: object %mul-vector-reps { } ;
|
||||
M: object %saturated-mul-vector-reps { } ;
|
||||
M: object %div-vector-reps { } ;
|
||||
M: object %min-vector-reps { } ;
|
||||
M: object %max-vector-reps { } ;
|
||||
M: object %dot-vector-reps { } ;
|
||||
M: object %sqrt-vector-reps { } ;
|
||||
M: object %horizontal-add-vector-reps { } ;
|
||||
M: object %horizontal-sub-vector-reps { } ;
|
||||
M: object %abs-vector-reps { } ;
|
||||
M: object %and-vector-reps { } ;
|
||||
M: object %andn-vector-reps { } ;
|
||||
M: object %or-vector-reps { } ;
|
||||
M: object %xor-vector-reps { } ;
|
||||
M: object %not-vector-reps { } ;
|
||||
M: object %shl-vector-reps { } ;
|
||||
M: object %shr-vector-reps { } ;
|
||||
M: object %horizontal-shl-vector-reps { } ;
|
||||
M: object %horizontal-shr-vector-reps { } ;
|
||||
|
||||
HOOK: %unbox-alien cpu ( dst src -- )
|
||||
HOOK: %unbox-any-c-ptr cpu ( dst src temp -- )
|
||||
HOOK: %box-alien cpu ( dst src temp -- )
|
||||
|
|
|
|||
|
|
@ -256,45 +256,6 @@ M:: ppc %binary-float-function ( dst src1 src2 func -- )
|
|||
M: ppc %single>double-float double-rep %copy ;
|
||||
M: ppc %double>single-float double-rep %copy ;
|
||||
|
||||
! VMX/AltiVec not supported yet
|
||||
M: ppc %zero-vector-reps { } ;
|
||||
M: ppc %fill-vector-reps { } ;
|
||||
M: ppc %gather-vector-2-reps { } ;
|
||||
M: ppc %gather-vector-4-reps { } ;
|
||||
M: ppc %shuffle-vector-reps { } ;
|
||||
M: ppc %merge-vector-reps { } ;
|
||||
M: ppc %signed-pack-vector-reps { } ;
|
||||
M: ppc %unsigned-pack-vector-reps { } ;
|
||||
M: ppc %unpack-vector-reps { } ;
|
||||
M: ppc %integer>float-vector-reps { } ;
|
||||
M: ppc %float>integer-vector-reps { } ;
|
||||
M: ppc %compare-vector-reps drop { } ;
|
||||
M: ppc %test-vector-reps { } ;
|
||||
M: ppc %add-vector-reps { } ;
|
||||
M: ppc %saturated-add-vector-reps { } ;
|
||||
M: ppc %add-sub-vector-reps { } ;
|
||||
M: ppc %sub-vector-reps { } ;
|
||||
M: ppc %saturated-sub-vector-reps { } ;
|
||||
M: ppc %mul-vector-reps { } ;
|
||||
M: ppc %saturated-mul-vector-reps { } ;
|
||||
M: ppc %div-vector-reps { } ;
|
||||
M: ppc %min-vector-reps { } ;
|
||||
M: ppc %max-vector-reps { } ;
|
||||
M: ppc %dot-vector-reps { } ;
|
||||
M: ppc %sqrt-vector-reps { } ;
|
||||
M: ppc %horizontal-add-vector-reps { } ;
|
||||
M: ppc %horizontal-sub-vector-reps { } ;
|
||||
M: ppc %abs-vector-reps { } ;
|
||||
M: ppc %and-vector-reps { } ;
|
||||
M: ppc %andn-vector-reps { } ;
|
||||
M: ppc %or-vector-reps { } ;
|
||||
M: ppc %xor-vector-reps { } ;
|
||||
M: ppc %not-vector-reps { } ;
|
||||
M: ppc %shl-vector-reps { } ;
|
||||
M: ppc %shr-vector-reps { } ;
|
||||
M: ppc %horizontal-shl-vector-reps { } ;
|
||||
M: ppc %horizontal-shr-vector-reps { } ;
|
||||
|
||||
M: ppc %unbox-alien ( dst src -- )
|
||||
alien-offset LWZ ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1 +0,0 @@
|
|||
DirectInput backend for game-input
|
||||
|
|
@ -1 +0,0 @@
|
|||
IOKit HID Manager backend for game-input
|
||||
|
|
@ -1,6 +1,6 @@
|
|||
USING: accessors alien alien.c-types alien.strings arrays
|
||||
assocs byte-arrays combinators combinators.short-circuit
|
||||
continuations game-input game-input.dinput.keys-array
|
||||
continuations game.input game.input.dinput.keys-array
|
||||
io.encodings.utf16 io.encodings.utf16n kernel locals math
|
||||
math.bitwise math.rectangles namespaces parser sequences
|
||||
shuffle specialized-arrays ui.backend.windows vectors
|
||||
|
|
@ -8,7 +8,7 @@ windows.com windows.dinput windows.dinput.constants
|
|||
windows.errors windows.kernel32 windows.messages
|
||||
windows.ole32 windows.user32 classes.struct alien.data ;
|
||||
SPECIALIZED-ARRAY: DIDEVICEOBJECTDATA
|
||||
IN: game-input.dinput
|
||||
IN: game.input.dinput
|
||||
|
||||
CONSTANT: MOUSE-BUFFER-SIZE 16
|
||||
|
||||
|
|
@ -1,6 +1,6 @@
|
|||
USING: sequences sequences.private math
|
||||
accessors alien.data ;
|
||||
IN: game-input.dinput.keys-array
|
||||
IN: game.input.dinput.keys-array
|
||||
|
||||
TUPLE: keys-array
|
||||
{ underlying sequence read-only }
|
||||
|
|
@ -0,0 +1 @@
|
|||
DirectInput backend for game.input
|
||||
|
|
@ -1,9 +1,9 @@
|
|||
USING: help.markup help.syntax kernel ui.gestures quotations
|
||||
sequences strings math ;
|
||||
IN: game-input
|
||||
IN: game.input
|
||||
|
||||
ARTICLE: "game-input" "Game controller input"
|
||||
"The " { $vocab-link "game-input" } " vocabulary provides cross-platform access to game controller devices such as joysticks and gamepads. It also provides an interface for polling raw keyboard and mouse input." $nl
|
||||
"The " { $vocab-link "game.input" } " vocabulary provides cross-platform access to game controller devices such as joysticks and gamepads. It also provides an interface for polling raw keyboard and mouse input." $nl
|
||||
"The game input interface must be initialized before being used:"
|
||||
{ $subsections
|
||||
open-game-input
|
||||
|
|
@ -136,8 +136,8 @@ HELP: controller-state
|
|||
{ "A value of " { $link f } " in any slot (besides the elements of " { $snippet "buttons" } ") indicates that the corresponding element is not present on the device." } } } ;
|
||||
|
||||
HELP: keyboard-state
|
||||
{ $class-description "The " { $link read-keyboard } " word returns objects of this class. The " { $snippet "keys" } " slot of a " { $snippet "keyboard-state" } " object contains a " { $link sequence } " of 256 members representing the state of the keys on the keyboard. Each element is a boolean value indicating whether the corresponding key is pressed. The sequence is indexed by scancode as defined under usage page 7 of the USB HID standard. Named scancode constants are provided in the " { $vocab-link "game-input.scancodes" } " vocabulary." }
|
||||
{ $warning "The scancodes used to index " { $snippet "keyboard-state" } " objects correspond to physical key positions on the keyboard--they are unaffected by keymaps, modifier keys, or other operating environment postprocessing. The face value of the constants in " { $vocab-link "game-input.scancodes" } " do not necessarily correspond to what the user expects the key to type. Because of this, " { $link read-keyboard } " should not be used for text entry purposes. The Factor UI's standard gesture mechanism should be used in cases where the logical meaning of keypresses is needed; see " { $link "keyboard-gestures" } "." } ;
|
||||
{ $class-description "The " { $link read-keyboard } " word returns objects of this class. The " { $snippet "keys" } " slot of a " { $snippet "keyboard-state" } " object contains a " { $link sequence } " of 256 members representing the state of the keys on the keyboard. Each element is a boolean value indicating whether the corresponding key is pressed. The sequence is indexed by scancode as defined under usage page 7 of the USB HID standard. Named scancode constants are provided in the " { $vocab-link "game.input.scancodes" } " vocabulary." }
|
||||
{ $warning "The scancodes used to index " { $snippet "keyboard-state" } " objects correspond to physical key positions on the keyboard--they are unaffected by keymaps, modifier keys, or other operating environment postprocessing. The face value of the constants in " { $vocab-link "game.input.scancodes" } " do not necessarily correspond to what the user expects the key to type. Because of this, " { $link read-keyboard } " should not be used for text entry purposes. The Factor UI's standard gesture mechanism should be used in cases where the logical meaning of keypresses is needed; see " { $link "keyboard-gestures" } "." } ;
|
||||
|
||||
HELP: mouse-state
|
||||
{ $class-description "The " { $link read-mouse } " word returns objects of this class. " { $snippet "mouse-state" } " objects have the following slots:"
|
||||
|
|
@ -1,6 +1,6 @@
|
|||
USING: ui game-input tools.test kernel system threads calendar
|
||||
USING: ui game.input tools.test kernel system threads calendar
|
||||
combinators.short-circuit ;
|
||||
IN: game-input.tests
|
||||
IN: game.input.tests
|
||||
|
||||
os { [ windows? ] [ macosx? ] } 1|| [
|
||||
[ ] [ open-game-input ] unit-test
|
||||
|
|
@ -1,6 +1,6 @@
|
|||
USING: arrays accessors continuations kernel math system
|
||||
sequences namespaces init vocabs vocabs.loader combinators ;
|
||||
IN: game-input
|
||||
IN: game.input
|
||||
|
||||
SYMBOLS: game-input-backend game-input-opened ;
|
||||
|
||||
|
|
@ -91,7 +91,7 @@ M: mouse-state clone
|
|||
call-next-method dup buttons>> clone >>buttons ;
|
||||
|
||||
{
|
||||
{ [ os windows? ] [ "game-input.dinput" require ] }
|
||||
{ [ os macosx? ] [ "game-input.iokit" require ] }
|
||||
{ [ os windows? ] [ "game.input.dinput" require ] }
|
||||
{ [ os macosx? ] [ "game.input.iokit" require ] }
|
||||
{ [ t ] [ ] }
|
||||
} cond
|
||||
|
|
@ -3,9 +3,9 @@ kernel cocoa.enumeration destructors math.parser cocoa.application
|
|||
sequences locals combinators.short-circuit threads
|
||||
namespaces assocs arrays combinators hints alien
|
||||
core-foundation.run-loop accessors sequences.private
|
||||
alien.c-types alien.data math parser game-input vectors
|
||||
alien.c-types alien.data math parser game.input vectors
|
||||
bit-arrays ;
|
||||
IN: game-input.iokit
|
||||
IN: game.input.iokit
|
||||
|
||||
SINGLETON: iokit-game-input-backend
|
||||
|
||||
|
|
@ -0,0 +1 @@
|
|||
IOKit HID Manager backend for game.input
|
||||
|
|
@ -1,4 +1,4 @@
|
|||
IN: game-input.scancodes
|
||||
IN: game.input.scancodes
|
||||
|
||||
CONSTANT: key-undefined HEX: 0000
|
||||
CONSTANT: key-error-roll-over HEX: 0001
|
||||
|
|
@ -26,6 +26,9 @@ CONSTANT: indexed-color 3
|
|||
CONSTANT: greyscale-alpha 4
|
||||
CONSTANT: truecolor-alpha 6
|
||||
|
||||
CONSTANT: interlace-none 0
|
||||
CONSTANT: interlace-adam7 1
|
||||
|
||||
: <loading-png> ( -- image )
|
||||
loading-png new
|
||||
V{ } clone >>chunks ;
|
||||
|
|
@ -86,8 +89,8 @@ ERROR: unimplemented-color-type image ;
|
|||
|
||||
: png-bytes-per-pixel ( loading-png -- n )
|
||||
dup color-type>> {
|
||||
{ 2 [ scale-bit-depth 3 * ] }
|
||||
{ 6 [ scale-bit-depth 4 * ] }
|
||||
{ truecolor [ scale-bit-depth 3 * ] }
|
||||
{ truecolor-alpha [ scale-bit-depth 4 * ] }
|
||||
[ unknown-color-type ]
|
||||
} case ; inline
|
||||
|
||||
|
|
@ -118,20 +121,41 @@ ERROR: unimplemented-color-type image ;
|
|||
lines dup first length 0 <array> prefix
|
||||
[ n 1 - 0 <array> prepend ] map
|
||||
2 clump [
|
||||
n swap first2 [ ] [ n 1 - swap nth ] [ [ 0 n 1 - ] dip set-nth ] tri
|
||||
n swap first2
|
||||
[ ]
|
||||
[ n 1 - swap nth ]
|
||||
[ [ 0 n 1 - ] dip set-nth ] tri
|
||||
png-unfilter-line
|
||||
] map B{ } concat-as ;
|
||||
|
||||
ERROR: unimplemented-interlace ;
|
||||
|
||||
: reverse-interlace ( byte-array loading-png -- byte-array )
|
||||
{
|
||||
{ interlace-none [ ] }
|
||||
{ interlace-adam7 [ unimplemented-interlace ] }
|
||||
[ unimplemented-interlace ]
|
||||
} case ;
|
||||
|
||||
: png-image-bytes ( loading-png -- byte-array )
|
||||
[ png-bytes-per-pixel ]
|
||||
[ inflate-data ]
|
||||
[ [ inflate-data ] [ interlace-method>> ] bi reverse-interlace ]
|
||||
[ png-group-width ] tri group reverse-png-filter ;
|
||||
|
||||
ERROR: unknown-component-type n ;
|
||||
|
||||
: png-component ( loading-png -- obj )
|
||||
bit-depth>> {
|
||||
{ 8 [ ubyte-components ] }
|
||||
{ 16 [ ushort-components ] }
|
||||
[ unknown-component-type ]
|
||||
} case ;
|
||||
|
||||
: loading-png>image ( loading-png -- image )
|
||||
[ image new ] dip {
|
||||
[ png-image-bytes >>bitmap ]
|
||||
[ [ width>> ] [ height>> ] bi 2array >>dim ]
|
||||
[ drop ubyte-components >>component-type ]
|
||||
[ png-component >>component-type ]
|
||||
} cleave ;
|
||||
|
||||
: decode-greyscale ( loading-png -- image )
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: assocs help.markup help.syntax math sequences ;
|
||||
USING: assocs help.markup help.syntax math sequences kernel ;
|
||||
IN: math.bitwise
|
||||
|
||||
HELP: bitfield
|
||||
|
|
@ -67,17 +67,21 @@ HELP: bit-clear?
|
|||
|
||||
HELP: bit-count
|
||||
{ $values
|
||||
{ "x" integer }
|
||||
{ "obj" object }
|
||||
{ "n" integer }
|
||||
}
|
||||
{ $description "Returns the number of set bits as an integer." }
|
||||
{ $description "Returns the number of set bits as an object. This word only works on non-negative integers or objects that can be represented as a byte-array." }
|
||||
{ $examples
|
||||
{ $example "USING: math.bitwise prettyprint ;"
|
||||
"HEX: f0 bit-count ."
|
||||
"4"
|
||||
}
|
||||
{ $example "USING: math.bitwise prettyprint ;"
|
||||
"-7 bit-count ."
|
||||
"-1 32 bits bit-count ."
|
||||
"32"
|
||||
}
|
||||
{ $example "USING: math.bitwise prettyprint ;"
|
||||
"B{ 1 0 1 } bit-count ."
|
||||
"2"
|
||||
}
|
||||
} ;
|
||||
|
|
@ -206,6 +210,20 @@ HELP: mask?
|
|||
}
|
||||
} ;
|
||||
|
||||
HELP: even-parity?
|
||||
{ $values
|
||||
{ "obj" object }
|
||||
{ "?" boolean }
|
||||
}
|
||||
{ $description "Returns true if the number of set bits in an object is even." } ;
|
||||
|
||||
HELP: odd-parity?
|
||||
{ $values
|
||||
{ "obj" object }
|
||||
{ "?" boolean }
|
||||
}
|
||||
{ $description "Returns true if the number of set bits in an object is odd." } ;
|
||||
|
||||
HELP: on-bits
|
||||
{ $values
|
||||
{ "n" integer }
|
||||
|
|
@ -368,6 +386,8 @@ $nl
|
|||
{ $subsections on-bits }
|
||||
"Counting the number of set bits:"
|
||||
{ $subsections bit-count }
|
||||
"Testing the parity of an object:"
|
||||
{ $subsections even-parity? odd-parity? }
|
||||
"More efficient modding by powers of two:"
|
||||
{ $subsections wrap }
|
||||
"Bit-rolling:"
|
||||
|
|
|
|||
|
|
@ -1,4 +1,7 @@
|
|||
USING: accessors math math.bitwise tools.test kernel words ;
|
||||
USING: accessors math math.bitwise tools.test kernel words
|
||||
specialized-arrays alien.c-types math.vectors.simd
|
||||
sequences destructors libc ;
|
||||
SPECIALIZED-ARRAY: int
|
||||
IN: math.bitwise.tests
|
||||
|
||||
[ 0 ] [ 1 0 0 bitroll ] unit-test
|
||||
|
|
@ -37,3 +40,23 @@ CONSTANT: b 2
|
|||
[ 4 ] [ BIN: 1010101 bit-count ] unit-test
|
||||
[ 0 ] [ BIN: 0 bit-count ] unit-test
|
||||
[ 1 ] [ BIN: 1 bit-count ] unit-test
|
||||
|
||||
SIMD: uint
|
||||
SPECIALIZED-ARRAY: uint
|
||||
SPECIALIZED-ARRAY: uint-4
|
||||
|
||||
[ 1 ] [ uint-4{ 1 0 0 0 } bit-count ] unit-test
|
||||
|
||||
[ 1 ] [
|
||||
[
|
||||
2 malloc-int-array &free 1 0 pick set-nth bit-count
|
||||
] with-destructors
|
||||
] unit-test
|
||||
|
||||
[ 1 ] [ B{ 1 0 0 } bit-count ] unit-test
|
||||
[ 3 ] [ B{ 1 1 1 } bit-count ] unit-test
|
||||
|
||||
[ t ] [ BIN: 0 even-parity? ] unit-test
|
||||
[ f ] [ BIN: 1 even-parity? ] unit-test
|
||||
[ f ] [ BIN: 0 odd-parity? ] unit-test
|
||||
[ t ] [ BIN: 1 odd-parity? ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,7 +1,9 @@
|
|||
! Copyright (C) 2007, 2008 Slava Pestov, Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays assocs combinators combinators.smart fry kernel
|
||||
macros math math.bits sequences sequences.private words ;
|
||||
macros math math.bits sequences sequences.private words
|
||||
byte-arrays alien alien.c-types specialized-arrays ;
|
||||
SPECIALIZED-ARRAY: uchar
|
||||
IN: math.bitwise
|
||||
|
||||
! utilities
|
||||
|
|
@ -84,24 +86,36 @@ DEFER: byte-bit-count
|
|||
GENERIC: (bit-count) ( x -- n )
|
||||
|
||||
M: fixnum (bit-count)
|
||||
[
|
||||
{
|
||||
[ byte-bit-count ]
|
||||
[ -8 shift byte-bit-count ]
|
||||
[ -16 shift byte-bit-count ]
|
||||
[ -24 shift byte-bit-count ]
|
||||
} cleave
|
||||
] sum-outputs ;
|
||||
0 swap [
|
||||
dup 0 >
|
||||
] [
|
||||
[ 8 bits byte-bit-count ] [ -8 shift ] bi
|
||||
[ + ] dip
|
||||
] while drop ;
|
||||
|
||||
M: bignum (bit-count)
|
||||
dup 0 = [ drop 0 ] [
|
||||
[ byte-bit-count ] [ -8 shift (bit-count) ] bi +
|
||||
] if ;
|
||||
|
||||
: byte-array-bit-count ( byte-array -- n )
|
||||
0 [ byte-bit-count + ] reduce ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: bit-count ( x -- n )
|
||||
dup 0 < [ bitnot ] when (bit-count) ; inline
|
||||
ERROR: invalid-bit-count-target object ;
|
||||
|
||||
GENERIC: bit-count ( obj -- n )
|
||||
|
||||
M: integer bit-count
|
||||
dup 0 < [ invalid-bit-count-target ] when (bit-count) ; inline
|
||||
|
||||
M: byte-array bit-count
|
||||
byte-array-bit-count ;
|
||||
|
||||
M: object bit-count
|
||||
[ >c-ptr ] [ byte-length ] bi <direct-uchar-array>
|
||||
byte-array-bit-count ;
|
||||
|
||||
: >signed ( x n -- y )
|
||||
2dup neg 1 + shift 1 = [ 2^ - ] [ drop ] if ;
|
||||
|
|
@ -113,3 +127,7 @@ PRIVATE>
|
|||
: next-even ( m -- n ) >even 2 + ; foldable
|
||||
|
||||
: next-odd ( m -- n ) dup even? [ 1 + ] [ 2 + ] if ; foldable
|
||||
|
||||
: even-parity? ( obj -- ? ) bit-count even? ;
|
||||
|
||||
: odd-parity? ( obj -- ? ) bit-count odd? ;
|
||||
|
|
|
|||
|
|
@ -80,3 +80,4 @@ M: mersenne-twister random-32* ( mt -- r )
|
|||
[
|
||||
default-mersenne-twister random-generator set-global
|
||||
] "bootstrap.random" add-init-hook
|
||||
|
||||
|
|
|
|||
|
|
@ -4,14 +4,27 @@ USING: accessors kernel random random.sfmt random.sfmt.private
|
|||
sequences tools.test ;
|
||||
IN: random.sfmt.tests
|
||||
|
||||
[ ] [ 100 <sfmt-19937> drop ] unit-test
|
||||
! Period certified by virtue of seed
|
||||
[ ] [ 5 <sfmt-19937> drop ] unit-test
|
||||
|
||||
[ 1096298955 ]
|
||||
[ 100 <sfmt-19937> dup generate dup generate uint-array>> first ] unit-test
|
||||
[ 1331696015 ]
|
||||
[ 5 <sfmt-19937> dup generate dup generate uint-array>> first ] unit-test
|
||||
|
||||
[ 2556114782 ]
|
||||
[ 100 <sfmt-19937> random-32* ] unit-test
|
||||
[ 1432875926 ]
|
||||
[ 5 <sfmt-19937> random-32* ] unit-test
|
||||
|
||||
|
||||
! Period certified by flipping a bit
|
||||
[ ] [ 7 <sfmt-19937> drop ] unit-test
|
||||
|
||||
[ 1674111379 ]
|
||||
[ 7 <sfmt-19937> dup generate dup generate uint-array>> first ] unit-test
|
||||
|
||||
[ 489955657 ]
|
||||
[ 7 <sfmt-19937> random-32* ] unit-test
|
||||
|
||||
|
||||
! Test re-seeding SFMT
|
||||
[ t ]
|
||||
[
|
||||
100 <sfmt-19937>
|
||||
|
|
|
|||
|
|
@ -2,7 +2,8 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors alien.c-types kernel locals math math.ranges
|
||||
math.bitwise math.vectors math.vectors.simd random
|
||||
sequences specialized-arrays sequences.private classes.struct ;
|
||||
sequences specialized-arrays sequences.private classes.struct
|
||||
combinators.short-circuit fry ;
|
||||
SIMD: uint
|
||||
SPECIALIZED-ARRAY: uint
|
||||
SPECIALIZED-ARRAY: uint-4
|
||||
|
|
@ -16,8 +17,9 @@ STRUCT: sfmt-state
|
|||
{ seed uint }
|
||||
{ n uint }
|
||||
{ m uint }
|
||||
{ ix uint }
|
||||
{ index uint }
|
||||
{ mask uint-4 }
|
||||
{ parity uint-4 }
|
||||
{ r1 uint-4 }
|
||||
{ r2 uint-4 } ;
|
||||
|
||||
|
|
@ -76,47 +78,65 @@ M:: sfmt generate ( sfmt -- )
|
|||
r state (>>r2)
|
||||
] each
|
||||
|
||||
0 state (>>ix) ;
|
||||
0 state (>>index) ;
|
||||
|
||||
: period-certified? ( sfmt -- ? )
|
||||
[ uint-4-array>> first ]
|
||||
[ state>> parity>> ] bi vbitand odd-parity? ;
|
||||
|
||||
: first-set-bit ( x -- n )
|
||||
0 swap [
|
||||
dup { [ 0 > ] [ 1 bitand 0 = ] } 1&&
|
||||
] [
|
||||
[ 1 + ] [ -1 shift ] bi*
|
||||
] while drop ;
|
||||
|
||||
: correct-period ( sfmt -- )
|
||||
[ drop 0 ]
|
||||
[ state>> parity>> first first-set-bit ]
|
||||
[ uint-array>> swap '[ _ toggle-bit ] change-nth ] tri ;
|
||||
|
||||
: certify-period ( sfmt -- sfmt )
|
||||
dup period-certified? [ dup correct-period ] unless ;
|
||||
|
||||
: <sfmt-array> ( sfmt -- uint-array uint-4-array )
|
||||
state>>
|
||||
[ n>> 4 * iota >uint-array ] [ seed>> ] bi
|
||||
[
|
||||
[ n>> 4 * 1 swap [a,b] >uint-array ] [ seed>> ] bi
|
||||
[
|
||||
[
|
||||
[ -30 shift ] [ ] bi bitxor
|
||||
state-multiplier * 32 bits
|
||||
] dip +
|
||||
] unless-zero 32 bits
|
||||
] dip + 32 bits
|
||||
] uint-array{ } accumulate-as nip
|
||||
dup underlying>> byte-array>uint-4-array ;
|
||||
|
||||
: <sfmt-state> ( seed n m mask -- sfmt )
|
||||
: <sfmt-state> ( seed n m mask parity -- sfmt )
|
||||
sfmt-state <struct>
|
||||
swap >>parity
|
||||
swap >>mask
|
||||
swap >>m
|
||||
swap >>n
|
||||
swap >>seed
|
||||
0 >>ix ;
|
||||
0 >>index ;
|
||||
|
||||
: init-sfmt ( sfmt -- sfmt' )
|
||||
dup <sfmt-array> [ >>uint-array ] [ >>uint-4-array ] bi*
|
||||
[ generate ] keep ; inline
|
||||
certify-period [ generate ] keep ; inline
|
||||
|
||||
: <sfmt> ( seed n m mask -- sfmt )
|
||||
: <sfmt> ( seed n m mask parity -- sfmt )
|
||||
<sfmt-state>
|
||||
sfmt new
|
||||
swap >>state
|
||||
init-sfmt ; inline
|
||||
|
||||
: refill-sfmt? ( sfmt -- ? )
|
||||
state>> [ ix>> ] [ n>> 4 * ] bi >= ;
|
||||
state>> [ index>> ] [ n>> 4 * ] bi >= ; inline
|
||||
|
||||
: next-ix ( sfmt -- ix )
|
||||
state>> [ dup 1 + ] change-ix drop ; inline
|
||||
: next-index ( sfmt -- index )
|
||||
state>> [ dup 1 + ] change-index drop ; inline
|
||||
|
||||
: next ( sfmt -- n )
|
||||
[ next-ix ] [ uint-array>> ] bi nth-unsafe ; inline
|
||||
[ next-index ] [ uint-array>> ] bi nth-unsafe ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
|
|
@ -128,5 +148,10 @@ M: sfmt seed-random ( sfmt seed -- sfmt )
|
|||
[ drop init-sfmt ] 2bi ;
|
||||
|
||||
: <sfmt-19937> ( seed -- sfmt )
|
||||
348 330 uint-4{ HEX: BFFFFFF6 HEX: BFFAFFFF HEX: DDFECB7F HEX: DFFFFFEF }
|
||||
156 122
|
||||
uint-4{ HEX: dfffffef HEX: ddfecb7f HEX: bffaffff HEX: bffffff6 }
|
||||
uint-4{ HEX: 1 HEX: 0 HEX: 0 HEX: 13c9e684 }
|
||||
<sfmt> ; inline
|
||||
|
||||
: default-sfmt ( -- sfmt )
|
||||
[ random-32 ] with-secure-random <sfmt-19937> ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Doug Coleman
|
||||
|
|
@ -0,0 +1,11 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: fry kernel math random random.mersenne-twister ;
|
||||
IN: benchmark.mt
|
||||
|
||||
: mt-benchmark ( n -- )
|
||||
>fixnum HEX: 533d <mersenne-twister> '[ _ random-32* drop ] times ;
|
||||
|
||||
: mt-main ( -- ) 10000000 mt-benchmark ;
|
||||
|
||||
MAIN: mt-main
|
||||
|
|
@ -6,6 +6,6 @@ IN: benchmark.sfmt
|
|||
: sfmt-benchmark ( n -- )
|
||||
>fixnum HEX: 533d <sfmt-19937> '[ _ random-32* drop ] times ;
|
||||
|
||||
: sfmt-main ( -- ) 100000000 sfmt-benchmark ;
|
||||
: sfmt-main ( -- ) 10000000 sfmt-benchmark ;
|
||||
|
||||
MAIN: sfmt-main
|
||||
|
|
|
|||
|
|
@ -9,4 +9,4 @@ ERROR: empty-xor-key ;
|
|||
|
||||
: xor-crypt ( seq key -- seq' )
|
||||
[ empty-xor-key ] when-empty
|
||||
[ dup length ] dip '[ _ mod-nth bitxor ] 2map ;
|
||||
[ dup length iota ] dip '[ _ mod-nth bitxor ] 2map ;
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
USING: accessors calendar continuations destructors kernel math
|
||||
math.order namespaces system threads ui ui.gadgets.worlds
|
||||
sequences ;
|
||||
IN: game-loop
|
||||
IN: game.loop
|
||||
|
||||
TUPLE: game-loop
|
||||
{ tick-length integer read-only }
|
||||
|
|
@ -106,4 +106,4 @@ M: game-loop dispose
|
|||
|
||||
USING: vocabs vocabs.loader ;
|
||||
|
||||
"prettyprint" vocab [ "game-loop.prettyprint" require ] when
|
||||
"prettyprint" vocab [ "game.loop.prettyprint" require ] when
|
||||
|
|
@ -1,6 +1,6 @@
|
|||
! (c)2009 Joe Groff bsd license
|
||||
USING: accessors debugger game-loop io ;
|
||||
IN: game-loop.prettyprint
|
||||
USING: accessors debugger game.loop io ;
|
||||
IN: game.loop.prettyprint
|
||||
|
||||
M: game-loop-error error.
|
||||
"An error occurred inside a game loop." print
|
||||
|
|
@ -1,6 +1,6 @@
|
|||
USING: accessors game-input game-loop kernel math ui.gadgets
|
||||
USING: accessors game.input game.loop kernel math ui.gadgets
|
||||
ui.gadgets.worlds ui.gestures threads ;
|
||||
IN: game-worlds
|
||||
IN: game.worlds
|
||||
|
||||
TUPLE: game-world < world
|
||||
game-loop
|
||||
|
|
@ -1,6 +1,6 @@
|
|||
! (c)2009 Joe Groff bsd license
|
||||
USING: accessors alien.c-types arrays classes.struct combinators
|
||||
combinators.short-circuit game-worlds gpu gpu.buffers
|
||||
combinators.short-circuit game.worlds gpu gpu.buffers
|
||||
gpu.util.wasd gpu.framebuffers gpu.render gpu.shaders gpu.state
|
||||
gpu.textures gpu.util grouping http.client images images.loader
|
||||
io io.encodings.ascii io.files io.files.temp kernel math
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
! (c)2009 Joe Groff bsd license
|
||||
USING: accessors arrays combinators.tuple game-loop game-worlds
|
||||
USING: accessors arrays combinators.tuple game.loop game.worlds
|
||||
generalizations gpu gpu.render gpu.shaders gpu.util gpu.util.wasd
|
||||
kernel literals math math.matrices math.order math.vectors
|
||||
method-chains sequences ui ui.gadgets ui.gadgets.worlds
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
! (c)2009 Joe Groff bsd license
|
||||
USING: accessors arrays combinators.smart game-input
|
||||
game-input.scancodes game-loop game-worlds
|
||||
USING: accessors arrays combinators.smart game.input
|
||||
game.input.scancodes game.loop game.worlds
|
||||
gpu.render gpu.state kernel literals
|
||||
locals math math.constants math.functions math.matrices
|
||||
math.order math.vectors opengl.gl sequences
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
USING: ui ui.gadgets sequences kernel arrays math colors
|
||||
colors.constants ui.render ui.pens.polygon ui.pens.solid math.vectors
|
||||
accessors fry ui.gadgets.packs game-input ui.gadgets.labels
|
||||
accessors fry ui.gadgets.packs game.input ui.gadgets.labels
|
||||
ui.gadgets.borders alarms calendar locals strings ui.gadgets.buttons
|
||||
combinators math.parser assocs threads ;
|
||||
IN: joystick-demo
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
USING: game-input game-input.scancodes
|
||||
USING: game.input game.input.scancodes
|
||||
kernel ui.gadgets ui.gadgets.buttons sequences accessors
|
||||
words arrays assocs math calendar fry alarms ui
|
||||
ui.gadgets.borders ui.gestures ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Doug Coleman
|
||||
|
|
@ -0,0 +1,42 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays kernel random random.cmwc sequences tools.test ;
|
||||
IN: random.cmwc.tests
|
||||
|
||||
[ ] [
|
||||
cmwc-4096 [
|
||||
random-32 drop
|
||||
] with-random
|
||||
] unit-test
|
||||
|
||||
[
|
||||
{
|
||||
4294604858
|
||||
4294948512
|
||||
4294929730
|
||||
4294910948
|
||||
4294892166
|
||||
4294873384
|
||||
4294854602
|
||||
4294835820
|
||||
4294817038
|
||||
4294798256
|
||||
}
|
||||
] [
|
||||
cmwc-4096
|
||||
4096 iota >array 362436 <cmwc-seed> seed-random [
|
||||
10 [ random-32 ] replicate
|
||||
] with-random
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
cmwc-4096 [
|
||||
4096 iota >array 362436 <cmwc-seed> seed-random [
|
||||
10 [ random-32 ] replicate
|
||||
] with-random
|
||||
] [
|
||||
4096 iota >array 362436 <cmwc-seed> seed-random [
|
||||
10 [ random-32 ] replicate
|
||||
] with-random
|
||||
] bi =
|
||||
] unit-test
|
||||
|
|
@ -0,0 +1,54 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays fry kernel locals math math.bitwise
|
||||
random sequences ;
|
||||
IN: random.cmwc
|
||||
|
||||
! Multiply-with-carry RNG
|
||||
|
||||
TUPLE: cmwc Q a b c i r mod ;
|
||||
|
||||
TUPLE: cmwc-seed Q c ;
|
||||
|
||||
: <cmwc> ( length a b c -- cmwc )
|
||||
cmwc new
|
||||
swap >>c
|
||||
swap >>b
|
||||
swap >>a
|
||||
swap [ 1 - >>i ] [ 0 <array> >>Q ] bi
|
||||
dup b>> 1 - >>r
|
||||
dup Q>> length 1 - >>mod ;
|
||||
|
||||
: <cmwc-seed> ( Q c -- cmwc-seed )
|
||||
cmwc-seed new
|
||||
swap >>c
|
||||
swap >>Q ; inline
|
||||
|
||||
M: cmwc seed-random
|
||||
[ Q>> >>Q ]
|
||||
[ Q>> length 1 - >>i ]
|
||||
[ c>> >>c ] tri ;
|
||||
|
||||
M:: cmwc random-32* ( cmwc -- n )
|
||||
cmwc dup mod>> '[ 1 + _ bitand ] change-i
|
||||
[ a>> ]
|
||||
[ [ i>> ] [ Q>> ] bi nth * ]
|
||||
[ c>> + ] tri :> t!
|
||||
|
||||
t -32 shift cmwc (>>c)
|
||||
|
||||
t cmwc [ b>> bitand ] [ c>> + ] bi 64 bits t!
|
||||
t cmwc r>> > [
|
||||
cmwc [ 1 + ] change-c drop
|
||||
t cmwc b>> - 64 bits t!
|
||||
] when
|
||||
|
||||
cmwc [ r>> t - 32 bits dup ] [ i>> ] [ Q>> ] tri set-nth ;
|
||||
|
||||
: cmwc-4096 ( -- cmwc )
|
||||
4096
|
||||
[ 18782 4294967295 362436 <cmwc> ]
|
||||
[
|
||||
'[ [ random-32 ] replicate ] with-system-random
|
||||
362436 <cmwc-seed> seed-random
|
||||
] bi ;
|
||||
|
|
@ -0,0 +1 @@
|
|||
Doug Coleman
|
||||
|
|
@ -0,0 +1,24 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: fry kernel math.functions random random.lagged-fibonacci
|
||||
sequences specialized-arrays.instances.double tools.test ;
|
||||
IN: random.lagged-fibonacci.tests
|
||||
|
||||
[ t ] [
|
||||
3 <lagged-fibonacci> [
|
||||
1000 [ random-float ] double-array{ } replicate-as
|
||||
999 swap nth 0.860072135925293 -.01 ~
|
||||
] with-random
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
3 <lagged-fibonacci> [
|
||||
[
|
||||
1000 [ random-float ] double-array{ } replicate-as
|
||||
] with-random
|
||||
] [
|
||||
3 seed-random [
|
||||
1000 [ random-float ] double-array{ } replicate-as
|
||||
] with-random =
|
||||
] bi
|
||||
] unit-test
|
||||
|
|
@ -0,0 +1,71 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors alien.c-types fry kernel literals locals math
|
||||
random sequences specialized-arrays namespaces ;
|
||||
SPECIALIZED-ARRAY: double
|
||||
IN: random.lagged-fibonacci
|
||||
|
||||
TUPLE: lagged-fibonacci u pt0 pt1 ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
CONSTANT: p-r 1278
|
||||
CONSTANT: q-r 417
|
||||
|
||||
CONSTANT: lagged-fibonacci 899999963
|
||||
CONSTANT: lagged-fibonacci-max-seed 900000000
|
||||
CONSTANT: lagged-fibonacci-sig-bits 24
|
||||
|
||||
: normalize-seed ( seed -- seed' )
|
||||
abs lagged-fibonacci-max-seed mod ;
|
||||
|
||||
: adjust-ptr ( ptr -- ptr' )
|
||||
1 - dup 0 < [ drop p-r ] when ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
M:: lagged-fibonacci seed-random ( lagged-fibonacci seed! -- lagged-fibonacci )
|
||||
seed normalize-seed seed!
|
||||
seed 30082 /i :> ij
|
||||
seed 30082 ij * - :> kl
|
||||
ij 177 /i 177 mod 2 + :> i!
|
||||
ij 177 mod 2 + :> j!
|
||||
kl 169 /i 178 mod 1 + :> k!
|
||||
kl 169 mod :> l!
|
||||
|
||||
lagged-fibonacci u>> [
|
||||
drop
|
||||
0.0 :> s!
|
||||
0.5 :> t!
|
||||
0.0 :> m!
|
||||
lagged-fibonacci-sig-bits [
|
||||
i j * 179 mod k * 179 mod m!
|
||||
j i!
|
||||
k j!
|
||||
m k!
|
||||
53 l * 1 + 169 mod l!
|
||||
l m * 64 mod 31 > [ s t + s! ] when
|
||||
t 0.5 * t!
|
||||
] times
|
||||
s
|
||||
] change-each
|
||||
lagged-fibonacci p-r >>pt0
|
||||
q-r >>pt1 ;
|
||||
|
||||
: <lagged-fibonacci> ( seed -- lagged-fibonacci )
|
||||
lagged-fibonacci new
|
||||
p-r 1 + <double-array> >>u
|
||||
swap seed-random ;
|
||||
|
||||
GENERIC: random-float* ( tuple -- r )
|
||||
|
||||
: random-float ( -- n ) random-generator get random-float* ;
|
||||
|
||||
M:: lagged-fibonacci random-float* ( lagged-fibonacci -- x )
|
||||
lagged-fibonacci [ pt0>> ] [ u>> ] bi nth
|
||||
lagged-fibonacci [ pt1>> ] [ u>> ] bi nth - :> uni!
|
||||
uni 0.0 < [ uni 1.0 + uni! ] when
|
||||
uni lagged-fibonacci [ pt0>> ] [ u>> ] bi set-nth
|
||||
lagged-fibonacci [ adjust-ptr ] change-pt0 drop
|
||||
lagged-fibonacci [ adjust-ptr ] change-pt1 drop
|
||||
uni ; inline
|
||||
|
|
@ -1,12 +1,12 @@
|
|||
! (c)2009 Joe Groff, Doug Coleman. bsd license
|
||||
USING: accessors arrays combinators game-input game-loop
|
||||
game-input.scancodes grouping kernel literals locals
|
||||
USING: accessors arrays combinators game.input game.loop
|
||||
game.input.scancodes grouping kernel literals locals
|
||||
math math.constants math.functions math.matrices math.order
|
||||
math.vectors opengl opengl.capabilities opengl.gl
|
||||
opengl.shaders opengl.textures opengl.textures.private
|
||||
sequences sequences.product specialized-arrays
|
||||
terrain.generation terrain.shaders ui ui.gadgets
|
||||
ui.gadgets.worlds ui.pixel-formats game-worlds method-chains
|
||||
ui.gadgets.worlds ui.pixel-formats game.worlds method-chains
|
||||
math.affine-transforms noise ui.gestures combinators.short-circuit
|
||||
destructors grid-meshes ;
|
||||
FROM: alien.c-types => float ;
|
||||
|
|
|
|||
|
|
@ -10,7 +10,7 @@ const char *vm_executable_path()
|
|||
static Dl_info info = {0};
|
||||
if (!info.dli_fname)
|
||||
dladdr((void *)main, &info);
|
||||
return info.dli_fname;
|
||||
return safe_strdup(info.dli_fname);
|
||||
}
|
||||
|
||||
}
|
||||
|
|
|
|||
Loading…
Reference in New Issue