diff --git a/basis/compression/huffman/huffman.factor b/basis/compression/huffman/huffman.factor index 2df4dce916..9922048009 100755 --- a/basis/compression/huffman/huffman.factor +++ b/basis/compression/huffman/huffman.factor @@ -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 ( -- 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 ) + 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 -- ) -- ) :> 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 :> 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 } ; -: ( bs tdesc -- decoder ) +: ( bs tdesc -- huffman-decoder ) huffman-decoder new - swap >>tdesc - swap >>bs - 16 >>bits/level - [ ] [ tdesc>> ] [ bits/level>> 2^ ] tri reverse-table >>rtable ; + swap >>tdesc + swap >>bs + 16 >>bits/level + 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 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 [ 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 diff --git a/basis/compression/inflate/inflate-tests.factor b/basis/compression/inflate/inflate-tests.factor new file mode 100644 index 0000000000..e2beefb9b2 --- /dev/null +++ b/basis/compression/inflate/inflate-tests.factor @@ -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 diff --git a/basis/compression/inflate/inflate.factor b/basis/compression/inflate/inflate.factor index 26b851cc1e..ab27c70ac0 100644 --- a/basis/compression/inflate/inflate.factor +++ b/basis/compression/inflate/inflate.factor @@ -1,59 +1,47 @@ ! 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 - seq ( assoc -- seq ) - dup keys [ ] [ max ] map-reduce 1 + f - [ '[ swap _ set-nth ] assoc-each ] keep ; - ERROR: zlib-unimplemented ; ERROR: bad-zlib-data ; ERROR: bad-zlib-header ; - + :: check-zlib-header ( data -- ) 16 data bs:peek 2 >le be> 31 mod ! checksum - 0 assert= + 0 assert= 4 data bs:read 8 assert= ! compression method: deflate 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 + 7 <= [ bad-zlib-header ] unless + 5 data bs:seek ! drop check bits + 1 data bs:read 0 assert= ! dictionary - not allowed in png 2 data bs:seek ! compression level; ignore ; -:: default-table ( -- table ) - 0 :> 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 clone - [ '[ _ push-at ] 2each ] keep seq>> 1 tail [ natural-sort ] map ; +: get-table ( values size -- table ) + 16 f + [ '[ _ 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 + bitstream swap [ 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,121 +49,118 @@ 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 append ] bi* ] [ suffix ] if ] reduce + ] [ ] produce swap suffix + { } [ + dup { [ array? ] [ first 16 = ] } 1&& [ + [ unclip-last-slice ] + [ second 1 + swap append ] bi* + ] [ + suffix + ] if + ] reduce [ dup array? [ second 0 ] [ 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 :> bytes - seq - [ + seq [ dup array? [ first2 '[ _ 1 - bytes nth* bytes push ] times ] [ bytes push ] if - ] each + ] each bytes ; -:: inflate-dynamic ( bitstream -- bytes ) - bitstream decode-huffman-tables - bitstream '[ _ swap ] map :> tables +:: inflate-huffman ( bitstream tables -- bytes ) + bitstream tables [ ] with map :> tables [ tables first read1-huff2 - 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 + dup 256 > [ + dup 285 = [ + dup 264 > [ + dup 261 - 4 /i + dup 5 > [ bad-zlib-data ] when + bitstream bs:read 2array + ] 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 ; - -:: inflate-raw ( bitstream -- bytes ) - 8 bitstream bs:align + +:: inflate-raw ( bitstream -- bytes ) + 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>> 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 - { + { { 0 [ inflate-raw ] } { 1 [ inflate-static ] } { 2 [ inflate-dynamic ] } { 3 [ bad-zlib-data f ] } - } - case - ] - [ produce ] keep call suffix concat ; + } case + ] [ produce ] keep call suffix concat ; PRIVATE> diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor index c7a7f0c5ef..8bf84f6670 100644 --- a/basis/cpu/architecture/architecture.factor +++ b/basis/cpu/architecture/architecture.factor @@ -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 -- ) diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor index 32c92a8da0..9237d320f3 100644 --- a/basis/cpu/ppc/ppc.factor +++ b/basis/cpu/ppc/ppc.factor @@ -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 ; diff --git a/basis/game-input/dinput/summary.txt b/basis/game-input/dinput/summary.txt deleted file mode 100755 index f758a5f83a..0000000000 --- a/basis/game-input/dinput/summary.txt +++ /dev/null @@ -1 +0,0 @@ -DirectInput backend for game-input diff --git a/basis/game-input/iokit/summary.txt b/basis/game-input/iokit/summary.txt deleted file mode 100644 index 8fc5d827d0..0000000000 --- a/basis/game-input/iokit/summary.txt +++ /dev/null @@ -1 +0,0 @@ -IOKit HID Manager backend for game-input diff --git a/basis/game-input/authors.txt b/basis/game/input/authors.txt similarity index 100% rename from basis/game-input/authors.txt rename to basis/game/input/authors.txt diff --git a/basis/game-input/dinput/authors.txt b/basis/game/input/dinput/authors.txt similarity index 100% rename from basis/game-input/dinput/authors.txt rename to basis/game/input/dinput/authors.txt diff --git a/basis/game-input/dinput/dinput.factor b/basis/game/input/dinput/dinput.factor similarity index 99% rename from basis/game-input/dinput/dinput.factor rename to basis/game/input/dinput/dinput.factor index e6a8cca477..f03147205f 100755 --- a/basis/game-input/dinput/dinput.factor +++ b/basis/game/input/dinput/dinput.factor @@ -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 diff --git a/basis/game-input/dinput/keys-array/keys-array.factor b/basis/game/input/dinput/keys-array/keys-array.factor similarity index 91% rename from basis/game-input/dinput/keys-array/keys-array.factor rename to basis/game/input/dinput/keys-array/keys-array.factor index a8813b0397..3426b89141 100755 --- a/basis/game-input/dinput/keys-array/keys-array.factor +++ b/basis/game/input/dinput/keys-array/keys-array.factor @@ -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 } diff --git a/basis/game/input/dinput/summary.txt b/basis/game/input/dinput/summary.txt new file mode 100755 index 0000000000..69a3737072 --- /dev/null +++ b/basis/game/input/dinput/summary.txt @@ -0,0 +1 @@ +DirectInput backend for game.input diff --git a/basis/game-input/dinput/tags.txt b/basis/game/input/dinput/tags.txt similarity index 100% rename from basis/game-input/dinput/tags.txt rename to basis/game/input/dinput/tags.txt diff --git a/basis/game-input/game-input-docs.factor b/basis/game/input/input-docs.factor similarity index 98% rename from basis/game-input/game-input-docs.factor rename to basis/game/input/input-docs.factor index 42e4163696..29b74ff570 100755 --- a/basis/game-input/game-input-docs.factor +++ b/basis/game/input/input-docs.factor @@ -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:" diff --git a/basis/game-input/game-input-tests.factor b/basis/game/input/input-tests.factor similarity index 69% rename from basis/game-input/game-input-tests.factor rename to basis/game/input/input-tests.factor index 10f3b5d7f5..bd993bf811 100644 --- a/basis/game-input/game-input-tests.factor +++ b/basis/game/input/input-tests.factor @@ -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 diff --git a/basis/game-input/game-input.factor b/basis/game/input/input.factor similarity index 95% rename from basis/game-input/game-input.factor rename to basis/game/input/input.factor index c21b900d8c..377a89a884 100755 --- a/basis/game-input/game-input.factor +++ b/basis/game/input/input.factor @@ -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 diff --git a/basis/game-input/iokit/authors.txt b/basis/game/input/iokit/authors.txt similarity index 100% rename from basis/game-input/iokit/authors.txt rename to basis/game/input/iokit/authors.txt diff --git a/basis/game-input/iokit/iokit.factor b/basis/game/input/iokit/iokit.factor similarity index 99% rename from basis/game-input/iokit/iokit.factor rename to basis/game/input/iokit/iokit.factor index 85f058f283..258f19ed5e 100755 --- a/basis/game-input/iokit/iokit.factor +++ b/basis/game/input/iokit/iokit.factor @@ -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 diff --git a/basis/game/input/iokit/summary.txt b/basis/game/input/iokit/summary.txt new file mode 100644 index 0000000000..5db3d08440 --- /dev/null +++ b/basis/game/input/iokit/summary.txt @@ -0,0 +1 @@ +IOKit HID Manager backend for game.input diff --git a/basis/game-input/iokit/tags.txt b/basis/game/input/iokit/tags.txt similarity index 100% rename from basis/game-input/iokit/tags.txt rename to basis/game/input/iokit/tags.txt diff --git a/basis/game-input/scancodes/authors.txt b/basis/game/input/scancodes/authors.txt similarity index 100% rename from basis/game-input/scancodes/authors.txt rename to basis/game/input/scancodes/authors.txt diff --git a/basis/game-input/scancodes/scancodes.factor b/basis/game/input/scancodes/scancodes.factor similarity index 99% rename from basis/game-input/scancodes/scancodes.factor rename to basis/game/input/scancodes/scancodes.factor index 3303a51c6f..cfa659e57a 100644 --- a/basis/game-input/scancodes/scancodes.factor +++ b/basis/game/input/scancodes/scancodes.factor @@ -1,4 +1,4 @@ -IN: game-input.scancodes +IN: game.input.scancodes CONSTANT: key-undefined HEX: 0000 CONSTANT: key-error-roll-over HEX: 0001 diff --git a/basis/game-input/scancodes/summary.txt b/basis/game/input/scancodes/summary.txt similarity index 100% rename from basis/game-input/scancodes/summary.txt rename to basis/game/input/scancodes/summary.txt diff --git a/basis/game-input/scancodes/tags.txt b/basis/game/input/scancodes/tags.txt similarity index 100% rename from basis/game-input/scancodes/tags.txt rename to basis/game/input/scancodes/tags.txt diff --git a/basis/game-input/summary.txt b/basis/game/input/summary.txt similarity index 100% rename from basis/game-input/summary.txt rename to basis/game/input/summary.txt diff --git a/basis/game-input/tags.txt b/basis/game/input/tags.txt similarity index 100% rename from basis/game-input/tags.txt rename to basis/game/input/tags.txt diff --git a/basis/images/png/png.factor b/basis/images/png/png.factor index 2af44e4e1d..08d8c56667 100755 --- a/basis/images/png/png.factor +++ b/basis/images/png/png.factor @@ -26,6 +26,9 @@ CONSTANT: indexed-color 3 CONSTANT: greyscale-alpha 4 CONSTANT: truecolor-alpha 6 +CONSTANT: interlace-none 0 +CONSTANT: interlace-adam7 1 + : ( -- 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 prefix [ n 1 - 0 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 ) diff --git a/basis/math/bitwise/bitwise-docs.factor b/basis/math/bitwise/bitwise-docs.factor index 2d487a621a..5dce9646f4 100755 --- a/basis/math/bitwise/bitwise-docs.factor +++ b/basis/math/bitwise/bitwise-docs.factor @@ -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:" diff --git a/basis/math/bitwise/bitwise-tests.factor b/basis/math/bitwise/bitwise-tests.factor index d1e6c11b6c..d10e4ccc87 100644 --- a/basis/math/bitwise/bitwise-tests.factor +++ b/basis/math/bitwise/bitwise-tests.factor @@ -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 diff --git a/basis/math/bitwise/bitwise.factor b/basis/math/bitwise/bitwise.factor index bed065a800..204f295944 100755 --- a/basis/math/bitwise/bitwise.factor +++ b/basis/math/bitwise/bitwise.factor @@ -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 + 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? ; diff --git a/basis/random/mersenne-twister/mersenne-twister.factor b/basis/random/mersenne-twister/mersenne-twister.factor index 51112ae980..a0e40e5c38 100644 --- a/basis/random/mersenne-twister/mersenne-twister.factor +++ b/basis/random/mersenne-twister/mersenne-twister.factor @@ -80,3 +80,4 @@ M: mersenne-twister random-32* ( mt -- r ) [ default-mersenne-twister random-generator set-global ] "bootstrap.random" add-init-hook + diff --git a/basis/random/sfmt/sfmt-tests.factor b/basis/random/sfmt/sfmt-tests.factor index 9f3fea0480..f7b75c3f13 100644 --- a/basis/random/sfmt/sfmt-tests.factor +++ b/basis/random/sfmt/sfmt-tests.factor @@ -4,14 +4,27 @@ USING: accessors kernel random random.sfmt random.sfmt.private sequences tools.test ; IN: random.sfmt.tests -[ ] [ 100 drop ] unit-test +! Period certified by virtue of seed +[ ] [ 5 drop ] unit-test -[ 1096298955 ] -[ 100 dup generate dup generate uint-array>> first ] unit-test +[ 1331696015 ] +[ 5 dup generate dup generate uint-array>> first ] unit-test -[ 2556114782 ] -[ 100 random-32* ] unit-test +[ 1432875926 ] +[ 5 random-32* ] unit-test + +! Period certified by flipping a bit +[ ] [ 7 drop ] unit-test + +[ 1674111379 ] +[ 7 dup generate dup generate uint-array>> first ] unit-test + +[ 489955657 ] +[ 7 random-32* ] unit-test + + +! Test re-seeding SFMT [ t ] [ 100 diff --git a/basis/random/sfmt/sfmt.factor b/basis/random/sfmt/sfmt.factor index 6b0fc66be2..28883838ce 100644 --- a/basis/random/sfmt/sfmt.factor +++ b/basis/random/sfmt/sfmt.factor @@ -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 } ; @@ -50,12 +52,12 @@ M:: sfmt generate ( sfmt -- ) sfmt uint-4-array>> :> array state n>> 2 - array nth state (>>r1) state n>> 1 - array nth state (>>r2) - state m>> :> m - state n>> :> n + state m>> :> m + state n>> :> n state mask>> :> mask n m - >fixnum iota [| i | - i array nth-unsafe + i array nth-unsafe i m + array nth-unsafe mask state r1>> state r2>> formula :> r @@ -75,48 +77,66 @@ M:: sfmt generate ( sfmt -- ) state r2>> state (>>r1) 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 -- uint-array uint-4-array ) - state>> - [ n>> 4 * iota >uint-array ] [ seed>> ] bi + state>> + [ n>> 4 * 1 swap [a,b] >uint-array ] [ seed>> ] bi [ [ - [ - [ -30 shift ] [ ] bi bitxor - state-multiplier * 32 bits - ] dip + - ] unless-zero 32 bits + [ -30 shift ] [ ] bi bitxor + state-multiplier * 32 bits + ] dip + 32 bits ] uint-array{ } accumulate-as nip dup underlying>> byte-array>uint-4-array ; -: ( seed n m mask -- sfmt ) +: ( seed n m mask parity -- sfmt ) sfmt-state + swap >>parity swap >>mask swap >>m swap >>n swap >>seed - 0 >>ix ; + 0 >>index ; : init-sfmt ( sfmt -- sfmt' ) dup [ >>uint-array ] [ >>uint-4-array ] bi* - [ generate ] keep ; inline + certify-period [ generate ] keep ; inline -: ( seed n m mask -- sfmt ) +: ( seed n m mask parity -- sfmt ) 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 ; : ( 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 } ; inline + +: default-sfmt ( -- sfmt ) + [ random-32 ] with-secure-random ; diff --git a/extra/benchmark/mt/authors.txt b/extra/benchmark/mt/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/extra/benchmark/mt/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/extra/benchmark/mt/mt.factor b/extra/benchmark/mt/mt.factor new file mode 100644 index 0000000000..b2f907ba68 --- /dev/null +++ b/extra/benchmark/mt/mt.factor @@ -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 '[ _ random-32* drop ] times ; + +: mt-main ( -- ) 10000000 mt-benchmark ; + +MAIN: mt-main diff --git a/extra/benchmark/sfmt/sfmt.factor b/extra/benchmark/sfmt/sfmt.factor index 9b4c6e43c8..e9c69303bd 100644 --- a/extra/benchmark/sfmt/sfmt.factor +++ b/extra/benchmark/sfmt/sfmt.factor @@ -6,6 +6,6 @@ IN: benchmark.sfmt : sfmt-benchmark ( n -- ) >fixnum HEX: 533d '[ _ random-32* drop ] times ; -: sfmt-main ( -- ) 100000000 sfmt-benchmark ; +: sfmt-main ( -- ) 10000000 sfmt-benchmark ; MAIN: sfmt-main diff --git a/extra/crypto/xor/xor.factor b/extra/crypto/xor/xor.factor index 662881f8cc..45bbe55d6e 100644 --- a/extra/crypto/xor/xor.factor +++ b/extra/crypto/xor/xor.factor @@ -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 ; diff --git a/extra/game-loop/game-loop.factor b/extra/game/loop/loop.factor similarity index 97% rename from extra/game-loop/game-loop.factor rename to extra/game/loop/loop.factor index 5f78c6770c..1346988fd1 100644 --- a/extra/game-loop/game-loop.factor +++ b/extra/game/loop/loop.factor @@ -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 diff --git a/extra/game-loop/prettyprint/prettyprint.factor b/extra/game/loop/prettyprint/prettyprint.factor similarity index 77% rename from extra/game-loop/prettyprint/prettyprint.factor rename to extra/game/loop/prettyprint/prettyprint.factor index 8b20dd4c9d..44649263de 100644 --- a/extra/game-loop/prettyprint/prettyprint.factor +++ b/extra/game/loop/prettyprint/prettyprint.factor @@ -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 diff --git a/extra/game-worlds/game-worlds.factor b/extra/game/worlds/worlds.factor similarity index 85% rename from extra/game-worlds/game-worlds.factor rename to extra/game/worlds/worlds.factor index 542c48fbae..399c5d1902 100644 --- a/extra/game-worlds/game-worlds.factor +++ b/extra/game/worlds/worlds.factor @@ -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 diff --git a/extra/gpu/demos/bunny/bunny.factor b/extra/gpu/demos/bunny/bunny.factor index d6c7456d63..2e292f0141 100755 --- a/extra/gpu/demos/bunny/bunny.factor +++ b/extra/gpu/demos/bunny/bunny.factor @@ -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 diff --git a/extra/gpu/demos/raytrace/raytrace.factor b/extra/gpu/demos/raytrace/raytrace.factor index 339f192416..5a3d5864fb 100644 --- a/extra/gpu/demos/raytrace/raytrace.factor +++ b/extra/gpu/demos/raytrace/raytrace.factor @@ -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 diff --git a/extra/gpu/util/wasd/wasd.factor b/extra/gpu/util/wasd/wasd.factor index 496735f0db..bee05463af 100644 --- a/extra/gpu/util/wasd/wasd.factor +++ b/extra/gpu/util/wasd/wasd.factor @@ -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 diff --git a/extra/joystick-demo/joystick-demo.factor b/extra/joystick-demo/joystick-demo.factor index 3f24a5bb39..90e28594e7 100755 --- a/extra/joystick-demo/joystick-demo.factor +++ b/extra/joystick-demo/joystick-demo.factor @@ -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 diff --git a/extra/key-caps/key-caps.factor b/extra/key-caps/key-caps.factor index b58870fadc..da901ed61e 100755 --- a/extra/key-caps/key-caps.factor +++ b/extra/key-caps/key-caps.factor @@ -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 ; diff --git a/extra/random/cmwc/authors.txt b/extra/random/cmwc/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/extra/random/cmwc/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/extra/random/cmwc/cmwc-tests.factor b/extra/random/cmwc/cmwc-tests.factor new file mode 100644 index 0000000000..6e3f4ac178 --- /dev/null +++ b/extra/random/cmwc/cmwc-tests.factor @@ -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 seed-random [ + 10 [ random-32 ] replicate + ] with-random +] unit-test + +[ t ] [ + cmwc-4096 [ + 4096 iota >array 362436 seed-random [ + 10 [ random-32 ] replicate + ] with-random + ] [ + 4096 iota >array 362436 seed-random [ + 10 [ random-32 ] replicate + ] with-random + ] bi = +] unit-test diff --git a/extra/random/cmwc/cmwc.factor b/extra/random/cmwc/cmwc.factor new file mode 100644 index 0000000000..00258257be --- /dev/null +++ b/extra/random/cmwc/cmwc.factor @@ -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 ; + +: ( length a b c -- cmwc ) + cmwc new + swap >>c + swap >>b + swap >>a + swap [ 1 - >>i ] [ 0 >>Q ] bi + dup b>> 1 - >>r + dup Q>> length 1 - >>mod ; + +: ( 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 ] + [ + '[ [ random-32 ] replicate ] with-system-random + 362436 seed-random + ] bi ; diff --git a/extra/random/lagged-fibonacci/authors.txt b/extra/random/lagged-fibonacci/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/extra/random/lagged-fibonacci/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/extra/random/lagged-fibonacci/lagged-fibonacci-tests.factor b/extra/random/lagged-fibonacci/lagged-fibonacci-tests.factor new file mode 100644 index 0000000000..e830c466c2 --- /dev/null +++ b/extra/random/lagged-fibonacci/lagged-fibonacci-tests.factor @@ -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 [ + 1000 [ random-float ] double-array{ } replicate-as + 999 swap nth 0.860072135925293 -.01 ~ + ] with-random +] unit-test + +[ t ] [ + 3 [ + [ + 1000 [ random-float ] double-array{ } replicate-as + ] with-random + ] [ + 3 seed-random [ + 1000 [ random-float ] double-array{ } replicate-as + ] with-random = + ] bi +] unit-test diff --git a/extra/random/lagged-fibonacci/lagged-fibonacci.factor b/extra/random/lagged-fibonacci/lagged-fibonacci.factor new file mode 100644 index 0000000000..45a4b132dd --- /dev/null +++ b/extra/random/lagged-fibonacci/lagged-fibonacci.factor @@ -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 ; + + + +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 ; + +: ( seed -- lagged-fibonacci ) + lagged-fibonacci new + p-r 1 + >>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 diff --git a/extra/terrain/terrain.factor b/extra/terrain/terrain.factor index 050a835422..18e49f3e2f 100644 --- a/extra/terrain/terrain.factor +++ b/extra/terrain/terrain.factor @@ -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 ; diff --git a/vm/os-netbsd.cpp b/vm/os-netbsd.cpp index e280d99a80..e1bdc30460 100644 --- a/vm/os-netbsd.cpp +++ b/vm/os-netbsd.cpp @@ -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); } }