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

basis/bootstrap/image/image.factor

@@ -52,6 +52,9 @@ GENERIC: (eql?) ( obj1 obj2 -- ? )
 
 M: integer (eql?) = ;
 
+M: float (eql?)
+    over float? [ fp-bitwise= ] [ 2drop f ] if ;
+
 M: sequence (eql?)
     over sequence? [
         2dup [ length ] bi@ =

basis/checksums/common/common.factor

@@ -9,6 +9,9 @@ SYMBOL: bytes-read
 : calculate-pad-length ( length -- length' )
     [ 56 < 55 119 ? ] keep - ;
 
+: calculate-pad-length-long ( length -- length' )
+    [ 120 < 119 247 ? ] keep - ;
+
 : pad-last-block ( str big-endian? length -- str )
     [
         [ % ] 2dip HEX: 80 ,

basis/checksums/sha2/sha2-tests.factor

@@ -1,7 +1,42 @@
-USING: arrays kernel math namespaces sequences tools.test checksums.sha2 checksums ;
+USING: arrays kernel math namespaces sequences tools.test
-[ "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855" ] [ "" sha-256 checksum-bytes hex-string ] unit-test
+checksums.sha2 checksums ;
-[ "ba7816bf8f01cfea414140de5dae2223b00361a396177a9cb410ff61f20015ad" ] [ "abc" sha-256 checksum-bytes hex-string ] unit-test
+IN: checksums.sha2.tests
-[ "f7846f55cf23e14eebeab5b4e1550cad5b509e3348fbc4efa3a1413d393cb650" ] [ "message digest" sha-256 checksum-bytes hex-string ] unit-test
+
-[ "71c480df93d6ae2f1efad1447c66c9525e316218cf51fc8d9ed832f2daf18b73" ] [ "abcdefghijklmnopqrstuvwxyz" sha-256 checksum-bytes hex-string ] unit-test
+: test-checksum ( text identifier -- checksum )
-[ "db4bfcbd4da0cd85a60c3c37d3fbd8805c77f15fc6b1fdfe614ee0a7c8fdb4c0" ] [ "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789" sha-256 checksum-bytes hex-string ] unit-test
+    checksum-bytes hex-string ;
-[ "f371bc4a311f2b009eef952dd83ca80e2b60026c8e935592d0f9c308453c813e" ] [ "12345678901234567890123456789012345678901234567890123456789012345678901234567890" sha-256 checksum-bytes hex-string ] unit-test
+
+[ "75388b16512776cc5dba5da1fd890150b0c6455cb4f58b1952522525" ]
+[
+    "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq"
+    sha-224 test-checksum
+] unit-test
+
+[ "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855" ]
+[ "" sha-256 test-checksum ] unit-test
+
+[ "ba7816bf8f01cfea414140de5dae2223b00361a396177a9cb410ff61f20015ad" ]
+[ "abc" sha-256 test-checksum ] unit-test
+
+[ "f7846f55cf23e14eebeab5b4e1550cad5b509e3348fbc4efa3a1413d393cb650" ]
+[ "message digest" sha-256 test-checksum ] unit-test
+
+[ "71c480df93d6ae2f1efad1447c66c9525e316218cf51fc8d9ed832f2daf18b73" ]
+[ "abcdefghijklmnopqrstuvwxyz" sha-256 test-checksum ] unit-test
+
+[ "db4bfcbd4da0cd85a60c3c37d3fbd8805c77f15fc6b1fdfe614ee0a7c8fdb4c0" ]
+[
+    "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789"
+    sha-256 test-checksum
+] unit-test
+
+[ "f371bc4a311f2b009eef952dd83ca80e2b60026c8e935592d0f9c308453c813e" ]
+[
+    "12345678901234567890123456789012345678901234567890123456789012345678901234567890"
+    sha-256 test-checksum
+] unit-test
+
+
+
+
+! [ "8e959b75dae313da8cf4f72814fc143f8f7779c6eb9f7fa17299aeadb6889018501d289e4900f7e4331b99dec4b5433ac7d329eeb6dd26545e96e55b874be909" ]
+! [ "abcdefghbcdefghicdefghijdefghijkefghijklfghijklmghijklmnhijklmnoijklmnopjklmnopqklmnopqrlmnopqrsmnopqrstnopqrstu" sha-512 test-checksum ] unit-test

basis/checksums/sha2/sha2.factor

@@ -2,12 +2,27 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel splitting grouping math sequences namespaces make
 io.binary math.bitwise checksums checksums.common
-sbufs strings ;
+sbufs strings combinators.smart math.ranges fry combinators
+accessors locals ;
 IN: checksums.sha2
 
-<PRIVATE
+SINGLETON: sha-224
+SINGLETON: sha-256
 
-SYMBOLS: vars M K H S0 S1 process-M word-size block-size ;
+INSTANCE: sha-224 checksum
+INSTANCE: sha-256 checksum
+
+TUPLE: sha2-state K H word-size block-size ;
+
+TUPLE: sha2-short < sha2-state ;
+
+TUPLE: sha2-long < sha2-state ;
+
+TUPLE: sha-224-state < sha2-short ;
+
+TUPLE: sha-256-state < sha2-short ;
+
+<PRIVATE
 
 CONSTANT: a 0
 CONSTANT: b 1
@@ -18,13 +33,43 @@ CONSTANT: f 5
 CONSTANT: g 6
 CONSTANT: h 7
 
-: initial-H-256 ( -- seq )
+CONSTANT: initial-H-224
+    {
+        HEX: c1059ed8 HEX: 367cd507 HEX: 3070dd17 HEX: f70e5939
+        HEX: ffc00b31 HEX: 68581511 HEX: 64f98fa7 HEX: befa4fa4
+    }
+
+CONSTANT: initial-H-256
     {
         HEX: 6a09e667 HEX: bb67ae85 HEX: 3c6ef372 HEX: a54ff53a
         HEX: 510e527f HEX: 9b05688c HEX: 1f83d9ab HEX: 5be0cd19
-    } ;
+    }
 
-: K-256 ( -- seq )
+CONSTANT: initial-H-384
+    {
+        HEX: cbbb9d5dc1059ed8
+        HEX: 629a292a367cd507
+        HEX: 9159015a3070dd17
+        HEX: 152fecd8f70e5939
+        HEX: 67332667ffc00b31
+        HEX: 8eb44a8768581511
+        HEX: db0c2e0d64f98fa7
+        HEX: 47b5481dbefa4fa4
+    }
+
+CONSTANT: initial-H-512
+    {
+        HEX: 6a09e667f3bcc908
+        HEX: bb67ae8584caa73b
+        HEX: 3c6ef372fe94f82b
+        HEX: a54ff53a5f1d36f1
+        HEX: 510e527fade682d1
+        HEX: 9b05688c2b3e6c1f
+        HEX: 1f83d9abfb41bd6b
+        HEX: 5be0cd19137e2179
+    }
+
+CONSTANT: K-256
     {
         HEX: 428a2f98 HEX: 71374491 HEX: b5c0fbcf HEX: e9b5dba5
         HEX: 3956c25b HEX: 59f111f1 HEX: 923f82a4 HEX: ab1c5ed5
@@ -42,62 +87,163 @@ CONSTANT: h 7
         HEX: 391c0cb3 HEX: 4ed8aa4a HEX: 5b9cca4f HEX: 682e6ff3
         HEX: 748f82ee HEX: 78a5636f HEX: 84c87814 HEX: 8cc70208
         HEX: 90befffa HEX: a4506ceb HEX: bef9a3f7 HEX: c67178f2
-    } ;
+    }
+
+CONSTANT: K-384
+    {
+
+        HEX: 428a2f98d728ae22 HEX: 7137449123ef65cd HEX: b5c0fbcfec4d3b2f HEX: e9b5dba58189dbbc 
+        HEX: 3956c25bf348b538 HEX: 59f111f1b605d019 HEX: 923f82a4af194f9b HEX: ab1c5ed5da6d8118 
+        HEX: d807aa98a3030242 HEX: 12835b0145706fbe HEX: 243185be4ee4b28c HEX: 550c7dc3d5ffb4e2
+        HEX: 72be5d74f27b896f HEX: 80deb1fe3b1696b1 HEX: 9bdc06a725c71235 HEX: c19bf174cf692694 
+        HEX: e49b69c19ef14ad2 HEX: efbe4786384f25e3 HEX: 0fc19dc68b8cd5b5 HEX: 240ca1cc77ac9c65 
+        HEX: 2de92c6f592b0275 HEX: 4a7484aa6ea6e483 HEX: 5cb0a9dcbd41fbd4 HEX: 76f988da831153b5 
+        HEX: 983e5152ee66dfab HEX: a831c66d2db43210 HEX: b00327c898fb213f HEX: bf597fc7beef0ee4 
+        HEX: c6e00bf33da88fc2 HEX: d5a79147930aa725 HEX: 06ca6351e003826f HEX: 142929670a0e6e70 
+        HEX: 27b70a8546d22ffc HEX: 2e1b21385c26c926 HEX: 4d2c6dfc5ac42aed HEX: 53380d139d95b3df 
+        HEX: 650a73548baf63de HEX: 766a0abb3c77b2a8 HEX: 81c2c92e47edaee6 HEX: 92722c851482353b 
+        HEX: a2bfe8a14cf10364 HEX: a81a664bbc423001 HEX: c24b8b70d0f89791 HEX: c76c51a30654be30 
+        HEX: d192e819d6ef5218 HEX: d69906245565a910 HEX: f40e35855771202a HEX: 106aa07032bbd1b8 
+        HEX: 19a4c116b8d2d0c8 HEX: 1e376c085141ab53 HEX: 2748774cdf8eeb99 HEX: 34b0bcb5e19b48a8 
+        HEX: 391c0cb3c5c95a63 HEX: 4ed8aa4ae3418acb HEX: 5b9cca4f7763e373 HEX: 682e6ff3d6b2b8a3 
+        HEX: 748f82ee5defb2fc HEX: 78a5636f43172f60 HEX: 84c87814a1f0ab72 HEX: 8cc702081a6439ec 
+        HEX: 90befffa23631e28 HEX: a4506cebde82bde9 HEX: bef9a3f7b2c67915 HEX: c67178f2e372532b 
+        HEX: ca273eceea26619c HEX: d186b8c721c0c207 HEX: eada7dd6cde0eb1e HEX: f57d4f7fee6ed178 
+        HEX: 06f067aa72176fba HEX: 0a637dc5a2c898a6 HEX: 113f9804bef90dae HEX: 1b710b35131c471b 
+        HEX: 28db77f523047d84 HEX: 32caab7b40c72493 HEX: 3c9ebe0a15c9bebc HEX: 431d67c49c100d4c 
+        HEX: 4cc5d4becb3e42b6 HEX: 597f299cfc657e2a HEX: 5fcb6fab3ad6faec HEX: 6c44198c4a475817
+    }
+
+ALIAS: K-512 K-384
 
 : s0-256 ( x -- x' )
-    [ -7 bitroll-32 ] keep
+    [
-    [ -18 bitroll-32 ] keep
+        [ -7 bitroll-32 ]
-    -3 shift bitxor bitxor ; inline
+        [ -18 bitroll-32 ]
+        [ -3 shift ] tri
+    ] [ bitxor ] reduce-outputs ; inline
 
 : s1-256 ( x -- x' )
-    [ -17 bitroll-32 ] keep
+    [
-    [ -19 bitroll-32 ] keep
+        [ -17 bitroll-32 ]
-    -10 shift bitxor bitxor ; inline
+        [ -19 bitroll-32 ]
-
+        [ -10 shift ] tri
-: process-M-256 ( seq n -- )
+    ] [ bitxor ] reduce-outputs ; inline
-    [ 16 - swap nth ] 2keep
-    [ 15 - swap nth s0-256 ] 2keep
-    [ 7 - swap nth ] 2keep
-    [ 2 - swap nth s1-256 ] 2keep
-    [ + + w+ ] 2dip swap set-nth ; inline
-
-: prepare-message-schedule ( seq -- w-seq )
-    word-size get group [ be> ] map block-size get 0 pad-tail
-    dup 16 64 dup <slice> [
-        process-M-256
-    ] with each ;
-
-: ch ( x y z -- x' )
-    [ bitxor bitand ] keep bitxor ;
-
-: maj ( x y z -- x' )
-    [ [ bitand ] 2keep bitor ] dip bitand bitor ;
 
 : S0-256 ( x -- x' )
-    [ -2 bitroll-32 ] keep
+    [
-    [ -13 bitroll-32 ] keep
+        [ -2 bitroll-32 ]
-    -22 bitroll-32 bitxor bitxor ; inline
+        [ -13 bitroll-32 ]
+        [ -22 bitroll-32 ] tri
+    ] [ bitxor ] reduce-outputs ; inline
 
 : S1-256 ( x -- x' )
-    [ -6 bitroll-32 ] keep
+    [
-    [ -11 bitroll-32 ] keep
+        [ -6 bitroll-32 ]
-    -25 bitroll-32 bitxor bitxor ; inline
+        [ -11 bitroll-32 ]
+        [ -25 bitroll-32 ] tri
+    ] [ bitxor ] reduce-outputs ; inline
 
-: slice3 ( n seq -- a b c ) [ dup 3 + ] dip <slice> first3 ; inline
+: s0-512 ( x -- x' )
+    [
+        [ -1 bitroll-64 ]
+        [ -8 bitroll-64 ]
+        [ -7 shift ] tri
+    ] [ bitxor ] reduce-outputs ; inline
 
-: T1 ( W n -- T1 )
+: s1-512 ( x -- x' )
-    [ swap nth ] keep
+    [
-    K get nth +
+        [ -19 bitroll-64 ]
-    e vars get slice3 ch +
+        [ -61 bitroll-64 ]
-    e vars get nth S1-256 +
+        [ -6 shift ] tri
-    h vars get nth w+ ;
+    ] [ bitxor ] reduce-outputs ; inline
 
-: T2 ( -- T2 )
+: S0-512 ( x -- x' )
-    a vars get nth S0-256
+    [
-    a vars get slice3 maj w+ ;
+        [ -28 bitroll-64 ]
+        [ -34 bitroll-64 ]
+        [ -39 bitroll-64 ] tri
+    ] [ bitxor ] reduce-outputs ; inline
 
-: update-vars ( T1 T2 -- )
+: S1-512 ( x -- x' )
-    vars get
+    [
+        [ -14 bitroll-64 ]
+        [ -18 bitroll-64 ]
+        [ -41 bitroll-64 ] tri
+    ] [ bitxor ] reduce-outputs ; inline
+
+: process-M-256 ( n seq -- )
+    {
+        [ [ 16 - ] dip nth ]
+        [ [ 15 - ] dip nth s0-256 ]
+        [ [ 7 - ] dip nth ]
+        [ [ 2 - ] dip nth s1-256 w+ w+ w+ ]
+        [ ]
+    } 2cleave set-nth ; inline
+
+: process-M-512 ( n seq -- )
+    {
+        [ [ 16 - ] dip nth ]
+        [ [ 15 - ] dip nth s0-512 ]
+        [ [ 7 - ] dip nth ]
+        [ [ 2 - ] dip nth s1-512 w+ w+ w+ ]
+        [ ]
+    } 2cleave set-nth ; inline
+
+: ch ( x y z -- x' )
+    [ bitxor bitand ] keep bitxor ; inline
+
+: maj ( x y z -- x' )
+    [ [ bitand ] [ bitor ] 2bi ] dip bitand bitor ; inline
+
+: slice3 ( n seq -- a b c )
+    [ dup 3 + ] dip <slice> first3 ; inline
+
+GENERIC: pad-initial-bytes ( string sha2 -- padded-string )
+
+M: sha2-short pad-initial-bytes ( string sha2 -- padded-string )
+    drop
+    dup [
+        HEX: 80 ,
+        length
+        [ 64 mod calculate-pad-length 0 <string> % ]
+        [ 3 shift 8 >be % ] bi
+    ] "" make append ;
+
+M: sha2-long pad-initial-bytes ( string sha2 -- padded-string )
+    drop dup [
+        HEX: 80 ,
+        length
+        [ 128 mod calculate-pad-length-long 0 <string> % ]
+        [ 3 shift 8 >be % ] bi
+    ] "" make append ;
+
+: seq>byte-array ( seq n -- string )
+    '[ _ >be ] map B{ } join ;
+
+:: T1-256 ( n M H sha2 -- T1 )
+    n M nth
+    n sha2 K>> nth +
+    e H slice3 ch w+
+    e H nth S1-256 w+
+    h H nth w+ ; inline
+
+: T2-256 ( H -- T2 )
+    [ a swap nth S0-256 ]
+    [ a swap slice3 maj w+ ] bi ; inline
+
+:: T1-512 ( n M H sha2 -- T1 )
+    n M nth
+    n sha2 K>> nth +
+    e H slice3 ch w+
+    e H nth S1-512 w+
+    h H nth w+ ; inline
+
+: T2-512 ( H -- T2 )
+    [ a swap nth S0-512 ]
+    [ a swap slice3 maj w+ ] bi ; inline
+
+: update-H ( T1 T2 H -- )
     h g pick exchange
     g f pick exchange
     f e pick exchange
@@ -105,42 +251,56 @@ CONSTANT: h 7
     d c pick exchange
     c b pick exchange
     b a pick exchange
-    [ w+ a ] dip set-nth ;
+    [ w+ a ] dip set-nth ; inline
 
-: process-chunk ( M -- )
+: prepare-message-schedule ( seq sha2 -- w-seq )
-    H get clone vars set
+    [ word-size>> <sliced-groups> [ be> ] map ]
-    prepare-message-schedule block-size get [
+    [
-        T1 T2 update-vars
+        block-size>> [ 0 pad-tail 16 ] keep [a,b) over
-    ] with each vars get H get [ w+ ] 2map H set ;
+        '[ _ process-M-256 ] each
+    ] bi ; inline
 
-: seq>byte-array ( n seq -- string )
+:: process-chunk ( M block-size cloned-H sha2 -- )
-    [ swap [ >be % ] curry each ] B{ } make ;
+    block-size [
+        M cloned-H sha2 T1-256
+        cloned-H T2-256
+        cloned-H update-H
+    ] each
+    cloned-H sha2 H>> [ w+ ] 2map sha2 (>>H) ; inline
 
-: preprocess-plaintext ( string big-endian? -- padded-string )
+: sha2-steps ( sliced-groups state -- )
-    #! pad 0x80 then 00 til 8 bytes left, then 64bit length in bits
+    '[
-    [ >sbuf ] dip over [
+        _
-        HEX: 80 ,
+        [ prepare-message-schedule ]
-        dup length HEX: 3f bitand
+        [ [ block-size>> ] [ H>> clone ] [ ] tri process-chunk ] bi
-        calculate-pad-length 0 <string> %
+    ] each ;
-        length 3 shift 8 rot [ >be ] [ >le ] if %
-    ] "" make over push-all ;
 
-: byte-array>sha2 ( byte-array -- string )
+: byte-array>sha2 ( bytes state -- )
-    t preprocess-plaintext
+    [ [ pad-initial-bytes ] [ nip block-size>> ] 2bi <sliced-groups> ]
-    block-size get group [ process-chunk ] each
+    [ sha2-steps ] bi ;
-    4 H get seq>byte-array ;
+
+: <sha-224-state> ( -- sha2-state )
+    sha-224-state new
+        K-256 >>K
+        initial-H-224 >>H
+        4 >>word-size
+        64 >>block-size ;
+
+: <sha-256-state> ( -- sha2-state )
+    sha-256-state new
+        K-256 >>K
+        initial-H-256 >>H
+        4 >>word-size
+        64 >>block-size ;
 
 PRIVATE>
 
-SINGLETON: sha-256
+M: sha-224 checksum-bytes
-
+    drop <sha-224-state>
-INSTANCE: sha-256 checksum
+    [ byte-array>sha2 ]
+    [ H>> 7 head 4 seq>byte-array ] bi ;
 
 M: sha-256 checksum-bytes
-    drop [
+    drop <sha-256-state>
-        K-256 K set
+    [ byte-array>sha2 ]
-        initial-H-256 H set
+    [ H>> 4 seq>byte-array ] bi ;
-        4 word-size set
-        64 block-size set
-        byte-array>sha2
-    ] with-scope ;

basis/cocoa/plists/plists.factor

@@ -4,7 +4,7 @@
 USING: strings arrays hashtables assocs sequences fry macros
 cocoa.messages cocoa.classes cocoa.application cocoa kernel
 namespaces io.backend math cocoa.enumeration byte-arrays
-combinators alien.c-types words core-foundation
+combinators alien.c-types words core-foundation quotations
 core-foundation.data core-foundation.utilities ;
 IN: cocoa.plists
 
@@ -41,10 +41,16 @@ DEFER: plist>
     *void* [ -> release "read-plist failed" throw ] when* ;
 
 MACRO: objc-class-case ( alist -- quot )
-    [ [ '[ dup _ execute -> isKindOfClass: c-bool> ] ] dip ] assoc-map '[ _ cond ] ;
+    [
+        dup callable?
+        [ first2 [ '[ dup _ execute -> isKindOfClass: c-bool> ] ] dip 2array ]
+        unless
+    ] map '[ _ cond ] ;
 
 PRIVATE>
 
+ERROR: invalid-plist-object object ;
+
 : plist> ( plist -- value )
     {
         { NSString [ (plist-NSString>) ] }
@@ -53,6 +59,7 @@ PRIVATE>
         { NSArray [ (plist-NSArray>) ] }
         { NSDictionary [ (plist-NSDictionary>) ] }
         { NSObject [ ] }
+        [ invalid-plist-object ]
     } objc-class-case ;
 
 : read-plist ( path -- assoc )

basis/core-graphics/core-graphics.factor

@@ -105,6 +105,15 @@ CONSTANT: kCGLRendererGenericFloatID HEX: 00020400
 
 FUNCTION: CGLError CGLSetParameter ( CGLContextObj ctx, CGLContextParameter pname, GLint* params ) ;
 
+FUNCTION: CGDirectDisplayID CGMainDisplayID ( ) ;
+
+FUNCTION: CGError CGDisplayHideCursor ( CGDirectDisplayID display ) ;
+FUNCTION: CGError CGDisplayShowCursor ( CGDirectDisplayID display ) ;
+
+FUNCTION: CGError CGAssociateMouseAndMouseCursorPosition ( boolean_t connected ) ;
+
+FUNCTION: CGError CGWarpMouseCursorPosition ( CGPoint newCursorPosition ) ;
+
 <PRIVATE
 
 : bitmap-flags ( -- flags )

basis/core-graphics/types/types.factor

@@ -90,5 +90,8 @@ TYPEDEF: void* CGContextRef
 TYPEDEF: uint CGBitmapInfo
 
 TYPEDEF: int CGLError
+TYPEDEF: int CGError
+TYPEDEF: uint CGDirectDisplayID
+TYPEDEF: int boolean_t
 TYPEDEF: void* CGLContextObj
 TYPEDEF: int CGLContextParameter

basis/dlists/dlists-docs.factor

@@ -15,6 +15,7 @@ $nl
 "Iterating over elements:"
 { $subsection dlist-each }
 { $subsection dlist-find }
+{ $subsection dlist-filter }
 { $subsection dlist-any? }
 "Deleting a node matching a predicate:"
 { $subsection delete-node-if* }
@@ -40,6 +41,11 @@ HELP: dlist-find
     "This operation is O(n)."
 } ;
 
+HELP: dlist-filter
+{ $values { "dlist" { $link dlist } } { "quot" quotation } { "dlist" { $link dlist } } }
+{ $description "Applies the quotation to each element of the " { $link dlist } " in turn, removing the corresponding nodes if the quotation returns " { $link f } "." }
+{ $side-effects { "dlist" } } ;
+
 HELP: dlist-any?
 { $values { "dlist" { $link dlist } } { "quot" quotation } { "?" "a boolean" } }
 { $description "Just like " { $link dlist-find } " except it doesn't return the object." }

basis/dlists/dlists-tests.factor

@@ -79,3 +79,8 @@ IN: dlists.tests
 [ V{ f 3 1 f } ] [ <dlist> 1 over push-front 3 over push-front f over push-front f over push-back dlist>seq ] unit-test
 
 [ V{ } ] [ <dlist> dlist>seq ] unit-test
+
+[ V{ 0 2 4 } ] [ <dlist> { 0 1 2 3 4 } over push-all-back [ even? ] dlist-filter dlist>seq ] unit-test
+[ V{ 2 4 } ] [ <dlist> { 1 2 3 4 } over push-all-back [ even? ] dlist-filter dlist>seq ] unit-test
+[ V{ 2 4 } ] [ <dlist> { 1 2 3 4 5 } over push-all-back [ even? ] dlist-filter dlist>seq ] unit-test
+[ V{ 0 2 4 } ] [ <dlist> { 0 1 2 3 4 5 } over push-all-back [ even? ] dlist-filter dlist>seq ] unit-test

basis/dlists/dlists.factor

@@ -95,7 +95,7 @@ M: dlist pop-front* ( dlist -- )
     [
         [
             [ empty-dlist ] unless*
-            [ f ] change-next drop
+            next>>
             f over set-prev-when
         ] change-front drop
     ] keep
@@ -108,7 +108,7 @@ M: dlist pop-back* ( dlist -- )
     [
         [
             [ empty-dlist ] unless*
-            [ f ] change-prev drop
+            prev>>
             f over set-next-when
         ] change-back drop
     ] keep
@@ -157,6 +157,9 @@ M: dlist clear-deque ( dlist -- )
 
 : 1dlist ( obj -- dlist ) <dlist> [ push-front ] keep ;
 
+: dlist-filter ( dlist quot -- dlist )
+    over [ '[ dup obj>> @ [ drop ] [ _ delete-node ] if ] dlist-each-node ] keep ; inline
+
 M: dlist clone
     <dlist> [ '[ _ push-back ] dlist-each ] keep ;
 

basis/math/bitwise/bitwise.factor

@@ -35,6 +35,11 @@ IN: math.bitwise
 : w- ( int int -- int ) - 32 bits ; inline
 : w* ( int int -- int ) * 32 bits ; inline
 
+! 64-bit arithmetic
+: W+ ( int int -- int ) + 64 bits ; inline
+: W- ( int int -- int ) - 64 bits ; inline
+: W* ( int int -- int ) * 64 bits ; inline
+
 ! flags
 MACRO: flags ( values -- )
     [ 0 ] [ [ ?execute bitor ] curry compose ] reduce ;
@@ -106,3 +111,10 @@ PRIVATE>
 : >signed ( x n -- y )
     2dup neg 1 + shift 1 = [ 2^ - ] [ drop ] if ;
 
+: >odd ( n -- int ) 0 set-bit ; foldable
+
+: >even ( n -- int ) 0 clear-bit ; foldable
+
+: next-even ( m -- n ) >even 2 + ; foldable
+
+: next-odd ( m -- n ) dup even? [ 1 + ] [ 2 + ] if ; foldable

basis/math/combinatorics/combinatorics-docs.factor

@@ -1,37 +1,93 @@
-USING: help.markup help.syntax kernel math math.order sequences ;
+USING: help.markup help.syntax kernel math math.order multiline sequences ;
 IN: math.combinatorics
 
 HELP: factorial
 { $values { "n" "a non-negative integer" } { "n!" integer } }
 { $description "Outputs the product of all positive integers less than or equal to " { $snippet "n" } "." }
-{ $examples { $example "USING: math.combinatorics prettyprint ;" "4 factorial ." "24" } } ;
+{ $examples 
+    { $example "USING: math.combinatorics prettyprint ;"
+        "4 factorial ." "24" }
+} ;
 
 HELP: nPk
 { $values { "n" "a non-negative integer" } { "k" "a non-negative integer" } { "nPk" integer } }
 { $description "Outputs the total number of unique permutations of size " { $snippet "k" } " (order does matter) that can be taken from a set of size " { $snippet "n" } "." }
-{ $examples { $example "USING: math.combinatorics prettyprint ;" "10 4 nPk ." "5040" } } ;
+{ $examples
+    { $example "USING: math.combinatorics prettyprint ;"
+        "10 4 nPk ." "5040" }
+} ;
 
 HELP: nCk
 { $values { "n" "a non-negative integer" } { "k" "a non-negative integer" } { "nCk" integer } }
 { $description "Outputs the total number of unique combinations of size " { $snippet "k" } " (order does not matter) that can be taken from a set of size " { $snippet "n" } ". Commonly written as \"n choose k\"." }
-{ $examples { $example "USING: math.combinatorics prettyprint ;" "10 4 nCk ." "210" } } ;
+{ $examples
+    { $example "USING: math.combinatorics prettyprint ;"
+        "10 4 nCk ." "210" }
+} ;
 
 HELP: permutation
 { $values { "n" "a non-negative integer" } { "seq" sequence } { "seq" sequence } }
 { $description "Outputs the " { $snippet "nth" } " lexicographical permutation of " { $snippet "seq" } "." }
 { $notes "Permutations are 0-based and a bounds error will be thrown if " { $snippet "n" } " is larger than " { $snippet "seq length factorial 1-" } "." }
-{ $examples { $example "USING: math.combinatorics prettyprint ;" "1 3 permutation ." "{ 0 2 1 }" } { $example "USING: math.combinatorics prettyprint ;" "5 { \"apple\" \"banana\" \"orange\" } permutation ." "{ \"orange\" \"banana\" \"apple\" }" } } ;
+{ $examples
+    { $example "USING: math.combinatorics prettyprint ;"
+        "1 3 permutation ." "{ 0 2 1 }" }
+    { $example "USING: math.combinatorics prettyprint ;"
+        "5 { \"apple\" \"banana\" \"orange\" } permutation ." "{ \"orange\" \"banana\" \"apple\" }" }
+} ;
 
 HELP: all-permutations
 { $values { "seq" sequence } { "seq" sequence } }
 { $description "Outputs a sequence containing all permutations of " { $snippet "seq" } " in lexicographical order." }
-{ $examples { $example "USING: math.combinatorics prettyprint ;" "3 all-permutations ." "{ { 0 1 2 } { 0 2 1 } { 1 0 2 } { 1 2 0 } { 2 0 1 } { 2 1 0 } }" } } ;
+{ $examples
+    { $example "USING: math.combinatorics prettyprint ;"
+        "3 all-permutations ." "{ { 0 1 2 } { 0 2 1 } { 1 0 2 } { 1 2 0 } { 2 0 1 } { 2 1 0 } }" }
+} ;
+
+HELP: each-permutation
+{ $values { "seq" sequence } { "quot" { $quotation "( seq -- )" } } }
+{ $description "Applies the quotation to each permuation of " { $snippet "seq" } " in order." } ;
 
 HELP: inverse-permutation
 { $values { "seq" sequence } { "permutation" sequence } }
 { $description "Outputs a sequence of indices representing the lexicographical permutation of " { $snippet "seq" } "." }
 { $notes "All items in " { $snippet "seq" } " must be comparable by " { $link <=> } "." }
-{ $examples { $example "USING: math.combinatorics prettyprint ;" "\"dcba\" inverse-permutation ." "{ 3 2 1 0 }" } { $example "USING: math.combinatorics prettyprint ;" "{ 12 56 34 78 } inverse-permutation ." "{ 0 2 1 3 }" } } ;
+{ $examples
+    { $example "USING: math.combinatorics prettyprint ;"
+        "\"dcba\" inverse-permutation ." "{ 3 2 1 0 }" }
+    { $example "USING: math.combinatorics prettyprint ;"
+        "{ 12 56 34 78 } inverse-permutation ." "{ 0 2 1 3 }" }
+} ;
+
+HELP: combination
+{ $values { "m" "a non-negative integer" } { "seq" sequence } { "k" "a non-negative integer" } { "seq" sequence } }
+{ $description "Outputs the " { $snippet "mth" } " lexicographical combination of " { $snippet "seq" } " choosing " { $snippet "k" } " elements." }
+{ $notes "Combinations are 0-based and a bounds error will be thrown if " { $snippet "m" } " is larger than " { $snippet "seq length k nCk" } "." }
+{ $examples
+    { $example "USING: math.combinatorics sequences prettyprint ;"
+        "6 7 iota 4 combination ." "{ 0 1 3 6 }" }
+    { $example "USING: math.combinatorics prettyprint ;"
+        "0 { \"a\" \"b\" \"c\" \"d\" } 2 combination ." "{ \"a\" \"b\" }" }
+} ;
+
+HELP: all-combinations
+{ $values { "seq" sequence } { "k" "a non-negative integer" } { "seq" sequence } }
+{ $description "Outputs a sequence containing all combinations of " { $snippet "seq" } " choosing " { $snippet "k" } " elements, in lexicographical order." }
+{ $examples
+    { $example "USING: math.combinatorics prettyprint ;"
+        "{ \"a\" \"b\" \"c\" \"d\" } 2 all-combinations ."
+<" {
+    { "a" "b" }
+    { "a" "c" }
+    { "a" "d" }
+    { "b" "c" }
+    { "b" "d" }
+    { "c" "d" }
+}"> } } ;
+
+HELP: each-combination
+{ $values { "seq" sequence } { "k" "a non-negative integer" } { "quot" { $quotation "( seq -- )" } } }
+{ $description "Applies the quotation to each combination of " { $snippet "seq" } " choosing " { $snippet "k" } " elements, in order." } ;
 
 
 IN: math.combinatorics.private

basis/math/combinatorics/combinatorics-tests.factor

@@ -1,18 +1,6 @@
-USING: math.combinatorics math.combinatorics.private tools.test ;
+USING: math.combinatorics math.combinatorics.private tools.test sequences ;
 IN: math.combinatorics.tests
 
-[ { } ] [ 0 factoradic ] unit-test
-[ { 1 0 } ] [ 1 factoradic ] unit-test
-[ { 1 1 0 3 0 1 0 } ] [ 859 factoradic ] unit-test
-
-[ { 0 1 2 3 } ] [ { 0 0 0 0 } >permutation ] unit-test
-[ { 0 1 3 2 } ] [ { 0 0 1 0 } >permutation ] unit-test
-[ { 1 2 0 6 3 5 4 } ] [ { 1 1 0 3 0 1 0 } >permutation ] unit-test
-
-[ { 0 1 2 3 } ] [ 0 4 permutation-indices ] unit-test
-[ { 0 1 3 2 } ] [ 1 4 permutation-indices ] unit-test
-[ { 1 2 0 6 3 5 4 } ] [ 859 7 permutation-indices ] unit-test
-
 [ 1 ] [ 0 factorial ] unit-test
 [ 1 ] [ 1 factorial ] unit-test
 [ 3628800 ] [ 10 factorial ] unit-test
@@ -31,6 +19,19 @@ IN: math.combinatorics.tests
 [ 2598960 ] [ 52 5 nCk ] unit-test
 [ 2598960 ] [ 52 47 nCk ] unit-test
 
+
+[ { } ] [ 0 factoradic ] unit-test
+[ { 1 0 } ] [ 1 factoradic ] unit-test
+[ { 1 1 0 3 0 1 0 } ] [ 859 factoradic ] unit-test
+
+[ { 0 1 2 3 } ] [ { 0 0 0 0 } >permutation ] unit-test
+[ { 0 1 3 2 } ] [ { 0 0 1 0 } >permutation ] unit-test
+[ { 1 2 0 6 3 5 4 } ] [ { 1 1 0 3 0 1 0 } >permutation ] unit-test
+
+[ { 0 1 2 3 } ] [ 0 4 iota permutation-indices ] unit-test
+[ { 0 1 3 2 } ] [ 1 4 iota permutation-indices ] unit-test
+[ { 1 2 0 6 3 5 4 } ] [ 859 7 iota permutation-indices ] unit-test
+
 [ { "a" "b" "c" "d" } ] [ 0 { "a" "b" "c" "d" } permutation ] unit-test
 [ { "d" "c" "b" "a" } ] [ 23 { "a" "b" "c" "d" } permutation ] unit-test
 [ { "d" "a" "b" "c" } ] [ 18 { "a" "b" "c" "d" } permutation ] unit-test
@@ -43,3 +44,29 @@ IN: math.combinatorics.tests
 [ { 2 1 0 } ] [ { "c" "b" "a" } inverse-permutation ] unit-test
 [ { 3 0 2 1 } ] [ { 12 45 34 2 } inverse-permutation ] unit-test
 
+
+[ 2598960 ] [ 52 iota 5 <combo> choose ] unit-test
+
+[ 6 3 13 6 ] [ 7 4 28 next-values ] unit-test
+[ 5 2 3 5 ] [ 6 3 13 next-values ] unit-test
+[ 3 1 0 3 ] [ 5 2 3 next-values ] unit-test
+[ 0 0 0 0 ] [ 3 1 0 next-values ] unit-test
+
+[ 9 ] [ 0 5 iota 3 <combo> dual-index ] unit-test
+[ 0 ] [ 9 5 iota 3 <combo> dual-index ] unit-test
+[ 179 ] [ 72 10 iota 5 <combo> dual-index ] unit-test
+
+[ { 5 3 2 1 } ] [ 7 4 <combo> 8 combinadic ] unit-test
+[ { 4 3 2 1 0 } ] [ 10 iota 5 <combo> 0 combinadic ] unit-test
+[ { 8 6 3 1 0 } ] [ 10 iota 5 <combo> 72 combinadic ] unit-test
+[ { 9 8 7 6 5 } ] [ 10 iota 5 <combo> 251 combinadic ] unit-test
+
+[ { 0 1 2 } ] [ 0 5 iota 3 <combo> combination-indices ] unit-test
+[ { 2 3 4 } ] [ 9 5 iota 3 <combo> combination-indices ] unit-test
+
+[ { "a" "b" "c" } ] [ 0 { "a" "b" "c" "d" "e" } 3 combination ] unit-test
+[ { "c" "d" "e" } ] [ 9 { "a" "b" "c" "d" "e" } 3 combination ] unit-test
+
+[ { { "a" "b" } { "a" "c" }
+    { "a" "d" } { "b" "c" }
+    { "b" "d" } { "c" "d" } } ] [ { "a" "b" "c" "d" } 2 all-combinations ] unit-test

basis/math/combinatorics/combinatorics.factor

@@ -1,7 +1,7 @@
-! Copyright (c) 2007, 2008 Slava Pestov, Doug Coleman, Aaron Schaefer.
+! Copyright (c) 2007-2009 Slava Pestov, Doug Coleman, Aaron Schaefer.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: assocs kernel math math.order math.ranges mirrors
+USING: accessors assocs binary-search fry kernel locals math math.order
-namespaces sequences sorting fry ;
+    math.ranges mirrors namespaces sequences sorting ;
 IN: math.combinatorics
 
 <PRIVATE
@@ -12,14 +12,27 @@ IN: math.combinatorics
 : twiddle ( n k -- n k )
     2dup - dupd > [ dupd - ] when ; inline
 
-! See this article for explanation of the factoradic-based permutation methodology:
+PRIVATE>
-! http://msdn2.microsoft.com/en-us/library/aa302371.aspx
+
+: factorial ( n -- n! )
+    1 [ 1 + * ] reduce ;
+
+: nPk ( n k -- nPk )
+    2dup possible? [ dupd - [a,b) product ] [ 2drop 0 ] if ;
+
+: nCk ( n k -- nCk )
+    twiddle [ nPk ] keep factorial / ;
+
+
+! Factoradic-based permutation methodology
+
+<PRIVATE
 
 : factoradic ( n -- factoradic )
-    0 [ over 0 > ] [ 1+ [ /mod ] keep swap ] produce reverse 2nip ;
+    0 [ over 0 > ] [ 1 + [ /mod ] keep swap ] produce reverse 2nip ;
 
 : (>permutation) ( seq n -- seq )
-    [ '[ _ dupd >= [ 1+ ] when ] map ] keep prefix ;
+    [ '[ _ dupd >= [ 1 + ] when ] map ] keep prefix ;
 
 : >permutation ( factoradic -- permutation )
     reverse 1 cut [ (>permutation) ] each ;
@@ -29,27 +42,84 @@ IN: math.combinatorics
 
 PRIVATE>
 
-: factorial ( n -- n! )
-    1 [ 1+ * ] reduce ;
-
-: nPk ( n k -- nPk )
-    2dup possible? [ dupd - [a,b) product ] [ 2drop 0 ] if ;
-
-: nCk ( n k -- nCk )
-    twiddle [ nPk ] keep factorial / ;
-
 : permutation ( n seq -- seq )
     [ permutation-indices ] keep nths ;
 
 : all-permutations ( seq -- seq )
-    [ length factorial ] keep '[ _ permutation ] map ;
+    [ length factorial ] keep
+    '[ _ permutation ] map ;
 
 : each-permutation ( seq quot -- )
     [ [ length factorial ] keep ] dip
     '[ _ permutation @ ] each ; inline
 
-: reduce-permutations ( seq initial quot -- result )
+: reduce-permutations ( seq identity quot -- result )
     swapd each-permutation ; inline
 
 : inverse-permutation ( seq -- permutation )
     <enum> >alist sort-values keys ;
+
+
+! Combinadic-based combination methodology
+
+<PRIVATE
+
+TUPLE: combo
+    { seq sequence }
+    { k integer } ;
+
+C: <combo> combo
+
+: choose ( combo -- nCk )
+    [ seq>> length ] [ k>> ] bi nCk ;
+
+: largest-value ( a b x -- v )
+    dup 0 = [
+        drop 1 - nip
+    ] [
+        [ [0,b) ] 2dip '[ _ nCk _ >=< ] search nip
+    ] if ;
+
+:: next-values ( a b x -- a' b' x' v )
+    a b x largest-value dup :> v  ! a'
+    b 1 -                         ! b'
+    x v b nCk -                   ! x'
+    v ;                           ! v == a'
+
+: dual-index ( m combo -- m' )
+    choose 1 - swap - ;
+
+: initial-values ( combo m -- n k m )
+    [ [ seq>> length ] [ k>> ] bi ] dip ;
+
+: combinadic ( combo m -- combinadic )
+    initial-values [ over 0 > ] [ next-values ] produce
+    [ 3drop ] dip ;
+
+: combination-indices ( m combo -- seq )
+    [ tuck dual-index combinadic ] keep
+    seq>> length 1 - swap [ - ] with map ;
+
+: apply-combination ( m combo -- seq )
+    [ combination-indices ] keep seq>> nths ;
+
+PRIVATE>
+
+: combination ( m seq k -- seq )
+    <combo> apply-combination ;
+
+: all-combinations ( seq k -- seq )
+    <combo> [ choose [0,b) ] keep
+    '[ _ apply-combination ] map ;
+
+: each-combination ( seq k quot -- )
+    [ <combo> [ choose [0,b) ] keep ] dip
+    '[ _ apply-combination @ ] each ; inline
+
+: map-combinations ( seq k quot -- )
+    [ <combo> [ choose [0,b) ] keep ] dip
+    '[ _ apply-combination @ ] map ; inline
+
+: reduce-combinations ( seq k identity quot -- result )
+    [ -rot ] dip each-combination ; inline
+

basis/math/miller-rabin/miller-rabin-docs.factor

@@ -1,100 +0,0 @@
-! Copyright (C) 2009 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax kernel sequences math ;
-IN: math.miller-rabin
-
-HELP: find-relative-prime
-{ $values
-    { "n" integer }
-    { "p" integer }
-}
-{ $description "Returns a number that is relatively prime to " { $snippet "n" } "." } ;
-
-HELP: find-relative-prime*
-{ $values
-    { "n" integer } { "guess" integer }
-    { "p" integer }
-}
-{ $description "Returns a number that is relatively prime to " { $snippet "n" } ", starting by trying " { $snippet "guess" } "." } ;
-
-HELP: miller-rabin
-{ $values
-    { "n" integer }
-    { "?" "a boolean" }
-}
-{ $description "Returns true if the number is a prime. Calls " { $link miller-rabin* } " with a default of 10 Miller-Rabin tests." } ;
-
-{ miller-rabin miller-rabin* } related-words
-
-HELP: miller-rabin*
-{ $values
-    { "n" integer } { "numtrials" integer }
-    { "?" "a boolean" }
-}
-{ $description "Performs " { $snippet "numtrials" } " trials of the Miller-Rabin probabilistic primality test algorithm and returns true if prime." } ;
-
-HELP: next-prime
-{ $values
-    { "n" integer }
-    { "p" integer }
-}
-{ $description "Tests consecutive numbers for primality with " { $link miller-rabin } " and returns the next prime." } ;
-
-HELP: next-safe-prime
-{ $values
-    { "n" integer }
-    { "q" integer }
-}
-{ $description "Tests consecutive numbers and returns the next safe prime. A safe prime is desirable in cryptography applications such as Diffie-Hellman and SRP6." } ;
-
-HELP: random-bits*
-{ $values
-    { "numbits" integer }
-    { "n" integer }
-}
-{ $description "Returns an integer exactly " { $snippet "numbits" } " in length, with the topmost bit set to one." } ;
-
-HELP: random-prime
-{ $values
-    { "numbits" integer }
-    { "p" integer }
-}
-{ $description "Returns a prime number exactly " { $snippet "numbits" } " bits in length, with the topmost bit set to one." } ;
-
-HELP: random-safe-prime
-{ $values
-    { "numbits" integer }
-    { "p" integer }
-}
-{ $description "Returns a safe prime number " { $snippet "numbits" } " bits in length, with the topmost bit set to one." } ;
-
-HELP: safe-prime?
-{ $values
-    { "q" integer }
-    { "?" "a boolean" }
-}
-{ $description "Tests whether the number is a safe prime. A safe prime " { $snippet "p" } " must be prime, as must " { $snippet "(p - 1) / 2" } "." } ;
-
-HELP: unique-primes
-{ $values
-    { "numbits" integer } { "n" integer }
-    { "seq" sequence }
-}
-{ $description "Generates a sequence of " { $snippet "n" } " unique prime numbers with exactly " { $snippet "numbits" } " bits." } ;
-
-ARTICLE: "math.miller-rabin" "Miller-Rabin probabilistic primality test"
-"The " { $vocab-link "math.miller-rabin" } " vocabulary implements the Miller-Rabin probabilistic primality test and utility words that use it in order to generate random prime numbers." $nl
-"The Miller-Rabin probabilistic primality test:"
-{ $subsection miller-rabin }
-{ $subsection miller-rabin* }
-"Generating relative prime numbers:"
-{ $subsection find-relative-prime }
-{ $subsection find-relative-prime* }
-"Generating prime numbers:"
-{ $subsection next-prime }
-{ $subsection random-prime }
-"Generating safe prime numbers:"
-{ $subsection next-safe-prime }
-{ $subsection random-safe-prime } ;
-
-ABOUT: "math.miller-rabin"

basis/math/miller-rabin/miller-rabin-tests.factor

@@ -1,29 +0,0 @@
-USING: math.miller-rabin tools.test kernel sequences
-math.miller-rabin.private math ;
-IN: math.miller-rabin.tests
-
-[ f ] [ 473155932665450549999756893736999469773678960651272093993257221235459777950185377130233556540099119926369437865330559863 miller-rabin ] unit-test
-[ t ] [ 2 miller-rabin ] unit-test
-[ t ] [ 3 miller-rabin ] unit-test
-[ f ] [ 36 miller-rabin ] unit-test
-[ t ] [ 37 miller-rabin ] unit-test
-[ 2 ] [ 1 next-prime ] unit-test
-[ 3 ] [ 2 next-prime ] unit-test
-[ 5 ] [ 3 next-prime ] unit-test
-[ 101 ] [ 100 next-prime ] unit-test
-[ t ] [ 2135623355842621559 miller-rabin ] unit-test
-[ 100000000000031 ] [ 100000000000000 next-prime ] unit-test
-
-[ 863 ] [ 862 next-safe-prime ] unit-test
-[ f ] [ 862 safe-prime? ] unit-test
-[ t ] [ 7 safe-prime? ] unit-test
-[ f ] [ 31 safe-prime? ] unit-test
-[ t ] [ 47 safe-prime-candidate? ] unit-test
-[ t ] [ 47 safe-prime? ] unit-test
-[ t ] [ 863 safe-prime? ] unit-test
-
-[ f ] [ 1000 [ drop 15 miller-rabin ] any? ] unit-test
-
-[ 47 ] [ 31 next-safe-prime ] unit-test
-[ 49 ] [ 50 random-prime log2 ] unit-test
-[ 49 ] [ 50 random-bits* log2 ] unit-test

basis/math/miller-rabin/miller-rabin.factor

@@ -1,114 +0,0 @@
-! Copyright (C) 2008 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: combinators kernel locals math math.functions math.ranges
-random sequences sets combinators.short-circuit math.bitwise
-math math.order ;
-IN: math.miller-rabin
-
-: >odd ( n -- int ) 0 set-bit ; foldable
-
-: >even ( n -- int ) 0 clear-bit ; foldable
-
-: next-even ( m -- n ) >even 2 + ;
-
-: next-odd ( m -- n ) dup even? [ 1 + ] [ 2 + ] if ;
-
-<PRIVATE
-
-:: (miller-rabin) ( n trials -- ? )
-    n 1 - :> n-1
-    n-1 factor-2s :> s :> r
-    0 :> a!
-    trials [
-        drop
-        2 n 2 - [a,b] random a!
-        a s n ^mod 1 = [
-            f
-        ] [
-            r iota [
-                2^ s * a swap n ^mod n - -1 =
-            ] any? not 
-        ] if
-    ] any? not ;
-
-PRIVATE>
-
-: miller-rabin* ( n numtrials -- ? )
-    over {
-        { [ dup 1 <= ] [ 3drop f ] }
-        { [ dup 2 = ] [ 3drop t ] }
-        { [ dup even? ] [ 3drop f ] }
-        [ drop (miller-rabin) ]
-    } cond ;
-
-: miller-rabin ( n -- ? ) 10 miller-rabin* ;
-
-ERROR: prime-range-error n ;
-
-: next-prime ( n -- p )
-    dup 1 < [ prime-range-error ] when
-    dup 1 = [
-        drop 2
-    ] [
-        next-odd dup miller-rabin [ next-prime ] unless
-    ] if ;
-
-: random-bits* ( numbits -- n )
-    1 - [ random-bits ] keep set-bit ;
-
-: random-prime ( numbits -- p )
-    random-bits* next-prime ;
-
-ERROR: no-relative-prime n ;
-
-<PRIVATE
-
-: (find-relative-prime) ( n guess -- p )
-    over 1 <= [ over no-relative-prime ] when
-    dup 1 <= [ drop 3 ] when
-    2dup gcd nip 1 > [ 2 + (find-relative-prime) ] [ nip ] if ;
-
-PRIVATE>
-
-: find-relative-prime* ( n guess -- p )
-    #! find a prime relative to n with initial guess
-    >odd (find-relative-prime) ;
-
-: find-relative-prime ( n -- p )
-    dup random find-relative-prime* ;
-
-ERROR: too-few-primes ;
-
-: unique-primes ( numbits n -- seq )
-    #! generate two primes
-    swap
-    dup 5 < [ too-few-primes ] when
-    2dup [ random-prime ] curry replicate
-    dup all-unique? [ 2nip ] [ drop unique-primes ] if ;
-
-! Safe primes are of the form p = 2q + 1, p,q are prime
-! See http://en.wikipedia.org/wiki/Safe_prime
-
-<PRIVATE
-
-: safe-prime-candidate? ( n -- ? )
-    1 + 6 divisor? ;
-
-: next-safe-prime-candidate ( n -- candidate )
-    next-prime dup safe-prime-candidate?
-    [ next-safe-prime-candidate ] unless ;
-
-PRIVATE>
-
-: safe-prime? ( q -- ? )
-    {
-        [ 1 - 2 / dup integer? [ miller-rabin ] [ drop f ] if ]
-        [ miller-rabin ]
-    } 1&& ;
-
-: next-safe-prime ( n -- q )
-    next-safe-prime-candidate
-    dup safe-prime? [ next-safe-prime ] unless ;
-
-: random-safe-prime ( numbits -- p )
-    random-bits* next-safe-prime ;

basis/math/polynomials/polynomials-docs.factor

@@ -93,7 +93,13 @@ HELP: pdiff
 { $description "Finds the derivative of " { $snippet "p" } "." } ;
 
 HELP: polyval
-{ $values { "p" "a polynomial" } { "x" number } { "p[x]" number } }
+{ $values { "x" number } { "p" "a polynomial" } { "p[x]" number } }
 { $description "Evaluate " { $snippet "p" } " with the input " { $snippet "x" } "." }
-{ $examples { $example "USING: math.polynomials prettyprint ;" "{ 1 0 1 } 2 polyval ." "5" } } ;
+{ $examples { $example "USING: math.polynomials prettyprint ;" "2 { 1 0 1 } polyval ." "5" } } ;
 
+HELP: polyval*
+{ $values { "p" "a literal polynomial" } }
+{ $description "Macro version of " { $link polyval } ". Evaluates the literal polynomial " { $snippet "p" } " at the value off the top of the stack." }
+{ $examples { $example "USING: math.polynomials prettyprint ;" "2 { 1 0 1 } polyval* ." "5" } } ;
+
+{ polyval polyval* } related-words

basis/math/polynomials/polynomials.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays kernel make math math.order math.vectors sequences
-    splitting vectors ;
+    splitting vectors macros combinators ;
 IN: math.polynomials
 
 <PRIVATE
@@ -80,6 +80,12 @@ PRIVATE>
 : pdiff ( p -- p' )
     dup length v* { 0 } ?head drop ;
 
-: polyval ( p x -- p[x] )
+: polyval ( x p -- p[x] )
-    [ dup length ] dip powers v. ;
+    [ length swap powers ] [ nip ] 2bi v. ;
+
+MACRO: polyval* ( p -- )
+    reverse
+    [ 1 tail [ \ * swap \ + [ ] 3sequence ] map ]
+    [ first \ drop swap [ ] 2sequence ] bi
+    prefix \ cleave [ ] 2sequence ;
 

basis/math/primes/factors/factors.factor

@@ -1,6 +1,7 @@
 ! Copyright (C) 2007-2009 Samuel Tardieu.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays combinators kernel make math math.functions math.primes sequences ;
+USING: arrays combinators kernel make math math.functions
+math.primes sequences ;
 IN: math.primes.factors
 
 <PRIVATE

basis/math/primes/lucas-lehmer/authors.txt

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

basis/math/primes/lucas-lehmer/lucas-lehmer-docs.factor

@@ -0,0 +1,25 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax kernel ;
+IN: math.primes.lucas-lehmer
+
+HELP: lucas-lehmer
+{ $values
+    { "p" "a prime number" }
+    { "?" "a boolean" }
+}
+{ $description "Runs the Lucas-Lehmer test on the prime " { $snippet "p" } " and returns " { $link t } " if " { $snippet "(2 ^ p) - 1" } " is prime." }
+{ $examples
+    { $example "! Test that (2 ^ 61) - 1 is prime:"
+               "USING: math.primes.lucas-lehmer prettyprint ;"
+               "61 lucas-lehmer ."
+               "t"
+    }
+} ;
+
+ARTICLE: "math.primes.lucas-lehmer" "Lucas-Lehmer Mersenne Primality test"
+"The " { $vocab-link "math.primes.lucas-lehmer" } " vocabulary tests numbers of the form " { $snippet "(2 ^ p) - 1" } " for primality, where " { $snippet "p" } " is prime." $nl
+"Run the Lucas-Lehmer test:"
+{ $subsection lucas-lehmer } ;
+
+ABOUT: "math.primes.lucas-lehmer"

basis/math/primes/lucas-lehmer/lucas-lehmer-tests.factor

@@ -0,0 +1,13 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test math.primes.lucas-lehmer ;
+IN: math.primes.lucas-lehmer.tests
+
+[ t ] [ 2 lucas-lehmer ] unit-test
+[ t ] [ 3 lucas-lehmer ] unit-test
+[ f ] [ 4 lucas-lehmer ] unit-test
+[ t ] [ 5 lucas-lehmer ] unit-test
+[ f ] [ 6 lucas-lehmer ] unit-test
+[ f ] [ 11 lucas-lehmer ] unit-test
+[ t ] [ 13 lucas-lehmer ] unit-test
+[ t ] [ 61 lucas-lehmer ] unit-test

basis/math/primes/lucas-lehmer/lucas-lehmer.factor

@@ -0,0 +1,27 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: combinators fry kernel locals math
+math.primes combinators.short-circuit ;
+IN: math.primes.lucas-lehmer
+
+ERROR: invalid-lucas-lehmer-candidate obj ;
+
+<PRIVATE
+
+: do-lucas-lehmer ( p -- ? )
+    [ drop 4 ] [ 2 - ] [ 2^ 1 - ] tri
+    '[ sq 2 - _ mod ] times 0 = ;
+
+: lucas-lehmer-guard ( obj -- obj )
+    dup { [ integer? ] [ 0 > ] } 1&&
+    [ invalid-lucas-lehmer-candidate ] unless ;
+
+PRIVATE>
+
+: lucas-lehmer ( p -- ? )
+    lucas-lehmer-guard
+    {
+        { [ dup 2 = ] [ drop t ] }
+        { [ dup prime? ] [ do-lucas-lehmer ] }
+        [ drop f ]
+    } cond ;

basis/math/primes/miller-rabin/miller-rabin-docs.factor

@@ -0,0 +1,28 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax kernel sequences math ;
+IN: math.primes.miller-rabin
+
+HELP: miller-rabin
+{ $values
+    { "n" integer }
+    { "?" "a boolean" }
+}
+{ $description "Returns true if the number is a prime. Calls " { $link miller-rabin* } " with a default of 10 Miller-Rabin tests." } ;
+
+{ miller-rabin miller-rabin* } related-words
+
+HELP: miller-rabin*
+{ $values
+    { "n" integer } { "numtrials" integer }
+    { "?" "a boolean" }
+}
+{ $description "Performs " { $snippet "numtrials" } " trials of the Miller-Rabin probabilistic primality test algorithm and returns true if prime." } ;
+
+ARTICLE: "math.primes.miller-rabin" "Miller-Rabin probabilistic primality test"
+"The " { $vocab-link "math.primes.miller-rabin" } " vocabulary implements the Miller-Rabin probabilistic primality test and utility words that use it in order to generate random prime numbers." $nl
+"The Miller-Rabin probabilistic primality test:"
+{ $subsection miller-rabin }
+{ $subsection miller-rabin* } ;
+
+ABOUT: "math.primes.miller-rabin"

basis/math/primes/miller-rabin/miller-rabin-tests.factor

@@ -0,0 +1,11 @@
+USING: kernel math.primes.miller-rabin sequences tools.test ;
+IN: math.primes.miller-rabin.tests
+
+[ f ] [ 473155932665450549999756893736999469773678960651272093993257221235459777950185377130233556540099119926369437865330559863 miller-rabin ] unit-test
+[ t ] [ 2 miller-rabin ] unit-test
+[ t ] [ 3 miller-rabin ] unit-test
+[ f ] [ 36 miller-rabin ] unit-test
+[ t ] [ 37 miller-rabin ] unit-test
+[ t ] [ 2135623355842621559 miller-rabin ] unit-test
+
+[ f ] [ 1000 [ drop 15 miller-rabin ] any? ] unit-test

basis/math/primes/miller-rabin/miller-rabin.factor

@@ -0,0 +1,35 @@
+! Copyright (c) 2008-2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: combinators combinators.short-circuit kernel locals math
+math.functions math.ranges random sequences sets ;
+IN: math.primes.miller-rabin
+
+<PRIVATE
+
+:: (miller-rabin) ( n trials -- ? )
+    n 1 - :> n-1
+    n-1 factor-2s :> s :> r
+    0 :> a!
+    trials [
+        drop
+        2 n 2 - [a,b] random a!
+        a s n ^mod 1 = [
+            f
+        ] [
+            r iota [
+                2^ s * a swap n ^mod n - -1 =
+            ] any? not
+        ] if
+    ] any? not ;
+
+PRIVATE>
+
+: miller-rabin* ( n numtrials -- ? )
+    over {
+        { [ dup 1 <= ] [ 3drop f ] }
+        { [ dup 2 = ] [ 3drop t ] }
+        { [ dup even? ] [ 3drop f ] }
+        [ drop (miller-rabin) ]
+    } cond ;
+
+: miller-rabin ( n -- ? ) 10 miller-rabin* ;

basis/math/primes/primes-docs.factor

@@ -1,10 +1,10 @@
-USING: help.markup help.syntax ;
+USING: help.markup help.syntax math sequences ;
 IN: math.primes
 
 { next-prime prime? } related-words
 
 HELP: next-prime
-{ $values { "n" "an integer not smaller than 2" } { "p" "a prime number" } }
+{ $values { "n" integer } { "p" "a prime number" } }
 { $description "Return the next prime number greater than " { $snippet "n" } "." } ;
 
 HELP: prime?
@@ -20,3 +20,48 @@ HELP: primes-upto
 HELP: primes-between
 { $values { "low" "an integer" } { "high" "an integer" } { "seq" "a sequence" } }
 { $description "Return a sequence containing all the prime numbers between " { $snippet "low" } " and " { $snippet "high" } "." } ;
+
+HELP: find-relative-prime
+{ $values
+    { "n" integer }
+    { "p" integer }
+}
+{ $description "Returns a number that is relatively prime to " { $snippet "n" } "." } ;
+
+HELP: find-relative-prime*
+{ $values
+    { "n" integer } { "guess" integer }
+    { "p" integer }
+}
+{ $description "Returns a number that is relatively prime to " { $snippet "n" } ", starting by trying " { $snippet "guess" } "." } ;
+
+HELP: random-prime
+{ $values
+    { "numbits" integer }
+    { "p" integer }
+}
+{ $description "Returns a prime number exactly " { $snippet "numbits" } " bits in length, with the topmost bit set to one." } ;
+
+HELP: unique-primes
+{ $values
+    { "numbits" integer } { "n" integer }
+    { "seq" sequence }
+}
+{ $description "Generates a sequence of " { $snippet "n" } " unique prime numbers with exactly " { $snippet "numbits" } " bits." } ;
+
+ARTICLE: "math.primes" "Prime numbers"
+"The " { $vocab-link "math.primes" } " vocabulary implements words related to prime numbers. Serveral useful vocabularies exist for testing primality. The Sieve of Eratosthenes in " { $vocab-link "math.primes.erato" } " is useful for testing primality below five million. For larger integers, " { $vocab-link "math.primes.miller-rabin" } " is a fast probabilstic primality test. The " { $vocab-link "math.primes.lucas-lehmer" } " vocabulary implements an algorithm for finding huge Mersenne prime numbers." $nl
+"Testing if a number is prime:"
+{ $subsection prime? }
+"Generating prime numbers:"
+{ $subsection next-prime }
+{ $subsection primes-upto }
+{ $subsection primes-between }
+{ $subsection random-prime }
+"Generating relative prime numbers:"
+{ $subsection find-relative-prime }
+{ $subsection find-relative-prime* }
+"Make a sequence of random prime numbers:"
+{ $subsection unique-primes } ;
+
+ABOUT: "math.primes"

basis/math/primes/primes-tests.factor

@@ -1,4 +1,6 @@
-USING: arrays math.primes tools.test ;
+USING: arrays math math.primes math.primes.miller-rabin
+tools.test ;
+IN: math.primes.tests
 
 { 1237 } [ 1234 next-prime ] unit-test
 { f t } [ 1234 prime? 1237 prime? ] unit-test
@@ -7,3 +9,12 @@ USING: arrays math.primes tools.test ;
 
 { { 4999963 4999999 5000011 5000077 5000081 } }
 [ 4999962 5000082 primes-between >array ] unit-test
+
+[ 2 ] [ 1 next-prime ] unit-test
+[ 3 ] [ 2 next-prime ] unit-test
+[ 5 ] [ 3 next-prime ] unit-test
+[ 101 ] [ 100 next-prime ] unit-test
+[ t ] [ 2135623355842621559 miller-rabin ] unit-test
+[ 100000000000031 ] [ 100000000000000 next-prime ] unit-test
+
+[ 49 ] [ 50 random-prime log2 ] unit-test

basis/math/primes/primes.factor

@@ -1,7 +1,8 @@
 ! Copyright (C) 2007-2009 Samuel Tardieu.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: combinators kernel math math.functions math.miller-rabin
+USING: combinators kernel math math.bitwise math.functions
-math.order math.primes.erato math.ranges sequences ;
+math.order math.primes.erato math.primes.miller-rabin
+math.ranges random sequences sets fry ;
 IN: math.primes
 
 <PRIVATE
@@ -21,7 +22,11 @@ PRIVATE>
     } cond ; foldable
 
 : next-prime ( n -- p )
-    next-odd [ dup really-prime? ] [ 2 + ] until ; foldable
+    dup 2 < [
+        drop 2
+    ] [
+        next-odd [ dup really-prime? ] [ 2 + ] until
+    ] if ; foldable
 
 : primes-between ( low high -- seq )
     [ dup 3 max dup even? [ 1 + ] when ] dip
@@ -31,3 +36,34 @@ PRIVATE>
 : primes-upto ( n -- seq ) 2 swap primes-between ;
 
 : coprime? ( a b -- ? ) gcd nip 1 = ; foldable
+
+: random-prime ( numbits -- p )
+    random-bits* next-prime ;
+
+: estimated-primes ( m -- n )
+    dup log / ; foldable
+
+ERROR: no-relative-prime n ;
+
+<PRIVATE
+
+: (find-relative-prime) ( n guess -- p )
+    over 1 <= [ over no-relative-prime ] when
+    dup 1 <= [ drop 3 ] when
+    2dup gcd nip 1 > [ 2 + (find-relative-prime) ] [ nip ] if ;
+
+PRIVATE>
+
+: find-relative-prime* ( n guess -- p )
+    #! find a prime relative to n with initial guess
+    >odd (find-relative-prime) ;
+
+: find-relative-prime ( n -- p )
+    dup random find-relative-prime* ;
+
+ERROR: too-few-primes n numbits ;
+
+: unique-primes ( n numbits -- seq )
+    2dup 2^ estimated-primes > [ too-few-primes ] when
+    2dup '[ _ random-prime ] replicate
+    dup all-unique? [ 2nip ] [ drop unique-primes ] if ;

basis/math/primes/safe/authors.txt

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

basis/math/primes/safe/safe-docs.factor

@@ -0,0 +1,38 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: combinators.short-circuit help.markup help.syntax kernel
+math math.functions math.primes random ;
+IN: math.primes.safe
+
+HELP: next-safe-prime
+{ $values
+    { "n" integer }
+    { "q" integer }
+}
+{ $description "Tests consecutive numbers and returns the next safe prime. A safe prime is desirable in cryptography applications such as Diffie-Hellman and SRP6." } ;
+
+HELP: random-safe-prime
+{ $values
+    { "numbits" integer }
+    { "p" integer }
+}
+{ $description "Returns a safe prime number " { $snippet "numbits" } " bits in length, with the topmost bit set to one." } ;
+
+HELP: safe-prime?
+{ $values
+    { "q" integer }
+    { "?" "a boolean" }
+}
+{ $description "Tests whether the number is a safe prime. A safe prime " { $snippet "p" } " must be prime, as must " { $snippet "(p - 1) / 2" } "." } ;
+
+
+ARTICLE: "math.primes.safe" "Safe prime numbers"
+"The " { $vocab-link "math.primes.safe" } " vocabulary implements words to calculate safe prime numbers. Safe primes are of the form p = 2q + 1, where p,q are prime. Safe primes have desirable qualities for cryptographic applications." $nl
+
+"Testing if a number is a safe prime:"
+{ $subsection safe-prime? }
+"Generating safe prime numbers:"
+{ $subsection next-safe-prime }
+{ $subsection random-safe-prime } ;
+
+ABOUT: "math.primes.safe"

basis/math/primes/safe/safe-tests.factor

@@ -0,0 +1,14 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: math.primes.safe math.primes.safe.private tools.test ;
+IN: math.primes.safe.tests
+
+[ 863 ] [ 862 next-safe-prime ] unit-test
+[ f ] [ 862 safe-prime? ] unit-test
+[ t ] [ 7 safe-prime? ] unit-test
+[ f ] [ 31 safe-prime? ] unit-test
+[ t ] [ 47 safe-prime-candidate? ] unit-test
+[ t ] [ 47 safe-prime? ] unit-test
+[ t ] [ 863 safe-prime? ] unit-test
+
+[ 47 ] [ 31 next-safe-prime ] unit-test

basis/math/primes/safe/safe.factor

@@ -0,0 +1,29 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: combinators.short-circuit kernel math math.functions
+math.primes random ;
+IN: math.primes.safe
+
+<PRIVATE
+
+: safe-prime-candidate? ( n -- ? )
+    1 + 6 divisor? ;
+
+: next-safe-prime-candidate ( n -- candidate )
+    next-prime dup safe-prime-candidate?
+    [ next-safe-prime-candidate ] unless ;
+
+PRIVATE>
+
+: safe-prime? ( q -- ? )
+    {
+        [ 1 - 2 / dup integer? [ prime? ] [ drop f ] if ]
+        [ prime? ]
+    } 1&& ;
+
+: next-safe-prime ( n -- q )
+    next-safe-prime-candidate
+    dup safe-prime? [ next-safe-prime ] unless ;
+
+: random-safe-prime ( numbits -- p )
+    random-bits* next-safe-prime ;

basis/math/rectangles/prettyprint/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

basis/math/rectangles/prettyprint/prettyprint.factor

@@ -0,0 +1,7 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors math.rectangles kernel prettyprint.custom prettyprint.backend ;
+IN: math.rectangles.prettyprint
+
+M: rect pprint*
+    \ RECT: [ [ loc>> ] [ dim>> ] bi [ pprint* ] bi@ ] pprint-prefix ;

basis/math/rectangles/rectangles.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel arrays sequences math math.vectors accessors
-parser prettyprint.custom prettyprint.backend ;
+parser ;
 IN: math.rectangles
 
 TUPLE: rect { loc initial: { 0 0 } } { dim initial: { 0 0 } } ;
@@ -10,9 +10,6 @@ TUPLE: rect { loc initial: { 0 0 } } { dim initial: { 0 0 } } ;
 
 SYNTAX: RECT: scan-object scan-object <rect> parsed ;
 
-M: rect pprint*
-    \ RECT: [ [ loc>> ] [ dim>> ] bi [ pprint* ] bi@ ] pprint-prefix ;
-
 : <zero-rect> ( -- rect ) rect new ; inline
 
 : point>rect ( loc -- rect ) { 0 0 } <rect> ; inline
@@ -21,6 +18,8 @@ M: rect pprint*
 
 : rect-extent ( rect -- loc ext ) rect-bounds over v+ ;
 
+: rect-center ( rect -- center ) rect-bounds 2 v/n v+ ;
+
 : with-rect-extents ( rect1 rect2 loc-quot: ( loc1 loc2 -- ) ext-quot: ( ext1 ext2 -- ) -- )
     [ [ rect-extent ] bi@ ] 2dip bi-curry* bi* ; inline
 
@@ -62,3 +61,7 @@ M: rect contains-point?
     [ [ loc>> ] dip (>>loc) ]
     [ [ dim>> ] dip (>>dim) ]
     2bi ; inline
+
+USING: vocabs vocabs.loader ;
+
+"prettyprint" vocab [ "math.rectangles.prettyprint" require ] when

basis/math/vectors/vectors-tests.factor

@@ -14,3 +14,5 @@ USING: math.vectors tools.test ;
 [ { 1.75 1.75 } ] [ { 1.0 2.5 } { 2.5 1.0 } 0.5 vnlerp ] unit-test 
 
 [ { 1.75 2.125 } ] [ { 1.0 2.5 } { 2.5 1.0 } { 0.5 0.25 } vlerp ] unit-test 
+
+[ 1.125 ] [ 0.0 1.0 2.0 4.0 { 0.5 0.25 } bilerp ] unit-test

basis/math/vectors/vectors.factor

@@ -41,6 +41,17 @@ IN: math.vectors
 : set-axis ( u v axis -- w )
     [ [ zero? 2over ? ] dip swap nth ] map-index 2nip ;
 
+: 2tetra@ ( p q r s t u v w quot -- )
+    dup [ [ 2bi@ ] curry 4dip ] dip 2bi@ ; inline
+
+: trilerp ( aaa baa aba bba aab bab abb bbb {t,u,v} -- a_tuv )
+    [ first lerp ] [ second lerp ] [ third lerp ] tri-curry
+    [ 2tetra@ ] [ 2bi@ ] [ call ] tri* ;
+
+: bilerp ( aa ba ab bb {t,u} -- a_tu )
+    [ first lerp ] [ second lerp ] bi-curry
+    [ 2bi@ ] [ call ] bi* ;
+
 : vlerp ( a b t -- a_t )
     [ lerp ] 3map ;
 
@@ -68,3 +79,6 @@ HINTS: v. { array array } ;
 
 HINTS: vlerp { array array array } ;
 HINTS: vnlerp { array array object } ;
+
+HINTS: bilerp { object object object object array } ;
+HINTS: trilerp { object object object object object object object object array } ;

basis/random/random-docs.factor

@@ -40,9 +40,17 @@ HELP: random-bytes
 } ;
 
 HELP: random-bits
-{ $values { "n" "an integer" } { "r" "a random integer" } }
+{ $values { "numbits" integer } { "r" "a random integer" } }
 { $description "Outputs an random integer n bits in length." } ;
 
+HELP: random-bits*
+{ $values
+    { "numbits" integer }
+    { "n" integer }
+}
+{ $description "Returns an integer exactly " { $snippet "numbits" } " in length, with the topmost bit set to one." } ;
+
+
 HELP: with-random
 { $values { "tuple" "a random generator" } { "quot" "a quotation" } }
 { $description "Calls the quotation with the random generator in a dynamic variable.  All random numbers will be generated using this random generator." } ;
@@ -93,6 +101,9 @@ $nl
 "Randomizing a sequence:"
 { $subsection randomize }
 "Deleting a random element from a sequence:"
-{ $subsection delete-random } ;
+{ $subsection delete-random }
+"Random numbers with " { $snippet "n" } " bits:"
+{ $subsection random-bits }
+{ $subsection random-bits* } ;
 
 ABOUT: "random"

basis/random/random-tests.factor

@@ -23,3 +23,5 @@ IN: random.tests
 
 [ f ]
 [ 100 [ { 0 1 } random ] replicate all-equal? ] unit-test
+
+[ 49 ] [ 50 random-bits* log2 ] unit-test

basis/random/random.factor

@@ -45,7 +45,10 @@ M: f random-32* ( obj -- * ) no-random-number-generator ;
 
 PRIVATE>
 
-: random-bits ( n -- r ) 2^ random-integer ;
+: random-bits ( numbits -- r ) 2^ random-integer ;
+
+: random-bits* ( numbits -- n )
+    1 - [ random-bits ] keep set-bit ;
 
 : random ( seq -- elt )
     [ f ] [

basis/specialized-arrays/specialized-arrays-tests.factor

@@ -2,7 +2,8 @@ IN: specialized-arrays.tests
 USING: tools.test specialized-arrays sequences
 specialized-arrays.int specialized-arrays.bool
 specialized-arrays.ushort alien.c-types accessors kernel
-specialized-arrays.direct.int specialized-arrays.char arrays ;
+specialized-arrays.direct.int specialized-arrays.char
+specialized-arrays.uint arrays combinators ;
 
 [ t ] [ { 1 2 3 } >int-array int-array? ] unit-test
 
@@ -10,7 +11,13 @@ specialized-arrays.direct.int specialized-arrays.char arrays ;
 
 [ 2 ] [ int-array{ 1 2 3 } second ] unit-test
 
-[ t ] [ { t f t } >bool-array underlying>> { 1 0 1 } >char-array underlying>> = ] unit-test
+[ t ] [
+    { t f t } >bool-array underlying>>
+    { 1 0 1 } "bool" heap-size {
+        { 1 [ >char-array ] }
+        { 4 [ >uint-array ] }
+    } case underlying>> =
+] unit-test
 
 [ ushort-array{ 1234 } ] [
     little-endian? B{ 210 4 } B{ 4 210 } ? byte-array>ushort-array

basis/ui/backend/backend.factor

@@ -32,3 +32,7 @@ HOOK: offscreen-pixels ui-backend ( world -- alien w h )
     [ flush-gl-context gl-error ] bi ; inline
 
 HOOK: (with-ui) ui-backend ( quot -- )
+
+HOOK: (grab-input) ui-backend ( handle -- )
+
+HOOK: (ungrab-input) ui-backend ( handle -- )

basis/ui/backend/cocoa/cocoa.factor

@@ -122,6 +122,17 @@ M:: cocoa-ui-backend (open-window) ( world -- )
 M: cocoa-ui-backend (close-window) ( handle -- )
     window>> -> release ;
 
+M: cocoa-ui-backend (grab-input) ( handle -- )
+    0 CGAssociateMouseAndMouseCursorPosition drop
+    CGMainDisplayID CGDisplayHideCursor drop
+    window>> -> frame CGRect>rect rect-center
+    first2 <CGPoint> CGWarpMouseCursorPosition drop ;
+
+M: cocoa-ui-backend (ungrab-input) ( handle -- )
+    drop
+    CGMainDisplayID CGDisplayShowCursor drop
+    1 CGAssociateMouseAndMouseCursorPosition drop ;
+
 M: cocoa-ui-backend close-window ( gadget -- )
     find-world [
         handle>> [

basis/ui/backend/windows/windows.factor

@@ -11,7 +11,7 @@ threads libc combinators fry combinators.short-circuit continuations
 command-line shuffle opengl ui.render ascii math.bitwise locals
 accessors math.rectangles math.order ascii calendar
 io.encodings.utf16n windows.errors literals ui.pixel-formats 
-ui.pixel-formats.private memoize classes ;
+ui.pixel-formats.private memoize classes struct-arrays ;
 IN: ui.backend.windows
 
 SINGLETON: windows-ui-backend
@@ -703,9 +703,23 @@ M: windows-ui-backend beep ( -- )
     "MONITORINFOEX" <c-object> dup length over set-MONITORINFOEX-cbSize
     [ GetMonitorInfo win32-error=0/f ] keep MONITORINFOEX-rcMonitor ;
 
+: client-area>RECT ( hwnd -- RECT )
+    "RECT" <c-object>
+    [ GetClientRect win32-error=0/f ]
+    [ "POINT" byte-array>struct-array [ ClientToScreen drop ] with each ]
+    [ nip ] 2tri ;
+
 : hwnd>RECT ( hwnd -- RECT )
     "RECT" <c-object> [ GetWindowRect win32-error=0/f ] keep ;
 
+M: windows-ui-backend (grab-input) ( handle -- )
+    0 ShowCursor drop
+    hWnd>> client-area>RECT ClipCursor drop ;
+M: windows-ui-backend (ungrab-input) ( handle -- )
+    drop
+    f ClipCursor drop
+    1 ShowCursor drop ;
+
 : fullscreen-flags ( -- n )
     { WS_CAPTION WS_BORDER WS_THICKFRAME } flags ; inline
 

basis/ui/gadgets/gadgets.factor

@@ -3,8 +3,7 @@
 USING: accessors arrays hashtables kernel models math namespaces
 make sequences quotations math.vectors combinators sorting
 binary-search vectors dlists deques models threads
-concurrency.flags math.order math.rectangles fry locals
+concurrency.flags math.order math.rectangles fry locals ;
-prettyprint.backend prettyprint.custom ;
 IN: ui.gadgets
 
 ! Values for orientation slot
@@ -28,9 +27,6 @@ interior
 boundary
 model ;
 
-! Don't print gadgets with RECT: syntax
-M: gadget pprint* pprint-tuple ;
-
 M: gadget equal? 2drop f ;
 
 M: gadget hashcode* nip [ [ \ gadget counter ] unless* ] change-id id>> ;
@@ -397,3 +393,7 @@ M: f request-focus-on 2drop ;
 
 : focus-path ( gadget -- seq )
     [ focus>> ] follow ;
+
+USING: vocabs vocabs.loader ;
+
+"prettyprint" vocab [ "ui.gadgets.prettyprint" require ] when

basis/ui/gadgets/prettyprint/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

basis/ui/gadgets/prettyprint/prettyprint.factor

@@ -0,0 +1,7 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: ui.gadgets prettyprint.backend prettyprint.custom ;
+IN: ui.gadgets.prettyprint
+
+! Don't print gadgets with RECT: syntax
+M: gadget pprint* pprint-tuple ;

basis/ui/gadgets/worlds/worlds.factor

@@ -11,7 +11,7 @@ CONSTANT: default-world-pixel-format-attributes
     { windowed double-buffered T{ depth-bits { value 16 } } }
 
 TUPLE: world < track
-    active? focused?
+    active? focused? grab-input?
     layers
     title status status-owner
     text-handle handle images
@@ -20,6 +20,7 @@ TUPLE: world < track
 
 TUPLE: world-attributes
     { world-class initial: world }
+    grab-input?
     title
     status
     gadgets
@@ -63,13 +64,15 @@ M: world request-focus-on ( child gadget -- )
     vertical swap new-track
         t >>root?
         t >>active?
-        { 0 0 } >>window-loc ;
+        { 0 0 } >>window-loc
+        f >>grab-input? ;
 
 : apply-world-attributes ( world attributes -- world )
     {
         [ title>> >>title ]
         [ status>> >>status ]
         [ pixel-format-attributes>> >>pixel-format-attributes ]
+        [ grab-input?>> >>grab-input? ]
         [ gadgets>> [ 1 track-add ] each ]
     } cleave ;
 

basis/ui/ui.factor

@@ -41,14 +41,23 @@ SYMBOL: windows
     lose-focus swap each-gesture
     gain-focus swap each-gesture ;
 
+: ?grab-input ( world -- )
+    dup grab-input?>> [ handle>> (grab-input) ] [ drop ] if ;
+
+: ?ungrab-input ( world -- )
+    dup grab-input?>> [ handle>> (ungrab-input) ] [ drop ] if ;
+
 : focus-world ( world -- )
     t >>focused?
+    [ ?grab-input ] [
         dup raised-window
-    focus-path f focus-gestures ;
+        focus-path f focus-gestures
+    ] bi ;
 
 : unfocus-world ( world -- )
     f >>focused?
-    focus-path f swap focus-gestures ;
+    [ ?ungrab-input ]
+    [ focus-path f swap focus-gestures ] bi ;
 
 : try-to-open-window ( world -- )
     {

basis/windows/user32/user32.factor

@@ -652,9 +652,9 @@ FUNCTION: HDC BeginPaint ( HWND hwnd, LPPAINTSTRUCT lpPaint ) ;
 FUNCTION: HWND ChildWindowFromPoint ( HWND hWndParent, POINT point ) ;
 ! FUNCTION: ChildWindowFromPointEx
 ! FUNCTION: ClientThreadSetup
-! FUNCTION: ClientToScreen
+FUNCTION: BOOL ClientToScreen ( HWND hWnd, POINT* point ) ;
 ! FUNCTION: CliImmSetHotKey
-! FUNCTION: ClipCursor
+FUNCTION: int ClipCursor ( RECT* clipRect ) ;
 FUNCTION: BOOL CloseClipboard ( ) ;
 ! FUNCTION: CloseDesktop
 ! FUNCTION: CloseWindow
@@ -1363,7 +1363,7 @@ CONSTANT: HWND_TOP f
 ! FUNCTION: SetWindowWord
 ! FUNCTION: SetWinEventHook
 ! FUNCTION: ShowCaret
-! FUNCTION: ShowCursor
+FUNCTION: int ShowCursor ( BOOL show ) ;
 ! FUNCTION: ShowOwnedPopups
 ! FUNCTION: ShowScrollBar
 ! FUNCTION: ShowStartGlass

core/generic/single/single.factor

@@ -163,7 +163,7 @@ M: hi-tag-dispatch-engine compile-engine
 
 : build-fast-hash ( methods -- buckets )
     >alist V{ } clone [ hashcode 1array ] distribute-buckets
-    [ compile-engines* >alist >array ] map ;
+    [ compile-engines* >alist { } join ] map ;
 
 M: echelon-dispatch-engine compile-engine
     dup n>> 0 = [

core/math/math-docs.factor

@@ -245,10 +245,22 @@ HELP: times
     { $example "USING: io math ;" "3 [ \"Hi\" print ] times" "Hi\nHi\nHi" }
 } ;
 
+HELP: fp-special?
+{ $values { "x" real } { "?" "a boolean" } }
+{ $description "Tests if " { $snippet "x" } " is an IEEE special value (Not-a-Number or Infinity). While " { $snippet "x" } " can be any real number, this word will only ever yield true if " { $snippet "x" } " is a " { $link float } "." } ;
+
 HELP: fp-nan?
 { $values { "x" real } { "?" "a boolean" } }
 { $description "Tests if " { $snippet "x" } " is an IEEE Not-a-Number value. While " { $snippet "x" } " can be any real number, this word will only ever yield true if " { $snippet "x" } " is a " { $link float } "." } ;
 
+HELP: fp-qnan?
+{ $values { "x" real } { "?" "a boolean" } }
+{ $description "Tests if " { $snippet "x" } " is an IEEE Quiet Not-a-Number value. While " { $snippet "x" } " can be any real number, this word will only ever yield true if " { $snippet "x" } " is a " { $link float } "." } ;
+
+HELP: fp-snan?
+{ $values { "x" real } { "?" "a boolean" } }
+{ $description "Tests if " { $snippet "x" } " is an IEEE Signaling Not-a-Number value. While " { $snippet "x" } " can be any real number, this word will only ever yield true if " { $snippet "x" } " is a " { $link float } "." } ;
+
 HELP: fp-infinity?
 { $values { "x" real } { "?" "a boolean" } }
 { $description "Tests if " { $snippet "x" } " is an IEEE Infinity value. While " { $snippet "x" } " can be any real number, this word will only ever yield true if " { $snippet "x" } " is a " { $link float } "." }
@@ -257,7 +269,26 @@ HELP: fp-infinity?
     { $example "USING: io kernel math ;" "-1/0. [ fp-infinity? ] [ 0 < ] bi and [ \"negative infinity\" print ] when" "negative infinity" }
 } ;
 
-{ fp-nan? fp-infinity? } related-words
+HELP: fp-nan-payload
+{ $values { "x" real } { "bits" integer } }
+{ $description "If " { $snippet "x" } " is an IEEE Not-a-Number value, returns the payload encoded in the value. Returns " { $link f } " if " { $snippet "x" } " is not a " { $link float } "." } ;
+
+HELP: <fp-nan>
+{ $values { "payload" integer } { "nan" float } }
+{ $description "Constructs an IEEE Not-a-Number value with a payload of " { $snippet "payload" } "." }
+{ $notes "A " { $snippet "payload" } " of " { $snippet "0" } " will construct an Infinity value." } ;
+
+{ fp-special? fp-nan? fp-qnan? fp-snan? fp-infinity? fp-nan-payload <fp-nan> } related-words
+
+HELP: next-float
+{ $values { "m" float } { "n" float } }
+{ $description "Returns the least representable " { $link float } " value greater than " { $snippet "m" } "." } ;
+
+HELP: prev-float
+{ $values { "m" float } { "n" float } }
+{ $description "Returns the greatest representable " { $link float } " value less than " { $snippet "m" } "." } ;
+
+{ next-float prev-float } related-words
 
 HELP: real-part
 { $values { "z" number } { "x" real } }

core/math/math-tests.factor

@@ -12,7 +12,24 @@ IN: math.tests
 [ f ] [ 1/0. fp-nan? ] unit-test
 [ f ] [ -1/0. fp-nan? ] unit-test
 [ t ] [ -0/0. fp-nan? ] unit-test
+[ t ] [ 1 <fp-nan> fp-nan? ] unit-test
+! [ t ] [ 1 <fp-nan> fp-snan? ] unit-test
+! [ f ] [ 1 <fp-nan> fp-qnan? ] unit-test
+[ t ] [ HEX: 8000000000001 <fp-nan> fp-nan? ] unit-test
+[ f ] [ HEX: 8000000000001 <fp-nan> fp-snan? ] unit-test
+[ t ] [ HEX: 8000000000001 <fp-nan> fp-qnan? ] unit-test
 
 [ t ] [ 1/0. fp-infinity? ] unit-test
 [ t ] [ -1/0. fp-infinity? ] unit-test
 [ f ] [ -0/0. fp-infinity? ] unit-test
+
+[ f ] [ 0 <fp-nan> fp-nan? ] unit-test
+[ t ] [ 0 <fp-nan> fp-infinity? ] unit-test
+
+[ 0.0 ] [ -0.0 next-float ] unit-test
+[ t ] [ 1.0 dup next-float < ] unit-test
+[ t ] [ -1.0 dup next-float < ] unit-test
+
+[ -0.0 ] [ 0.0 prev-float ] unit-test
+[ t ] [ 1.0 dup prev-float > ] unit-test
+[ t ] [ -1.0 dup prev-float > ] unit-test

core/math/math.factor

@@ -81,26 +81,64 @@ TUPLE: complex { real real read-only } { imaginary real read-only } ;
 
 UNION: number real complex ;
 
-GENERIC: fp-nan? ( x -- ? )
+: fp-bitwise= ( x y -- ? ) [ double>bits ] bi@ = ; inline
 
+GENERIC: fp-special? ( x -- ? )
+GENERIC: fp-nan? ( x -- ? )
+GENERIC: fp-qnan? ( x -- ? )
+GENERIC: fp-snan? ( x -- ? )
+GENERIC: fp-infinity? ( x -- ? )
+GENERIC: fp-nan-payload ( x -- bits )
+
+M: object fp-special?
+    drop f ;
 M: object fp-nan?
     drop f ;
-
+M: object fp-qnan?
-M: float fp-nan?
+    drop f ;
-    double>bits -51 shift HEX: fff [ bitand ] keep = ;
+M: object fp-snan?
-
+    drop f ;
-GENERIC: fp-infinity? ( x -- ? )
-
 M: object fp-infinity?
     drop f ;
+M: object fp-nan-payload
+    drop f ;
 
-M: float fp-infinity? ( float -- ? )
+M: float fp-special?
+    double>bits -52 shift HEX: 7ff [ bitand ] keep = ;
+
+M: float fp-nan-payload
+    double>bits HEX: fffffffffffff bitand ; foldable flushable
+
+M: float fp-nan?
+    dup fp-special? [ fp-nan-payload zero? not ] [ drop f ] if ;
+
+M: float fp-qnan?
+    dup fp-nan? [ fp-nan-payload HEX: 8000000000000 bitand zero? not ] [ drop f ] if ;
+
+M: float fp-snan?
+    dup fp-nan? [ fp-nan-payload HEX: 8000000000000 bitand zero? ] [ drop f ] if ;
+
+M: float fp-infinity?
+    dup fp-special? [ fp-nan-payload zero? ] [ drop f ] if ;
+
+: <fp-nan> ( payload -- nan )
+    HEX: 7ff0000000000000 bitor bits>double ; foldable flushable
+
+: next-float ( m -- n )
     double>bits
-    dup -52 shift HEX: 7ff [ bitand ] keep = [
+    dup -0.0 double>bits > [ 1 - bits>double ] [ ! negative non-zero
-        HEX: fffffffffffff bitand 0 =
+        dup -0.0 double>bits = [ drop 0.0 ] [ ! negative zero
-    ] [
+            1 + bits>double ! positive
-        drop f
+        ] if
-    ] if ;
+    ] if ; foldable flushable
+
+: prev-float ( m -- n )
+    double>bits
+    dup -0.0 double>bits >= [ 1 + bits>double ] [ ! negative
+        dup 0.0 double>bits = [ drop -0.0 ] [ ! positive zero
+            1 - bits>double ! positive non-zero
+        ] if
+    ] if ; foldable flushable
 
 : next-power-of-2 ( m -- n )
     dup 2 <= [ drop 2 ] [ 1 - log2 1 + 2^ ] if ; inline

extra/benchmark/pidigits/pidigits.factor

@@ -18,7 +18,7 @@ IN: benchmark.pidigits
 : >matrix ( q s r t -- z )
     4array 2 group ;
 
-: produce ( z n -- z' )
+: produce ( z y -- z' )
     [ 10 ] dip -10 * 0 1 >matrix swap m. ;
 
 : gen-x ( x -- matrix )

extra/crypto/hmac/hmac.factor

@@ -31,8 +31,8 @@ MEMO: opad ( -- seq ) 64 HEX: 5c <array> ;
 
 : init-hmac ( K -- o i )
     64 0 pad-tail 
-    [ opad seq-bitxor ] keep
+    [ opad seq-bitxor ]
-    ipad seq-bitxor ;
+    [ ipad seq-bitxor ] bi ;
 
 PRIVATE>
 

extra/crypto/rsa/rsa.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: math.miller-rabin kernel math math.functions namespaces
+USING: math.primes.miller-rabin kernel math math.functions
-sequences accessors ;
+namespaces sequences accessors ;
 IN: crypto.rsa
 
 ! The private key is the only secret.

extra/game-input/game-input-docs.factor

@@ -27,10 +27,10 @@ ARTICLE: "game-input" "Game controller input"
 { $subsection mouse-state } ;
 
 HELP: open-game-input
-{ $description "Initializes the game input interface. An exception will be thrown if the initialization fails. If the game input interface is already opened, nothing happens." } ;
+{ $description "Initializes the game input interface. An exception will be thrown if the initialization fails. Calls to open-game-input are reference counted; each call to open-game-input needs a corresponding call to close-game-input to close the game input interface." } ;
 
 HELP: close-game-input
-{ $description "Closes the game input interface, releasing any allocated resources. Once this word is called, any remaining " { $link controller } " objects are invalid. If the game input interface is not opened, nothing happens." } ;
+{ $description "Closes the game input interface, releasing any allocated resources. Once this word is called, any remaining " { $link controller } " objects are invalid." } ;
 
 HELP: game-input-opened?
 { $values { "?" "a boolean" } }

extra/game-input/game-input.factor

@@ -1,38 +1,61 @@
-USING: arrays accessors continuations kernel system
+USING: arrays accessors continuations kernel math system
 sequences namespaces init vocabs vocabs.loader combinators ;
 IN: game-input
 
 SYMBOLS: game-input-backend game-input-opened ;
 
+game-input-opened [ 0 ] initialize
+
 HOOK: (open-game-input)  game-input-backend ( -- )
 HOOK: (close-game-input) game-input-backend ( -- )
 HOOK: (reset-game-input) game-input-backend ( -- )
 
+HOOK: get-controllers game-input-backend ( -- sequence )
+
+HOOK: product-string game-input-backend ( controller -- string )
+HOOK: product-id game-input-backend ( controller -- id )
+HOOK: instance-id game-input-backend ( controller -- id )
+
+HOOK: read-controller game-input-backend ( controller -- controller-state )
+HOOK: calibrate-controller game-input-backend ( controller -- )
+
+HOOK: read-keyboard game-input-backend ( -- keyboard-state )
+
+HOOK: read-mouse game-input-backend ( -- mouse-state )
+
+HOOK: reset-mouse game-input-backend ( -- )
+
 : game-input-opened? ( -- ? )
-    game-input-opened get ;
+    game-input-opened get zero? not ;
 
 <PRIVATE
 
 M: f (reset-game-input) ;
 
 : reset-game-input ( -- )
-    game-input-opened off
     (reset-game-input) ;
 
 [ reset-game-input ] "game-input" add-init-hook
 
 PRIVATE>
 
+ERROR: game-input-not-open ;
+
 : open-game-input ( -- )
     game-input-opened? [
         (open-game-input) 
-        game-input-opened on
+    ] unless
-    ] unless ;
+    game-input-opened [ 1+ ] change-global
+    reset-mouse ;
 : close-game-input ( -- )
+    game-input-opened [
+        dup zero? [ game-input-not-open ] when
+        1-
+    ] change-global
     game-input-opened? [
         (close-game-input) 
         reset-game-input
-    ] when ;
+    ] unless ;
 
 : with-game-input ( quot -- )
     open-game-input [ close-game-input ] [ ] cleanup ; inline
@@ -48,12 +71,6 @@ SYMBOLS:
     pov-up pov-up-right pov-right pov-down-right
     pov-down pov-down-left pov-left pov-up-left ;
 
-HOOK: get-controllers game-input-backend ( -- sequence )
-
-HOOK: product-string game-input-backend ( controller -- string )
-HOOK: product-id game-input-backend ( controller -- id )
-HOOK: instance-id game-input-backend ( controller -- id )
-
 : find-controller-products ( product-id -- sequence )
     get-controllers [ product-id = ] with filter ;
 : find-controller-instance ( product-id instance-id -- controller/f )
@@ -63,25 +80,16 @@ HOOK: instance-id game-input-backend ( controller -- id )
         [ instance-id = ] 2bi* and
     ] with with find nip ;
 
-HOOK: read-controller game-input-backend ( controller -- controller-state )
-HOOK: calibrate-controller game-input-backend ( controller -- )
-
 TUPLE: keyboard-state keys ;
 
 M: keyboard-state clone
     call-next-method dup keys>> clone >>keys ;
 
-HOOK: read-keyboard game-input-backend ( -- keyboard-state )
-
 TUPLE: mouse-state dx dy scroll-dx scroll-dy buttons ;
 
 M: mouse-state clone
     call-next-method dup buttons>> clone >>buttons ;
 
-HOOK: read-mouse game-input-backend ( -- mouse-state )
-
-HOOK: reset-mouse game-input-backend ( -- )
-
 {
     { [ os windows? ] [ "game-input.dinput" require ] }
     { [ os macosx? ] [ "game-input.iokit" require ] }

extra/game-input/iokit/iokit.factor

@@ -1,13 +1,15 @@
 USING: cocoa cocoa.plists core-foundation iokit iokit.hid
 kernel cocoa.enumeration destructors math.parser cocoa.application 
 sequences locals combinators.short-circuit threads
-namespaces assocs vectors arrays combinators
+namespaces assocs vectors arrays combinators hints alien
 core-foundation.run-loop accessors sequences.private
 alien.c-types math parser game-input vectors ;
 IN: game-input.iokit
 
 SINGLETON: iokit-game-input-backend
 
+SYMBOLS: +hid-manager+ +keyboard-state+ +mouse-state+ +controller-states+ ;
+
 iokit-game-input-backend game-input-backend set-global
 
 : hid-manager-matching ( matching-seq -- alien )
@@ -23,7 +25,6 @@ iokit-game-input-backend game-input-backend set-global
 
 CONSTANT: game-devices-matching-seq
     {
-        H{ { "DeviceUsage" 1 } { "DeviceUsagePage" 1 } } ! pointers
         H{ { "DeviceUsage" 2 } { "DeviceUsagePage" 1 } } ! mouses
         H{ { "DeviceUsage" 4 } { "DeviceUsagePage" 1 } } ! joysticks
         H{ { "DeviceUsage" 5 } { "DeviceUsagePage" 1 } } ! gamepads
@@ -88,19 +89,17 @@ CONSTANT: hat-switch-matching-hash
     game-devices-matching-seq hid-manager-matching ;
 
 : device-property ( device key -- value )
-    <NSString> IOHIDDeviceGetProperty plist> ;
+    <NSString> IOHIDDeviceGetProperty [ plist> ] [ f ] if* ;
 : element-property ( element key -- value )
-    <NSString> IOHIDElementGetProperty plist> ;
+    <NSString> IOHIDElementGetProperty [ plist> ] [ f ] if* ;
 : set-element-property ( element key value -- )
     [ <NSString> ] [ >plist ] bi* IOHIDElementSetProperty drop ;
 : transfer-element-property ( element from-key to-key -- )
-    [ dupd element-property ] dip swap set-element-property ;
+    [ dupd element-property ] dip swap
+    [ set-element-property ] [ 2drop ] if* ;
 
 : mouse-device? ( device -- ? )
-    {
+    1 2 IOHIDDeviceConformsTo ;
-        [ 1 1 IOHIDDeviceConformsTo ]
-        [ 1 2 IOHIDDeviceConformsTo ]
-    } 1|| ;
 
 : controller-device? ( device -- ? )
     {
@@ -113,28 +112,31 @@ CONSTANT: hat-switch-matching-hash
     [ IOHIDElementGetUsagePage ] [ IOHIDElementGetUsage ] bi
     2array ;
 
-: button? ( {usage-page,usage} -- ? )
+: button? ( element -- ? )
-    first 9 = ; inline
+    IOHIDElementGetUsagePage 9 = ; inline
-: keyboard-key? ( {usage-page,usage} -- ? )
+: keyboard-key? ( element -- ? )
-    first 7 = ; inline
+    IOHIDElementGetUsagePage 7 = ; inline
+: axis? ( element -- ? )
+    IOHIDElementGetUsagePage 1 = ; inline
+
 : x-axis? ( {usage-page,usage} -- ? )
-    { 1 HEX: 30 } = ; inline
+    IOHIDElementGetUsage HEX: 30 = ; inline
 : y-axis? ( {usage-page,usage} -- ? )
-    { 1 HEX: 31 } = ; inline
+    IOHIDElementGetUsage HEX: 31 = ; inline
 : z-axis? ( {usage-page,usage} -- ? )
-    { 1 HEX: 32 } = ; inline
+    IOHIDElementGetUsage HEX: 32 = ; inline
 : rx-axis? ( {usage-page,usage} -- ? )
-    { 1 HEX: 33 } = ; inline
+    IOHIDElementGetUsage HEX: 33 = ; inline
 : ry-axis? ( {usage-page,usage} -- ? )
-    { 1 HEX: 34 } = ; inline
+    IOHIDElementGetUsage HEX: 34 = ; inline
 : rz-axis? ( {usage-page,usage} -- ? )
-    { 1 HEX: 35 } = ; inline
+    IOHIDElementGetUsage HEX: 35 = ; inline
 : slider? ( {usage-page,usage} -- ? )
-    { 1 HEX: 36 } = ; inline
+    IOHIDElementGetUsage HEX: 36 = ; inline
 : wheel? ( {usage-page,usage} -- ? )
-    { 1 HEX: 38 } = ; inline
+    IOHIDElementGetUsage HEX: 38 = ; inline
 : hat-switch? ( {usage-page,usage} -- ? )
-    { 1 HEX: 39 } = ; inline
+    IOHIDElementGetUsage HEX: 39 = ; inline
 
 CONSTANT: pov-values
     {
@@ -152,12 +154,13 @@ CONSTANT: pov-values
 : pov-value ( value -- pov-direction )
     IOHIDValueGetIntegerValue pov-values ?nth [ pov-neutral ] unless* ;
 
-: record-button ( hid-value usage state -- )
+: record-button ( state hid-value element -- )
-    [ button-value ] [ second 1- ] [ buttons>> ] tri* set-nth ;
+    [ buttons>> ] [ button-value ] [ IOHIDElementGetUsage 1- ] tri* rot set-nth ;
 
 : record-controller ( controller-state value -- )
-    dup IOHIDValueGetElement element-usage {
+    dup IOHIDValueGetElement {
-        { [ dup button? ] [ rot record-button ] } 
+        { [ dup button? ] [ record-button ] } 
+        { [ dup axis? ] [ {
             { [ dup x-axis? ] [ drop axis-value >>x drop ] }
             { [ dup y-axis? ] [ drop axis-value >>y drop ] }
             { [ dup z-axis? ] [ drop axis-value >>z drop ] }
@@ -167,30 +170,39 @@ CONSTANT: pov-values
             { [ dup slider? ] [ drop axis-value >>slider drop ] }
             { [ dup hat-switch? ] [ drop pov-value >>pov drop ] }
             [ 3drop ]
+        } cond ] }
+        [ 3drop ]
     } cond ;
 
-SYMBOLS: +hid-manager+ +keyboard-state+ +mouse-state+ +controller-states+ ;
+HINTS: record-controller { controller-state alien } ;
 
 : ?set-nth ( value nth seq -- )
     2dup bounds-check? [ set-nth-unsafe ] [ 3drop ] if ;
 
-: record-keyboard ( value -- )
+: record-keyboard ( keyboard-state value -- )
-    dup IOHIDValueGetElement element-usage keyboard-key? [
+    dup IOHIDValueGetElement dup keyboard-key? [
         [ IOHIDValueGetIntegerValue c-bool> ]
-        [ IOHIDValueGetElement IOHIDElementGetUsage ] bi
+        [ IOHIDElementGetUsage ] bi*
-        +keyboard-state+ get ?set-nth
+        rot ?set-nth
-    ] [ drop ] if ;
+    ] [ 3drop ] if ;
 
-: record-mouse ( value -- )
+HINTS: record-keyboard { array alien } ;
-    dup IOHIDValueGetElement element-usage {
+
-        { [ dup button? ] [ +mouse-state+ get record-button ] }
+: record-mouse ( mouse-state value -- )
-        { [ dup x-axis? ] [ drop mouse-axis-value +mouse-state+ get [ + ] change-dx drop ] }
+    dup IOHIDValueGetElement {
-        { [ dup y-axis? ] [ drop mouse-axis-value +mouse-state+ get [ + ] change-dy drop ] }
+        { [ dup button? ] [ record-button ] }
-        { [ dup wheel?  ] [ drop mouse-axis-value +mouse-state+ get [ + ] change-scroll-dx drop ] }
+        { [ dup axis? ] [ {
-        { [ dup z-axis? ] [ drop mouse-axis-value +mouse-state+ get [ + ] change-scroll-dy drop ] }
+            { [ dup x-axis? ] [ drop mouse-axis-value [ + ] curry change-dx drop ] }
-        [ 2drop ]
+            { [ dup y-axis? ] [ drop mouse-axis-value [ + ] curry change-dy drop ] }
+            { [ dup wheel?  ] [ drop mouse-axis-value [ + ] curry change-scroll-dx drop ] }
+            { [ dup z-axis? ] [ drop mouse-axis-value [ + ] curry change-scroll-dy drop ] }
+            [ 3drop ]
+        } cond ] }
+        [ 3drop ]
     } cond ;
 
+HINTS: record-mouse { mouse-state alien } ;
+
 M: iokit-game-input-backend read-mouse
     +mouse-state+ get ;
 
@@ -263,8 +275,8 @@ M: iokit-game-input-backend reset-mouse
             { [ sender controller-device? ] [
                 sender +controller-states+ get at value record-controller
             ] }
-            { [ sender mouse-device? ] [ value record-mouse ] }
+            { [ sender mouse-device? ] [ +mouse-state+ get value record-mouse ] }
-            [ value record-keyboard ]
+            [ +keyboard-state+ get value record-keyboard ]
         } cond
     ] IOHIDValueCallback ;
 
@@ -289,7 +301,7 @@ M: iokit-game-input-backend (open-game-input)
     } cleave ;
 
 M: iokit-game-input-backend (reset-game-input)
-    { +hid-manager+ +keyboard-state+ +controller-states+ }
+    { +hid-manager+ +keyboard-state+ +mouse-state+ +controller-states+ }
     [ f swap set-global ] each ;
 
 M: iokit-game-input-backend (close-game-input)
@@ -304,6 +316,7 @@ M: iokit-game-input-backend (close-game-input)
             f
         ] change-global
         f +keyboard-state+ set-global
+        f +mouse-state+ set-global
         f +controller-states+ set-global
     ] when ;
 

extra/game-worlds/game-worlds.factor

@@ -0,0 +1,25 @@
+USING: accessors game-input game-loop kernel math ui.gadgets
+ui.gadgets.worlds ui.gestures ;
+IN: game-worlds
+
+TUPLE: game-world < world
+    game-loop
+    { tick-slice float initial: 0.0 } ;
+
+GENERIC: tick-length ( world -- millis )
+
+M: game-world draw*
+    swap >>tick-slice draw-world ;
+
+M: game-world begin-world
+    dup [ tick-length ] [ ] bi <game-loop> [ >>game-loop ] keep start-loop
+    drop
+    open-game-input ;
+
+M: game-world end-world
+    close-game-input
+    [ [ stop-loop ] when* f ] change-game-loop
+    drop ;
+
+M: game-world focusable-child* drop t ;
+

extra/key-caps/key-caps.factor

@@ -162,18 +162,19 @@ M: key-caps-gadget pref-dim* drop KEYBOARD-SIZE ;
     relayout-1 ;
 
 M: key-caps-gadget graft*
+    open-game-input
     dup '[ _ update-key-caps-state ] FREQUENCY every >>alarm
     drop ;
 
 M: key-caps-gadget ungraft*
-    alarm>> [ cancel-alarm ] when* ;
+    alarm>> [ cancel-alarm ] when*
+    close-game-input ;
 
 M: key-caps-gadget handle-gesture
     drop [ key-down? ] [ key-up? ] bi or not ;
 
 : key-caps ( -- )
     [
-        open-game-input
         <key-caps-gadget> { 5 5 } <border> "Key Caps" open-window
     ] with-ui ;
 

extra/mason/report/report.factor

@@ -113,7 +113,6 @@ IN: mason.report
             benchmark-error-messages-file
             error-dump
 
-            "Benchmark timings"
             benchmarks-file eval-file benchmarks-table
         ] output>array
     ] with-report ;

extra/math/affine-transforms/affine-transforms.factor

@@ -17,6 +17,8 @@ CONSTANT: identity-transform T{ affine-transform f { 1.0 0.0 } { 0.0 1.0 } { 0.0
     [ drop origin>> ] 2tri
     v+ v+ ;
 
+: <identity> ( -- a )
+    { 1.0 0.0 } { 0.0 1.0 } { 0.0 0.0 } <affine-transform> ;
 : <translation> ( origin -- a )
     [ { 1.0 0.0 } { 0.0 1.0 } ] dip <affine-transform> ;
 : <rotation> ( theta -- transform )

extra/noise/noise.factor

@@ -1,61 +1,60 @@
 USING: byte-arrays combinators fry images kernel locals math
 math.affine-transforms math.functions math.order
 math.polynomials math.vectors random random.mersenne-twister
-sequences sequences.product ;
+sequences sequences.product hints arrays sequences.private
+combinators.short-circuit math.private ;
 IN: noise
 
 : <perlin-noise-table> ( -- table )
-    256 iota >byte-array randomize dup append ;
+    256 iota >byte-array randomize dup append ; inline
 
 : with-seed ( seed quot -- )
     [ <mersenne-twister> ] dip with-random ; inline
 
 <PRIVATE
 
-: fade ( point -- point' )
+: (fade) ( x y z -- x' y' z' )
-    { 0.0 0.0 0.0 10.0 -15.0 6.0 } swap [ polyval ] with map ;
+    [ { 0.0 0.0 0.0 10.0 -15.0 6.0 } polyval* ] tri@ ;
 
-:: grad ( hash gradients -- gradient )
+HINTS: (fade) { float float float } ;
-    hash 8  bitand zero? [ gradients first ] [ gradients second ] if
+
+: fade ( point -- point' )
+    first3 (fade) 3array ; inline
+
+:: grad ( hash x y z -- gradient )
+    hash 8  bitand zero? [ x ] [ y ] if
         :> u
     hash 12 bitand zero?
-    [ gradients second ]
+    [ y ] [ hash 13 bitand 12 = [ x ] [ z ] if ] if
-    [ hash 13 bitand 12 = [ gradients first ] [ gradients third ] if ] if
         :> v
 
     hash 1 bitand zero? [ u ] [ u neg ] if
     hash 2 bitand zero? [ v ] [ v neg ] if + ;
 
+HINTS: grad { fixnum float float float } ;
+
 : unit-cube ( point -- cube )
-    [ floor >fixnum 256 mod ] map ;
+    [ floor >fixnum 256 rem ] map ;
 
-:: hashes ( table cube -- aaa baa aba bba aab bab abb bbb )
+:: hashes ( table x y z -- aaa baa aba bba aab bab abb bbb )
-    cube first  :> x
+    x               table nth-unsafe y fixnum+fast :> a
-    cube second :> y
+    x 1 fixnum+fast table nth-unsafe y fixnum+fast :> b
-    cube third  :> z
-    x     table nth y + :> a
-    x 1 + table nth y + :> b
 
-    a     table nth z + :> aa
+    a               table nth-unsafe z fixnum+fast :> aa
-    b     table nth z + :> ba
+    b               table nth-unsafe z fixnum+fast :> ba
-    a 1 + table nth z + :> ab
+    a 1 fixnum+fast table nth-unsafe z fixnum+fast :> ab
-    b 1 + table nth z + :> bb
+    b 1 fixnum+fast table nth-unsafe z fixnum+fast :> bb
 
-    aa     table nth 
+    aa               table nth-unsafe 
-    ba     table nth 
+    ba               table nth-unsafe 
-    ab     table nth 
+    ab               table nth-unsafe 
-    bb     table nth 
+    bb               table nth-unsafe 
-    aa 1 + table nth 
+    aa 1 fixnum+fast table nth-unsafe 
-    ba 1 + table nth 
+    ba 1 fixnum+fast table nth-unsafe 
-    ab 1 + table nth 
+    ab 1 fixnum+fast table nth-unsafe 
-    bb 1 + table nth ;
+    bb 1 fixnum+fast table nth-unsafe ; inline
 
-:: 2tetra@ ( p q r s t u v w quot -- )
+HINTS: hashes { byte-array fixnum fixnum fixnum } ;
-    p q quot call
-    r s quot call
-    t u quot call
-    v w quot call
-    ; inline
 
 : >byte-map ( floats -- bytes )
     [ 255.0 * >fixnum ] B{ } map-as ;
@@ -63,26 +62,33 @@ IN: noise
 : >image ( bytes dim -- image )
     swap [ L f ] dip image boa ;
 
-PRIVATE>
+:: perlin-noise-unsafe ( table point -- value )
-
-:: perlin-noise ( table point -- value )
     point unit-cube :> cube
     point dup vfloor v- :> gradients
     gradients fade :> faded
 
-    table cube hashes {
+    table cube first3 hashes {
-        [ gradients                       grad ]
+        [ gradients first3                                    grad ]
-        [ gradients { -1.0  0.0  0.0 } v+ grad ]
+        [ gradients first3 [ 1.0 - ] [       ] [       ] tri* grad ]
-        [ gradients {  0.0 -1.0  0.0 } v+ grad ]
+        [ gradients first3 [       ] [ 1.0 - ] [       ] tri* grad ]
-        [ gradients { -1.0 -1.0  0.0 } v+ grad ]
+        [ gradients first3 [ 1.0 - ] [ 1.0 - ] [       ] tri* grad ]
-        [ gradients {  0.0  0.0 -1.0 } v+ grad ]
+        [ gradients first3 [       ] [       ] [ 1.0 - ] tri* grad ]
-        [ gradients { -1.0  0.0 -1.0 } v+ grad ]
+        [ gradients first3 [ 1.0 - ] [       ] [ 1.0 - ] tri* grad ]
-        [ gradients {  0.0 -1.0 -1.0 } v+ grad ]
+        [ gradients first3 [       ] [ 1.0 - ] [ 1.0 - ] tri* grad ]
-        [ gradients { -1.0 -1.0 -1.0 } v+ grad ]
+        [ gradients first3 [ 1.0 - ] [ 1.0 - ] [ 1.0 - ] tri* grad ]
     } spread
-    [ faded first lerp ] 2tetra@
+    faded trilerp ;
-    [ faded second lerp ] 2bi@
+
-    faded third lerp ;
+ERROR: invalid-perlin-noise-table table ;
+
+: validate-table ( table -- table )
+    dup { [ byte-array? ] [ length 512 >= ] } 1&&
+    [ invalid-perlin-noise-table ] unless ;
+
+PRIVATE>
+
+: perlin-noise ( table point -- value )
+    [ validate-table ] dip perlin-noise-unsafe ; inline
 
 : normalize-0-1 ( sequence -- sequence' )
     [ supremum ] [ infimum [ - ] keep ] [ ] tri
@@ -92,7 +98,8 @@ PRIVATE>
     [ 0.0 max 1.0 min ] map ;
 
 : perlin-noise-map ( table transform dim -- map ) 
-    [ iota ] map [ a.v 0.0 suffix perlin-noise ] with with product-map ;
+    [ validate-table ] 2dip
+    [ iota ] map [ a.v 0.0 suffix perlin-noise-unsafe ] with with product-map ;
 
 : perlin-noise-byte-map ( table transform dim -- map )
     perlin-noise-map normalize-0-1 >byte-map ;

extra/poker/poker-docs.factor

@@ -2,7 +2,7 @@ USING: help.markup help.syntax strings ;
 IN: poker
 
 HELP: <hand>
-{ $values { "str" string } { "hand" "a new hand" } }
+{ $values { "str" string } { "hand" "a new " { $link hand } } }
 { $description "Creates a new poker hand containing the cards specified in " { $snippet "str" } "." }
 { $examples
     { $example "USING: kernel math.order poker prettyprint ;"
@@ -12,8 +12,16 @@ HELP: <hand>
 }
 { $notes "Cards may be specified in any order. Hands are directly comparable to each other on the basis of their computed value. Two hands are considered equal when they would tie in a game (despite being composed of different cards)." } ;
 
+HELP: best-hand
+{ $values { "str" string } { "hand" "a new " { $link hand } } }
+{ $description "Creates a new poker hand containing the best possible combination of the cards specified in " { $snippet "str" } "." }
+{ $examples
+    { $example "USING: kernel poker prettyprint ;"
+        "\"AS KD JC KH 2D 2S KC\" best-hand >value ." "\"Full House\"" }
+} ;
+
 HELP: >cards
-{ $values { "hand" "a hand" } { "str" string } }
+{ $values { "hand" hand } { "str" string } }
 { $description "Outputs a string representation of a hand's cards." }
 { $examples
     { $example "USING: poker prettyprint ;"
@@ -21,10 +29,18 @@ HELP: >cards
 } ;
 
 HELP: >value
-{ $values { "hand" "a hand" } { "str" string } }
+{ $values { "hand" hand } { "str" string } }
 { $description "Outputs a string representation of a hand's value." }
 { $examples
     { $example "USING: poker prettyprint ;"
         "\"AC KC QC JC TC\" <hand> >value ." "\"Straight Flush\"" }
 }
 { $notes "This should not be used as a basis for hand comparison." } ;
+
+HELP: <deck>
+{ $values { "deck" "a new " { $link deck } } }
+{ $description "Creates a standard deck of 52 cards." } ;
+
+HELP: shuffle
+{ $values { "deck" deck } { "deck" "a shuffled " { $link deck } } }
+{ $description "Shuffles the cards in " { $snippet "deck" } ", in-place, using the Fisher-Yates algorithm." } ;

extra/poker/poker-tests.factor

@@ -1,4 +1,4 @@
-USING: accessors poker poker.private tools.test math.order kernel ;
+USING: accessors kernel math.order poker poker.private tools.test ;
 IN: poker.tests
 
 [ 134236965 ] [ "KD" >ckf ] unit-test
@@ -26,3 +26,5 @@ IN: poker.tests
 
 [ t ] [ "7C 5D 4H 3S 2C" "7D 5D 4D 3C 2S" [ <hand> ] bi@ = ] unit-test
 [ f ] [ "7C 5D 4H 3S 2C" "7D 5D 4D 3C 2S" [ <hand> ] bi@ eq? ] unit-test
+
+[ 190 ] [ "AS KD JC KH 2D 2S KC" best-hand value>> ] unit-test

extra/poker/poker.factor

@@ -1,7 +1,9 @@
-! Copyright (c) 2009 Aaron Schaefer.
+! Copyright (c) 2009 Aaron Schaefer. All rights reserved.
-! See http://factorcode.org/license.txt for BSD license.
+! The contents of this file are licensed under the Simplified BSD License
-USING: accessors ascii binary-search combinators kernel locals math
+! A copy of the license is available at http://factorcode.org/license.txt
-    math.bitwise math.order poker.arrays sequences splitting ;
+USING: accessors arrays ascii binary-search combinators kernel locals math
+    math.bitwise math.combinatorics math.order poker.arrays random sequences
+    sequences.product splitting ;
 IN: poker
 
 ! The algorithm used is based on Cactus Kev's Poker Hand Evaluator with
@@ -47,19 +49,21 @@ CONSTANT: QUEEN  10
 CONSTANT: KING   11
 CONSTANT: ACE    12
 
-CONSTANT: STRAIGHT_FLUSH   1
+CONSTANT: STRAIGHT_FLUSH   0
-CONSTANT: FOUR_OF_A_KIND   2
+CONSTANT: FOUR_OF_A_KIND   1
-CONSTANT: FULL_HOUSE       3
+CONSTANT: FULL_HOUSE       2
-CONSTANT: FLUSH            4
+CONSTANT: FLUSH            3
-CONSTANT: STRAIGHT         5
+CONSTANT: STRAIGHT         4
-CONSTANT: THREE_OF_A_KIND  6
+CONSTANT: THREE_OF_A_KIND  5
-CONSTANT: TWO_PAIR         7
+CONSTANT: TWO_PAIR         6
-CONSTANT: ONE_PAIR         8
+CONSTANT: ONE_PAIR         7
-CONSTANT: HIGH_CARD        9
+CONSTANT: HIGH_CARD        8
+
+CONSTANT: SUIT_STR { "C" "D" "H" "S" }
 
 CONSTANT: RANK_STR { "2" "3" "4" "5" "6" "7" "8" "9" "T" "J" "Q" "K" "A" }
 
-CONSTANT: VALUE_STR { "" "Straight Flush" "Four of a Kind" "Full House" "Flush"
+CONSTANT: VALUE_STR { "Straight Flush" "Four of a Kind" "Full House" "Flush"
     "Straight" "Three of a Kind" "Two Pair" "One Pair" "High Card" }
 
 : card-rank-prime ( rank -- n )
@@ -108,6 +112,9 @@ CONSTANT: VALUE_STR { "" "Straight Flush" "Four of a Kind" "Full House" "Flush"
     #! Cactus Kev Format
     >upper 1 cut (>ckf) ;
 
+: parse-cards ( str -- seq )
+    " " split [ >ckf ] map ;
+
 : flush? ( cards -- ? )
     HEX: F000 [ bitand ] reduce 0 = not ;
 
@@ -152,8 +159,8 @@ CONSTANT: VALUE_STR { "" "Straight Flush" "Four of a Kind" "Full House" "Flush"
         [ drop "S" ]
     } cond ;
 
-: hand-rank ( hand -- rank )
+: hand-rank ( value -- rank )
-    value>> {
+    {
         { [ dup 6185 > ] [ drop HIGH_CARD ] }        ! 1277 high card
         { [ dup 3325 > ] [ drop ONE_PAIR ] }         ! 2860 one pair
         { [ dup 2467 > ] [ drop TWO_PAIR ] }         !  858 two pair
@@ -165,24 +172,38 @@ CONSTANT: VALUE_STR { "" "Straight Flush" "Four of a Kind" "Full House" "Flush"
         [ drop STRAIGHT_FLUSH ]                      !   10 straight-flushes
     } cond ;
 
+: card>string ( card -- str )
+    [ >card-rank ] [ >card-suit ] bi append ;
+
 PRIVATE>
 
 TUPLE: hand
     { cards sequence }
-    { value integer } ;
+    { value integer initial: 9999 } ;
 
 M: hand <=> [ value>> ] compare ;
 M: hand equal?
     over hand? [ [ value>> ] bi@ = ] [ 2drop f ] if ;
 
 : <hand> ( str -- hand )
-    " " split [ >ckf ] map
+    parse-cards dup hand-value hand boa ;
-    dup hand-value hand boa ;
+
+: best-hand ( str -- hand )
+    parse-cards 5 hand new
+    [ dup hand-value hand boa min ] reduce-combinations ;
 
 : >cards ( hand -- str )
-    cards>> [
+    cards>> [ card>string ] map " " join ;
-        [ >card-rank ] [ >card-suit ] bi append
-    ] map " " join ;
 
 : >value ( hand -- str )
-    hand-rank VALUE_STR nth ;
+    value>> hand-rank VALUE_STR nth ;
+
+TUPLE: deck
+    { cards sequence } ;
+
+: <deck> ( -- deck )
+    RANK_STR SUIT_STR 2array [ concat >ckf ] product-map deck boa ;
+
+: shuffle ( deck -- deck )
+    [ randomize ] change-cards ;
+

extra/poker/summary.txt

@@ -1 +1 @@
-5-card poker hand evaluator
+Poker hand evaluator

extra/project-euler/001/001.factor

@@ -1,4 +1,4 @@
-! Copyright (c) 2007, 2008 Aaron Schaefer, Slava Pestov.
+! Copyright (c) 2007-2009 Aaron Schaefer, Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel math math.functions math.ranges project-euler.common sequences
     sets ;
@@ -47,14 +47,14 @@ PRIVATE>
 
 
 : euler001b ( -- answer )
-    1000 [ [ 5 mod ] [ 3 mod ] bi [ 0 = ] either? ] filter sum ;
+    1000 [0,b) [ [ 5 mod ] [ 3 mod ] bi [ 0 = ] either? ] filter sum ;
 
 ! [ euler001b ] 100 ave-time
 ! 0 ms ave run time - 0.06 SD (100 trials)
 
 
 : euler001c ( -- answer )
-    1000 [ { 3 5 } [ divisor? ] with any? ] filter sum ;
+    1000 [0,b) [ { 3 5 } [ divisor? ] with any? ] filter sum ;
 
 ! [ euler001c ] 100 ave-time
 ! 0 ms ave run time - 0.06 SD (100 trials)

extra/project-euler/005/005.factor

@@ -1,6 +1,6 @@
-! Copyright (c) 2007 Aaron Schaefer.
+! Copyright (c) 2007, 2009 Aaron Schaefer.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: math math.functions sequences project-euler.common ;
+USING: math math.functions math.ranges project-euler.common sequences ;
 IN: project-euler.005
 
 ! http://projecteuler.net/index.php?section=problems&id=5
@@ -18,7 +18,7 @@ IN: project-euler.005
 ! --------
 
 : euler005 ( -- answer )
-    20 1 [ 1+ lcm ] reduce ;
+    20 [1,b] 1 [ lcm ] reduce ;
 
 ! [ euler005 ] 100 ave-time
 ! 0 ms ave run time - 0.14 SD (100 trials)

extra/project-euler/018/018.factor

@@ -1,6 +1,6 @@
 ! Copyright (c) 2007 Samuel Tardieu, Aaron Schaefer.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math project-euler.common sequences ;
+USING: kernel math math.ranges project-euler.common sequences ;
 IN: project-euler.018
 
 ! http://projecteuler.net/index.php?section=problems&id=18
@@ -66,7 +66,7 @@ IN: project-euler.018
            91  71  52  38  17  14  91  43  58  50  27  29  48
          63  66  04  68  89  53  67  30  73  16  69  87  40  31
        04  62  98  27  23  09  70  98  73  93  38  53  60  04  23
-     } 15 iota [ 1+ cut swap ] map nip ;
+     } 15 [1,b] [ cut swap ] map nip ;
 
 PRIVATE>
 

extra/project-euler/025/025.factor

@@ -39,7 +39,7 @@ IN: project-euler.025
 ! Memoized brute force
 
 MEMO: fib ( m -- n )
-    dup 1 > [ 1- dup fib swap 1- fib + ] when ;
+    dup 1 > [ [ 1 - fib ] [ 2 - fib ] bi + ] when ;
 
 <PRIVATE
 

extra/project-euler/027/027.factor

@@ -1,7 +1,6 @@
 ! Copyright (c) 2008 Aaron Schaefer.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math math.primes project-euler.common sequences
+USING: kernel math math.primes math.ranges project-euler.common sequences ;
-project-euler.common ;
 IN: project-euler.027
 
 ! http://projecteuler.net/index.php?section=problems&id=27
@@ -47,7 +46,7 @@ IN: project-euler.027
 <PRIVATE
 
 : source-027 ( -- seq )
-    1000 [ prime? ] filter [ dup [ neg ] map append ] keep
+    1000 [0,b) [ prime? ] filter [ dup [ neg ] map append ] keep
     cartesian-product [ first2 < ] filter ;
 
 : quadratic ( b a n -- m )

extra/project-euler/030/030.factor

@@ -1,6 +1,6 @@
 ! Copyright (c) 2008 Aaron Schaefer.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math math.functions project-euler.common sequences ;
+USING: kernel math math.functions math.ranges project-euler.common sequences ;
 IN: project-euler.030
 
 ! http://projecteuler.net/index.php?section=problems&id=30
@@ -38,7 +38,7 @@ IN: project-euler.030
 PRIVATE>
 
 : euler030 ( -- answer )
-    325537 [ dup sum-fifth-powers = ] filter sum 1- ;
+    325537 [0,b) [ dup sum-fifth-powers = ] filter sum 1- ;
 
 ! [ euler030 ] 100 ave-time
 ! 1700 ms ave run time - 64.84 SD (100 trials)

extra/project-euler/032/032.factor

@@ -28,7 +28,7 @@ IN: project-euler.032
 
 : source-032 ( -- seq )
     9 factorial iota [
-        9 permutation [ 1+ ] map 10 digits>integer
+        9 permutation [ 1 + ] map 10 digits>integer
     ] map ;
 
 : 1and4 ( n -- ? )

extra/project-euler/046/046.factor

@@ -1,6 +1,7 @@
 ! Copyright (c) 2008 Aaron Schaefer.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math math.functions math.primes math.ranges sequences project-euler.common ;
+USING: kernel math math.functions math.primes math.ranges
+sequences project-euler.common math.bitwise ;
 IN: project-euler.046
 
 ! http://projecteuler.net/index.php?section=problems&id=46

extra/project-euler/048/048.factor

@@ -1,6 +1,6 @@
 ! Copyright (c) 2008 Aaron Schaefer.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math math.functions sequences project-euler.common ;
+USING: kernel math math.functions math.ranges project-euler.common sequences ;
 IN: project-euler.048
 
 ! http://projecteuler.net/index.php?section=problems&id=48
@@ -17,7 +17,7 @@ IN: project-euler.048
 ! --------
 
 : euler048 ( -- answer )
-    1000 [ 1+ dup ^ ] sigma 10 10 ^ mod ;
+    1000 [1,b] [ dup ^ ] sigma 10 10 ^ mod ;
 
 ! [ euler048 ] 100 ave-time
 ! 276 ms run / 1 ms GC ave time - 100 trials

extra/project-euler/055/055.factor

@@ -1,6 +1,6 @@
 ! Copyright (c) 2008 Aaron Schaefer.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math math.parser project-euler.common sequences ;
+USING: kernel math math.parser math.ranges project-euler.common sequences ;
 IN: project-euler.055
 
 ! http://projecteuler.net/index.php?section=problems&id=55
@@ -61,7 +61,7 @@ IN: project-euler.055
 PRIVATE>
 
 : euler055 ( -- answer )
-    10000 [ lychrel? ] count ;
+    10000 [0,b) [ lychrel? ] count ;
 
 ! [ euler055 ] 100 ave-time
 ! 478 ms ave run time - 30.63 SD (100 trials)

extra/project-euler/057/057.factor

@@ -1,6 +1,7 @@
 ! Copyright (c) 2008 Samuel Tardieu
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math math.functions math.parser sequences project-euler.common ;
+USING: kernel math math.functions math.parser math.ranges project-euler.common
+    sequences ;
 IN: project-euler.057
 
 ! http://projecteuler.net/index.php?section=problems&id=57
@@ -35,9 +36,9 @@ IN: project-euler.057
     >fraction [ number>string length ] bi@ > ; inline
 
 : euler057 ( -- answer )
-    0 1000 [ drop 2 + recip dup 1+ longer-numerator? ] count nip ;
+    0 1000 [0,b) [ drop 2 + recip dup 1 + longer-numerator? ] count nip ;
 
-! [ euler057 ] time
+! [ euler057 ] 100 ave-time
-! 3.375118 seconds
+! 1728 ms ave run time - 80.81 SD (100 trials)
 
 SOLUTION: euler057

extra/project-euler/150/150.factor

@@ -1,6 +1,7 @@
 ! Copyright (c) 2008 Eric Mertens.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: hints kernel locals math math.order sequences sequences.private project-euler.common ;
+USING: hints kernel locals math math.order math.ranges project-euler.common
+    sequences sequences.private ;
 IN: project-euler.150
 
 ! http://projecteuler.net/index.php?section=problems&id=150
@@ -50,13 +51,13 @@ IN: project-euler.150
     615949 * 797807 + 20 2^ rem dup 19 2^ - ; inline
 
 : sums-triangle ( -- seq )
-    0 1000 iota [ 1+ [ next ] replicate partial-sums ] map nip ;
+    0 1000 [1,b] [ [ next ] replicate partial-sums ] map nip ;
 
 :: (euler150) ( m -- n )
     [let | table [ sums-triangle ] |
         m [| x |
             x 1+ [| y |
-                m x - iota [| z |
+                m x - [0,b) [| z |
                     x z + table nth-unsafe
                     [ y z + 1+ swap nth-unsafe ]
                     [ y        swap nth-unsafe ] bi -

extra/project-euler/common/common.factor

@@ -1,7 +1,7 @@
 ! Copyright (c) 2007-2009 Aaron Schaefer.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays kernel lists make math math.functions math.matrices
-    math.miller-rabin math.order math.parser math.primes.factors
+    math.primes.miller-rabin math.order math.parser math.primes.factors
     math.primes.lists math.ranges math.ratios namespaces parser prettyprint
     quotations sequences sorting strings unicode.case vocabs vocabs.parser
     words ;

extra/random/blum-blum-shub/blum-blum-shub.factor

@@ -1,5 +1,5 @@
 USING: kernel math sequences namespaces
-math.miller-rabin math.functions accessors random ;
+math.primes.miller-rabin math.functions accessors random ;
 IN: random.blum-blum-shub
 
 ! Blum Blum Shub, n = pq, x_i+1 = x_i ^ 2 mod n

extra/tar/tar.factor

@@ -18,7 +18,7 @@ ERROR: checksum-error header ;
 : trim-string ( seq -- newseq ) [ "\0 " member? ] trim ;
 
 : read-c-string ( n -- str/f )
-    read [ zero? ] trim-tail [ f ] when-empty ;
+    read [ zero? ] trim-tail [ f ] when-empty >string ;
 
 : read-tar-header ( -- obj )
     \ tar-header new

extra/terrain/shaders/shaders.factor

@@ -1,18 +1,51 @@
 USING: multiline ;
 IN: terrain.shaders
 
+STRING: sky-vertex-shader
+
+uniform float sky_theta;
+varying vec3 direction;
+
+void main()
+{
+    vec4 v = vec4(gl_Vertex.xy, -1.0, 1.0);
+    gl_Position = v;
+    float s = sin(sky_theta), c = cos(sky_theta);
+    direction = mat3(1, 0, 0,  0, c, s,  0, -s, c)
+        * (gl_ModelViewMatrixInverse * vec4(v.xyz, 0.0)).xyz;
+}
+
+;
+
+STRING: sky-pixel-shader
+
+uniform sampler2D sky;
+uniform float sky_gradient, sky_theta;
+
+const vec4 SKY_COLOR_A = vec4(0.25, 0.0, 0.5,  1.0),
+           SKY_COLOR_B = vec4(0.6,  0.5, 0.75, 1.0);
+
+varying vec3 direction;
+
+void main()
+{
+    float t = texture2D(sky, normalize(direction.xyz).xy * 0.5 + vec2(0.5)).x + sky_gradient;
+    gl_FragColor = mix(SKY_COLOR_A, SKY_COLOR_B, sin(6.28*t));
+}
+
+;
+
 STRING: terrain-vertex-shader
 
 uniform sampler2D heightmap;
+uniform vec4 component_scale;
 
 varying vec2 heightcoords;
 
-const vec4 COMPONENT_SCALE = vec4(0.5, 0.01, 0.002, 0.0);
-
 float height(sampler2D map, vec2 coords)
 {
     vec4 v = texture2D(map, coords);
-    return dot(v, COMPONENT_SCALE);
+    return dot(v, component_scale);
 }
 
 void main()
@@ -27,15 +60,14 @@ void main()
 STRING: terrain-pixel-shader
 
 uniform sampler2D heightmap;
+uniform vec4 component_scale;
 
 varying vec2 heightcoords;
 
-const vec4 COMPONENT_SCALE = vec4(0.5, 0.01, 0.002, 0.0);
-
 float height(sampler2D map, vec2 coords)
 {
     vec4 v = texture2D(map, coords);
-    return dot(v, COMPONENT_SCALE);
+    return dot(v, component_scale);
 }
 
 void main()

extra/terrain/terrain.factor

@@ -1,30 +1,43 @@
-USING: accessors arrays combinators game-input
+USING: accessors arrays combinators game-input game-loop
-game-input.scancodes game-loop kernel literals locals math
+game-input.scancodes grouping kernel literals locals
-math.constants math.functions math.matrices math.order
+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.float
 terrain.generation terrain.shaders ui ui.gadgets
-ui.gadgets.worlds ui.pixel-formats ;
+ui.gadgets.worlds ui.pixel-formats game-worlds method-chains
+math.affine-transforms noise ;
 IN: terrain
 
 CONSTANT: FOV $[ 2.0 sqrt 1+ ]
 CONSTANT: NEAR-PLANE $[ 1.0 1024.0 / ]
-CONSTANT: FAR-PLANE 1.0
+CONSTANT: FAR-PLANE 2.0
-CONSTANT: EYE-START { 0.5 0.5 1.2 }
+CONSTANT: PLAYER-START-LOCATION { 0.5 0.51 0.5 }
-CONSTANT: TICK-LENGTH $[ 1000 30 /i ]
+CONSTANT: PLAYER-HEIGHT $[ 1.0 256.0 / ]
+CONSTANT: GRAVITY $[ 1.0 4096.0 / ]
+CONSTANT: JUMP $[ 1.0 1024.0 / ]
 CONSTANT: MOUSE-SCALE $[ 1.0 10.0 / ]
-CONSTANT: MOVEMENT-SPEED $[ 1.0 512.0 / ]
+CONSTANT: MOVEMENT-SPEED $[ 1.0 16384.0 / ]
+CONSTANT: FRICTION 0.95
+CONSTANT: COMPONENT-SCALE { 0.5 0.01 0.0005 0.0 }
+CONSTANT: SKY-PERIOD 1200
+CONSTANT: SKY-SPEED 0.0005
 
 CONSTANT: terrain-vertex-size { 512 512 }
 CONSTANT: terrain-vertex-distance { $[ 1.0 512.0 / ] $[ 1.0 512.0 / ] }
 CONSTANT: terrain-vertex-row-length $[ 512 1 + 2 * ]
 
-TUPLE: terrain-world < world
+TUPLE: player
-    eye yaw pitch
+    location yaw pitch velocity ;
+
+TUPLE: terrain-world < game-world
+    player
+    sky-image sky-texture sky-program
     terrain terrain-segment terrain-texture terrain-program
-    terrain-vertex-buffer
+    terrain-vertex-buffer ;
-    game-loop ;
+
+M: terrain-world tick-length
+    drop 1000 30 /i ;
 
 : frustum ( dim -- -x x -y y near far )
     dup first2 min v/n
@@ -32,12 +45,13 @@ TUPLE: terrain-world < world
     NEAR-PLANE FAR-PLANE ;
 
 : set-modelview-matrix ( gadget -- )
-    GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT bitor glClear
+    GL_DEPTH_BUFFER_BIT glClear
     GL_MODELVIEW glMatrixMode
     glLoadIdentity
+    player>>
     [ pitch>> 1.0 0.0 0.0 glRotatef ]
     [ yaw>> 0.0 1.0 0.0 glRotatef ]
-    [ eye>> vneg first3 glTranslatef ] tri ;
+    [ location>> vneg first3 glTranslatef ] tri ;
 
 : vertex-array-vertex ( x z -- vertex )
     [ terrain-vertex-distance first * ]
@@ -84,77 +98,126 @@ TUPLE: terrain-world < world
     siny cosp *  sinp neg  cosy cosp *      3array 3array
     v swap v.m ;
 
-: forward-vector ( world -- v )
+: forward-vector ( player -- v )
-    [ yaw>> ] [ pitch>> ] bi
+    yaw>> 0.0
     { 0.0 0.0 $ MOVEMENT-SPEED } vneg eye-rotate ;
-: rightward-vector ( world -- v )
+: rightward-vector ( player -- v )
-    [ yaw>> ] [ pitch>> ] bi
+    yaw>> 0.0
     { $ MOVEMENT-SPEED 0.0 0.0 } eye-rotate ;
 
-: move-forward ( world -- )
+: walk-forward ( player -- )
-    dup forward-vector [ v+ ] curry change-eye drop ;
+    dup forward-vector [ v+ ] curry change-velocity drop ;
-: move-backward ( world -- )
+: walk-backward ( player -- )
-    dup forward-vector [ v- ] curry change-eye drop ;
+    dup forward-vector [ v- ] curry change-velocity drop ;
-: move-leftward ( world -- )
+: walk-leftward ( player -- )
-    dup rightward-vector [ v- ] curry change-eye drop ;
+    dup rightward-vector [ v- ] curry change-velocity drop ;
-: move-rightward ( world -- )
+: walk-rightward ( player -- )
-    dup rightward-vector [ v+ ] curry change-eye drop ;
+    dup rightward-vector [ v+ ] curry change-velocity drop ;
+: jump ( player -- )
+    [ { 0.0 $ JUMP 0.0 } v+ ] change-velocity drop ;
 
-: rotate-with-mouse ( world mouse -- )
+: clamp-pitch ( pitch -- pitch' )
+    90.0 min -90.0 max ;
+
+: rotate-with-mouse ( player mouse -- )
     [ dx>> MOUSE-SCALE * [ + ] curry change-yaw ]
-    [ dy>> MOUSE-SCALE * [ + ] curry change-pitch ] bi
+    [ dy>> MOUSE-SCALE * [ + clamp-pitch ] curry change-pitch ] bi
     drop ;
 
 :: handle-input ( world -- )
+    world player>> :> player
     read-keyboard keys>> :> keys
-    key-w keys nth [ world move-forward ] when 
+    key-w keys nth [ player walk-forward ] when 
-    key-s keys nth [ world move-backward ] when 
+    key-s keys nth [ player walk-backward ] when 
-    key-a keys nth [ world move-leftward ] when 
+    key-a keys nth [ player walk-leftward ] when 
-    key-d keys nth [ world move-rightward ] when 
+    key-d keys nth [ player walk-rightward ] when 
-    world read-mouse rotate-with-mouse
+    key-space keys nth [ player jump ] when 
+    key-escape keys nth [ world close-window ] when
+    player read-mouse rotate-with-mouse
     reset-mouse ;
 
-M: terrain-world tick*
+: apply-friction ( velocity -- velocity' )
-    [ handle-input ] keep
+    FRICTION v*n ;
-    ! [ eye>> ] [ yaw>> ] [ pitch>> ] tri 3array P ! debug
+
+: apply-gravity ( velocity -- velocity' )
+    1 over [ GRAVITY - ] change-nth ;
+
+: clamp-coords ( coords dim -- coords' )
+    [ { 0 0 } vmax ] dip { 2 2 } v- vmin ;
+
+:: pixel-indices ( coords dim -- indices )
+    coords vfloor [ >integer ] map dim clamp-coords :> floor-coords
+    floor-coords first2 dim first * + :> base-index
+    base-index dim first + :> next-row-index
+
+    base-index
+    base-index 1 +
+    next-row-index
+    next-row-index 1 + 4array ;
+
+:: terrain-height-at ( segment point -- height )
+    segment dim>> :> dim
+    dim point v* :> pixel
+    pixel dup vfloor v- :> pixel-mantissa
+    segment bitmap>> 4 <groups> :> pixels
+    pixel dim pixel-indices :> indices
+    
+    indices [ pixels nth COMPONENT-SCALE v. 255.0 / ] map
+    first4 pixel-mantissa bilerp ;
+
+: collide ( segment location -- location' )
+    [ [ first ] [ third ] bi 2array terrain-height-at PLAYER-HEIGHT + ]
+    [ [ 1 ] 2dip [ max ] with change-nth ]
+    [ ] tri ;
+
+: tick-player ( world player -- )
+    [ apply-friction apply-gravity ] change-velocity
+    dup velocity>> [ v+ [ terrain-segment>> ] dip collide ] curry with change-location
     drop ;
 
-M: terrain-world draw*
+M: terrain-world tick*
-    nip draw-world ;
+    [ dup focused?>> [ handle-input ] [ drop ] if ]
+    [ dup player>> tick-player ] bi ;
 
-: set-heightmap-texture-parameters ( texture -- )
+: set-texture-parameters ( texture -- )
     GL_TEXTURE_2D GL_TEXTURE0 bind-texture-unit
     GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER GL_LINEAR glTexParameteri
     GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER GL_LINEAR glTexParameteri
-    GL_TEXTURE_2D GL_TEXTURE_WRAP_S GL_CLAMP glTexParameteri
+    GL_TEXTURE_2D GL_TEXTURE_WRAP_S GL_CLAMP_TO_EDGE glTexParameteri
-    GL_TEXTURE_2D GL_TEXTURE_WRAP_T GL_CLAMP glTexParameteri ;
+    GL_TEXTURE_2D GL_TEXTURE_WRAP_T GL_CLAMP_TO_EDGE glTexParameteri ;
 
-M: terrain-world begin-world
+: sky-gradient ( world -- t )
+    game-loop>> tick-number>> SKY-PERIOD mod SKY-PERIOD /f ;
+: sky-theta ( world -- theta )
+    game-loop>> tick-number>> SKY-SPEED * ;
+
+BEFORE: terrain-world begin-world
     "2.0" { "GL_ARB_vertex_buffer_object" "GL_ARB_shader_objects" }
     require-gl-version-or-extensions
     GL_DEPTH_TEST glEnable
     GL_TEXTURE_2D glEnable
     GL_VERTEX_ARRAY glEnableClientState
-    0.5 0.5 0.5 1.0 glClearColor
+    PLAYER-START-LOCATION 0.0 0.0 { 0.0 0.0 0.0 } player boa >>player
-    EYE-START >>eye
+    <perlin-noise-table> 0.01 0.01 <scale> { 512 512 } perlin-noise-image
-    0.0 >>yaw
+    [ >>sky-image ] keep
-    0.0 >>pitch
+    make-texture [ set-texture-parameters ] keep >>sky-texture
     <terrain> [ >>terrain ] keep
     { 0 0 } terrain-segment [ >>terrain-segment ] keep
-    make-texture [ set-heightmap-texture-parameters ] keep >>terrain-texture
+    make-texture [ set-texture-parameters ] keep >>terrain-texture
+    sky-vertex-shader sky-pixel-shader <simple-gl-program>
+    >>sky-program
     terrain-vertex-shader terrain-pixel-shader <simple-gl-program>
     >>terrain-program
     vertex-array >vertex-buffer >>terrain-vertex-buffer
-    TICK-LENGTH over <game-loop> [ >>game-loop ] keep start-loop
-    reset-mouse
     drop ;
 
-M: terrain-world end-world
+AFTER: terrain-world end-world
     {
-        [ game-loop>> stop-loop ]
         [ terrain-vertex-buffer>> delete-gl-buffer ]
         [ terrain-program>> delete-gl-program ]
         [ terrain-texture>> delete-texture ]
+        [ sky-program>> delete-gl-program ]
+        [ sky-texture>> delete-texture ]
     } cleave ;
 
 M: terrain-world resize-world
@@ -164,20 +227,27 @@ M: terrain-world resize-world
     [ frustum glFrustum ] bi ;
 
 M: terrain-world draw-world*
+    {
         [ set-modelview-matrix ]
         [ terrain-texture>> GL_TEXTURE_2D GL_TEXTURE0 bind-texture-unit ]
-    [ dup terrain-program>> [
+        [ sky-texture>> GL_TEXTURE_2D GL_TEXTURE1 bind-texture-unit ]
-        "heightmap" glGetUniformLocation 0 glUniform1i
+        [ GL_DEPTH_TEST glDisable dup sky-program>> [
+            [ nip "sky" glGetUniformLocation 1 glUniform1i ]
+            [ "sky_gradient" glGetUniformLocation swap sky-gradient glUniform1f ]
+            [ "sky_theta" glGetUniformLocation swap sky-theta glUniform1f ] 2tri
+            { -1.0 -1.0 } { 2.0 2.0 } gl-fill-rect
+        ] with-gl-program ]
+        [ GL_DEPTH_TEST glEnable dup terrain-program>> [
+            [ "heightmap" glGetUniformLocation 0 glUniform1i ]
+            [ "component_scale" glGetUniformLocation COMPONENT-SCALE first4 glUniform4f ] bi
             terrain-vertex-buffer>> draw-vertex-buffer
         ] with-gl-program ]
-    tri gl-error ;
+    } cleave gl-error ;
 
-M: terrain-world focusable-child* drop t ;
 M: terrain-world pref-dim* drop { 640 480 } ;
 
 : terrain-window ( -- )
     [
-        open-game-input
         f T{ world-attributes
             { world-class terrain-world }
             { title "Terrain" }
@@ -186,5 +256,8 @@ M: terrain-world pref-dim* drop { 640 480 } ;
                 double-buffered
                 T{ depth-bits { value 24 } }
             } }
+            { grab-input? t }
         } open-window
     ] with-ui ;
+
+MAIN: terrain-window

vm/callstack.cpp

@@ -24,10 +24,7 @@ void iterate_callstack(cell top, cell bottom, CALLSTACK_ITER iterator)
 
 void iterate_callstack_object(callstack *stack, CALLSTACK_ITER iterator)
 {
-	cell top = (cell)FIRST_STACK_FRAME(stack);
+	iterate_callstack((cell)stack->top(),(cell)stack->bottom(),iterator);
-	cell bottom = top + untag_fixnum(stack->length);
-
-	iterate_callstack(top,bottom,iterator);
 }
 
 callstack *allot_callstack(cell size)
@@ -75,7 +72,7 @@ PRIMITIVE(callstack)
 		size = 0;
 
 	callstack *stack = allot_callstack(size);
-	memcpy(FIRST_STACK_FRAME(stack),top,size);
+	memcpy(stack->top(),top,size);
 	dpush(tag<callstack>(stack));
 }
 
@@ -84,7 +81,7 @@ PRIMITIVE(set_callstack)
 	callstack *stack = untag_check<callstack>(dpop());
 
 	set_callstack(stack_chain->callstack_bottom,
-		FIRST_STACK_FRAME(stack),
+		stack->top(),
 		untag_fixnum(stack->length),
 		memcpy);
 
@@ -173,12 +170,11 @@ PRIMITIVE(callstack_to_array)
 	dpush(tag<array>(frames));
 }
 
-stack_frame *innermost_stack_frame(callstack *callstack)
+stack_frame *innermost_stack_frame(callstack *stack)
 {
-	stack_frame *top = FIRST_STACK_FRAME(callstack);
+	stack_frame *top = stack->top();
-	cell bottom = (cell)top + untag_fixnum(callstack->length);
+	stack_frame *bottom = stack->bottom();
-
+	stack_frame *frame = bottom - 1;
-	stack_frame *frame = (stack_frame *)bottom - 1;
 
 	while(frame >= top && frame_successor(frame) >= top)
 		frame = frame_successor(frame);

vm/callstack.hpp

@@ -6,8 +6,6 @@ inline static cell callstack_size(cell size)
 	return sizeof(callstack) + size;
 }
 
-#define FIRST_STACK_FRAME(stack) (stack_frame *)((stack) + 1)
-
 typedef void (*CALLSTACK_ITER)(stack_frame *frame);
 
 stack_frame *fix_callstack_top(stack_frame *top, stack_frame *bottom);

vm/code_block.cpp

@@ -3,6 +3,21 @@
 namespace factor
 {
 
+static relocation_type relocation_type_of(relocation_entry r)
+{
+	return (relocation_type)((r & 0xf0000000) >> 28);
+}
+
+static relocation_class relocation_class_of(relocation_entry r)
+{
+	return (relocation_class)((r & 0x0f000000) >> 24);
+}
+
+static cell relocation_offset_of(relocation_entry r)
+{
+	return  (r & 0x00ffffff);
+}
+
 void flush_icache_for(code_block *block)
 {
 	flush_icache((cell)block,block->size);
@@ -125,11 +140,11 @@ void *get_rel_symbol(array *literals, cell index)
 cell compute_relocation(relocation_entry rel, cell index, code_block *compiled)
 {
 	array *literals = untag<array>(compiled->literals);
-	cell offset = REL_OFFSET(rel) + (cell)compiled->xt();
+	cell offset = relocation_offset_of(rel) + (cell)compiled->xt();
 
 #define ARG array_nth(literals,index)
 
-	switch(REL_TYPE(rel))
+	switch(relocation_type_of(rel))
 	{
 	case RT_PRIMITIVE:
 		return (cell)primitives[untag_fixnum(ARG)];
@@ -174,7 +189,7 @@ void iterate_relocations(code_block *compiled, relocation_iterator iter)
 		{
 			relocation_entry rel = relocation->data<relocation_entry>()[i];
 			iter(rel,index,compiled);
-			index += number_of_parameters(REL_TYPE(rel));			
+			index += number_of_parameters(relocation_type_of(rel));			
 		}
 	}
 }
@@ -217,25 +232,25 @@ void store_address_in_code_block(cell klass, cell offset, fixnum absolute_value)
 		store_address_2_2((cell *)offset,absolute_value);
 		break;
 	case RC_ABSOLUTE_PPC_2:
-		store_address_masked((cell *)offset,absolute_value,REL_ABSOLUTE_PPC_2_MASK,0);
+		store_address_masked((cell *)offset,absolute_value,rel_absolute_ppc_2_mask,0);
 		break;
 	case RC_RELATIVE_PPC_2:
-		store_address_masked((cell *)offset,relative_value,REL_RELATIVE_PPC_2_MASK,0);
+		store_address_masked((cell *)offset,relative_value,rel_relative_ppc_2_mask,0);
 		break;
 	case RC_RELATIVE_PPC_3:
-		store_address_masked((cell *)offset,relative_value,REL_RELATIVE_PPC_3_MASK,0);
+		store_address_masked((cell *)offset,relative_value,rel_relative_ppc_3_mask,0);
 		break;
 	case RC_RELATIVE_ARM_3:
 		store_address_masked((cell *)offset,relative_value - sizeof(cell) * 2,
-			REL_RELATIVE_ARM_3_MASK,2);
+			rel_relative_arm_3_mask,2);
 		break;
 	case RC_INDIRECT_ARM:
 		store_address_masked((cell *)offset,relative_value - sizeof(cell),
-			REL_INDIRECT_ARM_MASK,0);
+			rel_indirect_arm_mask,0);
 		break;
 	case RC_INDIRECT_ARM_PC:
 		store_address_masked((cell *)offset,relative_value - sizeof(cell) * 2,
-			REL_INDIRECT_ARM_MASK,0);
+			rel_indirect_arm_mask,0);
 		break;
 	default:
 		critical_error("Bad rel class",klass);
@@ -245,12 +260,12 @@ void store_address_in_code_block(cell klass, cell offset, fixnum absolute_value)
 
 void update_literal_references_step(relocation_entry rel, cell index, code_block *compiled)
 {
-	if(REL_TYPE(rel) == RT_IMMEDIATE)
+	if(relocation_type_of(rel) == RT_IMMEDIATE)
 	{
-		cell offset = REL_OFFSET(rel) + (cell)(compiled + 1);
+		cell offset = relocation_offset_of(rel) + (cell)(compiled + 1);
 		array *literals = untag<array>(compiled->literals);
 		fixnum absolute_value = array_nth(literals,index);
-		store_address_in_code_block(REL_CLASS(rel),offset,absolute_value);
+		store_address_in_code_block(relocation_class_of(rel),offset,absolute_value);
 	}
 }
 
@@ -297,14 +312,14 @@ void relocate_code_block_step(relocation_entry rel, cell index, code_block *comp
 	tagged<byte_array>(compiled->relocation).untag_check();
 #endif
 
-	store_address_in_code_block(REL_CLASS(rel),
+	store_address_in_code_block(relocation_class_of(rel),
-				    REL_OFFSET(rel) + (cell)compiled->xt(),
+				    relocation_offset_of(rel) + (cell)compiled->xt(),
 				    compute_relocation(rel,index,compiled));
 }
 
 void update_word_references_step(relocation_entry rel, cell index, code_block *compiled)
 {
-	relocation_type type = REL_TYPE(rel);
+	relocation_type type = relocation_type_of(rel);
 	if(type == RT_XT || type == RT_XT_PIC || type == RT_XT_PIC_TAIL)
 		relocate_code_block_step(rel,index,compiled);
 }
@@ -369,7 +384,7 @@ void mark_stack_frame_step(stack_frame *frame)
 /* Mark code blocks executing in currently active stack frames. */
 void mark_active_blocks(context *stacks)
 {
-	if(collecting_gen == TENURED)
+	if(collecting_gen == data->tenured())
 	{
 		cell top = (cell)stacks->callstack_top;
 		cell bottom = (cell)stacks->callstack_bottom;
@@ -410,7 +425,7 @@ void mark_object_code_block(object *object)
 /* Perform all fixups on a code block */
 void relocate_code_block(code_block *compiled)
 {
-	compiled->last_scan = NURSERY;
+	compiled->last_scan = data->nursery();
 	compiled->needs_fixup = false;
 	iterate_relocations(compiled,relocate_code_block_step);
 	flush_icache_for(compiled);
@@ -480,7 +495,7 @@ code_block *add_code_block(
 
 	/* compiled header */
 	compiled->type = type;
-	compiled->last_scan = NURSERY;
+	compiled->last_scan = data->nursery();
 	compiled->needs_fixup = true;
 	compiled->relocation = relocation.value();
 
@@ -499,7 +514,7 @@ code_block *add_code_block(
 
 	/* next time we do a minor GC, we have to scan the code heap for
 	literals */
-	last_code_heap_scan = NURSERY;
+	last_code_heap_scan = data->nursery();
 
 	return compiled;
 }

vm/code_block.hpp

@@ -51,17 +51,14 @@ enum relocation_class {
 	RC_INDIRECT_ARM_PC
 };
 
-#define REL_ABSOLUTE_PPC_2_MASK 0xffff
+static const cell rel_absolute_ppc_2_mask = 0xffff;
-#define REL_RELATIVE_PPC_2_MASK 0xfffc
+static const cell rel_relative_ppc_2_mask = 0xfffc;
-#define REL_RELATIVE_PPC_3_MASK 0x3fffffc
+static const cell rel_relative_ppc_3_mask = 0x3fffffc;
-#define REL_INDIRECT_ARM_MASK 0xfff
+static const cell rel_indirect_arm_mask = 0xfff;
-#define REL_RELATIVE_ARM_3_MASK 0xffffff
+static const cell rel_relative_arm_3_mask = 0xffffff;
 
 /* code relocation table consists of a table of entries for each fixup */
 typedef u32 relocation_entry;
-#define REL_TYPE(r) (relocation_type)(((r) & 0xf0000000) >> 28)
-#define REL_CLASS(r) (relocation_class)(((r) & 0x0f000000) >> 24)
-#define REL_OFFSET(r) ((r) & 0x00ffffff)
 
 void flush_icache_for(code_block *compiled);
 

vm/code_gc.cpp

@@ -22,9 +22,9 @@ void new_heap(heap *heap, cell size)
 
 static void add_to_free_list(heap *heap, free_heap_block *block)
 {
-	if(block->size < FREE_LIST_COUNT * BLOCK_SIZE_INCREMENT)
+	if(block->size < free_list_count * block_size_increment)
 	{
-		int index = block->size / BLOCK_SIZE_INCREMENT;
+		int index = block->size / block_size_increment;
 		block->next_free = heap->free.small_blocks[index];
 		heap->free.small_blocks[index] = block;
 	}
@@ -45,7 +45,7 @@ void build_free_list(heap *heap, cell size)
 
 	clear_free_list(heap);
 
-	size = (size + BLOCK_SIZE_INCREMENT - 1) & ~(BLOCK_SIZE_INCREMENT - 1);
+	size = (size + block_size_increment - 1) & ~(block_size_increment - 1);
 
 	heap_block *scan = first_block(heap);
 	free_heap_block *end = (free_heap_block *)(heap->seg->start + size);
@@ -101,9 +101,9 @@ static free_heap_block *find_free_block(heap *heap, cell size)
 {
 	cell attempt = size;
 
-	while(attempt < FREE_LIST_COUNT * BLOCK_SIZE_INCREMENT)
+	while(attempt < free_list_count * block_size_increment)
 	{
-		int index = attempt / BLOCK_SIZE_INCREMENT;
+		int index = attempt / block_size_increment;
 		free_heap_block *block = heap->free.small_blocks[index];
 		if(block)
 		{
@@ -156,7 +156,7 @@ static free_heap_block *split_free_block(heap *heap, free_heap_block *block, cel
 /* Allocate a block of memory from the mark and sweep GC heap */
 heap_block *heap_allot(heap *heap, cell size)
 {
-	size = (size + BLOCK_SIZE_INCREMENT - 1) & ~(BLOCK_SIZE_INCREMENT - 1);
+	size = (size + block_size_increment - 1) & ~(block_size_increment - 1);
 
 	free_heap_block *block = find_free_block(heap,size);
 	if(block)

vm/code_gc.hpp

@@ -1,11 +1,11 @@
 namespace factor
 {
 
-#define FREE_LIST_COUNT 16
+static const cell free_list_count = 16;
-#define BLOCK_SIZE_INCREMENT 32
+static const cell block_size_increment = 32;
 
 struct heap_free_list {
-	free_heap_block *small_blocks[FREE_LIST_COUNT];
+	free_heap_block *small_blocks[free_list_count];
 	free_heap_block *large_blocks;
 };
 

vm/contexts.cpp

@@ -18,12 +18,12 @@ void reset_retainstack()
 	rs = rs_bot - sizeof(cell);
 }
 
-#define RESERVED (64 * sizeof(cell))
+static const cell stack_reserved = (64 * sizeof(cell));
 
 void fix_stacks()
 {
-	if(ds + sizeof(cell) < ds_bot || ds + RESERVED >= ds_top) reset_datastack();
+	if(ds + sizeof(cell) < ds_bot || ds + stack_reserved >= ds_top) reset_datastack();
-	if(rs + sizeof(cell) < rs_bot || rs + RESERVED >= rs_top) reset_retainstack();
+	if(rs + sizeof(cell) < rs_bot || rs + stack_reserved >= rs_top) reset_retainstack();
 }
 
 /* called before entry into foreign C code. Note that ds and rs might

vm/cpu-ppc.hpp

@@ -27,7 +27,7 @@ inline static void check_call_site(cell return_address)
 #endif
 }
 
-#define B_MASK 0x3fffffc
+static const cell b_mask = 0x3fffffc;
 
 inline static void *get_call_target(cell return_address)
 {
@@ -35,7 +35,7 @@ inline static void *get_call_target(cell return_address)
 	check_call_site(return_address);
 
 	cell insn = *(cell *)return_address;
-	cell unsigned_addr = (insn & B_MASK);
+	cell unsigned_addr = (insn & b_mask);
 	fixnum signed_addr = (fixnum)(unsigned_addr << 6) >> 6;
 	return (void *)(signed_addr + return_address);
 }
@@ -48,7 +48,7 @@ inline static void set_call_target(cell return_address, void *target)
 	cell insn = *(cell *)return_address;
 
 	fixnum relative_address = ((cell)target - return_address);
-	insn = ((insn & ~B_MASK) | (relative_address & B_MASK));
+	insn = ((insn & ~b_mask) | (relative_address & b_mask));
 	*(cell *)return_address = insn;
 
 	/* Flush the cache line containing the call we just patched */

vm/data_gc.cpp

@@ -9,15 +9,15 @@ bool performing_gc;
 bool performing_compaction;
 cell collecting_gen;
 
-/* if true, we collecting AGING space for the second time, so if it is still
+/* if true, we collecting aging space for the second time, so if it is still
-full, we go on to collect TENURED */
+full, we go on to collect tenured */
 bool collecting_aging_again;
 
 /* in case a generation fills up in the middle of a gc, we jump back
 up to try collecting the next generation. */
 jmp_buf gc_jmp;
 
-gc_stats stats[MAX_GEN_COUNT];
+gc_stats stats[max_gen_count];
 u64 cards_scanned;
 u64 decks_scanned;
 u64 card_scan_time;
@@ -36,7 +36,7 @@ data_heap *old_data_heap;
 void init_data_gc()
 {
 	performing_gc = false;
-	last_code_heap_scan = NURSERY;
+	last_code_heap_scan = data->nursery();
 	collecting_aging_again = false;
 }
 
@@ -66,11 +66,11 @@ static bool should_copy_p(object *untagged)
 {
 	if(in_zone(newspace,untagged))
 		return false;
-	if(collecting_gen == TENURED)
+	if(collecting_gen == data->tenured())
 		return true;
-	else if(HAVE_AGING_P && collecting_gen == AGING)
+	else if(data->have_aging_p() && collecting_gen == data->aging())
-		return !in_zone(&data->generations[TENURED],untagged);
+		return !in_zone(&data->generations[data->tenured()],untagged);
-	else if(collecting_gen == NURSERY)
+	else if(collecting_gen == data->nursery())
 		return in_zone(&nursery,untagged);
 	else
 	{
@@ -186,19 +186,19 @@ static void copy_gen_cards(cell gen)
 
 	/* if we are collecting the nursery, we care about old->nursery pointers
 	but not old->aging pointers */
-	if(collecting_gen == NURSERY)
+	if(collecting_gen == data->nursery())
 	{
-		mask = CARD_POINTS_TO_NURSERY;
+		mask = card_points_to_nursery;
 
 		/* after the collection, no old->nursery pointers remain
 		anywhere, but old->aging pointers might remain in tenured
 		space */
-		if(gen == TENURED)
+		if(gen == data->tenured())
-			unmask = CARD_POINTS_TO_NURSERY;
+			unmask = card_points_to_nursery;
 		/* after the collection, all cards in aging space can be
 		cleared */
-		else if(HAVE_AGING_P && gen == AGING)
+		else if(data->have_aging_p() && gen == data->aging())
-			unmask = CARD_MARK_MASK;
+			unmask = card_mark_mask;
 		else
 		{
 			critical_error("bug in copy_gen_cards",gen);
@@ -208,20 +208,20 @@ static void copy_gen_cards(cell gen)
 	/* if we are collecting aging space into tenured space, we care about
 	all old->nursery and old->aging pointers. no old->aging pointers can
 	remain */
-	else if(HAVE_AGING_P && collecting_gen == AGING)
+	else if(data->have_aging_p() && collecting_gen == data->aging())
 	{
 		if(collecting_aging_again)
 		{
-			mask = CARD_POINTS_TO_AGING;
+			mask = card_points_to_aging;
-			unmask = CARD_MARK_MASK;
+			unmask = card_mark_mask;
 		}
 		/* after we collect aging space into the aging semispace, no
 		old->nursery pointers remain but tenured space might still have
 		pointers to aging space. */
 		else
 		{
-			mask = CARD_POINTS_TO_AGING;
+			mask = card_points_to_aging;
-			unmask = CARD_POINTS_TO_NURSERY;
+			unmask = card_points_to_nursery;
 		}
 	}
 	else
@@ -366,8 +366,8 @@ static cell copy_next_from_aging(cell scan)
 	{
 		obj++;
 
-		cell tenured_start = data->generations[TENURED].start;
+		cell tenured_start = data->generations[data->tenured()].start;
-		cell tenured_end = data->generations[TENURED].end;
+		cell tenured_end = data->generations[data->tenured()].end;
 
 		cell newspace_start = newspace->start;
 		cell newspace_end = newspace->end;
@@ -421,17 +421,17 @@ static cell copy_next_from_tenured(cell scan)
 
 void copy_reachable_objects(cell scan, cell *end)
 {
-	if(collecting_gen == NURSERY)
+	if(collecting_gen == data->nursery())
 	{
 		while(scan < *end)
 			scan = copy_next_from_nursery(scan);
 	}
-	else if(HAVE_AGING_P && collecting_gen == AGING)
+	else if(data->have_aging_p() && collecting_gen == data->aging())
 	{
 		while(scan < *end)
 			scan = copy_next_from_aging(scan);
 	}
-	else if(collecting_gen == TENURED)
+	else if(collecting_gen == data->tenured())
 	{
 		while(scan < *end)
 			scan = copy_next_from_tenured(scan);
@@ -443,12 +443,12 @@ static void begin_gc(cell requested_bytes)
 {
 	if(growing_data_heap)
 	{
-		if(collecting_gen != TENURED)
+		if(collecting_gen != data->tenured())
 			critical_error("Invalid parameters to begin_gc",0);
 
 		old_data_heap = data;
 		set_data_heap(grow_data_heap(old_data_heap,requested_bytes));
-		newspace = &data->generations[TENURED];
+		newspace = &data->generations[data->tenured()];
 	}
 	else if(collecting_accumulation_gen_p())
 	{
@@ -491,12 +491,12 @@ static void end_gc(cell gc_elapsed)
 	if(collecting_accumulation_gen_p())
 	{
 		/* all younger generations except are now empty.
-		if collecting_gen == NURSERY here, we only have 1 generation;
+		if collecting_gen == data->nursery() here, we only have 1 generation;
 		old-school Cheney collector */
-		if(collecting_gen != NURSERY)
+		if(collecting_gen != data->nursery())
-			reset_generations(NURSERY,collecting_gen - 1);
+			reset_generations(data->nursery(),collecting_gen - 1);
 	}
-	else if(collecting_gen == NURSERY)
+	else if(collecting_gen == data->nursery())
 	{
 		nursery.here = nursery.start;
 	}
@@ -504,7 +504,7 @@ static void end_gc(cell gc_elapsed)
 	{
 		/* all generations up to and including the one
 		collected are now empty */
-		reset_generations(NURSERY,collecting_gen);
+		reset_generations(data->nursery(),collecting_gen);
 	}
 
 	collecting_aging_again = false;
@@ -534,17 +534,17 @@ void garbage_collection(cell gen,
 	{
 		/* We have no older generations we can try collecting, so we
 		resort to growing the data heap */
-		if(collecting_gen == TENURED)
+		if(collecting_gen == data->tenured())
 		{
 			growing_data_heap = true;
 
 			/* see the comment in unmark_marked() */
 			unmark_marked(&code);
 		}
-		/* we try collecting AGING space twice before going on to
+		/* we try collecting aging space twice before going on to
-		collect TENURED */
+		collect tenured */
-		else if(HAVE_AGING_P
+		else if(data->have_aging_p()
-			&& collecting_gen == AGING
+			&& collecting_gen == data->aging()
 			&& !collecting_aging_again)
 		{
 			collecting_aging_again = true;
@@ -575,7 +575,7 @@ void garbage_collection(cell gen,
 	{
 		code_heap_scans++;
 
-		if(collecting_gen == TENURED)
+		if(collecting_gen == data->tenured())
 			free_unmarked(&code,(heap_iterator)update_literal_and_word_references);
 		else
 			copy_code_heap_roots();
@@ -595,7 +595,7 @@ void garbage_collection(cell gen,
 
 void gc()
 {
-	garbage_collection(TENURED,false,0);
+	garbage_collection(data->tenured(),false,0);
 }
 
 PRIMITIVE(gc)
@@ -610,7 +610,7 @@ PRIMITIVE(gc_stats)
 	cell i;
 	u64 total_gc_time = 0;
 
-	for(i = 0; i < MAX_GEN_COUNT; i++)
+	for(i = 0; i < max_gen_count; i++)
 	{
 		gc_stats *s = &stats[i];
 		result.add(allot_cell(s->collections));
@@ -635,8 +635,7 @@ PRIMITIVE(gc_stats)
 
 void clear_gc_stats()
 {
-	int i;
+	for(cell i = 0; i < max_gen_count; i++)
-	for(i = 0; i < MAX_GEN_COUNT; i++)
 		memset(&stats[i],0,sizeof(gc_stats));
 
 	cards_scanned = 0;
@@ -683,7 +682,7 @@ PRIMITIVE(become)
 
 VM_C_API void minor_gc()
 {
-	garbage_collection(NURSERY,false,0);
+	garbage_collection(data->nursery(),false,0);
 }
 
 }

vm/data_gc.hpp

@@ -24,10 +24,10 @@ void gc();
 
 inline static bool collecting_accumulation_gen_p()
 {
-	return ((HAVE_AGING_P
+	return ((data->have_aging_p()
-		&& collecting_gen == AGING
+		&& collecting_gen == data->aging()
 		&& !collecting_aging_again)
-		|| collecting_gen == TENURED);
+		|| collecting_gen == data->tenured());
 }
 
 void copy_handle(cell *handle);
@@ -39,7 +39,7 @@ void garbage_collection(volatile cell gen,
 /* We leave this many bytes free at the top of the nursery so that inline
 allocation (which does not call GC because of possible roots in volatile
 registers) does not run out of memory */
-#define ALLOT_BUFFER_ZONE 1024
+static const cell allot_buffer_zone = 1024;
 
 inline static object *allot_zone(zone *z, cell a)
 {
@@ -63,11 +63,11 @@ inline static object *allot_object(header header, cell size)
 
 	object *obj;
 
-	if(nursery.size - ALLOT_BUFFER_ZONE > size)
+	if(nursery.size - allot_buffer_zone > size)
 	{
 		/* If there is insufficient room, collect the nursery */
-		if(nursery.here + ALLOT_BUFFER_ZONE + size > nursery.end)
+		if(nursery.here + allot_buffer_zone + size > nursery.end)
-			garbage_collection(NURSERY,false,0);
+			garbage_collection(data->nursery(),false,0);
 
 		cell h = nursery.here;
 		nursery.here = h + align8(size);
@@ -77,20 +77,20 @@ inline static object *allot_object(header header, cell size)
 	tenured space */
 	else
 	{
-		zone *tenured = &data->generations[TENURED];
+		zone *tenured = &data->generations[data->tenured()];
 
 		/* If tenured space does not have enough room, collect */
 		if(tenured->here + size > tenured->end)
 		{
 			gc();
-			tenured = &data->generations[TENURED];
+			tenured = &data->generations[data->tenured()];
 		}
 
 		/* If it still won't fit, grow the heap */
 		if(tenured->here + size > tenured->end)
 		{
-			garbage_collection(TENURED,true,size);
+			garbage_collection(data->tenured(),true,size);
-			tenured = &data->generations[TENURED];
+			tenured = &data->generations[data->tenured()];
 		}
 
 		obj = allot_zone(tenured,size);