[ dup c-setter '[ _ <c-object> [ 0 @ ] keep ] ] bi
(( value -- c-ptr )) define-inline ;
-: c-bool> ( int -- ? )
- 0 = not ; inline
+: >c-bool ( ? -- int ) 1 0 ? ; inline
+
+: c-bool> ( int -- ? ) 0 = not ; inline
: define-primitive-type ( type name -- )
[ typedef ]
"uchar" define-primitive-type
<c-type>
- [ alien-unsigned-1 zero? not ] >>getter
- [ [ 1 0 ? ] 2dip set-alien-unsigned-1 ] >>setter
+ [ alien-unsigned-1 c-bool> ] >>getter
+ [ [ >c-bool ] 2dip set-alien-unsigned-1 ] >>setter
1 >>size
1 >>align
"box_boolean" >>boxer
[ "abcdefghijklmnopqrstuvwxyz" ] [ "abcdefghijklmnopqrstuvwxyz" ascii encode >base64 base64> ascii decode
] unit-test
-[ f ] [ "" ascii encode >base64 base64> ascii decode ] unit-test
+[ "" ] [ "" ascii encode >base64 base64> ascii decode ] unit-test
[ "a" ] [ "a" ascii encode >base64 base64> ascii decode ] unit-test
[ "ab" ] [ "ab" ascii encode >base64 base64> ascii decode ] unit-test
[ "abc" ] [ "abc" ascii encode >base64 base64> ascii decode ] unit-test
: 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 ;
NSApplicationDelegateReplyFailure ;
: with-autorelease-pool ( quot -- )
- NSAutoreleasePool -> new slip -> release ; inline
+ NSAutoreleasePool -> new [ call ] [ -> release ] bi* ; inline
: NSApp ( -- app ) NSApplication -> sharedApplication ;
[ dup lookup-method ] dip
[ make-prepare-send ] 2keep
super-message-senders message-senders ? get at
- '[ _ call _ execute ] ;
+ 1quotation append ;
: send ( receiver args... selector -- return... ) f (send) ; inline
: do-callback ( quot token -- )
init-catchstack
- dup 2 setenv
- slip
+ [ 2 setenv call ] keep
wait-to-return ; inline
: callback-return-quot ( ctype -- quot )
] unit-test
: foobar ( quot: ( -- ) -- )
- dup slip swap [ foobar ] [ drop ] if ; inline recursive
+ [ call ] keep swap [ foobar ] [ drop ] if ; inline recursive
[ ] [ [ [ f ] foobar ] compile-call ] unit-test
[ 0 ] [ [ 1 cons boa "x" get slot ] count-unboxed-allocations ] unit-test
: impeach-node ( quot: ( node -- ) -- )
- dup slip impeach-node ; inline recursive
+ [ call ] keep impeach-node ; inline recursive
: bleach-node ( quot: ( node -- ) -- )
[ bleach-node ] curry [ ] compose impeach-node ; inline recursive
! A more complicated example
: impeach-node ( quot: ( node -- ) -- )
- dup slip impeach-node ; inline recursive
+ [ call ] keep impeach-node ; inline recursive
: bleach-node ( quot: ( node -- ) -- )
[ bleach-node ] curry [ ] compose impeach-node ; inline recursive
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs sequences kernel combinators make math
math.order math.ranges system namespaces locals layouts words
-alien alien.c-types literals cpu.architecture cpu.ppc.assembler
-cpu.ppc.assembler.backend literals compiler.cfg.registers
+alien alien.accessors alien.c-types literals cpu.architecture
+cpu.ppc.assembler cpu.ppc.assembler.backend literals compiler.cfg.registers
compiler.cfg.instructions compiler.constants compiler.codegen
compiler.codegen.fixup compiler.cfg.intrinsics
-compiler.cfg.stack-frame ;
+compiler.cfg.stack-frame compiler.units ;
IN: cpu.ppc
! PowerPC register assignments:
} cond
"complex-double" c-type t >>return-in-registers? drop
-"bool" c-type 4 >>size 4 >>align drop
\ No newline at end of file
+
+[
+ <c-type>
+ [ alien-unsigned-4 c-bool> ] >>getter
+ [ [ >c-bool ] 2dip set-alien-unsigned-4 ] >>setter
+ 4 >>size
+ 4 >>align
+ "box_boolean" >>boxer
+ "to_boolean" >>unboxer
+ "bool" define-primitive-type
+] with-compilation-unit
"Here are some built-in combinators rewritten in terms of fried quotations:"\r
{ $table\r
{ { $link literalize } { $snippet ": literalize '[ _ ] ;" } }\r
- { { $link slip } { $snippet ": slip '[ @ _ ] call ;" } }\r
{ { $link curry } { $snippet ": curry '[ _ @ ] ;" } }\r
{ { $link compose } { $snippet ": compose '[ @ @ ] ;" } }\r
{ { $link bi@ } { $snippet ": bi@ tuck '[ _ @ _ @ ] call ;" } }\r
}\r
} ;\r
\r
-HELP: nslip\r
-{ $values { "n" integer } }\r
-{ $description "A generalization of " { $link slip } " that can work " \r
-"for any stack depth. The first " { $snippet "n" } " items after the quotation will be "\r
-"removed from the stack, the quotation called, and the items restored."\r
-} \r
-{ $examples\r
- { $example "USING: generalizations kernel prettyprint ;" "[ 99 ] 1 2 3 4 5 5 nslip 6 narray ." "{ 99 1 2 3 4 5 }" }\r
- "Some core words expressed in terms of " { $link nslip } ":"\r
- { $table\r
- { { $link slip } { $snippet "1 nslip" } }\r
- { { $link 2slip } { $snippet "2 nslip" } }\r
- { { $link 3slip } { $snippet "3 nslip" } }\r
- }\r
-} ;\r
-\r
HELP: nkeep\r
{ $values { "quot" quotation } { "n" integer } }\r
{ $description "A generalization of " { $link keep } " that can work " \r
\r
ARTICLE: "combinator-generalizations" "Generalized combinators"\r
{ $subsection ndip }\r
-{ $subsection nslip }\r
{ $subsection nkeep }\r
{ $subsection napply }\r
{ $subsection ncleave }\r
[ [ 1 ] 5 ndip ] must-infer\r
[ 1 2 3 4 ] [ 2 3 4 [ 1 ] 3 ndip ] unit-test\r
\r
-[ [ 99 ] 1 2 3 4 5 5 nslip ] must-infer\r
-{ 99 1 2 3 4 5 } [ [ 99 ] 1 2 3 4 5 5 nslip ] unit-test\r
[ 1 2 3 4 5 [ drop drop drop drop drop 2 ] 5 nkeep ] must-infer\r
{ 2 1 2 3 4 5 } [ 1 2 3 4 5 [ drop drop drop drop drop 2 ] 5 nkeep ] unit-test\r
[ [ 1 2 3 + ] ] [ 1 2 3 [ + ] 3 ncurry ] unit-test\r
MACRO: ndip ( quot n -- )
[ '[ _ dip ] ] times ;
-MACRO: nslip ( n -- )
- '[ [ call ] _ ndip ] ;
-
MACRO: nkeep ( quot n -- )
tuck '[ _ ndup _ _ ndip ] ;
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax kernel quotations ;
+USING: help.markup help.syntax kernel quotations sequences ;
IN: io.directories.search
HELP: each-file
}
{ $description "Finds all files in the input directories matching the predicate quotation in a breadth-first or depth-first traversal." } ;
+HELP: find-by-extension
+{ $values
+ { "path" "a pathname string" } { "extension" "a file extension" }
+ { "seq" sequence }
+}
+{ $description "Searches a directory for all files with the given extension. File extension and filenames are converted to lower-case and compared using the " { $link tail? } " word. The file extension should contain the period." }
+{ $examples
+ { $unchecked-example
+ "USING: io.directories.search ;"
+ "\"/\" \".mp3\" find-by-extension"
+ }
+} ;
+
+HELP: find-by-extensions
+{ $values
+ { "path" "a pathname string" } { "extensions" "a sequence of file extensions" }
+ { "seq" sequence }
+}
+{ $description "Searches a directory for all files in the given list of extensions. File extensions and filenames are converted to lower-case and compared using the " { $link tail? } " word. File extensions should contain the period." }
+{ $examples
+ { $unchecked-example
+ "USING: io.directories.search ;"
+ "\"/\" { \".jpg\" \".gif\" \".tiff\" \".png\" \".bmp\" } find-by-extensions"
+ }
+} ;
+
{ find-file find-all-files find-in-directories find-all-in-directories } related-words
ARTICLE: "io.directories.search" "Searching directories"
{ $subsection recursive-directory-files }
{ $subsection recursive-directory-entries }
{ $subsection each-file }
-"Finding files:"
+"Finding files by name:"
{ $subsection find-file }
{ $subsection find-all-files }
{ $subsection find-in-directories }
-{ $subsection find-all-in-directories } ;
+{ $subsection find-all-in-directories }
+"Finding files by extension:"
+{ $subsection find-by-extension }
+{ $subsection find-by-extensions } ;
ABOUT: "io.directories.search"
USING: accessors arrays continuations deques dlists fry
io.directories io.files io.files.info io.pathnames kernel
sequences system vocabs.loader locals math namespaces
-sorting assocs calendar threads io math.parser ;
+sorting assocs calendar threads io math.parser unicode.case ;
IN: io.directories.search
: qualified-directory-entries ( path -- seq )
] { } map>assoc
] with-qualified-directory-entries sort-values ;
+: find-by-extensions ( path extensions -- seq )
+ [ >lower ] map
+ '[ >lower _ [ tail? ] with any? ] find-all-files ;
+
+: find-by-extension ( path extension -- seq )
+ 1array find-by-extensions ;
+
os windows? [ "io.directories.search.windows" require ] when
try-process
] unit-test
-[ f ] [
+[ "" ] [
"cat"
"launcher-test-1" temp-file
2array
tools.test ;
IN: io.streams.string.tests
+[ "" ] [ "" [ contents ] with-string-reader ] unit-test
+
[ "line 1" CHAR: l ]
[
"line 1\nline 2\nline 3" <string-reader>
: 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
+++ /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-2009 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 ;
: 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* ;
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 } ;
{ deploy-name "none" }
{ "stop-after-last-window?" t }
{ deploy-c-types? f }
- { deploy-compiler? f }
{ deploy-io 1 }
{ deploy-ui? f }
{ deploy-reflection 1 }
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 ] [
M: object infer-call*
"literal quotation" literal-expected ;
-: infer-nslip ( n -- )
- [ infer->r infer-call ] [ infer-r> ] bi ;
-
-: infer-slip ( -- ) 1 infer-nslip ;
-
-: infer-2slip ( -- ) 2 infer-nslip ;
-
-: infer-3slip ( -- ) 3 infer-nslip ;
-
: infer-ndip ( word n -- )
[ literals get ] 2dip
[ '[ _ def>> infer-quot-here ] ]
{ \ declare [ infer-declare ] }
{ \ call [ infer-call ] }
{ \ (call) [ infer-call ] }
- { \ slip [ infer-slip ] }
- { \ 2slip [ infer-2slip ] }
- { \ 3slip [ infer-3slip ] }
{ \ dip [ infer-dip ] }
{ \ 2dip [ infer-2dip ] }
{ \ 3dip [ infer-3dip ] }
"local-word-def" word-prop infer-quot-here ;
{
- declare call (call) slip 2slip 3slip dip 2dip 3dip curry compose
+ declare call (call) dip 2dip 3dip curry compose
execute (execute) call-effect-unsafe execute-effect-unsafe if
dispatch <tuple-boa> exit load-local load-locals get-local
drop-locals do-primitive alien-invoke alien-indirect
over [
2drop
] [
- [ swap slip ] keep swap bad-combinator
+ [ dip ] keep swap bad-combinator
] if ; inline recursive
[ [ [ 1 ] [ ] bad-combinator ] infer ] must-fail
[ my-arch make-image ] unless ;
: bootstrap-profile ( -- profile )
- {
- { "math" deploy-math? }
- { "compiler" deploy-compiler? }
- { "threads" deploy-threads? }
- { "ui" deploy-ui? }
- { "unicode" deploy-unicode? }
- } [ nip get ] assoc-filter keys
- native-io? [ "io" suffix ] when ;
+ [
+ deploy-math? get [ "math" , ] when
+ deploy-threads? get [ "threads" , ] when
+ "compiler" ,
+ deploy-ui? get [ "ui" , ] when
+ deploy-unicode? get [ "unicode" , ] when
+ native-io? [ "io" , ] when
+ ] { } make ;
: staging-image-name ( profile -- name )
"staging."
ARTICLE: "deploy-flags" "Deployment flags"
"There are two sets of deployment flags. The first set controls the major subsystems which are to be included in the deployment image:"
{ $subsection deploy-math? }
-{ $subsection deploy-compiler? }
{ $subsection deploy-unicode? }
{ $subsection deploy-threads? }
{ $subsection deploy-ui? }
$nl
"On by default. Often the programmer will use rationals without realizing it. A small amount of space can be saved by stripping these features out, but some code may require changes to work properly." } ;
-HELP: deploy-compiler?
-{ $description "Deploy flag. If set, words in the deployed image will be compiled with the optimizing compiler when possible."
-$nl
-"On by default. Most programs should be compiled, not only for performance but because features which depend on the C library interface only function after compilation." } ;
-
HELP: deploy-unicode?
{ $description "Deploy flag. If set, full Unicode " { $link POSTPONE: CHAR: } " syntax is included."
$nl
SYMBOL: deploy-name
SYMBOL: deploy-ui?
-SYMBOL: deploy-compiler?
SYMBOL: deploy-math?
SYMBOL: deploy-unicode?
SYMBOL: deploy-threads?
{ deploy-ui? f }
{ deploy-io 2 }
{ deploy-reflection 1 }
- { deploy-compiler? t }
{ deploy-threads? t }
{ deploy-unicode? f }
{ deploy-math? t }
"In deployed applications, the " { $link boa } " word does not verify that the parameters on the stack satisfy the tuple's slot declarations, if any. This reduces deploy image size but can make bugs harder to track down. Make sure your program is fully debugged before deployment."
{ $heading "Behavior of " { $link POSTPONE: execute( } }
"Similarly, the " { $link POSTPONE: execute( } " word does not check word stack effects in deployed applications, since stack effects are stripped out, and so it behaves exactly like " { $link POSTPONE: execute-effect-unsafe } "."
+{ $heading "Behavior of " { $link POSTPONE: call-next-method } }
+"The " { $link POSTPONE: call-next-method } " word does not check if the input is of the right type in deployed applications."
{ $heading "Error reporting" }
"If the " { $link deploy-reflection } " level in the configuration is low enough, the debugger is stripped out, and error messages can be rather cryptic. Increase the reflection level to get readable error messages."
{ $heading "Choosing the right deploy flags" }
\r
[ t ] [ "hello-ui" shake-and-bake 1300000 small-enough? ] unit-test\r
\r
-[ "staging.math-compiler-threads-ui-strip.image" ] [\r
+[ "staging.math-threads-compiler-ui-strip.image" ] [\r
"hello-ui" deploy-config\r
[ bootstrap-profile staging-image-name file-name ] bind\r
] unit-test\r
\r
[ t ] [ "tetris" shake-and-bake 1500000 small-enough? ] unit-test\r
\r
+[ t ] [ "spheres" shake-and-bake 1500000 small-enough? ] unit-test\r
+\r
+[ t ] [ "terrain" shake-and-bake 1600000 small-enough? ] unit-test\r
+\r
[ t ] [ "bunny" shake-and-bake 2500000 small-enough? ] unit-test\r
\r
os macosx? [\r
{\r
"tools.deploy.test.6"\r
"tools.deploy.test.7"\r
- "tools.deploy.test.8"\r
"tools.deploy.test.9"\r
"tools.deploy.test.10"\r
"tools.deploy.test.11"\r
! Copyright (C) 2007, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors io.backend io.streams.c init fry
-namespaces make assocs kernel parser lexer strings.parser vocabs
-sequences words memory kernel.private
-continuations io vocabs.loader system strings sets
-vectors quotations byte-arrays sorting compiler.units
-definitions generic generic.standard tools.deploy.config ;
+USING: arrays accessors io.backend io.streams.c init fry namespaces
+make assocs kernel parser lexer strings.parser vocabs sequences words
+memory kernel.private continuations io vocabs.loader system strings
+sets vectors quotations byte-arrays sorting compiler.units definitions
+generic generic.standard tools.deploy.config combinators classes ;
QUALIFIED: bootstrap.stage2
-QUALIFIED: classes
QUALIFIED: command-line
QUALIFIED: compiler.errors
QUALIFIED: continuations
strip-word-names? [ dup strip-word-names ] when
2drop ;
+: strip-compiler-classes ( -- )
+ "Stripping compiler classes" show
+ "compiler" child-vocabs [ words ] map concat [ class? ] filter
+ [ dup implementors [ "methods" word-prop delete-at ] with each ] each ;
+
: strip-default-methods ( -- )
strip-debugger? [
"Stripping default methods" show
{
gensym
name>char-hook
- classes:next-method-quot-cache
- classes:class-and-cache
- classes:class-not-cache
- classes:class-or-cache
- classes:class<=-cache
- classes:classes-intersect-cache
- classes:implementors-map
- classes:update-map
+ next-method-quot-cache
+ class-and-cache
+ class-not-cache
+ class-or-cache
+ class<=-cache
+ classes-intersect-cache
+ implementors-map
+ update-map
command-line:main-vocab-hook
compiled-crossref
compiled-generic-crossref
[ instances dup H{ } clone [ [ ] cache ] curry map ] dip call
become ; inline
-: compress-byte-arrays ( -- )
- [ byte-array? ] [ ] "byte arrays" compress ;
+: compress-object? ( obj -- ? )
+ {
+ { [ dup array? ] [ empty? ] }
+ { [ dup byte-array? ] [ drop t ] }
+ { [ dup string? ] [ drop t ] }
+ { [ dup wrapper? ] [ drop t ] }
+ [ drop f ]
+ } cond ;
+
+: compress-objects ( -- )
+ [ compress-object? ] [ ] "objects" compress ;
: remain-compiled ( old new -- old new )
#! Quotations which were formerly compiled must remain
[ quotation? ] [ remain-compiled ] "quotations" compress
[ quotation? ] instances [ f >>cached-effect f >>cache-counter drop ] each ;
-: compress-strings ( -- )
- [ string? ] [ ] "strings" compress ;
-
-: compress-wrappers ( -- )
- [ wrapper? ] [ ] "wrappers" compress ;
-
SYMBOL: deploy-vocab
: [:c] ( -- word ) ":c" "debugger" lookup ;
t "quiet" set-global
f output-stream set-global ;
+: unsafe-next-method-quot ( method -- quot )
+ [ "method-class" word-prop ]
+ [ "method-generic" word-prop ] bi
+ next-method 1quotation ;
+
: compute-next-methods ( -- )
[ standard-generic? ] instances [
"methods" word-prop [
- nip
- dup next-method-quot "next-method-quot" set-word-prop
+ nip dup
+ unsafe-next-method-quot
+ "next-method-quot" set-word-prop
] assoc-each
] each
"vocab:tools/deploy/shaker/next-methods.factor" run-file ;
: strip ( -- )
init-stripper
- strip-default-methods
strip-libc
strip-call
strip-cocoa
compute-next-methods
strip-init-hooks
strip-c-io
+ strip-compiler-classes
+ strip-default-methods
f 5 setenv ! we can't use the Factor debugger or Factor I/O anymore
deploy-vocab get vocab-main deploy-boot-quot
stripped-word-props
stripped-globals strip-globals
- compress-byte-arrays
+ compress-objects
compress-quotations
- compress-strings
- compress-wrappers
strip-words ;
: deploy-error-handler ( quot -- )
-! Copyright (C) 2007, 2008 Slava Pestov
+! Copyright (C) 2007, 2009 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: cocoa cocoa.messages cocoa.application cocoa.nibs assocs
namespaces kernel kernel.private words compiler.units sequences
-init vocabs ;
+init vocabs memoize accessors ;
IN: tools.deploy.shaker.cocoa
: pool ( obj -- obj' ) \ pool get [ ] cache ;
[ get values compile ] each
] bind
] with-variable
+
+\ make-prepare-send reset-memoized
+\ <selector> reset-memoized
+
+\ (send) def>> second clear-assoc
\ No newline at end of file
{ deploy-math? t }
{ deploy-io 2 }
{ deploy-name "tools.deploy.test.1" }
- { deploy-compiler? t }
{ deploy-reflection 1 }
{ "stop-after-last-window?" t }
}
{ deploy-unicode? f }
{ deploy-io 2 }
{ deploy-word-props? f }
- { deploy-compiler? f }
{ deploy-threads? f }
{ deploy-word-defs? f }
{ "stop-after-last-window?" t }
{ deploy-math? f }
{ deploy-unicode? f }
{ deploy-threads? f }
- { deploy-compiler? f }
{ deploy-io 2 }
{ deploy-ui? f }
}
{ deploy-io 2 }
{ deploy-ui? f }
{ deploy-name "tools.deploy.test.12" }
- { deploy-compiler? f }
{ deploy-word-defs? f }
{ deploy-threads? f }
}
USING: tools.deploy.config ;
H{
{ deploy-threads? t }
- { deploy-compiler? t }
{ deploy-math? t }
{ deploy-io 2 }
{ "stop-after-last-window?" t }
{ deploy-math? t }
{ deploy-io 2 }
{ deploy-name "tools.deploy.test.2" }
- { deploy-compiler? t }
{ deploy-reflection 1 }
{ "stop-after-last-window?" t }
}
{ "stop-after-last-window?" t }
{ deploy-word-defs? f }
{ deploy-reflection 1 }
- { deploy-compiler? t }
{ deploy-threads? t }
{ deploy-io 3 }
{ deploy-math? t }
{ deploy-math? t }
{ deploy-io 2 }
{ deploy-name "tools.deploy.test.4" }
- { deploy-compiler? t }
{ deploy-reflection 1 }
{ "stop-after-last-window?" t }
}
{ deploy-math? t }
{ deploy-io 3 }
{ deploy-name "tools.deploy.test.5" }
- { deploy-compiler? t }
{ deploy-reflection 1 }
{ "stop-after-last-window?" t }
}
{ deploy-io 1 }
{ deploy-name "tools.deploy.test.6" }
{ deploy-math? t }
- { deploy-compiler? t }
{ deploy-ui? f }
{ deploy-c-types? f }
{ deploy-word-defs? f }
{ deploy-io 2 }
{ deploy-math? t }
{ "stop-after-last-window?" t }
- { deploy-compiler? t }
{ deploy-unicode? f }
{ deploy-c-types? f }
{ deploy-reflection 1 }
+++ /dev/null
-USING: kernel ;
-IN: tools.deploy.test.8
-
-: literal-merge-test-1 ( -- x ) H{ { "lil" "wayne" } } ;
-: literal-merge-test-2 ( -- x ) H{ { "lil" "wayne" } } ;
-
-: literal-merge-test ( -- )
- literal-merge-test-1
- literal-merge-test-2 eq? t assert= ;
-
-MAIN: literal-merge-test
+++ /dev/null
-USING: tools.deploy.config ;
-H{
- { deploy-name "tools.deploy.test.8" }
- { deploy-c-types? f }
- { deploy-word-props? f }
- { deploy-ui? f }
- { deploy-reflection 1 }
- { deploy-compiler? f }
- { deploy-unicode? f }
- { deploy-io 1 }
- { deploy-word-defs? f }
- { deploy-threads? f }
- { "stop-after-last-window?" t }
- { deploy-math? f }
-}
{ "stop-after-last-window?" t }
{ deploy-word-defs? f }
{ deploy-reflection 1 }
- { deploy-compiler? t }
{ deploy-threads? f }
{ deploy-io 1 }
{ deploy-math? t }
GetDoubleClickTime milliseconds double-click-timeout set-global ;
: cleanup-win32-ui ( -- )
- class-name-ptr get-global [ dup f UnregisterClass drop free ] when*
- msg-obj get-global [ free ] when*
- f class-name-ptr set-global
- f msg-obj set-global ;
+ class-name-ptr [
+ [ [ f UnregisterClass drop ] [ free ] bi ] when* f
+ ] change-global
+ msg-obj change-global [ [ free ] when* f ] ;
-: get-dc ( world -- ) handle>> dup hWnd>> GetDC dup win32-error=0/f >>hDC drop ;
+: get-dc ( world -- )
+ handle>> dup hWnd>> GetDC dup win32-error=0/f >>hDC drop ;
: get-rc ( world -- )
handle>> dup hDC>> dup wglCreateContext dup win32-error=0/f
[ wglMakeCurrent win32-error=0/f ] keep >>hRC drop ;
: set-pixel-format ( pixel-format hdc -- )
- swap handle>> "PIXELFORMATDESCRIPTOR" <c-object> SetPixelFormat win32-error=0/f ;
+ swap handle>>
+ "PIXELFORMATDESCRIPTOR" <c-object> SetPixelFormat win32-error=0/f ;
: setup-gl ( world -- )
[ get-dc ] 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
namespaces opengl opengl.textures sequences io combinators
combinators.short-circuit fry math.vectors math.rectangles cache
ui.gadgets ui.gestures ui.render ui.backend ui.gadgets.tracks
-ui.commands ui.pixel-formats destructors literals ;
+ui.pixel-formats destructors literals ;
IN: ui.gadgets.worlds
CONSTANT: default-world-pixel-format-attributes
USING: accessors arrays assocs kernel math math.order models
namespaces make sequences words strings system hashtables math.parser
math.vectors classes.tuple classes boxes calendar alarms combinators
-sets columns fry deques ui.gadgets ui.gadgets.private unicode.case
-unicode.categories combinators.short-circuit ;
+sets columns fry deques ui.gadgets ui.gadgets.private ascii
+combinators.short-circuit ;
IN: ui.gestures
GENERIC: handle-gesture ( gesture gadget -- ? )
M: macosx modifiers>string
[
{
- { A+ [ "\u{place-of-interest-sign}" ] }
- { M+ [ "\u{option-key}" ] }
- { S+ [ "\u{upwards-white-arrow}" ] }
- { C+ [ "\u{up-arrowhead}" ] }
+ { A+ [ "\u002318" ] }
+ { M+ [ "\u002325" ] }
+ { S+ [ "\u0021e7" ] }
+ { C+ [ "\u002303" ] }
} case
] map "" join ;
USING: accessors assocs classes destructors functors kernel
lexer math parser sequences specialized-arrays.int ui.backend
-words.symbol ;
+words ;
IN: ui.pixel-formats
SYMBOLS:
M: object >PFA
drop { } ;
-M: symbol >PFA
+M: word >PFA
TABLE at [ { } ] unless* ;
M: pixel-format-attribute >PFA
dup class TABLE at
: advanced-settings ( parent -- parent )
"Advanced:" <label> add-gadget
- deploy-compiler? get "Use optimizing compiler" <checkbox> add-gadget
deploy-math? get "Rational and complex number support" <checkbox> add-gadget
deploy-threads? get "Threading support" <checkbox> add-gadget
deploy-unicode? get "Unicode character literal support" <checkbox> add-gadget
USING: urls.encoding tools.test arrays kernel assocs present accessors ;
[ "~hello world" ] [ "%7ehello world" url-decode ] unit-test
-[ f ] [ "%XX%XX%XX" url-decode ] unit-test
-[ f ] [ "%XX%XX%X" url-decode ] unit-test
+[ "" ] [ "%XX%XX%XX" url-decode ] unit-test
+[ "" ] [ "%XX%XX%X" url-decode ] unit-test
[ "hello world" ] [ "hello%20world" url-decode ] unit-test
[ " ! " ] [ "%20%21%20" url-decode ] unit-test
] if ;
: parse-host ( string -- host port )
- ":" split1 [ url-decode ] [
- dup [
- string>number
- dup [ "Invalid port" throw ] unless
- ] when
- ] bi* ;
+ [
+ ":" split1 [ url-decode ] [
+ dup [
+ string>number
+ dup [ "Invalid port" throw ] unless
+ ] when
+ ] bi*
+ ] [ f f ] if* ;
GENERIC: >url ( obj -- url )
IUnknown::Release drop ; inline\r
\r
: with-com-interface ( interface quot -- )\r
- over [ slip ] [ com-release ] [ ] cleanup ; inline\r
+ over [ com-release ] curry [ ] cleanup ; inline\r
\r
DESTRUCTOR: com-release\r
: compile-alien-callback ( word return parameters abi quot -- word )
'[ _ _ _ _ alien-callback ]
- [ [ (( -- alien )) define-declared ] pick slip ]
+ [ [ (( -- alien )) define-declared ] pick [ call ] dip ]
with-compilation-unit ;
: (callback-word) ( function-name interface-name counter -- word )
<PRIVATE
: call-under ( quot object -- quot )
- swap dup slip ; inline
+ swap [ call ] keep ; inline
: xml-loop ( quot: ( xml-elem -- ) -- )
parse-text call-under
": dip [ ] bi* ;"
": 2dip [ ] [ ] tri* ;"
""
- ": slip [ call ] [ ] bi* ;"
- ": 2slip [ call ] [ ] [ ] tri* ;"
- ""
": nip [ drop ] [ ] bi* ;"
": 2nip [ drop ] [ drop ] [ ] tri* ;"
""
{ $subsection both? }
{ $subsection either? } ;
-ARTICLE: "slip-keep-combinators" "Retain stack combinators"
+ARTICLE: "retainstack-combinators" "Retain stack combinators"
"Sometimes an additional storage area is needed to hold objects. The " { $emphasis "retain stack" } " is an auxilliary stack for this purpose. Objects can be moved between the data and retain stacks using a set of combinators."
$nl
"The dip combinators invoke the quotation at the top of the stack, hiding the values underneath:"
{ $subsection 2dip }
{ $subsection 3dip }
{ $subsection 4dip }
-"The slip combinators invoke a quotation further down on the stack. They are most useful for implementing other combinators:"
-{ $subsection slip }
-{ $subsection 2slip }
-{ $subsection 3slip }
"The keep combinators invoke a quotation which takes a number of values off the stack, and then they restore those values:"
{ $subsection keep }
{ $subsection 2keep }
ARTICLE: "dataflow-combinators" "Data flow combinators"
"Data flow combinators pass values between quotations:"
-{ $subsection "slip-keep-combinators" }
+{ $subsection "retainstack-combinators" }
{ $subsection "cleave-combinators" }
{ $subsection "spread-combinators" }
{ $subsection "apply-combinators" }
{ $description "Calls the quotation with successive blocks of data, until the current " { $link input-stream } " is exhausted." } ;
HELP: stream-contents
-{ $values { "stream" "an input stream" } { "seq" "a string, byte array or " { $link f } } }
-{ $description "Reads the entire contents of a stream. If the stream is empty, outputs " { $link f } "." }
+{ $values { "stream" "an input stream" } { "seq" { $or string byte-array } } }
+{ $description "Reads all elements in the given stream until the stream is exhausted. The type of the sequence depends on the stream's element type." }
$io-error ;
HELP: contents
-{ $values { "seq" "a string, byte array or " { $link f } } }
-{ $description "Reads the entire contents of a the stream stored in " { $link input-stream } ". If the stream is empty, outputs " { $link f } "." }
+{ $values { "seq" { $or string byte-array } } }
+{ $description "Reads all elements in the " { $link input-stream } " until the stream is exhausted. The type of the sequence depends on the stream's element type." }
$io-error ;
ARTICLE: "stream-protocol" "Stream protocol"
! Copyright (C) 2003, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: hashtables generic kernel math namespaces make sequences
-continuations destructors assocs ;
+continuations destructors assocs combinators ;
IN: io
SYMBOLS: +byte+ +character+ ;
GENERIC: stream-nl ( stream -- )
ERROR: bad-seek-type type ;
+
SINGLETONS: seek-absolute seek-relative seek-end ;
+
GENERIC: stream-seek ( n seek-type stream -- )
: stream-print ( str stream -- ) [ stream-write ] keep stream-nl ;
: bl ( -- ) " " write ;
-: stream-lines ( stream -- seq )
- [ [ readln dup ] [ ] produce nip ] with-input-stream ;
-
-: lines ( -- seq )
- input-stream get stream-lines ;
-
<PRIVATE
: each-morsel ( handler: ( data -- ) reader: ( -- data ) -- )
[ dup ] compose swap while drop ; inline
+: stream-element-exemplar ( type -- exemplar )
+ {
+ { +byte+ [ B{ } ] }
+ { +character+ [ "" ] }
+ } case ;
+
+: element-exemplar ( -- exemplar )
+ input-stream get
+ stream-element-type
+ stream-element-exemplar ;
+
PRIVATE>
: each-line ( quot -- )
[ readln ] each-morsel ; inline
-: stream-contents ( stream -- seq )
- [
- [ 65536 read-partial dup ] [ ] produce nip concat f like
- ] with-input-stream ;
+: lines ( -- seq )
+ [ ] accumulator [ each-line ] dip { } like ;
+
+: stream-lines ( stream -- seq )
+ [ lines ] with-input-stream ;
: contents ( -- seq )
- input-stream get stream-contents ;
+ [ 65536 read-partial dup ] [ ] produce nip
+ element-exemplar concat-as ;
+
+: stream-contents ( stream -- seq )
+ [ contents ] with-input-stream ;
: each-block ( quot: ( block -- ) -- )
[ 8192 read-partial ] each-morsel ; inline
USING: tools.test io.streams.byte-array io.encodings.binary
io.encodings.utf8 io kernel arrays strings namespaces ;
+[ B{ } ] [ B{ } binary [ contents ] with-byte-reader ] unit-test
[ B{ 1 2 3 } ] [ binary [ B{ 1 2 3 } write ] with-byte-writer ] unit-test
[ B{ 1 2 3 } ] [ { 1 2 3 } binary [ 3 read ] with-byte-reader ] unit-test
{ $description "Calls a quotation with an empty call stack. If the quotation returns, Factor will exit.." }
{ $notes "Used to implement " { $link "threads" } "." } ;
-HELP: slip
-{ $values { "quot" quotation } { "x" object } }
-{ $description "Calls a quotation while hiding the top of the stack." } ;
-
-HELP: 2slip
-{ $values { "quot" quotation } { "x" object } { "y" object } }
-{ $description "Calls a quotation while hiding the top two stack elements." } ;
-
-HELP: 3slip
-{ $values { "quot" quotation } { "x" object } { "y" object } { "z" object } }
-{ $description "Calls a quotation while hiding the top three stack elements." } ;
-
HELP: keep
{ $values { "quot" { $quotation "( x -- ... )" } } { "x" object } }
{ $description "Call a quotation with a value on the stack, restoring the value when the quotation returns." }
[ 2 ] [ f 2 xor ] unit-test
[ f ] [ f f xor ] unit-test
-[ slip ] must-fail
+[ dip ] must-fail
[ ] [ :c ] unit-test
-[ 1 slip ] must-fail
+[ 1 [ call ] dip ] must-fail
[ ] [ :c ] unit-test
-[ 1 2 slip ] must-fail
+[ 1 2 [ call ] dip ] must-fail
[ ] [ :c ] unit-test
-[ 1 2 3 slip ] must-fail
-[ ] [ :c ] unit-test
-
-
-[ 5 ] [ [ 2 2 + ] 1 slip + ] unit-test
+[ 5 ] [ 1 [ 2 2 + ] dip + ] unit-test
[ [ ] keep ] must-fail
: ?if ( default cond true false -- )
pick [ drop [ drop ] 2dip call ] [ 2nip call ] if ; inline
-! Slippers and dippers.
+! Dippers.
! Not declared inline because the compiler special-cases them
-: slip ( quot x -- x )
- #! 'slip' and 'dip' can be defined in terms of each other
- #! because the JIT special-cases a 'dip' preceeded by
- #! a literal quotation.
- [ call ] dip ;
+: dip ( x quot -- x ) swap [ call ] dip ;
-: 2slip ( quot x y -- x y )
- #! '2slip' and '2dip' can be defined in terms of each other
- #! because the JIT special-cases a '2dip' preceeded by
- #! a literal quotation.
- [ call ] 2dip ;
+: 2dip ( x y quot -- x y ) -rot [ call ] 2dip ;
-: 3slip ( quot x y z -- x y z )
- #! '3slip' and '3dip' can be defined in terms of each other
- #! because the JIT special-cases a '3dip' preceeded by
- #! a literal quotation.
- [ call ] 3dip ;
-
-: dip ( x quot -- x ) swap slip ;
-
-: 2dip ( x y quot -- x y ) -rot 2slip ;
-
-: 3dip ( x y z quot -- x y z ) -roll 3slip ;
+: 3dip ( x y z quot -- x y z ) -roll [ call ] 3dip ;
: 4dip ( w x y z quot -- w x y z ) swap [ 3dip ] dip ; inline
! Keepers
-: keep ( x quot -- x ) over slip ; inline
+: keep ( x quot -- x ) over [ call ] dip ; inline
: 2keep ( x y quot -- x y ) [ 2dup ] dip 2dip ; inline
M: curry call uncurry call ;
-M: compose call uncompose slip call ;
+M: compose call uncompose [ call ] dip call ;
M: wrapper equal?
over wrapper? [ [ wrapped>> ] bi@ = ] [ 2drop f ] if ;
{ $description "Concatenates a sequence of sequences together into one sequence. If " { $snippet "seq" } " is empty, outputs " { $snippet "{ }" } ", otherwise the resulting sequence is of the same class as the first element of " { $snippet "seq" } "." }
{ $errors "Throws an error if one of the sequences in " { $snippet "seq" } " contains elements not permitted in sequences of the same class as the first element of " { $snippet "seq" } "." } ;
+HELP: concat-as
+{ $values { "seq" sequence } { "exemplar" sequence } { "newseq" sequence } }
+{ $description "Concatenates a sequence of sequences together into one sequence with the same type as " { $snippet "exemplar" } "." }
+{ $errors "Throws an error if one of the sequences in " { $snippet "seq" } " contains elements not permitted in sequences of the same class as " { $snippet "exemplar" } "." } ;
+
HELP: join
{ $values { "seq" sequence } { "glue" sequence } { "newseq" sequence } }
{ $description "Concatenates a sequence of sequences together into one sequence, placing a copy of " { $snippet "glue" } " between each pair of sequences. The resulting sequence is of the same class as " { $snippet "glue" } "." }
+{ $notes "If the " { $snippet "glue" } " sequence is empty, this word calls " { $link concat-as } "." }
{ $errors "Throws an error if one of the sequences in " { $snippet "seq" } " contains elements not permitted in sequences of the same class as " { $snippet "glue" } "." } ;
-{ join concat } related-words
+{ join concat concat-as } related-words
HELP: peek
{ $values { "seq" sequence } { "elt" object } }
: sum-lengths ( seq -- n )
0 [ length + ] reduce ;
+: concat-as ( seq exemplar -- newseq )
+ swap [ { } ] [
+ [ sum-lengths over new-resizable ] keep
+ [ over push-all ] each
+ ] if-empty swap like ;
+
: concat ( seq -- newseq )
- [ { } ] [
- [ sum-lengths ] keep
- [ first new-resizable ] keep
- [ [ over push-all ] each ] keep
- first like
- ] if-empty ;
+ [ { } ] [ dup first concat-as ] if-empty ;
<PRIVATE
PRIVATE>
: join ( seq glue -- newseq )
- [
- 2dup joined-length over new-resizable [
- [ [ push-all ] 2curry ] [ [ nip push-all ] 2curry ] 2bi
- interleave
- ] keep
- ] keep like ;
+ dup empty? [ concat-as ] [
+ [
+ 2dup joined-length over new-resizable [
+ [ [ push-all ] 2curry ] [ [ nip push-all ] 2curry ] 2bi
+ interleave
+ ] keep
+ ] keep like
+ ] if ;
: padding ( seq n elt quot -- newseq )
[
{ deploy-math? t }
{ deploy-threads? t }
{ deploy-reflection 3 }
- { deploy-compiler? t }
{ deploy-unicode? t }
{ deploy-io 3 }
{ "stop-after-last-window?" t }
{ deploy-word-props? f }
{ deploy-ui? f }
{ deploy-io 1 }
- { deploy-compiler? t }
{ deploy-reflection 1 }
{ "stop-after-last-window?" t }
{ deploy-unicode? f }
{ deploy-word-defs? f }
{ deploy-word-props? f }
{ deploy-math? f }
- { deploy-compiler? t }
{ deploy-ui? f }
{ deploy-c-types? f }
{ "stop-after-last-window?" t }
{ deploy-io 3 }
{ deploy-word-defs? f }
{ deploy-reflection 1 }
- { deploy-compiler? t }
{ deploy-c-types? f }
{ deploy-name "Bunny" }
{ deploy-word-props? f }
{ deploy-ui? t }
{ deploy-io 1 }
{ deploy-reflection 1 }
- { deploy-compiler? t }
{ deploy-math? t }
{ deploy-word-props? f }
{ deploy-c-types? f }
{ deploy-unicode? f }
{ deploy-c-types? f }
{ deploy-word-defs? f }
- { deploy-compiler? t }
{ deploy-io 2 }
{ deploy-reflection 1 }
{ "stop-after-last-window?" t }
: 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
+USING: math.primes kernel math math.functions namespaces
sequences accessors ;
IN: crypto.rsa
CONSTANT: public-key 65537
: rsa-primes ( numbits -- p q )
- 2/ 2 unique-primes first2 ;
+ 2/ 2 swap unique-primes first2 ;
: modulus-phi ( numbits -- n phi )
#! Loop until phi is not divisible by the public key.
+++ /dev/null
-Doug Coleman
+++ /dev/null
-USING: crypto.timing kernel tools.test system math ;
-IN: crypto.timing.tests
-
-[ t ] [ millis [ ] 1000 with-timing millis swap - 1000 >= ] unit-test
+++ /dev/null
-! Copyright (C) 2008 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math threads system calendar ;
-IN: crypto.timing
-
-: with-timing ( quot n -- )
- #! force the quotation to execute in, at minimum, n milliseconds
- millis 2slip millis - + milliseconds sleep ; inline
{ deploy-math? t }
{ deploy-name "drills" }
{ deploy-ui? t }
- { deploy-compiler? t }
{ "stop-after-last-window?" t }
{ deploy-word-props? f }
{ deploy-c-types? f }
{ deploy-ui? t }
{ deploy-io 1 }
{ deploy-reflection 3 }
- { deploy-compiler? t }
{ deploy-math? t }
{ deploy-word-props? f }
{ deploy-c-types? f }
--- /dev/null
+Diego Martinelli
--- /dev/null
+USING: help.markup help.syntax kernel math ;
+IN: hashcash
+
+ARTICLE: "hashcash" "Hashcash"
+"Hashcash is a denial-of-service counter measure tool."
+$nl
+"A hashcash stamp constitutes a proof-of-work which takes a parameterizable amount of work to compute for the sender. The recipient can verify received hashcash stamps efficiently."
+$nl
+"More info on hashcash:"
+$nl
+{ $url "http://www.hashcash.org/" } $nl
+{ $url "http://en.wikipedia.org/wiki/Hashcash" } $nl
+{ $url "http://www.ibm.com/developerworks/linux/library/l-hashcash.html?ca=dgr-lnxw01HashCash" } $nl
+"This library provide basic utilities for hashcash creation and validation."
+$nl
+"Creating stamps:"
+{ $subsection mint }
+{ $subsection mint* }
+"Validation:"
+{ $subsection check-stamp }
+"Hashcash tuple and constructor:"
+{ $subsection hashcash }
+{ $subsection <hashcash> }
+"Utilities:"
+{ $subsection salt } ;
+
+{ mint mint* <hashcash> check-stamp salt } related-words
+
+HELP: mint
+{ $values { "resource" "a string" } { "stamp" "generated stamp" } }
+{ $description "This word generate a valid stamp with default parameters and the specified resource." } ;
+
+HELP: mint*
+{ $values { "tuple" "a tuple" } { "stamp" "generated stamp" } }
+{ $description "As " { $snippet "mint" } " but it takes an hashcash tuple as a parameter." } ;
+
+HELP: check-stamp
+{ $values { "stamp" "a string" } { "?" boolean } }
+{ $description "Check for stamp's validity. Only supports hashcash version 1." } ;
+
+HELP: salt
+{ $values { "length" integer } { "salted" "a string" } }
+{ $description "It generates a random string of " { $snippet "length" } " characters." } ;
+
+HELP: <hashcash>
+{ $values { "tuple" object } }
+{ $description "It fill an hashcash tuple with the default values: 1 as hashcash version, 20 as bits, today's date as date and a random 8 character long salt" } ;
+
+HELP: hashcash
+{ $class-description "An hashcash object. An hashcash have the following slots:"
+ { $table
+ { { $slot "version" } "The version number. Only version 1 is supported." }
+ { { $slot "bits" } "The claimed bit value." }
+ { { $slot "date" } "The date a stamp was minted." }
+ { { $slot "resource" } "The resource for which a stamp is minted." }
+ { { $slot "ext" } "Extensions that a specialized application may want." }
+ { { $slot "salt" } "A random salt." }
+ { { $slot "suffix" } "The computed suffix. This is supposed to be manipulated by the library." }
+ }
+} ;
--- /dev/null
+USING: accessors sequences tools.test hashcash ;
+
+[ t ] [ "foo@bar.com" mint check-stamp ] unit-test
+
+[ t ] [
+ <hashcash>
+ "foo@bar.com" >>resource
+ 16 >>bits
+ mint* check-stamp ] unit-test
+
+[ t ] [
+ "1:20:040927:mertz@gnosis.cx::odVZhQMP:7ca28" check-stamp
+] unit-test
+
+[ 8 ] [ 8 salt length ] unit-test
--- /dev/null
+! Copyright (C) 2009 Diego Martinelli.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors byte-arrays calendar calendar.format
+checksums checksums.openssl classes.tuple
+fry kernel make math math.functions math.parser math.ranges
+present random sequences splitting strings syntax ;
+IN: hashcash
+
+! Hashcash implementation
+! Reference materials listed below:
+!
+! http://hashcash.org
+! http://en.wikipedia.org/wiki/Hashcash
+! http://www.ibm.com/developerworks/linux/library/l-hashcash.html?ca=dgr-lnxw01HashCash
+!
+! And the reference implementation (in python):
+! http://www.gnosis.cx/download/gnosis/util/hashcash.py
+
+<PRIVATE
+
+! Return a string with today's date in the form YYMMDD
+: get-date ( -- str )
+ now [ year>> 100 mod pad-00 ]
+ [ month>> pad-00 ]
+ [ day>> pad-00 ] tri 3append ;
+
+! Random salt is formed by ascii characters
+! between 33 and 126
+: available-chars ( -- seq )
+ 33 126 [a,b] [ CHAR: : = not ] filter ;
+
+PRIVATE>
+
+! Generate a 'length' long random salt
+: salt ( length -- salted )
+ available-chars '[ _ random ] "" replicate-as ;
+
+TUPLE: hashcash version bits date resource ext salt suffix ;
+
+: <hashcash> ( -- tuple )
+ hashcash new
+ 1 >>version
+ 20 >>bits
+ get-date >>date
+ 8 salt >>salt ;
+
+M: hashcash string>>
+ tuple-slots [ present ] map ":" join ;
+
+<PRIVATE
+
+: sha1-checksum ( str -- bytes )
+ openssl-sha1 checksum-bytes ; inline
+
+: set-suffix ( tuple guess -- tuple )
+ >hex >>suffix ;
+
+: get-bits ( bytes -- str )
+ [ >bin 8 CHAR: 0 pad-head ] { } map-as concat ;
+
+: checksummed-bits ( tuple -- relevant-bits )
+ dup string>> sha1-checksum
+ swap bits>> 8 / ceiling head get-bits ;
+
+: all-char-zero? ( seq -- ? )
+ [ CHAR: 0 = ] all? ; inline
+
+: valid-guess? ( checksum tuple -- ? )
+ bits>> head all-char-zero? ;
+
+: (mint) ( tuple counter -- tuple )
+ 2dup set-suffix checksummed-bits pick
+ valid-guess? [ drop ] [ 1+ (mint) ] if ;
+
+PRIVATE>
+
+: mint* ( tuple -- stamp )
+ 0 (mint) string>> ;
+
+: mint ( resource -- stamp )
+ <hashcash>
+ swap >>resource
+ mint* ;
+
+! One might wanna add check based on the date,
+! passing a 'good-until' duration param
+: check-stamp ( stamp -- ? )
+ dup ":" split [ sha1-checksum get-bits ] dip
+ second string>number head all-char-zero? ;
+
--- /dev/null
+Hashcash implementation
USING: tools.deploy.config ;
H{
- { deploy-threads? t }
+ { deploy-ui? t }
+ { deploy-reflection 1 }
+ { deploy-unicode? f }
{ deploy-math? t }
- { deploy-name "Hello world" }
+ { deploy-io 2 }
{ deploy-c-types? f }
+ { deploy-name "Hello world" }
{ deploy-word-props? f }
- { deploy-io 2 }
- { deploy-ui? t }
- { "stop-after-last-window?" t }
{ deploy-word-defs? f }
- { deploy-compiler? t }
- { deploy-reflection 1 }
+ { "stop-after-last-window?" t }
+ { deploy-threads? t }
}
{ deploy-word-defs? f }
{ deploy-reflection 1 }
{ deploy-word-props? f }
- { deploy-compiler? t }
{ deploy-threads? t }
{ deploy-unicode? f }
{ "stop-after-last-window?" t }
H{
{ deploy-unicode? f }
{ deploy-ui? f }
- { deploy-compiler? t }
{ deploy-name "Hello world (console)" }
{ deploy-io 2 }
{ deploy-threads? f }
: genre ( id3 -- string/f )
"TCON" find-id3-frame parse-genre ;
-: find-mp3s ( path -- seq )
- [ >lower ".mp3" tail? ] find-all-files ;
+: find-mp3s ( path -- seq ) ".mp3" find-by-extension ;
ERROR: id3-parse-error path error ;
{ deploy-ui? t }
{ deploy-io 1 }
{ deploy-reflection 1 }
- { deploy-compiler? t }
{ deploy-math? t }
{ deploy-word-props? f }
{ deploy-c-types? f }
{ deploy-math? t }
{ "stop-after-last-window?" t }
{ deploy-ui? t }
- { deploy-compiler? t }
}
io.directories.hierarchy io.launcher io.encodings.utf8 prettyprint
combinators.short-circuit parser combinators calendar
calendar.format arrays mason.config locals system debugger fry
-continuations ;
+continuations strings ;
IN: mason.common
SYMBOL: current-git-id
-ERROR: output-process-error output process ;
+ERROR: output-process-error { output string } { process process } ;
M: output-process-error error.
[ "Process:" print process>> . nl ]
! See http://factorcode.org/license.txt for BSD license.
USING: arrays accessors io io.sockets io.encodings.utf8 io.files
io.launcher kernel make mason.config mason.common mason.email
-mason.twitter namespaces sequences prettyprint ;
+mason.twitter namespaces sequences prettyprint fry ;
IN: mason.notify
: status-notify ( input-file args -- )
target-cpu get ,
target-os get ,
] { } make prepend
- <process>
- swap >>command
- swap [ +closed+ ] unless* >>stdin
- try-output-process
+ [ 5 ] 2dip '[
+ <process>
+ _ >>command
+ _ [ +closed+ ] unless* >>stdin
+ try-output-process
+ ] retry
] [ 2drop ] if ;
: notify-begin-build ( git-id -- )
[ 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: tools.deploy.config ;
H{
- { deploy-threads? t }
+ { deploy-ui? t }
+ { deploy-reflection 1 }
+ { deploy-unicode? f }
{ deploy-math? t }
- { deploy-name "Maze" }
+ { deploy-io 2 }
{ deploy-c-types? f }
+ { deploy-name "Maze" }
{ deploy-word-props? f }
- { deploy-io 2 }
- { deploy-ui? t }
- { "stop-after-last-window?" t }
{ deploy-word-defs? f }
- { deploy-compiler? t }
- { deploy-reflection 1 }
+ { "stop-after-last-window?" t }
+ { deploy-threads? t }
}
{ "stop-after-last-window?" t }
{ deploy-ui? t }
{ deploy-reflection 1 }
- { deploy-compiler? t }
{ deploy-name "Merger" }
{ deploy-word-props? f }
{ deploy-threads? t }
{ deploy-ui? t }
{ deploy-io 1 }
{ deploy-reflection 1 }
- { deploy-compiler? t }
{ deploy-math? t }
{ deploy-word-props? f }
{ deploy-c-types? f }
{ deploy-ui? t }
{ deploy-io 1 }
{ deploy-reflection 1 }
- { deploy-compiler? t }
{ deploy-math? t }
{ deploy-word-props? f }
{ deploy-c-types? f }
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 ;
! 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) 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 ;
+USING: kernel math sequences namespaces math.primes
+math.functions accessors random ;
IN: random.blum-blum-shub
! Blum Blum Shub, n = pq, x_i+1 = x_i ^ 2 mod n
--- /dev/null
+Bruno Deferrari
--- /dev/null
+Bruno Deferrari
--- /dev/null
+! Copyright (C) 2009 Bruno Deferrari
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test redis.command-writer io.streams.string ;
+IN: redis.command-writer.tests
+
+#! Connection
+[ "QUIT\r\n" ] [ [ quit ] with-string-writer ] unit-test
+
+[ "PING\r\n" ] [ [ ping ] with-string-writer ] unit-test
+
+[ "AUTH password\r\n" ] [ [ "password" auth ] with-string-writer ] unit-test
+
+#! String values
+[ "SET key 3\r\nfoo\r\n" ] [ [ "foo" "key" set ] with-string-writer ] unit-test
+
+[ "GET key\r\n" ] [ [ "key" get ] with-string-writer ] unit-test
+
+[ "GETSET key 3\r\nfoo\r\n" ] [
+ [ "foo" "key" getset ] with-string-writer
+] unit-test
+
+[ "MGET key1 key2 key3\r\n" ] [
+ [ { "key1" "key2" "key3" } mget ] with-string-writer
+] unit-test
+
+[ "SETNX key 3\r\nfoo\r\n" ] [
+ [ "foo" "key" setnx ] with-string-writer
+] unit-test
+
+[ "INCR key\r\n" ] [ [ "key" incr ] with-string-writer ] unit-test
+
+[ "INCRBY key 7\r\n" ] [ [ 7 "key" incrby ] with-string-writer ] unit-test
+
+[ "DECR key\r\n" ] [ [ "key" decr ] with-string-writer ] unit-test
+
+[ "DECRBY key 7\r\n" ] [ [ 7 "key" decrby ] with-string-writer ] unit-test
+
+[ "EXISTS key\r\n" ] [ [ "key" exists ] with-string-writer ] unit-test
+
+[ "DEL key\r\n" ] [ [ "key" del ] with-string-writer ] unit-test
+
+[ "TYPE key\r\n" ] [ [ "key" type ] with-string-writer ] unit-test
+
+#! Key space
+[ "KEYS pat*\r\n" ] [ [ "pat*" keys ] with-string-writer ] unit-test
+
+[ "RANDOMKEY\r\n" ] [ [ randomkey ] with-string-writer ] unit-test
+
+[ "RENAME key newkey\r\n" ] [
+ [ "newkey" "key" rename ] with-string-writer
+] unit-test
+
+[ "RENAMENX key newkey\r\n" ] [
+ [ "newkey" "key" renamenx ] with-string-writer
+] unit-test
+
+[ "DBSIZE\r\n" ] [ [ dbsize ] with-string-writer ] unit-test
+
+[ "EXPIRE key 7\r\n" ] [ [ 7 "key" expire ] with-string-writer ] unit-test
+
+#! Lists
+[ "RPUSH key 3\r\nfoo\r\n" ] [ [ "foo" "key" rpush ] with-string-writer ] unit-test
+
+[ "LPUSH key 3\r\nfoo\r\n" ] [ [ "foo" "key" lpush ] with-string-writer ] unit-test
+
+[ "LLEN key\r\n" ] [ [ "key" llen ] with-string-writer ] unit-test
+
+[ "LRANGE key 5 9\r\n" ] [ [ 5 9 "key" lrange ] with-string-writer ] unit-test
+
+[ "LTRIM key 5 9\r\n" ] [ [ 5 9 "key" ltrim ] with-string-writer ] unit-test
+
+[ "LINDEX key 7\r\n" ] [ [ 7 "key" lindex ] with-string-writer ] unit-test
+
+[ "LSET key 0 3\r\nfoo\r\n" ] [ [ "foo" 0 "key" lset ] with-string-writer ] unit-test
+
+[ "LREM key 1 3\r\nfoo\r\n" ] [ [ "foo" 1 "key" lrem ] with-string-writer ] unit-test
+
+[ "LPOP key\r\n" ] [ [ "key" lpop ] with-string-writer ] unit-test
+
+[ "RPOP key\r\n" ] [ [ "key" rpop ] with-string-writer ] unit-test
+
+#! Sets
+[ "SADD key 3\r\nfoo\r\n" ] [ [ "foo" "key" sadd ] with-string-writer ] unit-test
+
+[ "SREM key 3\r\nfoo\r\n" ] [ [ "foo" "key" srem ] with-string-writer ] unit-test
+
+[ "SMOVE srckey dstkey 3\r\nfoo\r\n" ] [
+ [ "foo" "dstkey" "srckey" smove ] with-string-writer
+] unit-test
+
+[ "SCARD key\r\n" ] [ [ "key" scard ] with-string-writer ] unit-test
+
+[ "SISMEMBER key 3\r\nfoo\r\n" ] [
+ [ "foo" "key" sismember ] with-string-writer
+] unit-test
+
+[ "SINTER key1 key2 key3\r\n" ] [
+ [ { "key1" "key2" "key3" } sinter ] with-string-writer
+] unit-test
+
+[ "SINTERSTORE dstkey key1 key2 key3\r\n" ] [
+ [ { "key1" "key2" "key3" } "dstkey" sinterstore ] with-string-writer
+] unit-test
+
+[ "SUNION key1 key2 key3\r\n" ] [
+ [ { "key1" "key2" "key3" } sunion ] with-string-writer
+] unit-test
+
+[ "SUNIONSTORE dstkey key1 key2 key3\r\n" ] [
+ [ { "key1" "key2" "key3" } "dstkey" sunionstore ] with-string-writer
+] unit-test
+
+[ "SMEMBERS key\r\n" ] [ [ "key" smembers ] with-string-writer ] unit-test
+
+#! Multiple db
+[ "SELECT 2\r\n" ] [ [ 2 select ] with-string-writer ] unit-test
+
+[ "MOVE key 2\r\n" ] [ [ 2 "key" move ] with-string-writer ] unit-test
+
+[ "FLUSHDB\r\n" ] [ [ flushdb ] with-string-writer ] unit-test
+
+[ "FLUSHALL\r\n" ] [ [ flushall ] with-string-writer ] unit-test
+
+#! Sorting
+
+#! Persistence control
+[ "SAVE\r\n" ] [ [ save ] with-string-writer ] unit-test
+
+[ "BGSAVE\r\n" ] [ [ bgsave ] with-string-writer ] unit-test
+
+[ "LASTSAVE\r\n" ] [ [ lastsave ] with-string-writer ] unit-test
+
+[ "SHUTDOWN\r\n" ] [ [ shutdown ] with-string-writer ] unit-test
+
+#! Remote server control
+[ "INFO\r\n" ] [ [ info ] with-string-writer ] unit-test
+
+[ "MONITOR\r\n" ] [ [ monitor ] with-string-writer ] unit-test
--- /dev/null
+! Copyright (C) 2009 Bruno Deferrari
+! See http://factorcode.org/license.txt for BSD license.
+USING: io io.crlf kernel math.parser sequences strings interpolate locals ;
+IN: redis.command-writer
+
+<PRIVATE
+
+GENERIC: write-value-with-length ( value -- )
+
+M: string write-value-with-length
+ [ length number>string write crlf ]
+ [ write ] bi ;
+
+: space ( -- ) CHAR: space write1 ;
+
+: write-key/value ( value key -- )
+ write space
+ write-value-with-length ;
+
+: write-key/integer ( integer key -- )
+ write space
+ number>string write ;
+
+PRIVATE>
+
+#! Connection
+: quit ( -- ) "QUIT" write crlf ;
+: ping ( -- ) "PING" write crlf ;
+: auth ( password -- ) "AUTH " write write crlf ;
+
+#! String values
+: set ( value key -- ) "SET " write write-key/value crlf ;
+: get ( key -- ) "GET " write write crlf ;
+: getset ( value key -- ) "GETSET " write write-key/value crlf ;
+: mget ( keys -- ) "MGET " write " " join write crlf ;
+: setnx ( value key -- ) "SETNX " write write-key/value crlf ;
+: incr ( key -- ) "INCR " write write crlf ;
+: incrby ( integer key -- ) "INCRBY " write write-key/integer crlf ;
+: decr ( key -- ) "DECR " write write crlf ;
+: decrby ( integer key -- ) "DECRBY " write write-key/integer crlf ;
+: exists ( key -- ) "EXISTS " write write crlf ;
+: del ( key -- ) "DEL " write write crlf ;
+: type ( key -- ) "TYPE " write write crlf ;
+
+#! Key space
+: keys ( pattern -- ) "KEYS " write write crlf ;
+: randomkey ( -- ) "RANDOMKEY" write crlf ;
+: rename ( newkey key -- ) "RENAME " write write space write crlf ;
+: renamenx ( newkey key -- ) "RENAMENX " write write space write crlf ;
+: dbsize ( -- ) "DBSIZE" write crlf ;
+: expire ( integer key -- ) "EXPIRE " write write-key/integer crlf ;
+
+#! Lists
+: rpush ( value key -- ) "RPUSH " write write-key/value crlf ;
+: lpush ( value key -- ) "LPUSH " write write-key/value crlf ;
+: llen ( key -- ) "LLEN " write write crlf ;
+: lrange ( start end key -- )
+ "LRANGE " write write [ space number>string write ] bi@ crlf ;
+: ltrim ( start end key -- )
+ "LTRIM " write write [ space number>string write ] bi@ crlf ;
+: lindex ( integer key -- ) "LINDEX " write write-key/integer crlf ;
+: lset ( value index key -- )
+ "LSET " write write-key/integer space write-value-with-length crlf ;
+: lrem ( value amount key -- )
+ "LREM " write write-key/integer space write-value-with-length crlf ;
+: lpop ( key -- ) "LPOP " write write crlf ;
+: rpop ( key -- ) "RPOP " write write crlf ;
+
+#! Sets
+: sadd ( member key -- )
+ "SADD " write write space write-value-with-length crlf ;
+: srem ( member key -- )
+ "SREM " write write space write-value-with-length crlf ;
+: smove ( member newkey key -- )
+ "SMOVE " write write space write space write-value-with-length crlf ;
+: scard ( key -- ) "SCARD " write write crlf ;
+: sismember ( member key -- )
+ "SISMEMBER " write write space write-value-with-length crlf ;
+: sinter ( keys -- ) "SINTER " write " " join write crlf ;
+: sinterstore ( keys destkey -- )
+ "SINTERSTORE " write write space " " join write crlf ;
+: sunion ( keys -- ) "SUNION " write " " join write crlf ;
+: sunionstore ( keys destkey -- )
+ "SUNIONSTORE " write write " " join space write crlf ;
+: smembers ( key -- ) "SMEMBERS " write write crlf ;
+
+#! Multiple db
+: select ( integer -- ) "SELECT " write number>string write crlf ;
+: move ( integer key -- ) "MOVE " write write-key/integer crlf ;
+: flushdb ( -- ) "FLUSHDB" write crlf ;
+: flushall ( -- ) "FLUSHALL" write crlf ;
+
+#! Sorting
+! sort
+
+#! Persistence control
+: save ( -- ) "SAVE" write crlf ;
+: bgsave ( -- ) "BGSAVE" write crlf ;
+: lastsave ( -- ) "LASTSAVE" write crlf ;
+: shutdown ( -- ) "SHUTDOWN" write crlf ;
+
+#! Remote server control
+: info ( -- ) "INFO" write crlf ;
+: monitor ( -- ) "MONITOR" write crlf ;
--- /dev/null
+Definitions of messages sent to Redis
--- /dev/null
+! Copyright (C) 2009 Bruno Deferrari
+! See http://factorcode.org/license.txt for BSD license.
+USING: io redis.response-parser redis.command-writer ;
+IN: redis
+
+#! Connection
+: redis-quit ( -- ) quit flush ;
+: redis-ping ( -- response ) ping flush read-response ;
+: redis-auth ( password -- response ) auth flush read-response ;
+
+#! String values
+: redis-set ( value key -- response ) set flush read-response ;
+: redis-get ( key -- response ) get flush read-response ;
+: redis-getset ( value key -- response ) getset flush read-response ;
+: redis-mget ( keys -- response ) mget flush read-response ;
+: redis-setnx ( value key -- response ) setnx flush read-response ;
+: redis-incr ( key -- response ) incr flush read-response ;
+: redis-incrby ( integer key -- response ) incrby flush read-response ;
+: redis-decr ( key -- response ) decr flush read-response ;
+: redis-decrby ( integer key -- response ) decrby flush read-response ;
+: redis-exists ( key -- response ) exists flush read-response ;
+: redis-del ( key -- response ) del flush read-response ;
+: redis-type ( key -- response ) type flush read-response ;
+
+#! Key space
+: redis-keys ( pattern -- response ) keys flush read-response ;
+: redis-randomkey ( -- response ) randomkey flush read-response ;
+: redis-rename ( newkey key -- response ) rename flush read-response ;
+: redis-renamenx ( newkey key -- response ) renamenx flush read-response ;
+: redis-dbsize ( -- response ) dbsize flush read-response ;
+: redis-expire ( integer key -- response ) expire flush read-response ;
+
+#! Lists
+: redis-rpush ( value key -- response ) rpush flush read-response ;
+: redis-lpush ( value key -- response ) lpush flush read-response ;
+: redis-llen ( key -- response ) llen flush read-response ;
+: redis-lrange ( start end key -- response ) lrange flush read-response ;
+: redis-ltrim ( start end key -- response ) ltrim flush read-response ;
+: redis-lindex ( integer key -- response ) lindex flush read-response ;
+: redis-lset ( value index key -- response ) lset flush read-response ;
+: redis-lrem ( value amount key -- response ) lrem flush read-response ;
+: redis-lpop ( key -- response ) lpop flush read-response ;
+: redis-rpop ( key -- response ) rpop flush read-response ;
+
+#! Sets
+: redis-sadd ( member key -- response ) sadd flush read-response ;
+: redis-srem ( member key -- response ) srem flush read-response ;
+: redis-smove ( member newkey key -- response ) smove flush read-response ;
+: redis-scard ( key -- response ) scard flush read-response ;
+: redis-sismember ( member key -- response ) sismember flush read-response ;
+: redis-sinter ( keys -- response ) sinter flush read-response ;
+: redis-sinterstore ( keys destkey -- response ) sinterstore flush read-response ;
+: redis-sunion ( keys -- response ) sunion flush read-response ;
+: redis-sunionstore ( keys destkey -- response ) sunionstore flush read-response ;
+: redis-smembers ( key -- response ) smembers flush read-response ;
+
+#! Multiple db
+: redis-select ( integer -- response ) select flush read-response ;
+: redis-move ( integer key -- response ) move flush read-response ;
+: redis-flushdb ( -- response ) flushdb flush read-response ;
+: redis-flushall ( -- response ) flushall flush read-response ;
+
+#! Sorting
+! sort
+
+#! Persistence control
+: redis-save ( -- response ) save flush read-response ;
+: redis-bgsave ( -- response ) bgsave flush read-response ;
+: redis-lastsave ( -- response ) lastsave flush read-response ;
+: redis-shutdown ( -- response ) shutdown flush read-response ;
+
+#! Remote server control
+: redis-info ( -- response ) info flush read-response ;
+: redis-monitor ( -- response ) monitor flush read-response ;
--- /dev/null
+Bruno Deferrari
--- /dev/null
+! Copyright (C) 2009 Bruno Deferrari
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test redis.response-parser io.streams.string ;
+IN: redis.response-parser.tests
+
+[ 1 ] [ ":1\r\n" [ read-response ] with-string-reader ] unit-test
+
+[ "hello" ] [ "$5\r\nhello\r\n" [ read-response ] with-string-reader ] unit-test
+
+[ f ] [ "$-1\r\n" [ read-response ] with-string-reader ] unit-test
+
+[ { "hello" "world!" } ] [
+ "*2\r\n$5\r\nhello\r\n$6\r\nworld!\r\n" [ read-response ] with-string-reader
+] unit-test
+
+[ { "hello" f "world!" } ] [
+ "*3\r\n$5\r\nhello\r\n$-1\r\n$6\r\nworld!\r\n" [
+ read-response
+ ] with-string-reader
+] unit-test
--- /dev/null
+! Copyright (C) 2009 Bruno Deferrari
+! See http://factorcode.org/license.txt for BSD license.
+USING: combinators io kernel math math.parser sequences ;
+IN: redis.response-parser
+
+<PRIVATE
+
+: read-bulk ( n -- bytes ) dup 0 < [ drop f ] [ read 2 read drop ] if ;
+: (read-multi-bulk) ( -- bytes ) readln rest string>number read-bulk ;
+: read-multi-bulk ( n -- seq/f )
+ dup 0 < [ drop f ] [
+ iota [ drop (read-multi-bulk) ] map
+ ] if ;
+
+: handle-response ( string -- string ) ; ! TODO
+: handle-error ( string -- string ) ; ! TODO
+
+PRIVATE>
+
+: read-response ( -- response )
+ readln unclip {
+ { CHAR: : [ string>number ] }
+ { CHAR: + [ handle-response ] }
+ { CHAR: $ [ string>number read-bulk ] }
+ { CHAR: * [ string>number read-multi-bulk ] }
+ { CHAR: - [ handle-error ] }
+ } case ;
--- /dev/null
+Parser for responses sent by the Redis server
--- /dev/null
+Words for communicating with the Redis key-value database
{ 2keep 1 }\r
{ 2nip 2 }\r
{ 2over 4 }\r
- { 2slip 2 }\r
{ 2swap 3 }\r
{ 3curry 2 }\r
{ 3drop 1 }\r
{ 3dup 2 }\r
{ 3keep 3 }\r
- { 3slip 3 }\r
{ 4drop 2 }\r
{ 4dup 3 }\r
{ compose 1/2 }\r
{ nkeep 5 }\r
{ npick 6 }\r
{ nrot 5 }\r
- { nslip 5 }\r
{ ntuck 6 }\r
{ nwith 4 }\r
{ over 2 }\r
{ pick 4 }\r
{ roll 4 }\r
{ rot 3 }\r
- { slip 1 }\r
{ spin 3 }\r
{ swap 1 }\r
{ swapd 3 }\r
USING: tools.deploy.config ;
H{
+ { deploy-ui? t }
{ deploy-reflection 1 }
- { deploy-word-defs? f }
- { deploy-word-props? f }
- { deploy-name "Spheres" }
- { deploy-compiler? t }
+ { deploy-unicode? f }
{ deploy-math? t }
- { deploy-io 1 }
- { deploy-threads? t }
- { "stop-after-last-window?" t }
- { deploy-ui? t }
+ { deploy-io 2 }
{ deploy-c-types? f }
+ { deploy-name "Spheres" }
+ { deploy-word-props? f }
+ { deploy-word-defs? f }
+ { "stop-after-last-window?" t }
+ { deploy-threads? t }
}
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs deques dlists kernel spider ;
+USING: accessors assocs deques dlists kernel ;
IN: spider.unique-deque
TUPLE: todo-url url depth ;
: slurp-deque-when ( deque quot1 quot2: ( value -- ) -- )
pick deque-empty? [ 3drop ] [
- [ [ pop-front dup ] 2dip slip [ t ] compose [ drop f ] if ]
+ [ [ pop-front dup ] 2dip [ call ] dip [ t ] compose [ drop f ] if ]
[ roll [ slurp-deque-when ] [ 3drop ] if ] 3bi
] if ; inline recursive
{ deploy-word-defs? f }
{ deploy-name "Sudoku" }
{ deploy-threads? f }
- { deploy-compiler? t }
{ deploy-math? t }
{ deploy-c-types? f }
{ deploy-io 2 }
: 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
--- /dev/null
+USING: tools.deploy.config ;
+H{
+ { deploy-ui? t }
+ { deploy-reflection 1 }
+ { deploy-unicode? f }
+ { deploy-math? t }
+ { deploy-io 2 }
+ { deploy-c-types? f }
+ { deploy-name "Terrain" }
+ { deploy-word-props? f }
+ { deploy-word-defs? f }
+ { "stop-after-last-window?" t }
+ { deploy-threads? t }
+}
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;
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 game-worlds method-chains ;
+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 2048.0 / ]
-CONSTANT: FAR-PLANE 1.0
+CONSTANT: NEAR-PLANE $[ 1.0 1024.0 / ]
+CONSTANT: FAR-PLANE 2.0
CONSTANT: PLAYER-START-LOCATION { 0.5 0.51 0.5 }
-CONSTANT: PLAYER-HEIGHT $[ 3.0 1024.0 / ]
+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 16384.0 / ]
CONSTANT: FRICTION 0.95
-CONSTANT: COMPONENT-SCALE { 0.5 0.01 0.002 0.0 }
+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 / ] }
TUPLE: terrain-world < game-world
player
+ sky-image sky-texture sky-program
terrain terrain-segment terrain-texture terrain-program
terrain-vertex-buffer ;
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>>
[ 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_TO_EDGE glTexParameteri
GL_TEXTURE_2D GL_TEXTURE_WRAP_T GL_CLAMP_TO_EDGE glTexParameteri ;
+: sky-gradient ( world -- t )
+ game-loop>> tick-number>> SKY-PERIOD mod SKY-PERIOD /f ;
+: sky-theta ( world -- theta )
+ game-loop>> tick-number>> SKY-SPEED * ;
+
BEFORE: terrain-world begin-world
"2.0" { "GL_ARB_vertex_buffer_object" "GL_ARB_shader_objects" }
require-gl-version-or-extensions
GL_DEPTH_TEST glEnable
GL_TEXTURE_2D glEnable
GL_VERTEX_ARRAY glEnableClientState
- 0.5 0.5 0.5 1.0 glClearColor
PLAYER-START-LOCATION 0.0 0.0 { 0.0 0.0 0.0 } player boa >>player
+ <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
[ 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 ]
- [ "component_scale" glGetUniformLocation COMPONENT-SCALE first4 glUniform4f ] bi
- terrain-vertex-buffer>> draw-vertex-buffer
- ] with-gl-program ]
- tri gl-error ;
+ {
+ [ 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 } ;
USING: tools.deploy.config ;
H{
{ deploy-ui? t }
- { deploy-compiler? t }
{ deploy-threads? t }
{ deploy-word-props? f }
{ deploy-reflection 1 }
{ deploy-threads? f }
{ deploy-word-defs? f }
{ deploy-ui? f }
- { deploy-compiler? t }
{ deploy-word-props? f }
{ "stop-after-last-window?" t }
{ deploy-unicode? f }
projects / factor.git / commitdiff