M: integer (eql?) = ;
+M: float (eql?)
+ over float? [ fp-bitwise= ] [ 2drop f ] if ;
+
M: sequence (eql?)
over sequence? [
2dup [ length ] bi@ =
: 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 ,
-USING: arrays kernel math namespaces sequences tools.test checksums.sha2 checksums ;
-[ "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855" ] [ "" sha-256 checksum-bytes hex-string ] unit-test
-[ "ba7816bf8f01cfea414140de5dae2223b00361a396177a9cb410ff61f20015ad" ] [ "abc" sha-256 checksum-bytes hex-string ] unit-test
-[ "f7846f55cf23e14eebeab5b4e1550cad5b509e3348fbc4efa3a1413d393cb650" ] [ "message digest" sha-256 checksum-bytes hex-string ] unit-test
-[ "71c480df93d6ae2f1efad1447c66c9525e316218cf51fc8d9ed832f2daf18b73" ] [ "abcdefghijklmnopqrstuvwxyz" sha-256 checksum-bytes hex-string ] unit-test
-[ "db4bfcbd4da0cd85a60c3c37d3fbd8805c77f15fc6b1fdfe614ee0a7c8fdb4c0" ] [ "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789" sha-256 checksum-bytes hex-string ] unit-test
-[ "f371bc4a311f2b009eef952dd83ca80e2b60026c8e935592d0f9c308453c813e" ] [ "12345678901234567890123456789012345678901234567890123456789012345678901234567890" sha-256 checksum-bytes hex-string ] unit-test
+USING: arrays kernel math namespaces sequences tools.test
+checksums.sha2 checksums ;
+IN: checksums.sha2.tests
+
+: test-checksum ( text identifier -- checksum )
+ checksum-bytes hex-string ;
+
+[ "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
! 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
+
+INSTANCE: sha-224 checksum
+INSTANCE: sha-256 checksum
+
+TUPLE: sha2-state K H word-size block-size ;
+
+TUPLE: sha2-short < sha2-state ;
-SYMBOLS: vars M K H S0 S1 process-M word-size block-size ;
+TUPLE: sha2-long < sha2-state ;
+
+TUPLE: sha-224-state < sha2-short ;
+
+TUPLE: sha-256-state < sha2-short ;
+
+<PRIVATE
CONSTANT: a 0
CONSTANT: b 1
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
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
- -3 shift bitxor bitxor ; inline
+ [
+ [ -7 bitroll-32 ]
+ [ -18 bitroll-32 ]
+ [ -3 shift ] tri
+ ] [ bitxor ] reduce-outputs ; inline
: s1-256 ( x -- x' )
- [ -17 bitroll-32 ] keep
- [ -19 bitroll-32 ] keep
- -10 shift bitxor bitxor ; inline
-
-: process-M-256 ( seq n -- )
- [ 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 ;
+ [
+ [ -17 bitroll-32 ]
+ [ -19 bitroll-32 ]
+ [ -10 shift ] tri
+ ] [ bitxor ] reduce-outputs ; inline
+
+: S0-256 ( x -- x' )
+ [
+ [ -2 bitroll-32 ]
+ [ -13 bitroll-32 ]
+ [ -22 bitroll-32 ] tri
+ ] [ bitxor ] reduce-outputs ; inline
+
+: S1-256 ( x -- x' )
+ [
+ [ -6 bitroll-32 ]
+ [ -11 bitroll-32 ]
+ [ -25 bitroll-32 ] tri
+ ] [ bitxor ] reduce-outputs ; inline
+
+: s0-512 ( x -- x' )
+ [
+ [ -1 bitroll-64 ]
+ [ -8 bitroll-64 ]
+ [ -7 shift ] tri
+ ] [ bitxor ] reduce-outputs ; inline
+
+: s1-512 ( x -- x' )
+ [
+ [ -19 bitroll-64 ]
+ [ -61 bitroll-64 ]
+ [ -6 shift ] tri
+ ] [ bitxor ] reduce-outputs ; inline
+
+: S0-512 ( x -- x' )
+ [
+ [ -28 bitroll-64 ]
+ [ -34 bitroll-64 ]
+ [ -39 bitroll-64 ] tri
+ ] [ bitxor ] reduce-outputs ; inline
+
+: S1-512 ( x -- x' )
+ [
+ [ -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 ;
+ [ bitxor bitand ] keep bitxor ; inline
: maj ( x y z -- x' )
- [ [ bitand ] 2keep bitor ] dip bitand bitor ;
+ [ [ bitand ] [ bitor ] 2bi ] dip bitand bitor ; inline
-: S0-256 ( x -- x' )
- [ -2 bitroll-32 ] keep
- [ -13 bitroll-32 ] keep
- -22 bitroll-32 bitxor bitxor ; inline
+: slice3 ( n seq -- a b c )
+ [ dup 3 + ] dip <slice> first3 ; inline
-: S1-256 ( x -- x' )
- [ -6 bitroll-32 ] keep
- [ -11 bitroll-32 ] keep
- -25 bitroll-32 bitxor bitxor ; inline
+GENERIC: pad-initial-bytes ( string sha2 -- padded-string )
-: slice3 ( n seq -- a b c ) [ dup 3 + ] dip <slice> first3 ; inline
+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 ;
-: T1 ( W n -- T1 )
- [ swap nth ] keep
- K get nth +
- e vars get slice3 ch +
- e vars get nth S1-256 +
- h vars get nth w+ ;
+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 ( -- T2 )
- a vars get nth S0-256
- a vars get slice3 maj w+ ;
+: T2-256 ( H -- T2 )
+ [ a swap nth S0-256 ]
+ [ a swap slice3 maj w+ ] bi ; inline
-: update-vars ( T1 T2 -- )
- vars get
+:: 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
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 -- )
- H get clone vars set
- prepare-message-schedule block-size get [
- T1 T2 update-vars
- ] with each vars get H get [ w+ ] 2map H set ;
+: prepare-message-schedule ( seq sha2 -- w-seq )
+ [ word-size>> <sliced-groups> [ be> ] map ]
+ [
+ block-size>> [ 0 pad-tail 16 ] keep [a,b) over
+ '[ _ process-M-256 ] each
+ ] bi ; inline
-: seq>byte-array ( n seq -- string )
- [ swap [ >be % ] curry each ] B{ } make ;
+:: process-chunk ( M block-size cloned-H sha2 -- )
+ 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 )
- #! pad 0x80 then 00 til 8 bytes left, then 64bit length in bits
- [ >sbuf ] dip over [
- HEX: 80 ,
- dup length HEX: 3f bitand
- calculate-pad-length 0 <string> %
- length 3 shift 8 rot [ >be ] [ >le ] if %
- ] "" make over push-all ;
+: sha2-steps ( sliced-groups state -- )
+ '[
+ _
+ [ prepare-message-schedule ]
+ [ [ block-size>> ] [ H>> clone ] [ ] tri process-chunk ] bi
+ ] each ;
-: byte-array>sha2 ( byte-array -- string )
- t preprocess-plaintext
- block-size get group [ process-chunk ] each
- 4 H get seq>byte-array ;
+: byte-array>sha2 ( bytes state -- )
+ [ [ pad-initial-bytes ] [ nip block-size>> ] 2bi <sliced-groups> ]
+ [ sha2-steps ] bi ;
-PRIVATE>
+: <sha-224-state> ( -- sha2-state )
+ sha-224-state new
+ K-256 >>K
+ initial-H-224 >>H
+ 4 >>word-size
+ 64 >>block-size ;
-SINGLETON: sha-256
+: <sha-256-state> ( -- sha2-state )
+ sha-256-state new
+ K-256 >>K
+ initial-H-256 >>H
+ 4 >>word-size
+ 64 >>block-size ;
-INSTANCE: sha-256 checksum
+PRIVATE>
+
+M: sha-224 checksum-bytes
+ drop <sha-224-state>
+ [ byte-array>sha2 ]
+ [ H>> 7 head 4 seq>byte-array ] bi ;
M: sha-256 checksum-bytes
- drop [
- K-256 K set
- initial-H-256 H set
- 4 word-size set
- 64 block-size set
- byte-array>sha2
- ] with-scope ;
+ drop <sha-256-state>
+ [ byte-array>sha2 ]
+ [ H>> 4 seq>byte-array ] bi ;
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
*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>) ] }
{ NSArray [ (plist-NSArray>) ] }
{ NSDictionary [ (plist-NSDictionary>) ] }
{ NSObject [ ] }
+ [ invalid-plist-object ]
} objc-class-case ;
: read-plist ( path -- assoc )
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 )
TYPEDEF: uint CGBitmapInfo
TYPEDEF: int CGLError
+TYPEDEF: int CGError
+TYPEDEF: uint CGDirectDisplayID
+TYPEDEF: int boolean_t
TYPEDEF: void* CGLContextObj
-TYPEDEF: int CGLContextParameter
\ No newline at end of file
+TYPEDEF: int CGLContextParameter
"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* }
"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." }
[ 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
[
[
[ empty-dlist ] unless*
- [ f ] change-next drop
+ next>>
f over set-prev-when
] change-front drop
] keep
[
[
[ empty-dlist ] unless*
- [ f ] change-prev drop
+ prev>>
f over set-next-when
] change-back drop
] keep
: 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 ;
: 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 ;
: >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
-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
-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
[ 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
[ { 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
-! 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
-namespaces sequences sorting fry ;
+USING: accessors assocs binary-search fry kernel locals math math.order
+ math.ranges mirrors namespaces sequences sorting ;
IN: math.combinatorics
<PRIVATE
: twiddle ( n k -- n k )
2dup - dupd > [ dupd - ] when ; inline
-! See this article for explanation of the factoradic-based permutation methodology:
-! http://msdn2.microsoft.com/en-us/library/aa302371.aspx
+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 / ;
+
+
+! 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 ;
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
+
+++ /dev/null
-Doug Coleman
+++ /dev/null
-! 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"
+++ /dev/null
-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
+++ /dev/null
-! 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 ;
+++ /dev/null
-Miller-Rabin probabilistic primality test
{ $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
! 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
: pdiff ( p -- p' )
dup length v* { 0 } ?head drop ;
-: polyval ( p x -- p[x] )
- [ dup length ] dip powers v. ;
+: polyval ( x p -- p[x] )
+ [ length swap powers ] [ nip ] 2bi v. ;
+
+MACRO: polyval* ( p -- )
+ reverse
+ [ 1 tail [ \ * swap \ + [ ] 3sequence ] map ]
+ [ first \ drop swap [ ] 2sequence ] bi
+ prefix \ cleave [ ] 2sequence ;
! 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
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! 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"
--- /dev/null
+! 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
--- /dev/null
+! 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 ;
--- /dev/null
+Doug Coleman
--- /dev/null
+! 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"
--- /dev/null
+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
--- /dev/null
+! 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* ;
--- /dev/null
+Miller-Rabin probabilistic primality test
-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?
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"
-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
{ { 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
! Copyright (C) 2007-2009 Samuel Tardieu.
! See http://factorcode.org/license.txt for BSD license.
-USING: combinators kernel math math.functions math.miller-rabin
-math.order math.primes.erato math.ranges sequences ;
+USING: combinators kernel math math.bitwise math.functions
+math.order math.primes.erato math.primes.miller-rabin
+math.ranges random sequences sets fry ;
IN: math.primes
<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
: 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 ;
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! 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"
--- /dev/null
+! 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
--- /dev/null
+! 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 ;
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+! 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 ;
! 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 } } ;
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
: 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
[ [ loc>> ] dip (>>loc) ]
[ [ dim>> ] dip (>>dim) ]
2bi ; inline
+
+USING: vocabs vocabs.loader ;
+
+"prettyprint" vocab [ "math.rectangles.prettyprint" require ] when
\ No newline at end of file
[ { 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
: 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 ;
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 } ;
100 [ 100 random ] replicate ;
: test-rng ( seed quot -- )
- [ <mersenne-twister> ] dip with-random ; inline
+ [ <mersenne-twister> ] dip with-random ; inline
[ f ] [ 1234 [ randoms randoms = ] test-rng ] unit-test
} ;
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." } ;
"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"
[ f ]
[ 100 [ { 0 1 } random ] replicate all-equal? ] unit-test
+
+[ 49 ] [ 50 random-bits* log2 ] unit-test
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 ] [
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
[ 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
'[ select-gl-context @ ]
[ flush-gl-context gl-error ] bi ; inline
-HOOK: (with-ui) ui-backend ( quot -- )
\ No newline at end of file
+HOOK: (with-ui) ui-backend ( quot -- )
+
+HOOK: (grab-input) ui-backend ( handle -- )
+
+HOOK: (ungrab-input) ui-backend ( handle -- )
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>> [
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
"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
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
-prettyprint.backend prettyprint.custom ;
+concurrency.flags math.order math.rectangles fry locals ;
IN: ui.gadgets
! Values for orientation slot
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>> ;
: focus-path ( gadget -- seq )
[ focus>> ] follow ;
+
+USING: vocabs vocabs.loader ;
+
+"prettyprint" vocab [ "ui.gadgets.prettyprint" require ] when
\ No newline at end of file
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+! 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 ;
\ No newline at end of file
{ 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
TUPLE: world-attributes
{ world-class initial: world }
+ grab-input?
title
status
gadgets
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 ;
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?
- dup raised-window
- focus-path f focus-gestures ;
+ [ ?grab-input ] [
+ dup raised-window
+ 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 -- )
{
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
! FUNCTION: SetWindowWord
! FUNCTION: SetWinEventHook
! FUNCTION: ShowCaret
-! FUNCTION: ShowCursor
+FUNCTION: int ShowCursor ( BOOL show ) ;
! FUNCTION: ShowOwnedPopups
! FUNCTION: ShowScrollBar
! FUNCTION: ShowStartGlass
: 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 = [
{ $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 } "." }
{ $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 } }
[ 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
UNION: number real complex ;
+: 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?
+ drop f ;
+M: object fp-snan?
+ drop f ;
+M: object fp-infinity?
+ drop f ;
+M: object fp-nan-payload
+ drop f ;
+
+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?
- double>bits -51 shift HEX: fff [ bitand ] keep = ;
+ dup fp-special? [ fp-nan-payload zero? not ] [ drop f ] if ;
-GENERIC: fp-infinity? ( x -- ? )
+M: float fp-qnan?
+ dup fp-nan? [ fp-nan-payload HEX: 8000000000000 bitand zero? not ] [ drop f ] if ;
-M: object fp-infinity?
- drop f ;
+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
-M: float fp-infinity? ( float -- ? )
+: next-float ( m -- n )
double>bits
- dup -52 shift HEX: 7ff [ bitand ] keep = [
- HEX: fffffffffffff bitand 0 =
- ] [
- drop f
- ] if ;
+ dup -0.0 double>bits > [ 1 - bits>double ] [ ! negative non-zero
+ dup -0.0 double>bits = [ drop 0.0 ] [ ! negative zero
+ 1 + bits>double ! positive
+ ] 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
: >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 )
: init-hmac ( K -- o i )
64 0 pad-tail
- [ opad seq-bitxor ] keep
- ipad seq-bitxor ;
+ [ opad seq-bitxor ]
+ [ ipad seq-bitxor ] bi ;
PRIVATE>
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: math.miller-rabin kernel math math.functions namespaces
-sequences accessors ;
+USING: math.primes.miller-rabin kernel math math.functions
+namespaces sequences accessors ;
IN: crypto.rsa
! The private key is the only secret.
{ $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" } }
-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
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 )
[ 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 ] }
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 )
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
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 1 IOHIDDeviceConformsTo ]
- [ 1 2 IOHIDDeviceConformsTo ]
- } 1|| ;
+ 1 2 IOHIDDeviceConformsTo ;
: controller-device? ( device -- ? )
{
[ IOHIDElementGetUsagePage ] [ IOHIDElementGetUsage ] bi
2array ;
-: button? ( {usage-page,usage} -- ? )
- first 9 = ; inline
-: keyboard-key? ( {usage-page,usage} -- ? )
- first 7 = ; inline
+: button? ( element -- ? )
+ IOHIDElementGetUsagePage 9 = ; inline
+: keyboard-key? ( element -- ? )
+ 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
{
: pov-value ( value -- pov-direction )
IOHIDValueGetIntegerValue pov-values ?nth [ pov-neutral ] unless* ;
-: record-button ( hid-value usage state -- )
- [ button-value ] [ second 1- ] [ buttons>> ] tri* set-nth ;
+: record-button ( state hid-value element -- )
+ [ buttons>> ] [ button-value ] [ IOHIDElementGetUsage 1- ] tri* rot set-nth ;
: record-controller ( controller-state value -- )
- dup IOHIDValueGetElement element-usage {
- { [ dup button? ] [ rot record-button ] }
- { [ dup x-axis? ] [ drop axis-value >>x drop ] }
- { [ dup y-axis? ] [ drop axis-value >>y drop ] }
- { [ dup z-axis? ] [ drop axis-value >>z drop ] }
- { [ dup rx-axis? ] [ drop axis-value >>rx drop ] }
- { [ dup ry-axis? ] [ drop axis-value >>ry drop ] }
- { [ dup rz-axis? ] [ drop axis-value >>rz drop ] }
- { [ dup slider? ] [ drop axis-value >>slider drop ] }
- { [ dup hat-switch? ] [ drop pov-value >>pov drop ] }
+ dup IOHIDValueGetElement {
+ { [ 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 ] }
+ { [ dup rx-axis? ] [ drop axis-value >>rx drop ] }
+ { [ dup ry-axis? ] [ drop axis-value >>ry drop ] }
+ { [ dup rz-axis? ] [ drop axis-value >>rz drop ] }
+ { [ 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 -- )
- dup IOHIDValueGetElement element-usage keyboard-key? [
+: record-keyboard ( keyboard-state value -- )
+ dup IOHIDValueGetElement dup keyboard-key? [
[ IOHIDValueGetIntegerValue c-bool> ]
- [ IOHIDValueGetElement IOHIDElementGetUsage ] bi
- +keyboard-state+ get ?set-nth
- ] [ drop ] if ;
-
-: record-mouse ( value -- )
- dup IOHIDValueGetElement element-usage {
- { [ dup button? ] [ +mouse-state+ get record-button ] }
- { [ dup x-axis? ] [ drop mouse-axis-value +mouse-state+ get [ + ] change-dx drop ] }
- { [ dup y-axis? ] [ drop mouse-axis-value +mouse-state+ get [ + ] change-dy drop ] }
- { [ dup wheel? ] [ drop mouse-axis-value +mouse-state+ get [ + ] change-scroll-dx drop ] }
- { [ dup z-axis? ] [ drop mouse-axis-value +mouse-state+ get [ + ] change-scroll-dy drop ] }
- [ 2drop ]
+ [ IOHIDElementGetUsage ] bi*
+ rot ?set-nth
+ ] [ 3drop ] if ;
+
+HINTS: record-keyboard { array alien } ;
+
+: record-mouse ( mouse-state value -- )
+ dup IOHIDValueGetElement {
+ { [ dup button? ] [ record-button ] }
+ { [ dup axis? ] [ {
+ { [ dup x-axis? ] [ drop mouse-axis-value [ + ] curry change-dx drop ] }
+ { [ 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 ;
{ [ sender controller-device? ] [
sender +controller-states+ get at value record-controller
] }
- { [ sender mouse-device? ] [ value record-mouse ] }
- [ value record-keyboard ]
+ { [ sender mouse-device? ] [ +mouse-state+ get value record-mouse ] }
+ [ +keyboard-state+ get value record-keyboard ]
} cond
] IOHIDValueCallback ;
} 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)
f
] change-global
f +keyboard-state+ set-global
+ f +mouse-state+ set-global
f +controller-states+ set-global
] when ;
--- /dev/null
+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 ;
+
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 ;
benchmark-error-vocabs-file
benchmark-error-messages-file
error-dump
-
- "Benchmark timings"
+
benchmarks-file eval-file benchmarks-table
] output>array
] with-report ;
[ 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 )
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) ( x y z -- x' y' z' )
+ [ { 0.0 0.0 0.0 10.0 -15.0 6.0 } polyval* ] tri@ ;
+
+HINTS: (fade) { float float float } ;
+
: fade ( point -- point' )
- { 0.0 0.0 0.0 10.0 -15.0 6.0 } swap [ polyval ] with map ;
+ first3 (fade) 3array ; inline
-:: grad ( hash gradients -- gradient )
- hash 8 bitand zero? [ gradients first ] [ gradients second ] if
+:: grad ( hash x y z -- gradient )
+ hash 8 bitand zero? [ x ] [ y ] if
:> u
hash 12 bitand zero?
- [ gradients second ]
- [ hash 13 bitand 12 = [ gradients first ] [ gradients third ] if ] if
+ [ y ] [ hash 13 bitand 12 = [ x ] [ z ] 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 ;
-
-:: hashes ( table cube -- aaa baa aba bba aab bab abb bbb )
- cube first :> x
- cube second :> y
- cube third :> z
- x table nth y + :> a
- x 1 + table nth y + :> b
-
- a table nth z + :> aa
- b table nth z + :> ba
- a 1 + table nth z + :> ab
- b 1 + table nth z + :> bb
-
- aa table nth
- ba table nth
- ab table nth
- bb table nth
- aa 1 + table nth
- ba 1 + table nth
- ab 1 + table nth
- bb 1 + table nth ;
-
-:: 2tetra@ ( p q r s t u v w quot -- )
- p q quot call
- r s quot call
- t u quot call
- v w quot call
- ; inline
+ [ floor >fixnum 256 rem ] map ;
+
+:: hashes ( table x y z -- aaa baa aba bba aab bab abb bbb )
+ x table nth-unsafe y fixnum+fast :> a
+ x 1 fixnum+fast table nth-unsafe y fixnum+fast :> b
+
+ a table nth-unsafe z fixnum+fast :> aa
+ b table nth-unsafe z fixnum+fast :> ba
+ a 1 fixnum+fast table nth-unsafe z fixnum+fast :> ab
+ b 1 fixnum+fast table nth-unsafe z fixnum+fast :> bb
+
+ aa table nth-unsafe
+ ba table nth-unsafe
+ ab table nth-unsafe
+ bb table nth-unsafe
+ aa 1 fixnum+fast table nth-unsafe
+ ba 1 fixnum+fast table nth-unsafe
+ ab 1 fixnum+fast table nth-unsafe
+ bb 1 fixnum+fast table nth-unsafe ; inline
+
+HINTS: hashes { byte-array fixnum fixnum fixnum } ;
: >byte-map ( floats -- bytes )
[ 255.0 * >fixnum ] B{ } map-as ;
: >image ( bytes dim -- image )
swap [ L f ] dip image boa ;
-PRIVATE>
-
-:: perlin-noise ( table point -- value )
+:: perlin-noise-unsafe ( table point -- value )
point unit-cube :> cube
point dup vfloor v- :> gradients
gradients fade :> faded
- table cube hashes {
- [ gradients grad ]
- [ gradients { -1.0 0.0 0.0 } v+ grad ]
- [ gradients { 0.0 -1.0 0.0 } v+ grad ]
- [ gradients { -1.0 -1.0 0.0 } v+ grad ]
- [ gradients { 0.0 0.0 -1.0 } v+ grad ]
- [ gradients { -1.0 0.0 -1.0 } v+ grad ]
- [ gradients { 0.0 -1.0 -1.0 } v+ grad ]
- [ gradients { -1.0 -1.0 -1.0 } v+ grad ]
+ table cube first3 hashes {
+ [ gradients first3 grad ]
+ [ gradients first3 [ 1.0 - ] [ ] [ ] tri* grad ]
+ [ gradients first3 [ ] [ 1.0 - ] [ ] tri* grad ]
+ [ gradients first3 [ 1.0 - ] [ 1.0 - ] [ ] tri* grad ]
+ [ gradients first3 [ ] [ ] [ 1.0 - ] tri* grad ]
+ [ gradients first3 [ 1.0 - ] [ ] [ 1.0 - ] tri* grad ]
+ [ gradients first3 [ ] [ 1.0 - ] [ 1.0 - ] tri* grad ]
+ [ gradients first3 [ 1.0 - ] [ 1.0 - ] [ 1.0 - ] tri* grad ]
} spread
- [ faded first lerp ] 2tetra@
- [ faded second lerp ] 2bi@
- faded third lerp ;
+ faded trilerp ;
+
+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
[ 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 ;
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 ;"
}
{ $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 ;"
} ;
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." } ;
-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
[ 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
-! Copyright (c) 2009 Aaron Schaefer.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors ascii binary-search combinators kernel locals math
- math.bitwise math.order poker.arrays sequences splitting ;
+! Copyright (c) 2009 Aaron Schaefer. All rights reserved.
+! The contents of this file are licensed under the Simplified BSD License
+! A copy of the license is available at http://factorcode.org/license.txt
+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
CONSTANT: KING 11
CONSTANT: ACE 12
-CONSTANT: STRAIGHT_FLUSH 1
-CONSTANT: FOUR_OF_A_KIND 2
-CONSTANT: FULL_HOUSE 3
-CONSTANT: FLUSH 4
-CONSTANT: STRAIGHT 5
-CONSTANT: THREE_OF_A_KIND 6
-CONSTANT: TWO_PAIR 7
-CONSTANT: ONE_PAIR 8
-CONSTANT: HIGH_CARD 9
+CONSTANT: STRAIGHT_FLUSH 0
+CONSTANT: FOUR_OF_A_KIND 1
+CONSTANT: FULL_HOUSE 2
+CONSTANT: FLUSH 3
+CONSTANT: STRAIGHT 4
+CONSTANT: THREE_OF_A_KIND 5
+CONSTANT: TWO_PAIR 6
+CONSTANT: ONE_PAIR 7
+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 )
#! Cactus Kev Format
>upper 1 cut (>ckf) ;
+: parse-cards ( str -- seq )
+ " " split [ >ckf ] map ;
+
: flush? ( cards -- ? )
HEX: F000 [ bitand ] reduce 0 = not ;
[ drop "S" ]
} cond ;
-: hand-rank ( hand -- rank )
- value>> {
+: hand-rank ( value -- rank )
+ {
{ [ dup 6185 > ] [ drop HIGH_CARD ] } ! 1277 high card
{ [ dup 3325 > ] [ drop ONE_PAIR ] } ! 2860 one pair
{ [ dup 2467 > ] [ drop TWO_PAIR ] } ! 858 two pair
[ 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
- dup hand-value hand boa ;
+ parse-cards 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>> [
- [ >card-rank ] [ >card-suit ] bi append
- ] map " " join ;
+ cards>> [ card>string ] 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 ;
+
-5-card poker hand evaluator
+Poker hand evaluator
-! 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 ;
: 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)
-! 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
! --------
: 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)
! 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
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>
! 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
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math math.primes project-euler.common sequences
-project-euler.common ;
+USING: kernel math math.primes math.ranges project-euler.common sequences ;
IN: project-euler.027
! http://projecteuler.net/index.php?section=problems&id=27
<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 )
! 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
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)
: source-032 ( -- seq )
9 factorial iota [
- 9 permutation [ 1+ ] map 10 digits>integer
+ 9 permutation [ 1 + ] map 10 digits>integer
] map ;
: 1and4 ( n -- ? )
! 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
! 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
! --------
: 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
! 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
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)
! 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
! It is possible to show that the square root of two can be expressed
! as an infinite continued fraction.
-! √ 2 = 1 + 1/(2 + 1/(2 + 1/(2 + ... ))) = 1.414213...
+! √ 2 = 1 + 1/(2 + 1/(2 + 1/(2 + ... ))) = 1.414213...
! By expanding this for the first four iterations, we get:
-! 1 + 1/2 = 3/2 = 1.5
-! 1 + 1/(2 + 1/2) = 7/5 = 1.4
-! 1 + 1/(2 + 1/(2 + 1/2)) = 17/12 = 1.41666...
-! 1 + 1/(2 + 1/(2 + 1/(2 + 1/2))) = 41/29 = 1.41379...
+! 1 + 1/2 = 3/2 = 1.5
+! 1 + 1/(2 + 1/2) = 7/5 = 1.4
+! 1 + 1/(2 + 1/(2 + 1/2)) = 17/12 = 1.41666...
+! 1 + 1/(2 + 1/(2 + 1/(2 + 1/2))) = 41/29 = 1.41379...
! The next three expansions are 99/70, 239/169, and 577/408, but the
! eighth expansion, 1393/985, is the first example where the number of
>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
-! 3.375118 seconds
+! [ euler057 ] 100 ave-time
+! 1728 ms ave run time - 80.81 SD (100 trials)
SOLUTION: euler057
! 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
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 -
! 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 ;
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
: 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
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()
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()
-USING: accessors arrays combinators game-input
-game-input.scancodes game-loop kernel literals locals math
-math.constants math.functions math.matrices math.order
+USING: accessors arrays combinators game-input game-loop
+game-input.scancodes grouping kernel literals locals
+math math.constants math.functions math.matrices math.order
math.vectors opengl opengl.capabilities opengl.gl
opengl.shaders opengl.textures opengl.textures.private
sequences sequences.product specialized-arrays.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: EYE-START { 0.5 0.5 1.2 }
-CONSTANT: TICK-LENGTH $[ 1000 30 /i ]
+CONSTANT: FAR-PLANE 2.0
+CONSTANT: PLAYER-START-LOCATION { 0.5 0.51 0.5 }
+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
- eye yaw pitch
+TUPLE: player
+ 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
- game-loop ;
+ terrain-vertex-buffer ;
+
+M: terrain-world tick-length
+ drop 1000 30 /i ;
: frustum ( dim -- -x x -y y near far )
dup first2 min v/n
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 * ]
p cos :> cosp
p sin :> sinp
- cosy 0.0 siny neg 3array
- siny sinp * cosp cosy sinp * 3array
- siny cosp * sinp neg cosy cosp * 3array 3array
+ cosy 0.0 siny neg 3array
+ siny sinp * cosp cosy sinp * 3array
+ siny cosp * sinp neg cosy cosp * 3array 3array
v swap v.m ;
-: forward-vector ( world -- v )
- [ yaw>> ] [ pitch>> ] bi
+: forward-vector ( player -- v )
+ yaw>> 0.0
{ 0.0 0.0 $ MOVEMENT-SPEED } vneg eye-rotate ;
-: rightward-vector ( world -- v )
- [ yaw>> ] [ pitch>> ] bi
+: rightward-vector ( player -- v )
+ yaw>> 0.0
{ $ MOVEMENT-SPEED 0.0 0.0 } eye-rotate ;
-: move-forward ( world -- )
- dup forward-vector [ v+ ] curry change-eye drop ;
-: move-backward ( world -- )
- dup forward-vector [ v- ] curry change-eye drop ;
-: move-leftward ( world -- )
- dup rightward-vector [ v- ] curry change-eye drop ;
-: move-rightward ( world -- )
- dup rightward-vector [ v+ ] curry change-eye drop ;
+: walk-forward ( player -- )
+ dup forward-vector [ v+ ] curry change-velocity drop ;
+: walk-backward ( player -- )
+ dup forward-vector [ v- ] curry change-velocity drop ;
+: walk-leftward ( player -- )
+ dup rightward-vector [ v- ] curry change-velocity drop ;
+: walk-rightward ( player -- )
+ 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-s keys nth [ world move-backward ] when
- key-a keys nth [ world move-leftward ] when
- key-d keys nth [ world move-rightward ] when
- world read-mouse rotate-with-mouse
+ key-w keys nth [ player walk-forward ] when
+ key-s keys nth [ player walk-backward ] when
+ key-a keys nth [ player walk-leftward ] when
+ key-d keys nth [ player walk-rightward ] when
+ 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*
- [ handle-input ] keep
- ! [ eye>> ] [ yaw>> ] [ pitch>> ] tri 3array P ! debug
+: apply-friction ( velocity -- velocity' )
+ FRICTION v*n ;
+
+: 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*
- nip draw-world ;
+M: terrain-world tick*
+ [ 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_T GL_CLAMP glTexParameteri ;
+ GL_TEXTURE_2D GL_TEXTURE_WRAP_S GL_CLAMP_TO_EDGE 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
- EYE-START >>eye
- 0.0 >>yaw
- 0.0 >>pitch
+ PLAYER-START-LOCATION 0.0 0.0 { 0.0 0.0 0.0 } player boa >>player
+ <perlin-noise-table> 0.01 0.01 <scale> { 512 512 } perlin-noise-image
+ [ >>sky-image ] keep
+ 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
[ frustum glFrustum ] bi ;
M: terrain-world draw-world*
- [ set-modelview-matrix ]
- [ terrain-texture>> GL_TEXTURE_2D GL_TEXTURE0 bind-texture-unit ]
- [ dup terrain-program>> [
- "heightmap" glGetUniformLocation 0 glUniform1i
- terrain-vertex-buffer>> draw-vertex-buffer
- ] with-gl-program ]
- tri gl-error ;
-
-M: terrain-world focusable-child* drop t ;
+ {
+ [ set-modelview-matrix ]
+ [ terrain-texture>> GL_TEXTURE_2D GL_TEXTURE0 bind-texture-unit ]
+ [ sky-texture>> GL_TEXTURE_2D GL_TEXTURE1 bind-texture-unit ]
+ [ 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 ]
+ } cleave gl-error ;
+
M: terrain-world pref-dim* drop { 640 480 } ;
: terrain-window ( -- )
[
- open-game-input
f T{ world-attributes
{ world-class terrain-world }
{ title "Terrain" }
double-buffered
T{ depth-bits { value 24 } }
} }
+ { grab-input? t }
} open-window
] with-ui ;
+
+MAIN: terrain-window
void iterate_callstack_object(callstack *stack, CALLSTACK_ITER iterator)
{
- cell top = (cell)FIRST_STACK_FRAME(stack);
- cell bottom = top + untag_fixnum(stack->length);
-
- iterate_callstack(top,bottom,iterator);
+ iterate_callstack((cell)stack->top(),(cell)stack->bottom(),iterator);
}
callstack *allot_callstack(cell size)
size = 0;
callstack *stack = allot_callstack(size);
- memcpy(FIRST_STACK_FRAME(stack),top,size);
+ memcpy(stack->top(),top,size);
dpush(tag<callstack>(stack));
}
callstack *stack = untag_check<callstack>(dpop());
set_callstack(stack_chain->callstack_bottom,
- FIRST_STACK_FRAME(stack),
+ stack->top(),
untag_fixnum(stack->length),
memcpy);
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);
- cell bottom = (cell)top + untag_fixnum(callstack->length);
-
- stack_frame *frame = (stack_frame *)bottom - 1;
+ stack_frame *top = stack->top();
+ stack_frame *bottom = stack->bottom();
+ stack_frame *frame = bottom - 1;
while(frame >= top && frame_successor(frame) >= top)
frame = frame_successor(frame);
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);
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);
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)];
{
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));
}
}
}
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);
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);
}
}
tagged<byte_array>(compiled->relocation).untag_check();
#endif
- store_address_in_code_block(REL_CLASS(rel),
- REL_OFFSET(rel) + (cell)compiled->xt(),
+ store_address_in_code_block(relocation_class_of(rel),
+ 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);
}
/* 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;
/* 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);
/* compiled header */
compiled->type = type;
- compiled->last_scan = NURSERY;
+ compiled->last_scan = data->nursery();
compiled->needs_fixup = true;
compiled->relocation = relocation.value();
/* 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;
}
RC_INDIRECT_ARM_PC
};
-#define REL_ABSOLUTE_PPC_2_MASK 0xffff
-#define REL_RELATIVE_PPC_2_MASK 0xfffc
-#define REL_RELATIVE_PPC_3_MASK 0x3fffffc
-#define REL_INDIRECT_ARM_MASK 0xfff
-#define REL_RELATIVE_ARM_3_MASK 0xffffff
+static const cell rel_absolute_ppc_2_mask = 0xffff;
+static const cell rel_relative_ppc_2_mask = 0xfffc;
+static const cell rel_relative_ppc_3_mask = 0x3fffffc;
+static const cell rel_indirect_arm_mask = 0xfff;
+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);
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;
}
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);
{
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)
{
/* 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)
namespace factor
{
-#define FREE_LIST_COUNT 16
-#define BLOCK_SIZE_INCREMENT 32
+static const cell free_list_count = 16;
+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;
};
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(rs + sizeof(cell) < rs_bot || rs + RESERVED >= rs_top) reset_retainstack();
+ if(ds + sizeof(cell) < ds_bot || ds + stack_reserved >= ds_top) reset_datastack();
+ 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
#endif
}
-#define B_MASK 0x3fffffc
+static const cell b_mask = 0x3fffffc;
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);
}
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 */
bool performing_compaction;
cell collecting_gen;
-/* if true, we collecting AGING space for the second time, so if it is still
-full, we go on to collect TENURED */
+/* if true, we collecting aging space for the second time, so if it is still
+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;
void init_data_gc()
{
performing_gc = false;
- last_code_heap_scan = NURSERY;
+ last_code_heap_scan = data->nursery();
collecting_aging_again = false;
}
{
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)
- return !in_zone(&data->generations[TENURED],untagged);
- else if(collecting_gen == NURSERY)
+ else if(data->have_aging_p() && collecting_gen == data->aging())
+ return !in_zone(&data->generations[data->tenured()],untagged);
+ else if(collecting_gen == data->nursery())
return in_zone(&nursery,untagged);
else
{
/* 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)
- unmask = CARD_POINTS_TO_NURSERY;
+ if(gen == data->tenured())
+ unmask = card_points_to_nursery;
/* after the collection, all cards in aging space can be
cleared */
- else if(HAVE_AGING_P && gen == AGING)
- unmask = CARD_MARK_MASK;
+ else if(data->have_aging_p() && gen == data->aging())
+ unmask = card_mark_mask;
else
{
critical_error("bug in copy_gen_cards",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;
- unmask = CARD_MARK_MASK;
+ mask = card_points_to_aging;
+ 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;
- unmask = CARD_POINTS_TO_NURSERY;
+ mask = card_points_to_aging;
+ unmask = card_points_to_nursery;
}
}
else
{
obj++;
- cell tenured_start = data->generations[TENURED].start;
- cell tenured_end = data->generations[TENURED].end;
+ cell tenured_start = data->generations[data->tenured()].start;
+ cell tenured_end = data->generations[data->tenured()].end;
cell newspace_start = newspace->start;
cell newspace_end = newspace->end;
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);
{
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())
{
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)
- reset_generations(NURSERY,collecting_gen - 1);
+ if(collecting_gen != data->nursery())
+ reset_generations(data->nursery(),collecting_gen - 1);
}
- else if(collecting_gen == NURSERY)
+ else if(collecting_gen == data->nursery())
{
nursery.here = nursery.start;
}
{
/* 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;
{
/* 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
- collect TENURED */
- else if(HAVE_AGING_P
- && collecting_gen == AGING
+ /* we try collecting aging space twice before going on to
+ collect tenured */
+ else if(data->have_aging_p()
+ && collecting_gen == data->aging()
&& !collecting_aging_again)
{
collecting_aging_again = true;
{
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();
void gc()
{
- garbage_collection(TENURED,false,0);
+ garbage_collection(data->tenured(),false,0);
}
PRIMITIVE(gc)
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));
void clear_gc_stats()
{
- int i;
- for(i = 0; i < MAX_GEN_COUNT; i++)
+ for(cell i = 0; i < max_gen_count; i++)
memset(&stats[i],0,sizeof(gc_stats));
cards_scanned = 0;
VM_C_API void minor_gc()
{
- garbage_collection(NURSERY,false,0);
+ garbage_collection(data->nursery(),false,0);
}
}
inline static bool collecting_accumulation_gen_p()
{
- return ((HAVE_AGING_P
- && collecting_gen == AGING
+ return ((data->have_aging_p()
+ && collecting_gen == data->aging()
&& !collecting_aging_again)
- || collecting_gen == TENURED);
+ || collecting_gen == data->tenured());
}
void copy_handle(cell *handle);
/* 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)
{
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)
- garbage_collection(NURSERY,false,0);
+ if(nursery.here + allot_buffer_zone + size > nursery.end)
+ garbage_collection(data->nursery(),false,0);
cell h = nursery.here;
nursery.here = h + align8(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);
- tenured = &data->generations[TENURED];
+ garbage_collection(data->tenured(),true,size);
+ tenured = &data->generations[data->tenured()];
}
obj = allot_zone(tenured,size);
void init_card_decks()
{
- cell start = align(data->seg->start,DECK_SIZE);
- allot_markers_offset = (cell)data->allot_markers - (start >> CARD_BITS);
- cards_offset = (cell)data->cards - (start >> CARD_BITS);
- decks_offset = (cell)data->decks - (start >> DECK_BITS);
+ cell start = align(data->seg->start,deck_size);
+ allot_markers_offset = (cell)data->allot_markers - (start >> card_bits);
+ cards_offset = (cell)data->cards - (start >> card_bits);
+ decks_offset = (cell)data->decks - (start >> deck_bits);
}
data_heap *alloc_data_heap(cell gens,
cell aging_size,
cell tenured_size)
{
- young_size = align(young_size,DECK_SIZE);
- aging_size = align(aging_size,DECK_SIZE);
- tenured_size = align(tenured_size,DECK_SIZE);
+ young_size = align(young_size,deck_size);
+ aging_size = align(aging_size,deck_size);
+ tenured_size = align(tenured_size,deck_size);
data_heap *data = (data_heap *)safe_malloc(sizeof(data_heap));
data->young_size = young_size;
return NULL; /* can't happen */
}
- total_size += DECK_SIZE;
+ total_size += deck_size;
data->seg = alloc_segment(total_size);
data->generations = (zone *)safe_malloc(sizeof(zone) * data->gen_count);
data->semispaces = (zone *)safe_malloc(sizeof(zone) * data->gen_count);
- cell cards_size = total_size >> CARD_BITS;
+ cell cards_size = total_size >> card_bits;
data->allot_markers = (cell *)safe_malloc(cards_size);
data->allot_markers_end = data->allot_markers + cards_size;
data->cards = (cell *)safe_malloc(cards_size);
data->cards_end = data->cards + cards_size;
- cell decks_size = total_size >> DECK_BITS;
+ cell decks_size = total_size >> deck_bits;
data->decks = (cell *)safe_malloc(decks_size);
data->decks_end = data->decks + decks_size;
- cell alloter = align(data->seg->start,DECK_SIZE);
+ cell alloter = align(data->seg->start,deck_size);
- alloter = init_zone(&data->generations[TENURED],tenured_size,alloter);
- alloter = init_zone(&data->semispaces[TENURED],tenured_size,alloter);
+ alloter = init_zone(&data->generations[data->tenured()],tenured_size,alloter);
+ alloter = init_zone(&data->semispaces[data->tenured()],tenured_size,alloter);
if(data->gen_count == 3)
{
- alloter = init_zone(&data->generations[AGING],aging_size,alloter);
- alloter = init_zone(&data->semispaces[AGING],aging_size,alloter);
+ alloter = init_zone(&data->generations[data->aging()],aging_size,alloter);
+ alloter = init_zone(&data->semispaces[data->aging()],aging_size,alloter);
}
if(data->gen_count >= 2)
{
- alloter = init_zone(&data->generations[NURSERY],young_size,alloter);
- alloter = init_zone(&data->semispaces[NURSERY],0,alloter);
+ alloter = init_zone(&data->generations[data->nursery()],young_size,alloter);
+ alloter = init_zone(&data->semispaces[data->nursery()],0,alloter);
}
- if(data->seg->end - alloter > DECK_SIZE)
+ if(data->seg->end - alloter > deck_size)
critical_error("Bug in alloc_data_heap",alloter);
return data;
/* NOTE: reverse order due to heap layout. */
card *first_card = addr_to_allot_marker((object *)data->generations[to].start);
card *last_card = addr_to_allot_marker((object *)data->generations[from].end);
- memset(first_card,INVALID_ALLOT_MARKER,last_card - first_card);
+ memset(first_card,invalid_allot_marker,last_card - first_card);
}
void reset_generation(cell i)
{
- zone *z = (i == NURSERY ? &nursery : &data->generations[i]);
+ zone *z = (i == data->nursery() ? &nursery : &data->generations[i]);
z->here = z->start;
if(secure_gc)
void set_data_heap(data_heap *data_)
{
data = data_;
- nursery = data->generations[NURSERY];
+ nursery = data->generations[data->nursery()];
init_card_decks();
- clear_cards(NURSERY,TENURED);
- clear_decks(NURSERY,TENURED);
- clear_allot_markers(NURSERY,TENURED);
+ clear_cards(data->nursery(),data->tenured());
+ clear_decks(data->nursery(),data->tenured());
+ clear_allot_markers(data->nursery(),data->tenured());
}
void init_data_heap(cell gens,
cell gen;
for(gen = 0; gen < data->gen_count; gen++)
{
- zone *z = (gen == NURSERY ? &nursery : &data->generations[gen]);
+ zone *z = (gen == data->nursery() ? &nursery : &data->generations[gen]);
a.add(tag_fixnum((z->end - z->here) >> 10));
a.add(tag_fixnum((z->size) >> 10));
}
/* Disables GC and activates next-object ( -- obj ) primitive */
void begin_scan()
{
- heap_scan_ptr = data->generations[TENURED].start;
+ heap_scan_ptr = data->generations[data->tenured()].start;
gc_off = true;
}
if(!gc_off)
general_error(ERROR_HEAP_SCAN,F,F,NULL);
- if(heap_scan_ptr >= data->generations[TENURED].here)
+ if(heap_scan_ptr >= data->generations[data->tenured()].here)
return F;
object *obj = (object *)heap_scan_ptr;
cell *decks;
cell *decks_end;
+
+ /* the 0th generation is where new objects are allocated. */
+ cell nursery() { return 0; }
+
+ /* where objects hang around */
+ cell aging() { return gen_count - 2; }
+
+ /* the oldest generation */
+ cell tenured() { return gen_count - 1; }
+
+ bool have_aging_p() { return gen_count > 2; }
};
extern data_heap *data;
-/* the 0th generation is where new objects are allocated. */
-#define NURSERY 0
-/* where objects hang around */
-#define AGING (data->gen_count-2)
-#define HAVE_AGING_P (data->gen_count>2)
-/* the oldest generation */
-#define TENURED (data->gen_count-1)
-
-#define MIN_GEN_COUNT 1
-#define MAX_GEN_COUNT 3
+static const cell max_gen_count = 3;
inline static bool in_zone(zone *z, object *pointer)
{
static cell search_lookup_alist(cell table, cell klass)
{
- array *
pairs = untag<array>(table);
- fixnum index = array_capacity(pairs) - 1;
+ array *
elements = untag<array>(table);
+ fixnum index = array_capacity(elements) - 2;
while(index >= 0)
{
- array *pair = untag<array>(array_nth(pairs,index));
- if(array_nth(pair,0) == klass)
- return array_nth(pair,1);
+ if(array_nth(elements,index) == klass)
+ return array_nth(elements,index + 1);
else
- index--;
+ index -= 2;
}
return F;
clear_gc_stats();
- zone *tenured = &data->generations[TENURED];
+ zone *tenured = &data->generations[data->tenured()];
fixnum bytes_read = fread((void*)tenured->start,1,h->data_size,file);
return false;
}
- zone *tenured = &data->generations[TENURED];
+ zone *tenured = &data->generations[data->tenured()];
- h.magic = IMAGE_MAGIC;
- h.version = IMAGE_VERSION;
+ h.magic = image_magic;
+ h.version = image_version;
h.data_relocation_base = tenured->start;
h.data_size = tenured->here - tenured->start;
h.code_relocation_base = code.seg->start;
if(immediate_p(*cell))
return;
- zone *tenured = &data->generations[TENURED];
+ zone *tenured = &data->generations[data->tenured()];
*cell += (tenured->start - data_relocation_base);
}
data_fixup(&bignum_pos_one);
data_fixup(&bignum_neg_one);
- zone *tenured = &data->generations[TENURED];
+ zone *tenured = &data->generations[data->tenured()];
for(relocating = tenured->start;
relocating < tenured->here;
if(fread(&h,sizeof(image_header),1,file) != 1)
fatal_error("Cannot read image header",0);
- if(h.magic != IMAGE_MAGIC)
+ if(h.magic != image_magic)
fatal_error("Bad image: magic number check failed",h.magic);
- if(h.version != IMAGE_VERSION)
+ if(h.version != image_version)
fatal_error("Bad image: version number check failed",h.version);
load_data_heap(file,&h,p);
namespace factor
{
-#define IMAGE_MAGIC 0x0f0e0d0c
-#define IMAGE_VERSION 4
+static const cell image_magic = 0x0f0e0d0c;
+static const cell image_version = 4;
struct image_header {
cell magic;
return (a + (b-1)) & ~(b-1);
}
-#define align8(a) align(a,8)
-#define align_page(a) align(a,getpagesize())
+inline static cell align8(cell a)
+{
+ return align(a,8);
+}
#define WORD_SIZE (signed)(sizeof(cell)*8)
void *dll;
};
-struct callstack : public object {
- static const cell type_number = CALLSTACK_TYPE;
- /* tagged */
- cell length;
-};
-
struct stack_frame
{
void *xt;
cell size;
};
+struct callstack : public object {
+ static const cell type_number = CALLSTACK_TYPE;
+ /* tagged */
+ cell length;
+
+ stack_frame *top() { return (stack_frame *)(this + 1); }
+ stack_frame *bottom() { return (stack_frame *)((cell)(this + 1) + untag_fixnum(length)); }
+};
+
struct tuple : public object {
static const cell type_number = TUPLE_TYPE;
/* tagged layout */
#include <stdlib.h>
#include <string.h>
#include <time.h>
+#include <unistd.h>
#include <sys/param.h>
/* C++ headers */
fixnum y = untag_fixnum(dpop()); \
fixnum x = untag_fixnum(dpeek());
fixnum result = x / y;
- if(result == -FIXNUM_MIN)
- drepl(allot_integer(-FIXNUM_MIN));
+ if(result == -fixnum_min)
+ drepl(allot_integer(-fixnum_min));
else
drepl(tag_fixnum(result));
}
{
cell y = ((cell *)ds)[0];
cell x = ((cell *)ds)[-1];
- if(y == tag_fixnum(-1) && x == tag_fixnum(FIXNUM_MIN))
+ if(y == tag_fixnum(-1) && x == tag_fixnum(fixnum_min))
{
- ((cell *)ds)[-1] = allot_integer(-FIXNUM_MIN);
+ ((cell *)ds)[-1] = allot_integer(-fixnum_min);
((cell *)ds)[0] = tag_fixnum(0);
}
else
* If we're shifting right by n bits, we won't overflow as long as none of the
* high WORD_SIZE-TAG_BITS-n bits are set.
*/
-#define SIGN_MASK(x) ((x) >> (WORD_SIZE - 1))
-#define BRANCHLESS_MAX(x,y) ((x) - (((x) - (y)) & SIGN_MASK((x) - (y))))
-#define BRANCHLESS_ABS(x) ((x ^ SIGN_MASK(x)) - SIGN_MASK(x))
+static inline fixnum sign_mask(fixnum x)
+{
+ return x >> (WORD_SIZE - 1);
+}
+
+static inline fixnum branchless_max(fixnum x, fixnum y)
+{
+ return (x - ((x - y) & sign_mask(x - y)));
+}
+
+static inline fixnum branchless_abs(fixnum x)
+{
+ return (x ^ sign_mask(x)) - sign_mask(x);
+}
PRIMITIVE(fixnum_shift)
{
return;
else if(y < 0)
{
- y = BRANCHLESS_MAX(y,-WORD_SIZE + 1);
+ y = branchless_max(y,-WORD_SIZE + 1);
drepl(tag_fixnum(x >> -y));
return;
}
else if(y < WORD_SIZE - TAG_BITS)
{
fixnum mask = -((fixnum)1 << (WORD_SIZE - 1 - TAG_BITS - y));
- if(!(BRANCHLESS_ABS(x) & mask))
+ if(!(branchless_abs(x) & mask))
{
drepl(tag_fixnum(x << y));
return;
case FIXNUM_TYPE:
{
fixnum n = untag_fixnum(dpeek());
- if(n >= 0 && n < (fixnum)ARRAY_SIZE_MAX)
+ if(n >= 0 && n < (fixnum)array_size_max)
{
dpop();
return n;
case BIGNUM_TYPE:
{
bignum * zero = untag<bignum>(bignum_zero);
- bignum * max = cell_to_bignum(ARRAY_SIZE_MAX);
+ bignum * max = cell_to_bignum(array_size_max);
bignum * n = untag<bignum>(dpeek());
if(bignum_compare(n,zero) != bignum_comparison_less
&& bignum_compare(n,max) == bignum_comparison_less)
}
}
- general_error(ERROR_ARRAY_SIZE,dpop(),tag_fixnum(ARRAY_SIZE_MAX),NULL);
+ general_error(ERROR_ARRAY_SIZE,dpop(),tag_fixnum(array_size_max),NULL);
return 0; /* can't happen */
}
VM_C_API void box_signed_8(s64 n)
{
- if(n < FIXNUM_MIN || n > FIXNUM_MAX)
+ if(n < fixnum_min || n > fixnum_max)
dpush(tag<bignum>(long_long_to_bignum(n)));
else
dpush(tag_fixnum(n));
VM_C_API void box_unsigned_8(u64 n)
{
- if(n > FIXNUM_MAX)
+ if(n > (u64)fixnum_max)
dpush(tag<bignum>(ulong_long_to_bignum(n)));
else
dpush(tag_fixnum(n));
extern cell bignum_pos_one;
extern cell bignum_neg_one;
-#define cell_MAX (cell)(-1)
-#define FIXNUM_MAX (((fixnum)1 << (WORD_SIZE - TAG_BITS - 1)) - 1)
-#define FIXNUM_MIN (-((fixnum)1 << (WORD_SIZE - TAG_BITS - 1)))
-#define ARRAY_SIZE_MAX ((cell)1 << (WORD_SIZE - TAG_BITS - 2))
+static const fixnum fixnum_max = (((fixnum)1 << (WORD_SIZE - TAG_BITS - 1)) - 1);
+static const fixnum fixnum_min = (-((fixnum)1 << (WORD_SIZE - TAG_BITS - 1)));
+static const fixnum array_size_max = ((cell)1 << (WORD_SIZE - TAG_BITS - 2));
PRIMITIVE(fixnum_add);
PRIMITIVE(fixnum_subtract);
inline static cell allot_integer(fixnum x)
{
- if(x < FIXNUM_MIN || x > FIXNUM_MAX)
+ if(x < fixnum_min || x > fixnum_max)
return tag<bignum>(fixnum_to_bignum(x));
else
return tag_fixnum(x);
inline static cell allot_cell(cell x)
{
- if(x > (cell)FIXNUM_MAX)
+ if(x > (cell)fixnum_max)
return tag<bignum>(cell_to_bignum(x));
else
return tag_fixnum(x);
cell end;
};
+inline static cell align_page(cell a)
+{
+ return align(a,getpagesize());
+}
+
}
namespace factor
{
-/* if CARD_POINTS_TO_NURSERY is set, CARD_POINTS_TO_AGING must also be set. */
-#define CARD_POINTS_TO_NURSERY 0x80
-#define CARD_POINTS_TO_AGING 0x40
-#define CARD_MARK_MASK (CARD_POINTS_TO_NURSERY | CARD_POINTS_TO_AGING)
+/* if card_points_to_nursery is set, card_points_to_aging must also be set. */
+static const cell card_points_to_nursery = 0x80;
+static const cell card_points_to_aging = 0x40;
+static const cell card_mark_mask = (card_points_to_nursery | card_points_to_aging);
typedef u8 card;
-#define CARD_BITS 8
-#define CARD_SIZE (1<<CARD_BITS)
-#define ADDR_CARD_MASK (CARD_SIZE-1)
+static const cell card_bits = 8;
+static const cell card_size = (1<<card_bits);
+static const cell addr_card_mask = (card_size-1);
inline static card *addr_to_card(cell a)
{
- return (card*)(((cell)(a) >> CARD_BITS) + cards_offset);
+ return (card*)(((cell)(a) >> card_bits) + cards_offset);
}
inline static cell card_to_addr(card *c)
{
- return ((cell)c - cards_offset) << CARD_BITS;
+ return ((cell)c - cards_offset) << card_bits;
}
inline static cell card_offset(card *c)
typedef u8 card_deck;
-#define DECK_BITS (CARD_BITS + 10)
-#define DECK_SIZE (1<<DECK_BITS)
-#define ADDR_DECK_MASK (DECK_SIZE-1)
+static const cell deck_bits = (card_bits + 10);
+static const cell deck_size = (1<<deck_bits);
+static const cell addr_deck_mask = (deck_size-1);
inline static card_deck *addr_to_deck(cell a)
{
- return (card_deck *)(((cell)a >> DECK_BITS) + decks_offset);
+ return (card_deck *)(((cell)a >> deck_bits) + decks_offset);
}
inline static cell deck_to_addr(card_deck *c)
{
- return ((cell)c - decks_offset) << DECK_BITS;
+ return ((cell)c - decks_offset) << deck_bits;
}
inline static card *deck_to_card(card_deck *d)
{
- return (card *)((((cell)d - decks_offset) << (DECK_BITS - CARD_BITS)) + cards_offset);
+ return (card *)((((cell)d - decks_offset) << (deck_bits - card_bits)) + cards_offset);
}
-#define INVALID_ALLOT_MARKER 0xff
+static const cell invalid_allot_marker = 0xff;
extern cell allot_markers_offset;
inline static card *addr_to_allot_marker(object *a)
{
- return (card *)(((cell)a >> CARD_BITS) + allot_markers_offset);
+ return (card *)(((cell)a >> card_bits) + allot_markers_offset);
}
/* the write barrier must be called any time we are potentially storing a
pointer from an older generation to a younger one */
inline static void write_barrier(object *obj)
{
- *addr_to_card((cell)obj) = CARD_MARK_MASK;
- *addr_to_deck((cell)obj) = CARD_MARK_MASK;
+ *addr_to_card((cell)obj) = card_mark_mask;
+ *addr_to_deck((cell)obj) = card_mark_mask;
}
/* we need to remember the first object allocated in the card */
inline static void allot_barrier(object *address)
{
card *ptr = addr_to_allot_marker(address);
- if(*ptr == INVALID_ALLOT_MARKER)
- *ptr = ((cell)address & ADDR_CARD_MASK);
+ if(*ptr == invalid_allot_marker)
+ *ptr = ((cell)address & addr_card_mask);
}
}
projects / factor.git / commitdiff