Merge branch 'master' of git://factorcode.org/git/factor
Conflicts: basis/io/launcher/launcher.factordb4
Sam Anklesaria
commit
db76a7b98d
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien alien.strings alien.c-types alien.accessors alien.structs
|
||||
arrays words sequences math kernel namespaces fry libc cpu.architecture
|
||||
io.encodings.utf8 io.encodings.utf16n ;
|
||||
io.encodings.utf8 ;
|
||||
IN: alien.arrays
|
||||
|
||||
UNION: value-type array struct-type ;
|
||||
|
|
@ -95,5 +95,4 @@ M: string-type c-type-setter
|
|||
|
||||
{ "char*" utf8 } "char*" typedef
|
||||
"char*" "uchar*" typedef
|
||||
{ "char*" utf16n } "wchar_t*" typedef
|
||||
|
||||
|
|
|
|||
|
|
@ -259,8 +259,9 @@ M: long-long-type box-return ( type -- )
|
|||
[ 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 ]
|
||||
|
|
@ -409,8 +410,8 @@ CONSTANT: primitive-types
|
|||
"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
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@ IN: base64.tests
|
|||
|
||||
[ "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
|
||||
|
|
|
|||
|
|
@ -52,6 +52,9 @@ GENERIC: (eql?) ( obj1 obj2 -- ? )
|
|||
|
||||
M: integer (eql?) = ;
|
||||
|
||||
M: float (eql?)
|
||||
over float? [ fp-bitwise= ] [ 2drop f ] if ;
|
||||
|
||||
M: sequence (eql?)
|
||||
over sequence? [
|
||||
2dup [ length ] bi@ =
|
||||
|
|
@ -445,7 +448,6 @@ M: quotation '
|
|||
array>> '
|
||||
quotation [
|
||||
emit ! array
|
||||
f ' emit ! compiled
|
||||
f ' emit ! cached-effect
|
||||
f ' emit ! cache-counter
|
||||
0 emit ! xt
|
||||
|
|
|
|||
|
|
@ -12,6 +12,16 @@ SYMBOL: core-bootstrap-time
|
|||
|
||||
SYMBOL: bootstrap-time
|
||||
|
||||
: strip-encodings ( -- )
|
||||
os unix? [
|
||||
[
|
||||
P" resource:core/io/encodings/utf16/utf16.factor"
|
||||
P" resource:core/io/encodings/utf16n/utf16n.factor" [ forget ] bi@
|
||||
"io.encodings.utf16"
|
||||
"io.encodings.utf16n" [ child-vocabs [ forget-vocab ] each ] bi@
|
||||
] with-compilation-unit
|
||||
] when ;
|
||||
|
||||
: default-image-name ( -- string )
|
||||
vm file-name os windows? [ "." split1-last drop ] when
|
||||
".image" append resource-path ;
|
||||
|
|
@ -55,6 +65,8 @@ SYMBOL: bootstrap-time
|
|||
"math compiler threads help io tools ui ui.tools unicode handbook" "include" set-global
|
||||
"" "exclude" set-global
|
||||
|
||||
strip-encodings
|
||||
|
||||
(command-line) parse-command-line
|
||||
|
||||
! Set dll paths
|
||||
|
|
|
|||
|
|
@ -9,6 +9,9 @@ SYMBOL: bytes-read
|
|||
: calculate-pad-length ( length -- length' )
|
||||
[ 56 < 55 119 ? ] keep - ;
|
||||
|
||||
: calculate-pad-length-long ( length -- length' )
|
||||
[ 120 < 119 247 ? ] keep - ;
|
||||
|
||||
: pad-last-block ( str big-endian? length -- str )
|
||||
[
|
||||
[ % ] 2dip HEX: 80 ,
|
||||
|
|
|
|||
|
|
@ -1,7 +1,42 @@
|
|||
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
|
||||
|
|
|
|||
|
|
@ -2,12 +2,27 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel splitting grouping math sequences namespaces make
|
||||
io.binary math.bitwise checksums checksums.common
|
||||
sbufs strings ;
|
||||
sbufs strings combinators.smart math.ranges fry combinators
|
||||
accessors locals ;
|
||||
IN: checksums.sha2
|
||||
|
||||
<PRIVATE
|
||||
SINGLETON: sha-224
|
||||
SINGLETON: sha-256
|
||||
|
||||
SYMBOLS: vars M K H S0 S1 process-M word-size block-size ;
|
||||
INSTANCE: sha-224 checksum
|
||||
INSTANCE: sha-256 checksum
|
||||
|
||||
TUPLE: sha2-state K H word-size block-size ;
|
||||
|
||||
TUPLE: sha2-short < sha2-state ;
|
||||
|
||||
TUPLE: sha2-long < sha2-state ;
|
||||
|
||||
TUPLE: sha-224-state < sha2-short ;
|
||||
|
||||
TUPLE: sha-256-state < sha2-short ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
CONSTANT: a 0
|
||||
CONSTANT: b 1
|
||||
|
|
@ -18,13 +33,43 @@ CONSTANT: f 5
|
|||
CONSTANT: g 6
|
||||
CONSTANT: h 7
|
||||
|
||||
: initial-H-256 ( -- seq )
|
||||
CONSTANT: initial-H-224
|
||||
{
|
||||
HEX: c1059ed8 HEX: 367cd507 HEX: 3070dd17 HEX: f70e5939
|
||||
HEX: ffc00b31 HEX: 68581511 HEX: 64f98fa7 HEX: befa4fa4
|
||||
}
|
||||
|
||||
CONSTANT: initial-H-256
|
||||
{
|
||||
HEX: 6a09e667 HEX: bb67ae85 HEX: 3c6ef372 HEX: a54ff53a
|
||||
HEX: 510e527f HEX: 9b05688c HEX: 1f83d9ab HEX: 5be0cd19
|
||||
} ;
|
||||
}
|
||||
|
||||
: K-256 ( -- seq )
|
||||
CONSTANT: initial-H-384
|
||||
{
|
||||
HEX: cbbb9d5dc1059ed8
|
||||
HEX: 629a292a367cd507
|
||||
HEX: 9159015a3070dd17
|
||||
HEX: 152fecd8f70e5939
|
||||
HEX: 67332667ffc00b31
|
||||
HEX: 8eb44a8768581511
|
||||
HEX: db0c2e0d64f98fa7
|
||||
HEX: 47b5481dbefa4fa4
|
||||
}
|
||||
|
||||
CONSTANT: initial-H-512
|
||||
{
|
||||
HEX: 6a09e667f3bcc908
|
||||
HEX: bb67ae8584caa73b
|
||||
HEX: 3c6ef372fe94f82b
|
||||
HEX: a54ff53a5f1d36f1
|
||||
HEX: 510e527fade682d1
|
||||
HEX: 9b05688c2b3e6c1f
|
||||
HEX: 1f83d9abfb41bd6b
|
||||
HEX: 5be0cd19137e2179
|
||||
}
|
||||
|
||||
CONSTANT: K-256
|
||||
{
|
||||
HEX: 428a2f98 HEX: 71374491 HEX: b5c0fbcf HEX: e9b5dba5
|
||||
HEX: 3956c25b HEX: 59f111f1 HEX: 923f82a4 HEX: ab1c5ed5
|
||||
|
|
@ -42,62 +87,163 @@ CONSTANT: h 7
|
|||
HEX: 391c0cb3 HEX: 4ed8aa4a HEX: 5b9cca4f HEX: 682e6ff3
|
||||
HEX: 748f82ee HEX: 78a5636f HEX: 84c87814 HEX: 8cc70208
|
||||
HEX: 90befffa HEX: a4506ceb HEX: bef9a3f7 HEX: c67178f2
|
||||
} ;
|
||||
}
|
||||
|
||||
CONSTANT: K-384
|
||||
{
|
||||
|
||||
HEX: 428a2f98d728ae22 HEX: 7137449123ef65cd HEX: b5c0fbcfec4d3b2f HEX: e9b5dba58189dbbc
|
||||
HEX: 3956c25bf348b538 HEX: 59f111f1b605d019 HEX: 923f82a4af194f9b HEX: ab1c5ed5da6d8118
|
||||
HEX: d807aa98a3030242 HEX: 12835b0145706fbe HEX: 243185be4ee4b28c HEX: 550c7dc3d5ffb4e2
|
||||
HEX: 72be5d74f27b896f HEX: 80deb1fe3b1696b1 HEX: 9bdc06a725c71235 HEX: c19bf174cf692694
|
||||
HEX: e49b69c19ef14ad2 HEX: efbe4786384f25e3 HEX: 0fc19dc68b8cd5b5 HEX: 240ca1cc77ac9c65
|
||||
HEX: 2de92c6f592b0275 HEX: 4a7484aa6ea6e483 HEX: 5cb0a9dcbd41fbd4 HEX: 76f988da831153b5
|
||||
HEX: 983e5152ee66dfab HEX: a831c66d2db43210 HEX: b00327c898fb213f HEX: bf597fc7beef0ee4
|
||||
HEX: c6e00bf33da88fc2 HEX: d5a79147930aa725 HEX: 06ca6351e003826f HEX: 142929670a0e6e70
|
||||
HEX: 27b70a8546d22ffc HEX: 2e1b21385c26c926 HEX: 4d2c6dfc5ac42aed HEX: 53380d139d95b3df
|
||||
HEX: 650a73548baf63de HEX: 766a0abb3c77b2a8 HEX: 81c2c92e47edaee6 HEX: 92722c851482353b
|
||||
HEX: a2bfe8a14cf10364 HEX: a81a664bbc423001 HEX: c24b8b70d0f89791 HEX: c76c51a30654be30
|
||||
HEX: d192e819d6ef5218 HEX: d69906245565a910 HEX: f40e35855771202a HEX: 106aa07032bbd1b8
|
||||
HEX: 19a4c116b8d2d0c8 HEX: 1e376c085141ab53 HEX: 2748774cdf8eeb99 HEX: 34b0bcb5e19b48a8
|
||||
HEX: 391c0cb3c5c95a63 HEX: 4ed8aa4ae3418acb HEX: 5b9cca4f7763e373 HEX: 682e6ff3d6b2b8a3
|
||||
HEX: 748f82ee5defb2fc HEX: 78a5636f43172f60 HEX: 84c87814a1f0ab72 HEX: 8cc702081a6439ec
|
||||
HEX: 90befffa23631e28 HEX: a4506cebde82bde9 HEX: bef9a3f7b2c67915 HEX: c67178f2e372532b
|
||||
HEX: ca273eceea26619c HEX: d186b8c721c0c207 HEX: eada7dd6cde0eb1e HEX: f57d4f7fee6ed178
|
||||
HEX: 06f067aa72176fba HEX: 0a637dc5a2c898a6 HEX: 113f9804bef90dae HEX: 1b710b35131c471b
|
||||
HEX: 28db77f523047d84 HEX: 32caab7b40c72493 HEX: 3c9ebe0a15c9bebc HEX: 431d67c49c100d4c
|
||||
HEX: 4cc5d4becb3e42b6 HEX: 597f299cfc657e2a HEX: 5fcb6fab3ad6faec HEX: 6c44198c4a475817
|
||||
}
|
||||
|
||||
ALIAS: K-512 K-384
|
||||
|
||||
: s0-256 ( x -- x' )
|
||||
[ -7 bitroll-32 ] keep
|
||||
[ -18 bitroll-32 ] keep
|
||||
-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 ;
|
||||
|
||||
: ch ( x y z -- x' )
|
||||
[ bitxor bitand ] keep bitxor ;
|
||||
|
||||
: maj ( x y z -- x' )
|
||||
[ [ bitand ] 2keep bitor ] dip bitand bitor ;
|
||||
[
|
||||
[ -17 bitroll-32 ]
|
||||
[ -19 bitroll-32 ]
|
||||
[ -10 shift ] tri
|
||||
] [ bitxor ] reduce-outputs ; inline
|
||||
|
||||
: S0-256 ( x -- x' )
|
||||
[ -2 bitroll-32 ] keep
|
||||
[ -13 bitroll-32 ] keep
|
||||
-22 bitroll-32 bitxor bitxor ; inline
|
||||
[
|
||||
[ -2 bitroll-32 ]
|
||||
[ -13 bitroll-32 ]
|
||||
[ -22 bitroll-32 ] tri
|
||||
] [ bitxor ] reduce-outputs ; inline
|
||||
|
||||
: S1-256 ( x -- x' )
|
||||
[ -6 bitroll-32 ] keep
|
||||
[ -11 bitroll-32 ] keep
|
||||
-25 bitroll-32 bitxor bitxor ; inline
|
||||
[
|
||||
[ -6 bitroll-32 ]
|
||||
[ -11 bitroll-32 ]
|
||||
[ -25 bitroll-32 ] tri
|
||||
] [ bitxor ] reduce-outputs ; inline
|
||||
|
||||
: slice3 ( n seq -- a b c ) [ dup 3 + ] dip <slice> first3 ; inline
|
||||
: s0-512 ( x -- x' )
|
||||
[
|
||||
[ -1 bitroll-64 ]
|
||||
[ -8 bitroll-64 ]
|
||||
[ -7 shift ] tri
|
||||
] [ bitxor ] reduce-outputs ; inline
|
||||
|
||||
: T1 ( W n -- T1 )
|
||||
[ swap nth ] keep
|
||||
K get nth +
|
||||
e vars get slice3 ch +
|
||||
e vars get nth S1-256 +
|
||||
h vars get nth w+ ;
|
||||
: s1-512 ( x -- x' )
|
||||
[
|
||||
[ -19 bitroll-64 ]
|
||||
[ -61 bitroll-64 ]
|
||||
[ -6 shift ] tri
|
||||
] [ bitxor ] reduce-outputs ; inline
|
||||
|
||||
: T2 ( -- T2 )
|
||||
a vars get nth S0-256
|
||||
a vars get slice3 maj w+ ;
|
||||
: S0-512 ( x -- x' )
|
||||
[
|
||||
[ -28 bitroll-64 ]
|
||||
[ -34 bitroll-64 ]
|
||||
[ -39 bitroll-64 ] tri
|
||||
] [ bitxor ] reduce-outputs ; inline
|
||||
|
||||
: update-vars ( T1 T2 -- )
|
||||
vars get
|
||||
: 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 ; inline
|
||||
|
||||
: maj ( x y z -- x' )
|
||||
[ [ bitand ] [ bitor ] 2bi ] dip bitand bitor ; inline
|
||||
|
||||
: slice3 ( n seq -- a b c )
|
||||
[ dup 3 + ] dip <slice> first3 ; inline
|
||||
|
||||
GENERIC: pad-initial-bytes ( string sha2 -- padded-string )
|
||||
|
||||
M: sha2-short pad-initial-bytes ( string sha2 -- padded-string )
|
||||
drop
|
||||
dup [
|
||||
HEX: 80 ,
|
||||
length
|
||||
[ 64 mod calculate-pad-length 0 <string> % ]
|
||||
[ 3 shift 8 >be % ] bi
|
||||
] "" make append ;
|
||||
|
||||
M: sha2-long pad-initial-bytes ( string sha2 -- padded-string )
|
||||
drop dup [
|
||||
HEX: 80 ,
|
||||
length
|
||||
[ 128 mod calculate-pad-length-long 0 <string> % ]
|
||||
[ 3 shift 8 >be % ] bi
|
||||
] "" make append ;
|
||||
|
||||
: seq>byte-array ( seq n -- string )
|
||||
'[ _ >be ] map B{ } join ;
|
||||
|
||||
:: T1-256 ( n M H sha2 -- T1 )
|
||||
n M nth
|
||||
n sha2 K>> nth +
|
||||
e H slice3 ch w+
|
||||
e H nth S1-256 w+
|
||||
h H nth w+ ; inline
|
||||
|
||||
: T2-256 ( H -- T2 )
|
||||
[ a swap nth S0-256 ]
|
||||
[ a swap slice3 maj w+ ] bi ; inline
|
||||
|
||||
:: T1-512 ( n M H sha2 -- T1 )
|
||||
n M nth
|
||||
n sha2 K>> nth +
|
||||
e H slice3 ch w+
|
||||
e H nth S1-512 w+
|
||||
h H nth w+ ; inline
|
||||
|
||||
: T2-512 ( H -- T2 )
|
||||
[ a swap nth S0-512 ]
|
||||
[ a swap slice3 maj w+ ] bi ; inline
|
||||
|
||||
: update-H ( T1 T2 H -- )
|
||||
h g pick exchange
|
||||
g f pick exchange
|
||||
f e pick exchange
|
||||
|
|
@ -105,42 +251,56 @@ CONSTANT: h 7
|
|||
d c pick exchange
|
||||
c b pick exchange
|
||||
b a pick exchange
|
||||
[ w+ a ] dip set-nth ;
|
||||
[ w+ a ] dip set-nth ; inline
|
||||
|
||||
: process-chunk ( M -- )
|
||||
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 ;
|
||||
|
||||
: <sha-224-state> ( -- sha2-state )
|
||||
sha-224-state new
|
||||
K-256 >>K
|
||||
initial-H-224 >>H
|
||||
4 >>word-size
|
||||
64 >>block-size ;
|
||||
|
||||
: <sha-256-state> ( -- sha2-state )
|
||||
sha-256-state new
|
||||
K-256 >>K
|
||||
initial-H-256 >>H
|
||||
4 >>word-size
|
||||
64 >>block-size ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
SINGLETON: sha-256
|
||||
|
||||
INSTANCE: sha-256 checksum
|
||||
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 ;
|
||||
|
|
|
|||
|
|
@ -43,6 +43,11 @@ HELP: push-growing-circular
|
|||
{ "elt" object } { "circular" circular } }
|
||||
{ $description "Pushes an element onto a " { $link growing-circular } " object." } ;
|
||||
|
||||
HELP: rotate-circular
|
||||
{ $values
|
||||
{ "circular" circular } }
|
||||
{ $description "Advances the start index of a circular object by one." } ;
|
||||
|
||||
ARTICLE: "circular" "Circular sequences"
|
||||
"The " { $vocab-link "circular" } " vocabulary implements the " { $link "sequence-protocol" } " to allow an arbitrary start index and wrap-around indexing." $nl
|
||||
"Creating a new circular object:"
|
||||
|
|
@ -51,6 +56,7 @@ ARTICLE: "circular" "Circular sequences"
|
|||
{ $subsection <growing-circular> }
|
||||
"Changing the start index:"
|
||||
{ $subsection change-circular-start }
|
||||
{ $subsection rotate-circular }
|
||||
"Pushing new elements:"
|
||||
{ $subsection push-circular }
|
||||
{ $subsection push-growing-circular } ;
|
||||
|
|
|
|||
|
|
@ -12,6 +12,7 @@ circular strings ;
|
|||
[ CHAR: e ] [ "test" <circular> 5 swap nth-unsafe ] unit-test
|
||||
|
||||
[ [ 1 2 3 ] ] [ { 1 2 3 } <circular> [ ] like ] unit-test
|
||||
[ [ 2 3 1 ] ] [ { 1 2 3 } <circular> [ rotate-circular ] keep [ ] like ] unit-test
|
||||
[ [ 2 3 1 ] ] [ { 1 2 3 } <circular> 1 over change-circular-start [ ] like ] unit-test
|
||||
[ [ 3 1 2 ] ] [ { 1 2 3 } <circular> 1 over change-circular-start 1 over change-circular-start [ ] like ] unit-test
|
||||
[ [ 3 1 2 ] ] [ { 1 2 3 } <circular> -100 over change-circular-start [ ] like ] unit-test
|
||||
|
|
|
|||
|
|
@ -27,6 +27,9 @@ M: circular virtual-seq seq>> ;
|
|||
#! change start to (start + n) mod length
|
||||
circular-wrap (>>start) ;
|
||||
|
||||
: rotate-circular ( circular -- )
|
||||
[ start>> 1 + ] keep circular-wrap (>>start) ;
|
||||
|
||||
: push-circular ( elt circular -- )
|
||||
[ set-first ] [ 1 swap change-circular-start ] bi ;
|
||||
|
||||
|
|
|
|||
|
|
@ -14,7 +14,7 @@ NSApplicationDelegateReplyCancel
|
|||
NSApplicationDelegateReplyFailure ;
|
||||
|
||||
: with-autorelease-pool ( quot -- )
|
||||
NSAutoreleasePool -> new slip -> release ; inline
|
||||
NSAutoreleasePool -> new [ call ] [ -> release ] bi* ; inline
|
||||
|
||||
: NSApp ( -- app ) NSApplication -> sharedApplication ;
|
||||
|
||||
|
|
|
|||
|
|
@ -68,7 +68,7 @@ MACRO: (send) ( selector super? -- quot )
|
|||
[ 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
|
||||
|
||||
|
|
|
|||
|
|
@ -11,8 +11,8 @@ MACRO: output>sequence ( quot exemplar -- newquot )
|
|||
[ dup infer out>> ] dip
|
||||
'[ @ _ _ nsequence ] ;
|
||||
|
||||
: output>array ( quot -- newquot )
|
||||
{ } output>sequence ; inline
|
||||
MACRO: output>array ( quot -- newquot )
|
||||
'[ _ { } output>sequence ] ;
|
||||
|
||||
MACRO: input<sequence ( quot -- newquot )
|
||||
[ infer in>> ] keep
|
||||
|
|
@ -25,8 +25,8 @@ MACRO: input<sequence-unsafe ( quot -- newquot )
|
|||
MACRO: reduce-outputs ( quot operation -- newquot )
|
||||
[ dup infer out>> 1 [-] ] dip n*quot compose ;
|
||||
|
||||
: sum-outputs ( quot -- n )
|
||||
[ + ] reduce-outputs ; inline
|
||||
MACRO: sum-outputs ( quot -- n )
|
||||
'[ _ [ + ] reduce-outputs ] ;
|
||||
|
||||
MACRO: map-reduce-outputs ( quot mapper reducer -- newquot )
|
||||
[ dup infer out>> ] 2dip
|
||||
|
|
@ -37,5 +37,5 @@ MACRO: map-reduce-outputs ( quot mapper reducer -- newquot )
|
|||
MACRO: append-outputs-as ( quot exemplar -- newquot )
|
||||
[ dup infer out>> ] dip '[ @ _ _ nappend-as ] ;
|
||||
|
||||
: append-outputs ( quot -- seq )
|
||||
{ } append-outputs-as ; inline
|
||||
MACRO: append-outputs ( quot -- seq )
|
||||
'[ _ { } append-outputs-as ] ;
|
||||
|
|
|
|||
|
|
@ -444,8 +444,7 @@ TUPLE: callback-context ;
|
|||
|
||||
: do-callback ( quot token -- )
|
||||
init-catchstack
|
||||
dup 2 setenv
|
||||
slip
|
||||
[ 2 setenv call ] keep
|
||||
wait-to-return ; inline
|
||||
|
||||
: callback-return-quot ( ctype -- quot )
|
||||
|
|
|
|||
|
|
@ -20,7 +20,7 @@ CONSTANT: deck-bits 18
|
|||
: underlying-alien-offset ( -- n ) bootstrap-cell alien tag-number - ; inline
|
||||
: tuple-class-offset ( -- n ) bootstrap-cell tuple tag-number - ; inline
|
||||
: word-xt-offset ( -- n ) 10 bootstrap-cells \ word tag-number - ; inline
|
||||
: quot-xt-offset ( -- n ) 5 bootstrap-cells quotation tag-number - ; inline
|
||||
: quot-xt-offset ( -- n ) 4 bootstrap-cells quotation tag-number - ; inline
|
||||
: word-code-offset ( -- n ) 11 bootstrap-cells \ word tag-number - ; inline
|
||||
: array-start-offset ( -- n ) 2 bootstrap-cells array tag-number - ; inline
|
||||
: compiled-header-size ( -- n ) 4 bootstrap-cells ; inline
|
||||
|
|
|
|||
|
|
@ -33,7 +33,7 @@ IN: compiler.tests.curry
|
|||
] 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
|
||||
|
||||
|
|
|
|||
|
|
@ -396,3 +396,19 @@ DEFER: loop-bbb
|
|||
|
||||
[ 1 ] [ 257 modular-arithmetic-bug ] unit-test
|
||||
[ -10 ] [ -10 modular-arithmetic-bug ] unit-test
|
||||
|
||||
! Optimizer needs to ignore invalid generics
|
||||
GENERIC# bad-dispatch-position-test* 3 ( -- )
|
||||
|
||||
M: object bad-dispatch-position-test* ;
|
||||
|
||||
: bad-dispatch-position-test ( -- ) bad-dispatch-position-test* ;
|
||||
|
||||
[ 1 2 3 4 bad-dispatch-position-test ] must-fail
|
||||
|
||||
[ ] [
|
||||
[
|
||||
\ bad-dispatch-position-test forget
|
||||
\ bad-dispatch-position-test* forget
|
||||
] with-compilation-unit
|
||||
] unit-test
|
||||
|
|
@ -302,7 +302,7 @@ C: <ro-box> ro-box
|
|||
[ 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
|
||||
|
|
|
|||
|
|
@ -59,9 +59,11 @@ M: callable splicing-nodes splicing-body ;
|
|||
|
||||
: inlining-standard-method ( #call word -- class/f method/f )
|
||||
dup "methods" word-prop assoc-empty? [ 2drop f f ] [
|
||||
2dup [ in-d>> length ] [ dispatch# ] bi* <= [ 2drop f f ] [
|
||||
[ in-d>> <reversed> ] [ [ dispatch# ] keep ] bi*
|
||||
[ swap nth value-info class>> dup ] dip
|
||||
specific-method
|
||||
] if
|
||||
] if ;
|
||||
|
||||
: inline-standard-method ( #call word -- ? )
|
||||
|
|
|
|||
|
|
@ -39,7 +39,7 @@ TUPLE: empty-tuple ;
|
|||
|
||||
! 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
|
||||
|
|
|
|||
|
|
@ -2,11 +2,11 @@
|
|||
! 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:
|
||||
|
|
@ -713,4 +713,14 @@ USE: vocabs.loader
|
|||
} cond
|
||||
|
||||
"complex-double" c-type t >>return-in-registers? drop
|
||||
"bool" c-type 4 >>size 4 >>align drop
|
||||
|
||||
[
|
||||
<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
|
||||
|
|
|
|||
|
|
@ -15,6 +15,7 @@ $nl
|
|||
"Iterating over elements:"
|
||||
{ $subsection dlist-each }
|
||||
{ $subsection dlist-find }
|
||||
{ $subsection dlist-filter }
|
||||
{ $subsection dlist-any? }
|
||||
"Deleting a node matching a predicate:"
|
||||
{ $subsection delete-node-if* }
|
||||
|
|
@ -40,6 +41,11 @@ HELP: dlist-find
|
|||
"This operation is O(n)."
|
||||
} ;
|
||||
|
||||
HELP: dlist-filter
|
||||
{ $values { "dlist" { $link dlist } } { "quot" quotation } { "dlist" { $link dlist } } }
|
||||
{ $description "Applies the quotation to each element of the " { $link dlist } " in turn, removing the corresponding nodes if the quotation returns " { $link f } "." }
|
||||
{ $side-effects { "dlist" } } ;
|
||||
|
||||
HELP: dlist-any?
|
||||
{ $values { "dlist" { $link dlist } } { "quot" quotation } { "?" "a boolean" } }
|
||||
{ $description "Just like " { $link dlist-find } " except it doesn't return the object." }
|
||||
|
|
|
|||
|
|
@ -79,3 +79,8 @@ IN: dlists.tests
|
|||
[ V{ f 3 1 f } ] [ <dlist> 1 over push-front 3 over push-front f over push-front f over push-back dlist>seq ] unit-test
|
||||
|
||||
[ V{ } ] [ <dlist> dlist>seq ] unit-test
|
||||
|
||||
[ V{ 0 2 4 } ] [ <dlist> { 0 1 2 3 4 } over push-all-back [ even? ] dlist-filter dlist>seq ] unit-test
|
||||
[ V{ 2 4 } ] [ <dlist> { 1 2 3 4 } over push-all-back [ even? ] dlist-filter dlist>seq ] unit-test
|
||||
[ V{ 2 4 } ] [ <dlist> { 1 2 3 4 5 } over push-all-back [ even? ] dlist-filter dlist>seq ] unit-test
|
||||
[ V{ 0 2 4 } ] [ <dlist> { 0 1 2 3 4 5 } over push-all-back [ even? ] dlist-filter dlist>seq ] unit-test
|
||||
|
|
|
|||
|
|
@ -95,7 +95,7 @@ M: dlist pop-front* ( dlist -- )
|
|||
[
|
||||
[
|
||||
[ empty-dlist ] unless*
|
||||
[ f ] change-next drop
|
||||
next>>
|
||||
f over set-prev-when
|
||||
] change-front drop
|
||||
] keep
|
||||
|
|
@ -108,7 +108,7 @@ M: dlist pop-back* ( dlist -- )
|
|||
[
|
||||
[
|
||||
[ empty-dlist ] unless*
|
||||
[ f ] change-prev drop
|
||||
prev>>
|
||||
f over set-next-when
|
||||
] change-back drop
|
||||
] keep
|
||||
|
|
@ -157,6 +157,9 @@ M: dlist clear-deque ( dlist -- )
|
|||
|
||||
: 1dlist ( obj -- dlist ) <dlist> [ push-front ] keep ;
|
||||
|
||||
: dlist-filter ( dlist quot -- dlist )
|
||||
over [ '[ dup obj>> @ [ drop ] [ _ delete-node ] if ] dlist-each-node ] keep ; inline
|
||||
|
||||
M: dlist clone
|
||||
<dlist> [ '[ _ push-back ] dlist-each ] keep ;
|
||||
|
||||
|
|
|
|||
|
|
@ -57,7 +57,6 @@ $nl
|
|||
"Here are some built-in combinators rewritten in terms of fried quotations:"
|
||||
{ $table
|
||||
{ { $link literalize } { $snippet ": literalize '[ _ ] ;" } }
|
||||
{ { $link slip } { $snippet ": slip '[ @ _ ] call ;" } }
|
||||
{ { $link curry } { $snippet ": curry '[ _ @ ] ;" } }
|
||||
{ { $link compose } { $snippet ": compose '[ @ @ ] ;" } }
|
||||
{ { $link bi@ } { $snippet ": bi@ tuck '[ _ @ _ @ ] call ;" } }
|
||||
|
|
|
|||
|
|
@ -0,0 +1,8 @@
|
|||
IN: game-input.tests
|
||||
USING: ui game-input tools.test kernel system threads calendar ;
|
||||
|
||||
os windows? os macosx? or [
|
||||
[ ] [ open-game-input ] unit-test
|
||||
[ ] [ 1 seconds sleep ] unit-test
|
||||
[ ] [ close-game-input ] unit-test
|
||||
] when
|
||||
|
|
@ -161,22 +161,6 @@ HELP: ndip
|
|||
}
|
||||
} ;
|
||||
|
||||
HELP: nslip
|
||||
{ $values { "n" integer } }
|
||||
{ $description "A generalization of " { $link slip } " that can work "
|
||||
"for any stack depth. The first " { $snippet "n" } " items after the quotation will be "
|
||||
"removed from the stack, the quotation called, and the items restored."
|
||||
}
|
||||
{ $examples
|
||||
{ $example "USING: generalizations kernel prettyprint ;" "[ 99 ] 1 2 3 4 5 5 nslip 6 narray ." "{ 99 1 2 3 4 5 }" }
|
||||
"Some core words expressed in terms of " { $link nslip } ":"
|
||||
{ $table
|
||||
{ { $link slip } { $snippet "1 nslip" } }
|
||||
{ { $link 2slip } { $snippet "2 nslip" } }
|
||||
{ { $link 3slip } { $snippet "3 nslip" } }
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: nkeep
|
||||
{ $values { "quot" quotation } { "n" integer } }
|
||||
{ $description "A generalization of " { $link keep } " that can work "
|
||||
|
|
@ -339,7 +323,6 @@ ARTICLE: "shuffle-generalizations" "Generalized shuffle words"
|
|||
|
||||
ARTICLE: "combinator-generalizations" "Generalized combinators"
|
||||
{ $subsection ndip }
|
||||
{ $subsection nslip }
|
||||
{ $subsection nkeep }
|
||||
{ $subsection napply }
|
||||
{ $subsection ncleave }
|
||||
|
|
|
|||
|
|
@ -26,8 +26,6 @@ IN: generalizations.tests
|
|||
[ [ 1 ] 5 ndip ] must-infer
|
||||
[ 1 2 3 4 ] [ 2 3 4 [ 1 ] 3 ndip ] unit-test
|
||||
|
||||
[ [ 99 ] 1 2 3 4 5 5 nslip ] must-infer
|
||||
{ 99 1 2 3 4 5 } [ [ 99 ] 1 2 3 4 5 5 nslip ] unit-test
|
||||
[ 1 2 3 4 5 [ drop drop drop drop drop 2 ] 5 nkeep ] must-infer
|
||||
{ 2 1 2 3 4 5 } [ 1 2 3 4 5 [ drop drop drop drop drop 2 ] 5 nkeep ] unit-test
|
||||
[ [ 1 2 3 + ] ] [ 1 2 3 [ + ] 3 ncurry ] unit-test
|
||||
|
|
|
|||
|
|
@ -60,9 +60,6 @@ MACRO: ntuck ( n -- )
|
|||
MACRO: ndip ( quot n -- )
|
||||
[ '[ _ dip ] ] times ;
|
||||
|
||||
MACRO: nslip ( n -- )
|
||||
'[ [ call ] _ ndip ] ;
|
||||
|
||||
MACRO: nkeep ( quot n -- )
|
||||
tuck '[ _ ndup _ _ ndip ] ;
|
||||
|
||||
|
|
|
|||
|
|
@ -173,10 +173,11 @@ M: stdin refill
|
|||
size-read-fd <fd> init-fd <input-port> >>size
|
||||
data-read-fd <fd> >>data ;
|
||||
|
||||
M: unix (init-stdio)
|
||||
M: unix init-stdio
|
||||
<stdin> <input-port>
|
||||
1 <fd> <output-port>
|
||||
2 <fd> <output-port> t ;
|
||||
2 <fd> <output-port>
|
||||
set-stdio ;
|
||||
|
||||
! mx io-task for embedding an fd-based mx inside another mx
|
||||
TUPLE: mx-port < port mx ;
|
||||
|
|
|
|||
|
|
@ -1,9 +1,9 @@
|
|||
USING: alien alien.c-types arrays assocs combinators
|
||||
continuations destructors io io.backend io.ports io.timeouts
|
||||
io.backend.windows io.files.windows io.files.windows.nt io.files
|
||||
io.pathnames io.buffers io.streams.c libc kernel math namespaces
|
||||
sequences threads windows windows.errors windows.kernel32
|
||||
strings splitting ascii system accessors locals ;
|
||||
USING: alien alien.c-types arrays assocs combinators continuations
|
||||
destructors io io.backend io.ports io.timeouts io.backend.windows
|
||||
io.files.windows io.files.windows.nt io.files io.pathnames io.buffers
|
||||
io.streams.c io.streams.null libc kernel math namespaces sequences
|
||||
threads windows windows.errors windows.kernel32 strings splitting
|
||||
ascii system accessors locals ;
|
||||
QUALIFIED: windows.winsock
|
||||
IN: io.backend.windows.nt
|
||||
|
||||
|
|
@ -140,7 +140,9 @@ M: winnt (wait-to-read) ( port -- )
|
|||
|
||||
: console-app? ( -- ? ) GetConsoleWindow >boolean ;
|
||||
|
||||
M: winnt (init-stdio)
|
||||
console-app? [ init-c-stdio t ] [ f f f f ] if ;
|
||||
M: winnt init-stdio
|
||||
console-app?
|
||||
[ init-c-stdio ]
|
||||
[ null-reader null-writer null-writer set-stdio ] if ;
|
||||
|
||||
winnt set-io-backend
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
! 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
|
||||
|
|
@ -57,6 +57,32 @@ HELP: find-all-in-directories
|
|||
}
|
||||
{ $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"
|
||||
|
|
@ -65,10 +91,13 @@ 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"
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
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 )
|
||||
|
|
@ -106,4 +106,11 @@ ERROR: file-not-found path bfs? quot ;
|
|||
] { } 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
|
||||
|
|
|
|||
|
|
@ -0,0 +1,10 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien.c-types io.directories.unix kernel system unix ;
|
||||
IN: io.directories.unix.linux
|
||||
|
||||
M: unix find-next-file ( DIR* -- byte-array )
|
||||
"dirent" <c-object>
|
||||
f <void*>
|
||||
[ readdir64_r 0 = [ (io-error) ] unless ] 2keep
|
||||
*void* [ drop f ] unless ;
|
||||
|
|
@ -0,0 +1 @@
|
|||
unportable
|
||||
|
|
@ -4,7 +4,7 @@ USING: accessors alien.c-types alien.strings combinators
|
|||
continuations destructors fry io io.backend io.backend.unix
|
||||
io.directories io.encodings.binary io.encodings.utf8 io.files
|
||||
io.pathnames io.files.types kernel math.bitwise sequences system
|
||||
unix unix.stat ;
|
||||
unix unix.stat vocabs.loader ;
|
||||
IN: io.directories.unix
|
||||
|
||||
: touch-mode ( -- n )
|
||||
|
|
@ -34,7 +34,9 @@ M: unix copy-file ( from to -- )
|
|||
[ opendir dup [ (io-error) ] unless ] dip
|
||||
dupd curry swap '[ _ closedir io-error ] [ ] cleanup ; inline
|
||||
|
||||
: find-next-file ( DIR* -- byte-array )
|
||||
HOOK: find-next-file os ( DIR* -- byte-array )
|
||||
|
||||
M: unix find-next-file ( DIR* -- byte-array )
|
||||
"dirent" <c-object>
|
||||
f <void*>
|
||||
[ readdir_r 0 = [ (io-error) ] unless ] 2keep
|
||||
|
|
@ -54,8 +56,10 @@ M: unix copy-file ( from to -- )
|
|||
} case ;
|
||||
|
||||
M: unix >directory-entry ( byte-array -- directory-entry )
|
||||
{
|
||||
[ dirent-d_name utf8 alien>string ]
|
||||
[ dirent-d_type dirent-type>file-type ] bi directory-entry boa ;
|
||||
[ dirent-d_type dirent-type>file-type ]
|
||||
} cleave directory-entry boa ;
|
||||
|
||||
M: unix (directory-entries) ( path -- seq )
|
||||
[
|
||||
|
|
@ -63,3 +67,5 @@ M: unix (directory-entries) ( path -- seq )
|
|||
[ >directory-entry ]
|
||||
produce nip
|
||||
] with-unix-directory ;
|
||||
|
||||
os linux? [ "io.directories.unix.linux" require ] when
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2008 Doug Coleman, Eduardo Cavazos.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors kernel system sequences combinators
|
||||
vocabs.loader io.files.types ;
|
||||
vocabs.loader io.files.types math ;
|
||||
IN: io.files.info
|
||||
|
||||
! File info
|
||||
|
|
@ -14,6 +14,9 @@ HOOK: link-info os ( path -- info )
|
|||
|
||||
: directory? ( file-info -- ? ) type>> +directory+ = ;
|
||||
|
||||
: sparse-file? ( file-info -- ? )
|
||||
[ size-on-disk>> ] [ size>> ] bi < ;
|
||||
|
||||
! File systems
|
||||
HOOK: file-systems os ( -- array )
|
||||
|
||||
|
|
|
|||
|
|
@ -1,11 +1,11 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: system kernel namespaces strings hashtables sequences
|
||||
assocs combinators vocabs.loader init threads continuations
|
||||
math accessors concurrency.flags destructors environment
|
||||
io io.encodings.utf8 io.backend io.timeouts io.pipes
|
||||
io.pipes.private io.encodings io.streams.duplex io.ports
|
||||
debugger prettyprint summary calendar io.pathnames ;
|
||||
USING: system kernel namespaces strings hashtables sequences assocs
|
||||
combinators vocabs.loader init threads continuations math accessors
|
||||
concurrency.flags destructors environment io io.encodings.ascii
|
||||
io.backend io.timeouts io.pipes io.pipes.private io.encodings
|
||||
io.encodings.utf8 io.streams.duplex io.ports debugger prettyprint
|
||||
summary calendar ;
|
||||
IN: io.launcher
|
||||
|
||||
TUPLE: process < identity-tuple
|
||||
|
|
@ -254,6 +254,21 @@ M: object run-pipeline-element
|
|||
swap [ with-stream ] dip
|
||||
wait-for-success ; inline
|
||||
|
||||
ERROR: output-process-error { output string } { process process } ;
|
||||
|
||||
M: output-process-error error.
|
||||
[ "Process:" print process>> . nl ]
|
||||
[ "Output:" print output>> print ]
|
||||
bi ;
|
||||
|
||||
: try-output-process ( command -- )
|
||||
>process
|
||||
+stdout+ >>stderr
|
||||
+closed+ >>stdin
|
||||
utf8 <process-reader*>
|
||||
[ stream-contents ] [ dup wait-for-process ] bi*
|
||||
0 = [ 2drop ] [ output-process-error ] if ;
|
||||
|
||||
: notify-exit ( process status -- )
|
||||
>>status
|
||||
[ processes get delete-at* drop [ resume ] each ] keep
|
||||
|
|
|
|||
|
|
@ -48,7 +48,7 @@ concurrency.promises threads unix.process ;
|
|||
try-process
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
[ "" ] [
|
||||
"cat"
|
||||
"launcher-test-1" temp-file
|
||||
2array
|
||||
|
|
|
|||
|
|
@ -2,6 +2,8 @@ USING: io.streams.string io kernel arrays namespaces make
|
|||
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>
|
||||
|
|
|
|||
|
|
@ -35,6 +35,11 @@ IN: math.bitwise
|
|||
: w- ( int int -- int ) - 32 bits ; inline
|
||||
: w* ( int int -- int ) * 32 bits ; inline
|
||||
|
||||
! 64-bit arithmetic
|
||||
: W+ ( int int -- int ) + 64 bits ; inline
|
||||
: W- ( int int -- int ) - 64 bits ; inline
|
||||
: W* ( int int -- int ) * 64 bits ; inline
|
||||
|
||||
! flags
|
||||
MACRO: flags ( values -- )
|
||||
[ 0 ] [ [ ?execute bitor ] curry compose ] reduce ;
|
||||
|
|
@ -106,3 +111,10 @@ PRIVATE>
|
|||
: >signed ( x n -- y )
|
||||
2dup neg 1 + shift 1 = [ 2^ - ] [ drop ] if ;
|
||||
|
||||
: >odd ( n -- int ) 0 set-bit ; foldable
|
||||
|
||||
: >even ( n -- int ) 0 clear-bit ; foldable
|
||||
|
||||
: next-even ( m -- n ) >even 2 + ; foldable
|
||||
|
||||
: next-odd ( m -- n ) dup even? [ 1 + ] [ 2 + ] if ; foldable
|
||||
|
|
|
|||
|
|
@ -1,100 +0,0 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: help.markup help.syntax kernel sequences math ;
|
||||
IN: math.miller-rabin
|
||||
|
||||
HELP: find-relative-prime
|
||||
{ $values
|
||||
{ "n" integer }
|
||||
{ "p" integer }
|
||||
}
|
||||
{ $description "Returns a number that is relatively prime to " { $snippet "n" } "." } ;
|
||||
|
||||
HELP: find-relative-prime*
|
||||
{ $values
|
||||
{ "n" integer } { "guess" integer }
|
||||
{ "p" integer }
|
||||
}
|
||||
{ $description "Returns a number that is relatively prime to " { $snippet "n" } ", starting by trying " { $snippet "guess" } "." } ;
|
||||
|
||||
HELP: miller-rabin
|
||||
{ $values
|
||||
{ "n" integer }
|
||||
{ "?" "a boolean" }
|
||||
}
|
||||
{ $description "Returns true if the number is a prime. Calls " { $link miller-rabin* } " with a default of 10 Miller-Rabin tests." } ;
|
||||
|
||||
{ miller-rabin miller-rabin* } related-words
|
||||
|
||||
HELP: miller-rabin*
|
||||
{ $values
|
||||
{ "n" integer } { "numtrials" integer }
|
||||
{ "?" "a boolean" }
|
||||
}
|
||||
{ $description "Performs " { $snippet "numtrials" } " trials of the Miller-Rabin probabilistic primality test algorithm and returns true if prime." } ;
|
||||
|
||||
HELP: next-prime
|
||||
{ $values
|
||||
{ "n" integer }
|
||||
{ "p" integer }
|
||||
}
|
||||
{ $description "Tests consecutive numbers for primality with " { $link miller-rabin } " and returns the next prime." } ;
|
||||
|
||||
HELP: next-safe-prime
|
||||
{ $values
|
||||
{ "n" integer }
|
||||
{ "q" integer }
|
||||
}
|
||||
{ $description "Tests consecutive numbers and returns the next safe prime. A safe prime is desirable in cryptography applications such as Diffie-Hellman and SRP6." } ;
|
||||
|
||||
HELP: random-bits*
|
||||
{ $values
|
||||
{ "numbits" integer }
|
||||
{ "n" integer }
|
||||
}
|
||||
{ $description "Returns an integer exactly " { $snippet "numbits" } " in length, with the topmost bit set to one." } ;
|
||||
|
||||
HELP: random-prime
|
||||
{ $values
|
||||
{ "numbits" integer }
|
||||
{ "p" integer }
|
||||
}
|
||||
{ $description "Returns a prime number exactly " { $snippet "numbits" } " bits in length, with the topmost bit set to one." } ;
|
||||
|
||||
HELP: random-safe-prime
|
||||
{ $values
|
||||
{ "numbits" integer }
|
||||
{ "p" integer }
|
||||
}
|
||||
{ $description "Returns a safe prime number " { $snippet "numbits" } " bits in length, with the topmost bit set to one." } ;
|
||||
|
||||
HELP: safe-prime?
|
||||
{ $values
|
||||
{ "q" integer }
|
||||
{ "?" "a boolean" }
|
||||
}
|
||||
{ $description "Tests whether the number is a safe prime. A safe prime " { $snippet "p" } " must be prime, as must " { $snippet "(p - 1) / 2" } "." } ;
|
||||
|
||||
HELP: unique-primes
|
||||
{ $values
|
||||
{ "numbits" integer } { "n" integer }
|
||||
{ "seq" sequence }
|
||||
}
|
||||
{ $description "Generates a sequence of " { $snippet "n" } " unique prime numbers with exactly " { $snippet "numbits" } " bits." } ;
|
||||
|
||||
ARTICLE: "math.miller-rabin" "Miller-Rabin probabilistic primality test"
|
||||
"The " { $vocab-link "math.miller-rabin" } " vocabulary implements the Miller-Rabin probabilistic primality test and utility words that use it in order to generate random prime numbers." $nl
|
||||
"The Miller-Rabin probabilistic primality test:"
|
||||
{ $subsection miller-rabin }
|
||||
{ $subsection miller-rabin* }
|
||||
"Generating relative prime numbers:"
|
||||
{ $subsection find-relative-prime }
|
||||
{ $subsection find-relative-prime* }
|
||||
"Generating prime numbers:"
|
||||
{ $subsection next-prime }
|
||||
{ $subsection random-prime }
|
||||
"Generating safe prime numbers:"
|
||||
{ $subsection next-safe-prime }
|
||||
{ $subsection random-safe-prime } ;
|
||||
|
||||
ABOUT: "math.miller-rabin"
|
||||
|
|
@ -1,29 +0,0 @@
|
|||
USING: math.miller-rabin tools.test kernel sequences
|
||||
math.miller-rabin.private math ;
|
||||
IN: math.miller-rabin.tests
|
||||
|
||||
[ f ] [ 473155932665450549999756893736999469773678960651272093993257221235459777950185377130233556540099119926369437865330559863 miller-rabin ] unit-test
|
||||
[ t ] [ 2 miller-rabin ] unit-test
|
||||
[ t ] [ 3 miller-rabin ] unit-test
|
||||
[ f ] [ 36 miller-rabin ] unit-test
|
||||
[ t ] [ 37 miller-rabin ] unit-test
|
||||
[ 2 ] [ 1 next-prime ] unit-test
|
||||
[ 3 ] [ 2 next-prime ] unit-test
|
||||
[ 5 ] [ 3 next-prime ] unit-test
|
||||
[ 101 ] [ 100 next-prime ] unit-test
|
||||
[ t ] [ 2135623355842621559 miller-rabin ] unit-test
|
||||
[ 100000000000031 ] [ 100000000000000 next-prime ] unit-test
|
||||
|
||||
[ 863 ] [ 862 next-safe-prime ] unit-test
|
||||
[ f ] [ 862 safe-prime? ] unit-test
|
||||
[ t ] [ 7 safe-prime? ] unit-test
|
||||
[ f ] [ 31 safe-prime? ] unit-test
|
||||
[ t ] [ 47 safe-prime-candidate? ] unit-test
|
||||
[ t ] [ 47 safe-prime? ] unit-test
|
||||
[ t ] [ 863 safe-prime? ] unit-test
|
||||
|
||||
[ f ] [ 1000 [ drop 15 miller-rabin ] any? ] unit-test
|
||||
|
||||
[ 47 ] [ 31 next-safe-prime ] unit-test
|
||||
[ 49 ] [ 50 random-prime log2 ] unit-test
|
||||
[ 49 ] [ 50 random-bits* log2 ] unit-test
|
||||
|
|
@ -1,114 +0,0 @@
|
|||
! 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 ;
|
||||
|
|
@ -93,7 +93,13 @@ HELP: pdiff
|
|||
{ $description "Finds the derivative of " { $snippet "p" } "." } ;
|
||||
|
||||
HELP: polyval
|
||||
{ $values { "p" "a polynomial" } { "x" number } { "p[x]" number } }
|
||||
{ $values { "x" number } { "p" "a polynomial" } { "p[x]" number } }
|
||||
{ $description "Evaluate " { $snippet "p" } " with the input " { $snippet "x" } "." }
|
||||
{ $examples { $example "USING: math.polynomials prettyprint ;" "{ 1 0 1 } 2 polyval ." "5" } } ;
|
||||
{ $examples { $example "USING: math.polynomials prettyprint ;" "2 { 1 0 1 } polyval ." "5" } } ;
|
||||
|
||||
HELP: polyval*
|
||||
{ $values { "p" "a literal polynomial" } }
|
||||
{ $description "Macro version of " { $link polyval } ". Evaluates the literal polynomial " { $snippet "p" } " at the value off the top of the stack." }
|
||||
{ $examples { $example "USING: math.polynomials prettyprint ;" "2 { 1 0 1 } polyval* ." "5" } } ;
|
||||
|
||||
{ polyval polyval* } related-words
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays kernel make math math.order math.vectors sequences
|
||||
splitting vectors ;
|
||||
splitting vectors macros combinators ;
|
||||
IN: math.polynomials
|
||||
|
||||
<PRIVATE
|
||||
|
|
@ -80,6 +80,12 @@ PRIVATE>
|
|||
: pdiff ( p -- p' )
|
||||
dup length v* { 0 } ?head drop ;
|
||||
|
||||
: polyval ( p x -- p[x] )
|
||||
[ 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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,6 +1,7 @@
|
|||
! Copyright (C) 2007-2009 Samuel Tardieu.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays combinators kernel make math math.functions math.primes sequences ;
|
||||
USING: arrays combinators kernel make math math.functions
|
||||
math.primes sequences ;
|
||||
IN: math.primes.factors
|
||||
|
||||
<PRIVATE
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Doug Coleman
|
||||
|
|
@ -0,0 +1,25 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: help.markup help.syntax kernel ;
|
||||
IN: math.primes.lucas-lehmer
|
||||
|
||||
HELP: lucas-lehmer
|
||||
{ $values
|
||||
{ "p" "a prime number" }
|
||||
{ "?" "a boolean" }
|
||||
}
|
||||
{ $description "Runs the Lucas-Lehmer test on the prime " { $snippet "p" } " and returns " { $link t } " if " { $snippet "(2 ^ p) - 1" } " is prime." }
|
||||
{ $examples
|
||||
{ $example "! Test that (2 ^ 61) - 1 is prime:"
|
||||
"USING: math.primes.lucas-lehmer prettyprint ;"
|
||||
"61 lucas-lehmer ."
|
||||
"t"
|
||||
}
|
||||
} ;
|
||||
|
||||
ARTICLE: "math.primes.lucas-lehmer" "Lucas-Lehmer Mersenne Primality test"
|
||||
"The " { $vocab-link "math.primes.lucas-lehmer" } " vocabulary tests numbers of the form " { $snippet "(2 ^ p) - 1" } " for primality, where " { $snippet "p" } " is prime." $nl
|
||||
"Run the Lucas-Lehmer test:"
|
||||
{ $subsection lucas-lehmer } ;
|
||||
|
||||
ABOUT: "math.primes.lucas-lehmer"
|
||||
|
|
@ -0,0 +1,13 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: tools.test math.primes.lucas-lehmer ;
|
||||
IN: math.primes.lucas-lehmer.tests
|
||||
|
||||
[ t ] [ 2 lucas-lehmer ] unit-test
|
||||
[ t ] [ 3 lucas-lehmer ] unit-test
|
||||
[ f ] [ 4 lucas-lehmer ] unit-test
|
||||
[ t ] [ 5 lucas-lehmer ] unit-test
|
||||
[ f ] [ 6 lucas-lehmer ] unit-test
|
||||
[ f ] [ 11 lucas-lehmer ] unit-test
|
||||
[ t ] [ 13 lucas-lehmer ] unit-test
|
||||
[ t ] [ 61 lucas-lehmer ] unit-test
|
||||
|
|
@ -0,0 +1,27 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: combinators fry kernel locals math
|
||||
math.primes combinators.short-circuit ;
|
||||
IN: math.primes.lucas-lehmer
|
||||
|
||||
ERROR: invalid-lucas-lehmer-candidate obj ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: do-lucas-lehmer ( p -- ? )
|
||||
[ drop 4 ] [ 2 - ] [ 2^ 1 - ] tri
|
||||
'[ sq 2 - _ mod ] times 0 = ;
|
||||
|
||||
: lucas-lehmer-guard ( obj -- obj )
|
||||
dup { [ integer? ] [ 0 > ] } 1&&
|
||||
[ invalid-lucas-lehmer-candidate ] unless ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: lucas-lehmer ( p -- ? )
|
||||
lucas-lehmer-guard
|
||||
{
|
||||
{ [ dup 2 = ] [ drop t ] }
|
||||
{ [ dup prime? ] [ do-lucas-lehmer ] }
|
||||
[ drop f ]
|
||||
} cond ;
|
||||
|
|
@ -0,0 +1,28 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: help.markup help.syntax kernel sequences math ;
|
||||
IN: math.primes.miller-rabin
|
||||
|
||||
HELP: miller-rabin
|
||||
{ $values
|
||||
{ "n" integer }
|
||||
{ "?" "a boolean" }
|
||||
}
|
||||
{ $description "Returns true if the number is a prime. Calls " { $link miller-rabin* } " with a default of 10 Miller-Rabin tests." } ;
|
||||
|
||||
{ miller-rabin miller-rabin* } related-words
|
||||
|
||||
HELP: miller-rabin*
|
||||
{ $values
|
||||
{ "n" integer } { "numtrials" integer }
|
||||
{ "?" "a boolean" }
|
||||
}
|
||||
{ $description "Performs " { $snippet "numtrials" } " trials of the Miller-Rabin probabilistic primality test algorithm and returns true if prime." } ;
|
||||
|
||||
ARTICLE: "math.primes.miller-rabin" "Miller-Rabin probabilistic primality test"
|
||||
"The " { $vocab-link "math.primes.miller-rabin" } " vocabulary implements the Miller-Rabin probabilistic primality test and utility words that use it in order to generate random prime numbers." $nl
|
||||
"The Miller-Rabin probabilistic primality test:"
|
||||
{ $subsection miller-rabin }
|
||||
{ $subsection miller-rabin* } ;
|
||||
|
||||
ABOUT: "math.primes.miller-rabin"
|
||||
|
|
@ -0,0 +1,11 @@
|
|||
USING: kernel math.primes.miller-rabin sequences tools.test ;
|
||||
IN: math.primes.miller-rabin.tests
|
||||
|
||||
[ f ] [ 473155932665450549999756893736999469773678960651272093993257221235459777950185377130233556540099119926369437865330559863 miller-rabin ] unit-test
|
||||
[ t ] [ 2 miller-rabin ] unit-test
|
||||
[ t ] [ 3 miller-rabin ] unit-test
|
||||
[ f ] [ 36 miller-rabin ] unit-test
|
||||
[ t ] [ 37 miller-rabin ] unit-test
|
||||
[ t ] [ 2135623355842621559 miller-rabin ] unit-test
|
||||
|
||||
[ f ] [ 1000 [ drop 15 miller-rabin ] any? ] unit-test
|
||||
|
|
@ -0,0 +1,35 @@
|
|||
! Copyright (c) 2008-2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: combinators combinators.short-circuit kernel locals math
|
||||
math.functions math.ranges random sequences sets ;
|
||||
IN: math.primes.miller-rabin
|
||||
|
||||
<PRIVATE
|
||||
|
||||
:: (miller-rabin) ( n trials -- ? )
|
||||
n 1 - :> n-1
|
||||
n-1 factor-2s :> s :> r
|
||||
0 :> a!
|
||||
trials [
|
||||
drop
|
||||
2 n 2 - [a,b] random a!
|
||||
a s n ^mod 1 = [
|
||||
f
|
||||
] [
|
||||
r iota [
|
||||
2^ s * a swap n ^mod n - -1 =
|
||||
] any? not
|
||||
] if
|
||||
] any? not ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: miller-rabin* ( n numtrials -- ? )
|
||||
over {
|
||||
{ [ dup 1 <= ] [ 3drop f ] }
|
||||
{ [ dup 2 = ] [ 3drop t ] }
|
||||
{ [ dup even? ] [ 3drop f ] }
|
||||
[ drop (miller-rabin) ]
|
||||
} cond ;
|
||||
|
||||
: miller-rabin ( n -- ? ) 10 miller-rabin* ;
|
||||
|
|
@ -1,10 +1,10 @@
|
|||
USING: help.markup help.syntax ;
|
||||
USING: help.markup help.syntax math sequences ;
|
||||
IN: math.primes
|
||||
|
||||
{ next-prime prime? } related-words
|
||||
|
||||
HELP: next-prime
|
||||
{ $values { "n" "an integer not smaller than 2" } { "p" "a prime number" } }
|
||||
{ $values { "n" integer } { "p" "a prime number" } }
|
||||
{ $description "Return the next prime number greater than " { $snippet "n" } "." } ;
|
||||
|
||||
HELP: prime?
|
||||
|
|
@ -20,3 +20,48 @@ HELP: primes-upto
|
|||
HELP: primes-between
|
||||
{ $values { "low" "an integer" } { "high" "an integer" } { "seq" "a sequence" } }
|
||||
{ $description "Return a sequence containing all the prime numbers between " { $snippet "low" } " and " { $snippet "high" } "." } ;
|
||||
|
||||
HELP: find-relative-prime
|
||||
{ $values
|
||||
{ "n" integer }
|
||||
{ "p" integer }
|
||||
}
|
||||
{ $description "Returns a number that is relatively prime to " { $snippet "n" } "." } ;
|
||||
|
||||
HELP: find-relative-prime*
|
||||
{ $values
|
||||
{ "n" integer } { "guess" integer }
|
||||
{ "p" integer }
|
||||
}
|
||||
{ $description "Returns a number that is relatively prime to " { $snippet "n" } ", starting by trying " { $snippet "guess" } "." } ;
|
||||
|
||||
HELP: random-prime
|
||||
{ $values
|
||||
{ "numbits" integer }
|
||||
{ "p" integer }
|
||||
}
|
||||
{ $description "Returns a prime number exactly " { $snippet "numbits" } " bits in length, with the topmost bit set to one." } ;
|
||||
|
||||
HELP: unique-primes
|
||||
{ $values
|
||||
{ "numbits" integer } { "n" integer }
|
||||
{ "seq" sequence }
|
||||
}
|
||||
{ $description "Generates a sequence of " { $snippet "n" } " unique prime numbers with exactly " { $snippet "numbits" } " bits." } ;
|
||||
|
||||
ARTICLE: "math.primes" "Prime numbers"
|
||||
"The " { $vocab-link "math.primes" } " vocabulary implements words related to prime numbers. Serveral useful vocabularies exist for testing primality. The Sieve of Eratosthenes in " { $vocab-link "math.primes.erato" } " is useful for testing primality below five million. For larger integers, " { $vocab-link "math.primes.miller-rabin" } " is a fast probabilstic primality test. The " { $vocab-link "math.primes.lucas-lehmer" } " vocabulary implements an algorithm for finding huge Mersenne prime numbers." $nl
|
||||
"Testing if a number is prime:"
|
||||
{ $subsection prime? }
|
||||
"Generating prime numbers:"
|
||||
{ $subsection next-prime }
|
||||
{ $subsection primes-upto }
|
||||
{ $subsection primes-between }
|
||||
{ $subsection random-prime }
|
||||
"Generating relative prime numbers:"
|
||||
{ $subsection find-relative-prime }
|
||||
{ $subsection find-relative-prime* }
|
||||
"Make a sequence of random prime numbers:"
|
||||
{ $subsection unique-primes } ;
|
||||
|
||||
ABOUT: "math.primes"
|
||||
|
|
|
|||
|
|
@ -1,4 +1,6 @@
|
|||
USING: arrays math.primes tools.test ;
|
||||
USING: arrays math math.primes math.primes.miller-rabin
|
||||
tools.test ;
|
||||
IN: math.primes.tests
|
||||
|
||||
{ 1237 } [ 1234 next-prime ] unit-test
|
||||
{ f t } [ 1234 prime? 1237 prime? ] unit-test
|
||||
|
|
@ -7,3 +9,12 @@ USING: arrays math.primes tools.test ;
|
|||
|
||||
{ { 4999963 4999999 5000011 5000077 5000081 } }
|
||||
[ 4999962 5000082 primes-between >array ] unit-test
|
||||
|
||||
[ 2 ] [ 1 next-prime ] unit-test
|
||||
[ 3 ] [ 2 next-prime ] unit-test
|
||||
[ 5 ] [ 3 next-prime ] unit-test
|
||||
[ 101 ] [ 100 next-prime ] unit-test
|
||||
[ t ] [ 2135623355842621559 miller-rabin ] unit-test
|
||||
[ 100000000000031 ] [ 100000000000000 next-prime ] unit-test
|
||||
|
||||
[ 49 ] [ 50 random-prime log2 ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,7 +1,8 @@
|
|||
! Copyright (C) 2007-2009 Samuel Tardieu.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: combinators kernel math math.functions math.miller-rabin
|
||||
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
|
||||
|
|
@ -21,7 +22,11 @@ PRIVATE>
|
|||
} cond ; foldable
|
||||
|
||||
: next-prime ( n -- p )
|
||||
next-odd [ dup really-prime? ] [ 2 + ] until ; foldable
|
||||
dup 2 < [
|
||||
drop 2
|
||||
] [
|
||||
next-odd [ dup really-prime? ] [ 2 + ] until
|
||||
] if ; foldable
|
||||
|
||||
: primes-between ( low high -- seq )
|
||||
[ dup 3 max dup even? [ 1 + ] when ] dip
|
||||
|
|
@ -31,3 +36,34 @@ PRIVATE>
|
|||
: primes-upto ( n -- seq ) 2 swap primes-between ;
|
||||
|
||||
: coprime? ( a b -- ? ) gcd nip 1 = ; foldable
|
||||
|
||||
: random-prime ( numbits -- p )
|
||||
random-bits* next-prime ;
|
||||
|
||||
: estimated-primes ( m -- n )
|
||||
dup log / ; foldable
|
||||
|
||||
ERROR: no-relative-prime n ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: (find-relative-prime) ( n guess -- p )
|
||||
over 1 <= [ over no-relative-prime ] when
|
||||
dup 1 <= [ drop 3 ] when
|
||||
2dup gcd nip 1 > [ 2 + (find-relative-prime) ] [ nip ] if ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: find-relative-prime* ( n guess -- p )
|
||||
#! find a prime relative to n with initial guess
|
||||
>odd (find-relative-prime) ;
|
||||
|
||||
: find-relative-prime ( n -- p )
|
||||
dup random find-relative-prime* ;
|
||||
|
||||
ERROR: too-few-primes n numbits ;
|
||||
|
||||
: unique-primes ( n numbits -- seq )
|
||||
2dup 2^ estimated-primes > [ too-few-primes ] when
|
||||
2dup '[ _ random-prime ] replicate
|
||||
dup all-unique? [ 2nip ] [ drop unique-primes ] if ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Doug Coleman
|
||||
|
|
@ -0,0 +1,38 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: combinators.short-circuit help.markup help.syntax kernel
|
||||
math math.functions math.primes random ;
|
||||
IN: math.primes.safe
|
||||
|
||||
HELP: next-safe-prime
|
||||
{ $values
|
||||
{ "n" integer }
|
||||
{ "q" integer }
|
||||
}
|
||||
{ $description "Tests consecutive numbers and returns the next safe prime. A safe prime is desirable in cryptography applications such as Diffie-Hellman and SRP6." } ;
|
||||
|
||||
HELP: random-safe-prime
|
||||
{ $values
|
||||
{ "numbits" integer }
|
||||
{ "p" integer }
|
||||
}
|
||||
{ $description "Returns a safe prime number " { $snippet "numbits" } " bits in length, with the topmost bit set to one." } ;
|
||||
|
||||
HELP: safe-prime?
|
||||
{ $values
|
||||
{ "q" integer }
|
||||
{ "?" "a boolean" }
|
||||
}
|
||||
{ $description "Tests whether the number is a safe prime. A safe prime " { $snippet "p" } " must be prime, as must " { $snippet "(p - 1) / 2" } "." } ;
|
||||
|
||||
|
||||
ARTICLE: "math.primes.safe" "Safe prime numbers"
|
||||
"The " { $vocab-link "math.primes.safe" } " vocabulary implements words to calculate safe prime numbers. Safe primes are of the form p = 2q + 1, where p,q are prime. Safe primes have desirable qualities for cryptographic applications." $nl
|
||||
|
||||
"Testing if a number is a safe prime:"
|
||||
{ $subsection safe-prime? }
|
||||
"Generating safe prime numbers:"
|
||||
{ $subsection next-safe-prime }
|
||||
{ $subsection random-safe-prime } ;
|
||||
|
||||
ABOUT: "math.primes.safe"
|
||||
|
|
@ -0,0 +1,14 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: math.primes.safe math.primes.safe.private tools.test ;
|
||||
IN: math.primes.safe.tests
|
||||
|
||||
[ 863 ] [ 862 next-safe-prime ] unit-test
|
||||
[ f ] [ 862 safe-prime? ] unit-test
|
||||
[ t ] [ 7 safe-prime? ] unit-test
|
||||
[ f ] [ 31 safe-prime? ] unit-test
|
||||
[ t ] [ 47 safe-prime-candidate? ] unit-test
|
||||
[ t ] [ 47 safe-prime? ] unit-test
|
||||
[ t ] [ 863 safe-prime? ] unit-test
|
||||
|
||||
[ 47 ] [ 31 next-safe-prime ] unit-test
|
||||
|
|
@ -0,0 +1,29 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: combinators.short-circuit kernel math math.functions
|
||||
math.primes random ;
|
||||
IN: math.primes.safe
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: safe-prime-candidate? ( n -- ? )
|
||||
1 + 6 divisor? ;
|
||||
|
||||
: next-safe-prime-candidate ( n -- candidate )
|
||||
next-prime dup safe-prime-candidate?
|
||||
[ next-safe-prime-candidate ] unless ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: safe-prime? ( q -- ? )
|
||||
{
|
||||
[ 1 - 2 / dup integer? [ prime? ] [ drop f ] if ]
|
||||
[ prime? ]
|
||||
} 1&& ;
|
||||
|
||||
: next-safe-prime ( n -- q )
|
||||
next-safe-prime-candidate
|
||||
dup safe-prime? [ next-safe-prime ] unless ;
|
||||
|
||||
: random-safe-prime ( numbits -- p )
|
||||
random-bits* next-safe-prime ;
|
||||
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
||||
|
|
@ -0,0 +1,7 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors math.rectangles kernel prettyprint.custom prettyprint.backend ;
|
||||
IN: math.rectangles.prettyprint
|
||||
|
||||
M: rect pprint*
|
||||
\ RECT: [ [ loc>> ] [ dim>> ] bi [ pprint* ] bi@ ] pprint-prefix ;
|
||||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel arrays sequences math math.vectors accessors
|
||||
parser prettyprint.custom prettyprint.backend ;
|
||||
parser ;
|
||||
IN: math.rectangles
|
||||
|
||||
TUPLE: rect { loc initial: { 0 0 } } { dim initial: { 0 0 } } ;
|
||||
|
|
@ -10,9 +10,6 @@ TUPLE: rect { loc initial: { 0 0 } } { dim initial: { 0 0 } } ;
|
|||
|
||||
SYNTAX: RECT: scan-object scan-object <rect> parsed ;
|
||||
|
||||
M: rect pprint*
|
||||
\ RECT: [ [ loc>> ] [ dim>> ] bi [ pprint* ] bi@ ] pprint-prefix ;
|
||||
|
||||
: <zero-rect> ( -- rect ) rect new ; inline
|
||||
|
||||
: point>rect ( loc -- rect ) { 0 0 } <rect> ; inline
|
||||
|
|
@ -64,3 +61,7 @@ M: rect contains-point?
|
|||
[ [ loc>> ] dip (>>loc) ]
|
||||
[ [ dim>> ] dip (>>dim) ]
|
||||
2bi ; inline
|
||||
|
||||
USING: vocabs vocabs.loader ;
|
||||
|
||||
"prettyprint" vocab [ "math.rectangles.prettyprint" require ] when
|
||||
|
|
@ -14,3 +14,5 @@ USING: math.vectors tools.test ;
|
|||
[ { 1.75 1.75 } ] [ { 1.0 2.5 } { 2.5 1.0 } 0.5 vnlerp ] unit-test
|
||||
|
||||
[ { 1.75 2.125 } ] [ { 1.0 2.5 } { 2.5 1.0 } { 0.5 0.25 } vlerp ] unit-test
|
||||
|
||||
[ 1.125 ] [ 0.0 1.0 2.0 4.0 { 0.5 0.25 } bilerp ] unit-test
|
||||
|
|
|
|||
|
|
@ -41,6 +41,17 @@ IN: math.vectors
|
|||
: set-axis ( u v axis -- w )
|
||||
[ [ zero? 2over ? ] dip swap nth ] map-index 2nip ;
|
||||
|
||||
: 2tetra@ ( p q r s t u v w quot -- )
|
||||
dup [ [ 2bi@ ] curry 4dip ] dip 2bi@ ; inline
|
||||
|
||||
: trilerp ( aaa baa aba bba aab bab abb bbb {t,u,v} -- a_tuv )
|
||||
[ first lerp ] [ second lerp ] [ third lerp ] tri-curry
|
||||
[ 2tetra@ ] [ 2bi@ ] [ call ] tri* ;
|
||||
|
||||
: bilerp ( aa ba ab bb {t,u} -- a_tu )
|
||||
[ first lerp ] [ second lerp ] bi-curry
|
||||
[ 2bi@ ] [ call ] bi* ;
|
||||
|
||||
: vlerp ( a b t -- a_t )
|
||||
[ lerp ] 3map ;
|
||||
|
||||
|
|
@ -68,3 +79,6 @@ HINTS: v. { array array } ;
|
|||
|
||||
HINTS: vlerp { array array array } ;
|
||||
HINTS: vnlerp { array array object } ;
|
||||
|
||||
HINTS: bilerp { object object object object array } ;
|
||||
HINTS: trilerp { object object object object object object object object array } ;
|
||||
|
|
|
|||
|
|
@ -6,7 +6,6 @@ H{
|
|||
{ deploy-name "none" }
|
||||
{ "stop-after-last-window?" t }
|
||||
{ deploy-c-types? f }
|
||||
{ deploy-compiler? f }
|
||||
{ deploy-io 1 }
|
||||
{ deploy-ui? f }
|
||||
{ deploy-reflection 1 }
|
||||
|
|
|
|||
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue