Merge branch 'master' of git://factorcode.org/git/factor

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
 
 <PRIVATE
 
-! huffman codes
-
 TUPLE: huffman-code
-    { value }
+    { value fixnum }
-    { size }
+    { size fixnum }
-    { code } ;
+    { code fixnum } ;
 
-: <huffman-code> ( -- code ) 0 0 0 huffman-code boa ;
+: <huffman-code> ( -- huffman-code )
-: next-size ( code -- ) [ 1 + ] change-size [ 2 * ] change-code drop ;
+    0 0 0 huffman-code boa ; inline
-: next-code ( code -- ) [ 1 + ] change-code drop ;
 
-:: all-patterns ( huff n -- seq )
+: next-size ( huffman-code -- )
-    n log2 huff size>> - :> free-bits
+    [ 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 ]
+    [ free-bits 2^ iota [ huffman-code code>> free-bits 2^ * + ] map ]
-    [ huff code>> free-bits neg 2^ /i 1array ] if ;
+    [ 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 }
+    { bs bit-reader }
-    { tdesc }
+    { tdesc array }
-    { rtable }
+    { rtable array }
-    { bits/level } ;
+    { bits/level fixnum } ;
 
-: <huffman-decoder> ( bs tdesc -- decoder )
+: <huffman-decoder> ( bs tdesc -- huffman-decoder )
     huffman-decoder new
-    swap >>tdesc
+        swap >>tdesc
-    swap >>bs
+        swap >>bs
-    16 >>bits/level
+        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 )
+: read1-huff ( huffman-decoder -- elt )
-    16 over [ bs>> bs:peek ] [ rtable>> nth ] bi ! first/last
+    16 over [ bs>> bs:peek ] [ rtable>> nth ] bi
-    [ size>> swap bs>> bs:seek ] [ value>> ] 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 )
+: read1-huff2 ( huffman-decoder -- elt )
-    16 over [ bs>> bs:peek 16 reverse-bits ] [ rtable>> nth ] bi ! first/last
+    16 over [ bs>> bs:peek 16 reverse-bits ] [ rtable>> nth ] bi
-    [ size>> swap bs>> bs:seek ] [ value>> ] bi ;
+    [ size>> swap bs>> bs:seek ] [ value>> ] bi ; inline
-
-/*
-: 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 ;
-*/

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

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
+combinators.smart compression.huffman fry hashtables io.binary
-math.bitwise math.order math.ranges sequences sorting ;
+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 ;
-    
+
 :: 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     
+    7 <= [ bad-zlib-header ] unless
-    5 data bs:seek                      ! drop check bits 
+    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 ) 
+: get-table ( values size -- table )
-    16 f <array> clone <enum> 
+    16 f <array> <enum>
-    [ '[ _ push-at ] 2each ] keep seq>> 1 tail [ natural-sort ] map ;
+    [ '[ _ 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 +
+    4 bitstream bs:read 4 + clen-shuffle swap head 
-    clen-shuffle swap head
+
-    dup [ drop 3 bitstream bs:read ] map
+    dup length iota [ 3 bitstream bs:read ] replicate
     get-table
-    bitstream swap <huffman-decoder> 
+    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,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
-    [ ] produce swap suffix
+    { } [
-    { } [ dup array? [ dup first 16 = ] [ f ] if [ [ unclip-last ] [ second 1 + swap <repetition> append ] bi* ] [ suffix ] if ] reduce
+            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
+        3 4 5 6 7 8 9 10 11 13 15 17 19 23 27 31
-        11 13 15 17
+        35 43 51 59 67 83 99 115 131 163 195 227 258
-        19 23 27 31
-        35 43 51 59
-        67 83 99 115
-        131 163 195 227 258
     }
 
 CONSTANT: dist-table
     {
-        1 2 3 4 
+        1 2 3 4 5 7 9 13 17 25 33 49
-        5 7 9 13 
+        65 97 129 193 257 385 513 769 1025 1537 2049 3073
-        17 25 33 49
+        4097 6145 8193 12289 16385 24577
-        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 
+    ] each
     bytes ;
 
-:: inflate-dynamic ( bitstream -- bytes )
+:: inflate-huffman ( bitstream tables -- bytes )
-    bitstream decode-huffman-tables
+    bitstream tables [ <huffman-decoder> ] with map :> tables
-    bitstream '[ _ swap <huffman-decoder> ] map :> tables
     [
         tables first read1-huff2
-        dup 256 >
+        dup 256 > [
-        [
+            dup 285 = [
-            dup 285 = 
+                dup 264 > [
-            [ ]
+                    dup 261 - 4 /i
-            [ 
+                    dup 5 > [ bad-zlib-data ] when
-                dup 264 > 
+                    bitstream bs:read 2array
-                [ 
+                ] when
-                    dup 261 - 4 /i dup 5 > 
+            ] unless
-                    [ bad-zlib-data ] when 
+
-                    bitstream bs:read 2array 
-                ]
-                when 
-            ] if
-            ! 5 bitstream read-bits ! distance
             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
+        ] when dup 256 = not
-            2array
+    ] [ ] produce nip
-        ]
-        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*
+            ] bi* 2array
-            2array
         ] when
     ] map ;
-    
+
-:: inflate-raw ( bitstream -- bytes ) 
+:: inflate-raw ( bitstream -- bytes )
-    8 bitstream bs:align 
+    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 )
+: inflate-static ( bitstream -- array )
-    [ 1 bitstream bs:read 0 = ]
+    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
-        case
+    ] [ produce ] keep call suffix concat ;
-    ]
-    [ produce ] keep call suffix concat ;
 
 PRIVATE>
 

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 -- )

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 ;
 

basis/game-input/dinput/summary.txt

@@ -1 +0,0 @@
-DirectInput backend for game-input

basis/game-input/iokit/summary.txt

@@ -1 +0,0 @@
-IOKit HID Manager backend for game-input

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
 

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 }

basis/game/input/dinput/summary.txt

@@ -0,0 +1 @@
+DirectInput backend for game.input

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." }
+{ $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" } "." } ;
+{ $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:"

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

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 windows? ] [ "game.input.dinput" require ] }
-    { [ os macosx? ] [ "game-input.iokit" require ] }
+    { [ os macosx? ] [ "game.input.iokit" require ] }
     { [ t ] [ ] }
 } cond

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
 

basis/game/input/iokit/summary.txt

@@ -0,0 +1 @@
+IOKit HID Manager backend for game.input

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

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
+
 : <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 * ] }
+        { truecolor [ scale-bit-depth 3 * ] }
-        { 6 [ scale-bit-depth 4 * ] }
+        { 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 )

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:"

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

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)
-    [
+    0 swap [
-        {
+        dup 0 >
-            [           byte-bit-count ]
+    ] [
-            [ -8  shift byte-bit-count ]
+        [ 8 bits byte-bit-count ] [ -8 shift ] bi
-            [ -16 shift byte-bit-count ]
+        [ + ] dip
-            [ -24 shift byte-bit-count ]
+    ] while drop ;
-        } cleave
-    ] sum-outputs ;
 
 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 )
+ERROR: invalid-bit-count-target object ;
-    dup 0 < [ bitnot ] when (bit-count) ; inline
+
+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? ;

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
+

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 <sfmt-19937> drop ] unit-test
+! Period certified by virtue of seed
+[ ] [ 5 <sfmt-19937> drop ] unit-test
 
-[ 1096298955 ]
+[ 1331696015 ]
-[ 100 <sfmt-19937> dup generate dup generate uint-array>> first ] unit-test
+[ 5 <sfmt-19937> dup generate dup generate uint-array>> first ] unit-test
 
-[ 2556114782 ]
+[ 1432875926 ]
-[ 100 <sfmt-19937> random-32* ] unit-test
+[ 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>

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 m>> :> m
-    state n>> :> n 
+    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-array> ( sfmt -- uint-array uint-4-array )
-    state>> 
+    state>>
-    [ n>> 4 * iota >uint-array ] [ seed>> ] bi
+    [ n>> 4 * 1 swap [a,b] >uint-array ] [ seed>> ] bi
     [
         [
-            [
+            [ -30 shift ] [ ] bi bitxor
-                [ -30 shift ] [ ] bi bitxor
+            state-multiplier * 32 bits
-                state-multiplier * 32 bits
+        ] dip + 32 bits
-            ] dip +
-        ] unless-zero 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 )
+: next-index ( sfmt -- index )
-    state>> [ dup 1 + ] change-ix drop ; inline
+    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> ;

extra/benchmark/mt/authors.txt

@@ -0,0 +1 @@
+Doug Coleman

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 <mersenne-twister> '[ _ random-32* drop ] times ;
+
+: mt-main ( -- ) 10000000 mt-benchmark ;
+
+MAIN: mt-main

extra/benchmark/sfmt/sfmt.factor

@@ -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

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 ;

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

extra/game/loop/prettyprint/prettyprint.factor

@@ -1,6 +1,6 @@
 ! (c)2009 Joe Groff bsd license
-USING: accessors debugger game-loop io ;
+USING: accessors debugger game.loop io ;
-IN: game-loop.prettyprint
+IN: game.loop.prettyprint
 
 M: game-loop-error error.
     "An error occurred inside a game loop." print

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

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

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

extra/gpu/util/wasd/wasd.factor

@@ -1,6 +1,6 @@
 ! (c)2009 Joe Groff bsd license
-USING: accessors arrays combinators.smart game-input
+USING: accessors arrays combinators.smart game.input
-game-input.scancodes game-loop game-worlds
+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

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

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 ;

extra/random/cmwc/authors.txt

@@ -0,0 +1 @@
+Doug Coleman

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 <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

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 ;
+
+: <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 ;

extra/random/lagged-fibonacci/authors.txt

@@ -0,0 +1 @@
+Doug Coleman

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 <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

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 ;
+
+<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

extra/terrain/terrain.factor

@@ -1,12 +1,12 @@
 ! (c)2009 Joe Groff, Doug Coleman. bsd license
-USING: accessors arrays combinators game-input game-loop
+USING: accessors arrays combinators game.input game.loop
-game-input.scancodes grouping kernel literals locals
+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 ;

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);
 }
 
 }