From 1e7506f7c1ee92576d403308f47d0504e8ed1106 Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Thu, 7 May 2009 10:32:32 +0200 Subject: [PATCH 01/27] reworked insert, save and update; added save-deep --- extra/mongodb/tuple/tuple.factor | 16 ++++++++++++---- 1 file changed, 12 insertions(+), 4 deletions(-) diff --git a/extra/mongodb/tuple/tuple.factor b/extra/mongodb/tuple/tuple.factor index 9173957979..e5e4867d71 100644 --- a/extra/mongodb/tuple/tuple.factor +++ b/extra/mongodb/tuple/tuple.factor @@ -54,14 +54,22 @@ M: mdb-persistent id-selector >upsert update ] assoc-each ; inline PRIVATE> -: save-tuple ( tuple -- ) - tuple>storable [ (save-tuples) ] assoc-each ; +: save-tuple-deep ( tuple -- ) + tuple>storable [ (save-tuples) ] assoc-each ; : update-tuple ( tuple -- ) - save-tuple ; + [ tuple-collection name>> ] + [ id-selector ] + [ tuple>assoc ] tri + update ; + +: save-tuple ( tuple -- ) + update-tuple ; : insert-tuple ( tuple -- ) - save-tuple ; + [ tuple-collection name>> ] + [ tuple>assoc ] bi + save ; : delete-tuple ( tuple -- ) [ tuple-collection name>> ] keep From d047c5110f8991b7364fe708463452dccd05dae9 Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Thu, 7 May 2009 12:01:01 +0200 Subject: [PATCH 02/27] some bug fixes --- extra/mongodb/tuple/collection/collection.factor | 4 +++- extra/mongodb/tuple/tuple.factor | 2 +- 2 files changed, 4 insertions(+), 2 deletions(-) diff --git a/extra/mongodb/tuple/collection/collection.factor b/extra/mongodb/tuple/collection/collection.factor index 1bd2d94e69..60b2d25764 100644 --- a/extra/mongodb/tuple/collection/collection.factor +++ b/extra/mongodb/tuple/collection/collection.factor @@ -92,6 +92,8 @@ GENERIC: mdb-index-map ( tuple -- sequence ) [ ] [ name>> ] bi H{ } clone [ set-at ] keep ] [ 2drop H{ } clone ] if ; + + PRIVATE> : MDB_ADDON_SLOTS ( -- slots ) @@ -116,7 +118,7 @@ PRIVATE> [ drop MDB_USER_KEY set-word-prop ] [ 3drop ] if ; inline : set-index-map ( class index-list -- ) - [ [ dup user-defined-key-index ] dip index-list>map ] output>sequence + [ dup user-defined-key-index ] dip index-list>map 2array assoc-combine MDB_INDEX_MAP set-word-prop ; inline M: tuple-class tuple-collection ( tuple -- mdb-collection ) diff --git a/extra/mongodb/tuple/tuple.factor b/extra/mongodb/tuple/tuple.factor index e5e4867d71..8f7504d9bc 100644 --- a/extra/mongodb/tuple/tuple.factor +++ b/extra/mongodb/tuple/tuple.factor @@ -69,7 +69,7 @@ PRIVATE> : insert-tuple ( tuple -- ) [ tuple-collection name>> ] [ tuple>assoc ] bi - save ; + save ; : delete-tuple ( tuple -- ) [ tuple-collection name>> ] keep From dc1b97e70ab9eaa8b9453b30ce57a5399582ad88 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 8 May 2009 09:51:57 -0500 Subject: [PATCH 03/27] cleaning up sha2 --- basis/checksums/sha2/sha2.factor | 28 ++++++++++++++++------------ 1 file changed, 16 insertions(+), 12 deletions(-) diff --git a/basis/checksums/sha2/sha2.factor b/basis/checksums/sha2/sha2.factor index 3b092a78de..b4b787a2b7 100644 --- a/basis/checksums/sha2/sha2.factor +++ b/basis/checksums/sha2/sha2.factor @@ -2,12 +2,12 @@ ! 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 ; IN: checksums.sha2 Date: Fri, 8 May 2009 10:04:31 -0500 Subject: [PATCH 04/27] more refactoring on sha2 --- basis/checksums/sha2/sha2.factor | 40 ++++++++++++++++++-------------- 1 file changed, 22 insertions(+), 18 deletions(-) diff --git a/basis/checksums/sha2/sha2.factor b/basis/checksums/sha2/sha2.factor index b4b787a2b7..57a1db5ac1 100644 --- a/basis/checksums/sha2/sha2.factor +++ b/basis/checksums/sha2/sha2.factor @@ -2,7 +2,7 @@ ! 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 combinators.smart ; +sbufs strings combinators.smart math.ranges fry combinators ; IN: checksums.sha2 ] map block-size get 0 pad-tail - dup 16 64 dup [ - process-M-256 - ] with each ; + 16 64 [a,b) over '[ _ process-M-256 ] each ; : ch ( x y z -- x' ) [ bitxor bitand ] keep bitxor ; : maj ( x y z -- x' ) - [ [ bitand ] 2keep bitor ] dip bitand bitor ; + [ [ bitand ] [ bitor ] 2bi ] dip bitand bitor ; : 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 first3 ; inline @@ -118,7 +122,7 @@ CONSTANT: K-256 ] with each vars get H get [ w+ ] 2map H set ; : seq>byte-array ( n seq -- string ) - [ swap [ >be % ] curry each ] B{ } make ; + [ swap '[ _ >be % ] each ] B{ } make ; : preprocess-plaintext ( string big-endian? -- padded-string ) #! pad 0x80 then 00 til 8 bytes left, then 64bit length in bits From 0dd2aa643acf460d0cb039d4b7eed7461fa3ea06 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 8 May 2009 10:52:25 -0500 Subject: [PATCH 05/27] more refactoring on sha2 --- basis/checksums/sha2/sha2.factor | 114 +++++++++++++++++-------------- 1 file changed, 62 insertions(+), 52 deletions(-) diff --git a/basis/checksums/sha2/sha2.factor b/basis/checksums/sha2/sha2.factor index 57a1db5ac1..cd67418516 100644 --- a/basis/checksums/sha2/sha2.factor +++ b/basis/checksums/sha2/sha2.factor @@ -2,12 +2,13 @@ ! 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 combinators.smart math.ranges fry combinators ; +sbufs strings combinators.smart math.ranges fry combinators +accessors ; IN: checksums.sha2 ] map block-size get 0 pad-tail - 16 64 [a,b) over '[ _ process-M-256 ] each ; - -: ch ( x y z -- x' ) - [ bitxor bitand ] keep bitxor ; - -: maj ( x y z -- x' ) - [ [ bitand ] [ bitor ] 2bi ] dip bitand bitor ; - : S0-256 ( x -- x' ) [ [ -2 bitroll-32 ] @@ -91,21 +73,42 @@ CONSTANT: K-256 [ -25 bitroll-32 ] tri ] [ bitxor ] reduce-outputs ; inline -: slice3 ( n seq -- a b c ) [ dup 3 + ] dip first3 ; 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 -: 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+ ; +: ch ( x y z -- x' ) + [ bitxor bitand ] keep bitxor ; -: T2 ( -- T2 ) - a vars get nth S0-256 - a vars get slice3 maj w+ ; +: maj ( x y z -- x' ) + [ [ bitand ] [ bitor ] 2bi ] dip bitand bitor ; -: update-vars ( T1 T2 -- ) - vars get +: prepare-message-schedule ( seq -- w-seq ) + word-size get [ be> ] map block-size get 0 pad-tail + 16 64 [a,b) over '[ _ process-M-256 ] each ; + +: slice3 ( n seq -- a b c ) + [ dup 3 + ] dip first3 ; inline + +: T1 ( W n H -- T1 ) + [ + [ swap nth ] keep + K-256 nth + + ] dip + [ e swap slice3 ch w+ ] + [ e swap nth S1-256 w+ ] + [ h swap nth w+ ] tri ; + +: T2 ( H -- T2 ) + [ a swap nth S0-256 ] + [ a swap slice3 maj w+ ] bi ; + +: update-H ( T1 T2 H -- ) h g pick exchange g f pick exchange f e pick exchange @@ -115,28 +118,35 @@ CONSTANT: K-256 b a pick exchange [ w+ a ] dip set-nth ; -: 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 ; +: process-chunk ( M block-size H-cloned -- ) + [ + '[ + _ + [ T1 ] + [ T2 ] + [ update-H ] tri + ] with each + ] keep H get [ w+ ] 2map H set ; -: seq>byte-array ( n seq -- string ) - [ swap '[ _ >be % ] each ] B{ } make ; - -: preprocess-plaintext ( string big-endian? -- padded-string ) - #! pad 0x80 then 00 til 8 bytes left, then 64bit length in bits - [ >sbuf ] dip over [ +: pad-initial-bytes ( string -- padded-string ) + dup [ HEX: 80 , - dup length HEX: 3f bitand - calculate-pad-length 0 % - length 3 shift 8 rot [ >be ] [ >le ] if % - ] "" make over push-all ; + length + [ HEX: 3f bitand calculate-pad-length 0 % ] + [ 3 shift 8 >be % ] bi + ] "" make append ; + +: seq>byte-array ( seq n -- string ) + '[ _ >be ] map B{ } join ; : byte-array>sha2 ( byte-array -- string ) - t preprocess-plaintext - block-size get group [ process-chunk ] each - 4 H get seq>byte-array ; + pad-initial-bytes + block-size get + [ + prepare-message-schedule + block-size get H get clone process-chunk + ] each + H get 4 seq>byte-array ; PRIVATE> @@ -146,9 +156,9 @@ INSTANCE: sha-256 checksum 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 ; From 7a849022f4baf1aedb6c2ba9ebbe604fde244c8c Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 8 May 2009 17:18:43 -0500 Subject: [PATCH 06/27] move sha2 state to a tuple --- basis/checksums/sha2/sha2.factor | 36 +++++++++++++++++++------------- 1 file changed, 22 insertions(+), 14 deletions(-) diff --git a/basis/checksums/sha2/sha2.factor b/basis/checksums/sha2/sha2.factor index cd67418516..ff19c4c9a8 100644 --- a/basis/checksums/sha2/sha2.factor +++ b/basis/checksums/sha2/sha2.factor @@ -8,7 +8,7 @@ IN: checksums.sha2 [ be> ] map block-size get 0 pad-tail + sha2 get word-size>> [ be> ] map sha2 get block-size>> 0 pad-tail 16 64 [a,b) over '[ _ process-M-256 ] each ; : slice3 ( n seq -- a b c ) @@ -98,7 +98,7 @@ CONSTANT: K-256 : T1 ( W n H -- T1 ) [ [ swap nth ] keep - K-256 nth + + sha2 get K>> nth + ] dip [ e swap slice3 ch w+ ] [ e swap nth S1-256 w+ ] @@ -126,7 +126,7 @@ CONSTANT: K-256 [ T2 ] [ update-H ] tri ] with each - ] keep H get [ w+ ] 2map H set ; + ] keep sha2 get H>> [ w+ ] 2map sha2 get (>>H) ; : pad-initial-bytes ( string -- padded-string ) dup [ @@ -141,12 +141,12 @@ CONSTANT: K-256 : byte-array>sha2 ( byte-array -- string ) pad-initial-bytes - block-size get + sha2 get block-size>> [ prepare-message-schedule - block-size get H get clone process-chunk + sha2 get [ block-size>> ] [ H>> clone ] bi process-chunk ] each - H get 4 seq>byte-array ; + sha2 get H>> 4 seq>byte-array ; PRIVATE> @@ -154,11 +154,19 @@ SINGLETON: sha-256 INSTANCE: sha-256 checksum -M: sha-256 checksum-bytes - drop [ - initial-H-256 H set - 4 word-size set - 64 block-size set - byte-array>sha2 +TUPLE: sha2-state K H word-size block-size ; - ] with-scope ; +TUPLE: sha-256-state < sha2-state ; + +: ( -- sha2-state ) + sha-256-state new + K-256 >>K + initial-H-256 >>H + 4 >>word-size + 64 >>block-size ; + +M: sha-256 checksum-bytes + drop + sha2 [ + byte-array>sha2 + ] with-variable ; From e033f92e0ceac8c27d102792c8757db9b88c56ee Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 8 May 2009 17:39:11 -0500 Subject: [PATCH 07/27] remove dynamic variables from sha2 --- basis/checksums/sha2/sha2.factor | 89 +++++++++++++++----------------- 1 file changed, 41 insertions(+), 48 deletions(-) diff --git a/basis/checksums/sha2/sha2.factor b/basis/checksums/sha2/sha2.factor index ff19c4c9a8..d019a6913b 100644 --- a/basis/checksums/sha2/sha2.factor +++ b/basis/checksums/sha2/sha2.factor @@ -3,7 +3,7 @@ USING: kernel splitting grouping math sequences namespaces make io.binary math.bitwise checksums checksums.common sbufs strings combinators.smart math.ranges fry combinators -accessors ; +accessors locals ; IN: checksums.sha2 > [ be> ] map sha2 get block-size>> 0 pad-tail - 16 64 [a,b) over '[ _ process-M-256 ] each ; + [ [ bitand ] [ bitor ] 2bi ] dip bitand bitor ; inline : slice3 ( n seq -- a b c ) [ dup 3 + ] dip first3 ; inline -: T1 ( W n H -- T1 ) - [ - [ swap nth ] keep - sha2 get K>> nth + - ] dip - [ e swap slice3 ch w+ ] - [ e swap nth S1-256 w+ ] - [ h swap nth w+ ] tri ; +: pad-initial-bytes ( string -- padded-string ) + dup [ + HEX: 80 , + length + [ HEX: 3f bitand calculate-pad-length 0 % ] + [ 3 shift 8 >be % ] bi + ] "" make append ; + +: seq>byte-array ( seq n -- string ) + '[ _ >be ] map B{ } join ; + +:: T1 ( 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+ ; : T2 ( H -- T2 ) [ a swap nth S0-256 ] @@ -116,37 +121,28 @@ CONSTANT: K-256 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 block-size H-cloned -- ) - [ - '[ - _ - [ T1 ] - [ T2 ] - [ update-H ] tri - ] with each - ] keep sha2 get H>> [ w+ ] 2map sha2 get (>>H) ; +: prepare-message-schedule ( seq sha2 -- w-seq ) + [ word-size>> [ be> ] map ] + [ block-size>> 0 pad-tail 16 64 [a,b) over '[ _ process-M-256 ] each ] bi ; -: pad-initial-bytes ( string -- padded-string ) - dup [ - HEX: 80 , - length - [ HEX: 3f bitand calculate-pad-length 0 % ] - [ 3 shift 8 >be % ] bi - ] "" make append ; - -: seq>byte-array ( seq n -- string ) - '[ _ >be ] map B{ } join ; - -: byte-array>sha2 ( byte-array -- string ) - pad-initial-bytes - sha2 get block-size>> - [ - prepare-message-schedule - sha2 get [ block-size>> ] [ H>> clone ] bi process-chunk +:: process-chunk ( M block-size cloned-H sha2 -- ) + block-size [ + M cloned-H sha2 T1 + cloned-H T2 + cloned-H update-H ] each - sha2 get H>> 4 seq>byte-array ; + cloned-H sha2 H>> [ w+ ] 2map sha2 (>>H) ; + +:: byte-array>sha2 ( bytes state -- string ) + bytes pad-initial-bytes + state block-size>> + [ + state prepare-message-schedule + state [ block-size>> ] [ H>> clone ] bi state process-chunk + ] each + state H>> 4 seq>byte-array ; PRIVATE> @@ -163,10 +159,7 @@ TUPLE: sha-256-state < sha2-state ; K-256 >>K initial-H-256 >>H 4 >>word-size - 64 >>block-size ; + 64 >>block-size ; M: sha-256 checksum-bytes - drop - sha2 [ - byte-array>sha2 - ] with-variable ; + drop byte-array>sha2 ; From 0e4f82f663a166581990fefb806ad545d9c2eaff Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 8 May 2009 18:11:13 -0500 Subject: [PATCH 08/27] support sha-224, add constants for all sha2 --- basis/checksums/sha2/sha2-tests.factor | 43 ++++++++-- basis/checksums/sha2/sha2.factor | 108 +++++++++++++++++++++---- 2 files changed, 130 insertions(+), 21 deletions(-) diff --git a/basis/checksums/sha2/sha2-tests.factor b/basis/checksums/sha2/sha2-tests.factor index 2f4e3c51c4..1476f04e75 100644 --- a/basis/checksums/sha2/sha2-tests.factor +++ b/basis/checksums/sha2/sha2-tests.factor @@ -1,7 +1,36 @@ -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 diff --git a/basis/checksums/sha2/sha2.factor b/basis/checksums/sha2/sha2.factor index d019a6913b..6a695b0965 100644 --- a/basis/checksums/sha2/sha2.factor +++ b/basis/checksums/sha2/sha2.factor @@ -19,12 +19,42 @@ CONSTANT: f 5 CONSTANT: g 6 CONSTANT: h 7 +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 } +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 @@ -45,6 +75,29 @@ CONSTANT: K-256 HEX: 90befffa HEX: a4506ceb HEX: bef9a3f7 HEX: c67178f2 } +CONSTANT: K-384 + { + 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 ] @@ -107,11 +160,11 @@ CONSTANT: K-256 n sha2 K>> nth + e H slice3 ch w+ e H nth S1-256 w+ - h H nth w+ ; + h H nth w+ ; inline : T2 ( H -- T2 ) [ a swap nth S0-256 ] - [ a swap slice3 maj w+ ] bi ; + [ a swap slice3 maj w+ ] bi ; inline : update-H ( T1 T2 H -- ) h g pick exchange @@ -125,33 +178,53 @@ CONSTANT: K-256 : prepare-message-schedule ( seq sha2 -- w-seq ) [ word-size>> [ be> ] map ] - [ block-size>> 0 pad-tail 16 64 [a,b) over '[ _ process-M-256 ] each ] bi ; + [ + block-size>> 0 pad-tail 16 64 [a,b) over + '[ _ process-M-256 ] each + ] bi ; inline :: process-chunk ( M block-size cloned-H sha2 -- ) block-size [ M cloned-H sha2 T1 cloned-H T2 - cloned-H update-H + cloned-H update-H ] each - cloned-H sha2 H>> [ w+ ] 2map sha2 (>>H) ; + cloned-H sha2 H>> [ w+ ] 2map sha2 (>>H) ; inline -:: byte-array>sha2 ( bytes state -- string ) - bytes pad-initial-bytes - state block-size>> - [ - state prepare-message-schedule - state [ block-size>> ] [ H>> clone ] bi state process-chunk - ] each - state H>> 4 seq>byte-array ; +: sha2-steps ( sliced-groups state -- ) + '[ + _ + [ prepare-message-schedule ] + [ [ block-size>> ] [ H>> clone ] [ ] tri process-chunk ] bi + ] each ; + +: byte-array>sha2 ( bytes state -- ) + [ [ pad-initial-bytes ] [ block-size>> ] bi* ] + [ sha2-steps ] bi ; PRIVATE> +SINGLETON: sha-224 SINGLETON: sha-256 +SINGLETON: sha-384 +SINGLETON: sha-512 +INSTANCE: sha-224 checksum INSTANCE: sha-256 checksum +INSTANCE: sha-384 checksum +INSTANCE: sha-512 checksum TUPLE: sha2-state K H word-size block-size ; +TUPLE: sha-224-state < sha2-state ; + +: ( -- sha2-state ) + sha-224-state new + K-256 >>K + initial-H-224 >>H + 4 >>word-size + 64 >>block-size ; + TUPLE: sha-256-state < sha2-state ; : ( -- sha2-state ) @@ -161,5 +234,12 @@ TUPLE: sha-256-state < sha2-state ; 4 >>word-size 64 >>block-size ; +M: sha-224 checksum-bytes + drop + [ byte-array>sha2 ] + [ H>> 7 head 4 seq>byte-array ] bi ; + M: sha-256 checksum-bytes - drop byte-array>sha2 ; + drop + [ byte-array>sha2 ] + [ H>> 4 seq>byte-array ] bi ; From 097ce4c6dda63ea96cc73d3d9082871b347e2d46 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 8 May 2009 19:00:06 -0500 Subject: [PATCH 09/27] implementing sha2 512 --- basis/checksums/common/common.factor | 3 + basis/checksums/sha2/sha2-tests.factor | 6 ++ basis/checksums/sha2/sha2.factor | 93 +++++++++++++++++++------- 3 files changed, 78 insertions(+), 24 deletions(-) diff --git a/basis/checksums/common/common.factor b/basis/checksums/common/common.factor index 0ae4328446..01cc2cb739 100644 --- a/basis/checksums/common/common.factor +++ b/basis/checksums/common/common.factor @@ -9,6 +9,9 @@ SYMBOL: bytes-read : calculate-pad-length ( length -- length' ) [ 56 < 55 119 ? ] keep - ; +: calculate-pad-length-long ( length -- length' ) + [ 112 < 111 249 ? ] keep - ; + : pad-last-block ( str big-endian? length -- str ) [ [ % ] 2dip HEX: 80 , diff --git a/basis/checksums/sha2/sha2-tests.factor b/basis/checksums/sha2/sha2-tests.factor index 1476f04e75..f224d497a6 100644 --- a/basis/checksums/sha2/sha2-tests.factor +++ b/basis/checksums/sha2/sha2-tests.factor @@ -34,3 +34,9 @@ IN: checksums.sha2.tests "12345678901234567890123456789012345678901234567890123456789012345678901234567890" sha-256 test-checksum ] unit-test + + + + +[ "8e959b75dae313da8cf4f72814fc143f8f7779c6eb9f7fa17299aeadb6889018501d289e4900f7e4331b99dec4b5433ac7d329eeb6dd26545e96e55b874be909" ] +[ "abcdefghbcdefghicdefghijdefghijkefghijklfghijklmghijklmnhijklmnoijklmnopjklmnopqklmnopqrlmnopqrsmnopqrstnopqrstu" sha-512 test-checksum ] unit-test diff --git a/basis/checksums/sha2/sha2.factor b/basis/checksums/sha2/sha2.factor index 6a695b0965..1abed088a3 100644 --- a/basis/checksums/sha2/sha2.factor +++ b/basis/checksums/sha2/sha2.factor @@ -6,9 +6,31 @@ sbufs strings combinators.smart math.ranges fry combinators accessors locals ; IN: checksums.sha2 - first3 ; inline -: pad-initial-bytes ( string -- padded-string ) +GENERIC: pad-initial-bytes ( string sha2 -- padded-string ) + +M: sha2-short pad-initial-bytes ( string sha2 -- padded-string ) + drop dup [ HEX: 80 , length - [ HEX: 3f bitand calculate-pad-length 0 % ] + [ 64 mod calculate-pad-length 0 % ] [ 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 % ] + [ 3 shift 16 >be % ] bi + ] "" make append ; + : seq>byte-array ( seq n -- string ) '[ _ >be ] map B{ } join ; @@ -179,7 +216,7 @@ ALIAS: K-512 K-384 : prepare-message-schedule ( seq sha2 -- w-seq ) [ word-size>> [ be> ] map ] [ - block-size>> 0 pad-tail 16 64 [a,b) over + block-size>> [ 0 pad-tail 16 ] keep [a,b) over '[ _ process-M-256 ] each ] bi ; inline @@ -199,25 +236,9 @@ ALIAS: K-512 K-384 ] each ; : byte-array>sha2 ( bytes state -- ) - [ [ pad-initial-bytes ] [ block-size>> ] bi* ] + [ [ pad-initial-bytes ] [ nip block-size>> ] 2bi ] [ sha2-steps ] bi ; -PRIVATE> - -SINGLETON: sha-224 -SINGLETON: sha-256 -SINGLETON: sha-384 -SINGLETON: sha-512 - -INSTANCE: sha-224 checksum -INSTANCE: sha-256 checksum -INSTANCE: sha-384 checksum -INSTANCE: sha-512 checksum - -TUPLE: sha2-state K H word-size block-size ; - -TUPLE: sha-224-state < sha2-state ; - : ( -- sha2-state ) sha-224-state new K-256 >>K @@ -225,8 +246,6 @@ TUPLE: sha-224-state < sha2-state ; 4 >>word-size 64 >>block-size ; -TUPLE: sha-256-state < sha2-state ; - : ( -- sha2-state ) sha-256-state new K-256 >>K @@ -234,6 +253,22 @@ TUPLE: sha-256-state < sha2-state ; 4 >>word-size 64 >>block-size ; +: ( -- sha2-state ) + sha-384-state new + K-384 >>K + initial-H-384 >>H + 8 >>word-size + 80 >>block-size ; + +: ( -- sha2-state ) + sha-512-state new + K-512 >>K + initial-H-512 >>H + 8 >>word-size + 80 >>block-size ; + +PRIVATE> + M: sha-224 checksum-bytes drop [ byte-array>sha2 ] @@ -243,3 +278,13 @@ M: sha-256 checksum-bytes drop [ byte-array>sha2 ] [ H>> 4 seq>byte-array ] bi ; + +M: sha-384 checksum-bytes + drop + [ byte-array>sha2 ] + [ H>> 6 head 8 seq>byte-array ] bi ; + +M: sha-512 checksum-bytes + drop + [ byte-array>sha2 ] + [ H>> 8 seq>byte-array ] bi ; From 6913653d6233b93eb700edc4e1abd5b285fef5e0 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 9 May 2009 13:54:18 -0500 Subject: [PATCH 10/27] use bi, call >string on c-strings from tar --- extra/crypto/hmac/hmac.factor | 4 ++-- extra/tar/tar.factor | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/extra/crypto/hmac/hmac.factor b/extra/crypto/hmac/hmac.factor index 6e6229f182..9a668aa23a 100755 --- a/extra/crypto/hmac/hmac.factor +++ b/extra/crypto/hmac/hmac.factor @@ -31,8 +31,8 @@ MEMO: opad ( -- seq ) 64 HEX: 5c ; : init-hmac ( K -- o i ) 64 0 pad-tail - [ opad seq-bitxor ] keep - ipad seq-bitxor ; + [ opad seq-bitxor ] + [ ipad seq-bitxor ] bi ; PRIVATE> diff --git a/extra/tar/tar.factor b/extra/tar/tar.factor index e281871252..93554c146a 100755 --- a/extra/tar/tar.factor +++ b/extra/tar/tar.factor @@ -18,7 +18,7 @@ ERROR: checksum-error header ; : trim-string ( seq -- newseq ) [ "\0 " member? ] trim ; : read-c-string ( n -- str/f ) - read [ zero? ] trim-tail [ f ] when-empty ; + read [ zero? ] trim-tail [ f ] when-empty >string ; : read-tar-header ( -- obj ) \ tar-header new From 97da4e994bc148aa782fd5098d838fb788f90f72 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 9 May 2009 13:54:42 -0500 Subject: [PATCH 11/27] 64-bit add/subtract/multiply --- basis/math/bitwise/bitwise.factor | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/basis/math/bitwise/bitwise.factor b/basis/math/bitwise/bitwise.factor index 73d111f91e..4fe2340643 100755 --- a/basis/math/bitwise/bitwise.factor +++ b/basis/math/bitwise/bitwise.factor @@ -35,6 +35,11 @@ IN: math.bitwise : w- ( int int -- int ) - 32 bits ; inline : w* ( int int -- int ) * 32 bits ; inline +! 64-bit arithmetic +: W+ ( int int -- int ) + 64 bits ; inline +: W- ( int int -- int ) - 64 bits ; inline +: W* ( int int -- int ) * 64 bits ; inline + ! flags MACRO: flags ( values -- ) [ 0 ] [ [ ?execute bitor ] curry compose ] reduce ; From f0bd82b2dd7f08f1d024c8b8d8a57ec053dfd5bb Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Thu, 7 May 2009 10:32:32 +0200 Subject: [PATCH 12/27] reworked insert, save and update; added save-deep --- extra/mongodb/tuple/tuple.factor | 16 ++++++++++++---- 1 file changed, 12 insertions(+), 4 deletions(-) diff --git a/extra/mongodb/tuple/tuple.factor b/extra/mongodb/tuple/tuple.factor index 9173957979..e5e4867d71 100644 --- a/extra/mongodb/tuple/tuple.factor +++ b/extra/mongodb/tuple/tuple.factor @@ -54,14 +54,22 @@ M: mdb-persistent id-selector >upsert update ] assoc-each ; inline PRIVATE> -: save-tuple ( tuple -- ) - tuple>storable [ (save-tuples) ] assoc-each ; +: save-tuple-deep ( tuple -- ) + tuple>storable [ (save-tuples) ] assoc-each ; : update-tuple ( tuple -- ) - save-tuple ; + [ tuple-collection name>> ] + [ id-selector ] + [ tuple>assoc ] tri + update ; + +: save-tuple ( tuple -- ) + update-tuple ; : insert-tuple ( tuple -- ) - save-tuple ; + [ tuple-collection name>> ] + [ tuple>assoc ] bi + save ; : delete-tuple ( tuple -- ) [ tuple-collection name>> ] keep From 5399fe1d3dbeb5ee4d13b98401041694bfffd4b0 Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Thu, 7 May 2009 12:01:01 +0200 Subject: [PATCH 13/27] some bug fixes --- extra/mongodb/tuple/collection/collection.factor | 4 +++- extra/mongodb/tuple/tuple.factor | 2 +- 2 files changed, 4 insertions(+), 2 deletions(-) diff --git a/extra/mongodb/tuple/collection/collection.factor b/extra/mongodb/tuple/collection/collection.factor index 1bd2d94e69..60b2d25764 100644 --- a/extra/mongodb/tuple/collection/collection.factor +++ b/extra/mongodb/tuple/collection/collection.factor @@ -92,6 +92,8 @@ GENERIC: mdb-index-map ( tuple -- sequence ) [ ] [ name>> ] bi H{ } clone [ set-at ] keep ] [ 2drop H{ } clone ] if ; + + PRIVATE> : MDB_ADDON_SLOTS ( -- slots ) @@ -116,7 +118,7 @@ PRIVATE> [ drop MDB_USER_KEY set-word-prop ] [ 3drop ] if ; inline : set-index-map ( class index-list -- ) - [ [ dup user-defined-key-index ] dip index-list>map ] output>sequence + [ dup user-defined-key-index ] dip index-list>map 2array assoc-combine MDB_INDEX_MAP set-word-prop ; inline M: tuple-class tuple-collection ( tuple -- mdb-collection ) diff --git a/extra/mongodb/tuple/tuple.factor b/extra/mongodb/tuple/tuple.factor index e5e4867d71..8f7504d9bc 100644 --- a/extra/mongodb/tuple/tuple.factor +++ b/extra/mongodb/tuple/tuple.factor @@ -69,7 +69,7 @@ PRIVATE> : insert-tuple ( tuple -- ) [ tuple-collection name>> ] [ tuple>assoc ] bi - save ; + save ; : delete-tuple ( tuple -- ) [ tuple-collection name>> ] keep From 87caa8d7a000361e37a19579136cb9baeb2f29ab Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Sun, 10 May 2009 11:54:42 +0200 Subject: [PATCH 14/27] added delete-tuples word --- extra/mongodb/tuple/tuple.factor | 3 +++ 1 file changed, 3 insertions(+) diff --git a/extra/mongodb/tuple/tuple.factor b/extra/mongodb/tuple/tuple.factor index 8f7504d9bc..1b4b3cd4f1 100644 --- a/extra/mongodb/tuple/tuple.factor +++ b/extra/mongodb/tuple/tuple.factor @@ -75,6 +75,9 @@ PRIVATE> [ tuple-collection name>> ] keep id-selector delete ; +: delete-tuples ( seq -- ) + [ delete-tuple ] each ; + : tuple>query ( tuple -- query ) [ tuple-collection name>> ] keep tuple>selector ; From e301d29f903fd9a11427ee6fbe339b26ea557df5 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sun, 10 May 2009 10:41:50 -0500 Subject: [PATCH 15/27] cut perlin-noise time in half --- .../math/polynomials/polynomials-docs.factor | 10 +- basis/math/polynomials/polynomials.factor | 12 +- basis/math/vectors/vectors.factor | 10 ++ .../affine-transforms.factor | 2 + extra/noise/noise.factor | 105 ++++++++++-------- 5 files changed, 85 insertions(+), 54 deletions(-) diff --git a/basis/math/polynomials/polynomials-docs.factor b/basis/math/polynomials/polynomials-docs.factor index edffa5377d..6617556270 100644 --- a/basis/math/polynomials/polynomials-docs.factor +++ b/basis/math/polynomials/polynomials-docs.factor @@ -93,7 +93,13 @@ HELP: pdiff { $description "Finds the derivative of " { $snippet "p" } "." } ; HELP: polyval -{ $values { "p" "a polynomial" } { "x" number } { "p[x]" number } } +{ $values { "x" number } { "p" "a polynomial" } { "p[x]" number } } { $description "Evaluate " { $snippet "p" } " with the input " { $snippet "x" } "." } -{ $examples { $example "USING: math.polynomials prettyprint ;" "{ 1 0 1 } 2 polyval ." "5" } } ; +{ $examples { $example "USING: math.polynomials prettyprint ;" "2 { 1 0 1 } polyval ." "5" } } ; +HELP: polyval* +{ $values { "p" "a literal polynomial" } } +{ $description "Macro version of " { $link polyval } ". Evaluates the literal polynomial " { $snippet "p" } " at the value off the top of the stack." } +{ $examples { $example "USING: math.polynomials prettyprint ;" "2 { 1 0 1 } polyval* ." "5" } } ; + +{ polyval polyval* } related-words diff --git a/basis/math/polynomials/polynomials.factor b/basis/math/polynomials/polynomials.factor index f65c4ecaaf..fd6eda4a90 100644 --- a/basis/math/polynomials/polynomials.factor +++ b/basis/math/polynomials/polynomials.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: arrays kernel make math math.order math.vectors sequences - splitting vectors ; + splitting vectors macros combinators ; IN: math.polynomials : 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 ; diff --git a/basis/math/vectors/vectors.factor b/basis/math/vectors/vectors.factor index 17f6c39f04..bad2733bbf 100644 --- a/basis/math/vectors/vectors.factor +++ b/basis/math/vectors/vectors.factor @@ -41,6 +41,13 @@ 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* ; @@ -72,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 } ; diff --git a/extra/math/affine-transforms/affine-transforms.factor b/extra/math/affine-transforms/affine-transforms.factor index 20b73ba678..d1fd602f72 100644 --- a/extra/math/affine-transforms/affine-transforms.factor +++ b/extra/math/affine-transforms/affine-transforms.factor @@ -17,6 +17,8 @@ CONSTANT: identity-transform T{ affine-transform f { 1.0 0.0 } { 0.0 1.0 } { 0.0 [ drop origin>> ] 2tri v+ v+ ; +: ( -- a ) + { 1.0 0.0 } { 0.0 1.0 } { 0.0 0.0 } ; : ( origin -- a ) [ { 1.0 0.0 } { 0.0 1.0 } ] dip ; : ( theta -- transform ) diff --git a/extra/noise/noise.factor b/extra/noise/noise.factor index c28768283c..46704eed36 100644 --- a/extra/noise/noise.factor +++ b/extra/noise/noise.factor @@ -1,61 +1,60 @@ USING: byte-arrays combinators fry images kernel locals math math.affine-transforms math.functions math.order math.polynomials math.vectors random random.mersenne-twister -sequences sequences.product ; +sequences sequences.product hints arrays sequences.private +combinators.short-circuit math.private ; IN: noise : ( -- table ) - 256 iota >byte-array randomize dup append ; + 256 iota >byte-array randomize dup append ; inline : with-seed ( seed quot -- ) [ ] dip with-random ; inline 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 ; + [ floor >fixnum 256 rem ] 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 +:: 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 z + :> aa - b table nth z + :> ba - a 1 + table nth z + :> ab - b 1 + table nth z + :> bb + 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 - 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 ; + 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 -:: 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 +HINTS: hashes { byte-array fixnum fixnum fixnum } ; : >byte-map ( floats -- bytes ) [ 255.0 * >fixnum ] B{ } map-as ; @@ -63,26 +62,33 @@ IN: noise : >image ( bytes dim -- image ) swap [ L f ] dip image boa ; -PRIVATE> - -:: perlin-noise ( 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 @@ -92,7 +98,8 @@ PRIVATE> [ 0.0 max 1.0 min ] map ; : perlin-noise-map ( table transform dim -- map ) - [ iota ] map [ a.v 0.0 suffix perlin-noise ] with with product-map ; + [ validate-table ] 2dip + [ iota ] map [ a.v 0.0 suffix perlin-noise-unsafe ] with with product-map ; : perlin-noise-byte-map ( table transform dim -- map ) perlin-noise-map normalize-0-1 >byte-map ; From 2ce5b4f3f65f32336d2b594f8fc76ceac36bd702 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 10 May 2009 12:18:59 -0500 Subject: [PATCH 16/27] working on sha2 --- basis/checksums/common/common.factor | 2 +- basis/checksums/sha2/sha2-tests.factor | 4 +- basis/checksums/sha2/sha2.factor | 90 +++++++++++++++----------- 3 files changed, 56 insertions(+), 40 deletions(-) diff --git a/basis/checksums/common/common.factor b/basis/checksums/common/common.factor index 01cc2cb739..76675f9413 100644 --- a/basis/checksums/common/common.factor +++ b/basis/checksums/common/common.factor @@ -10,7 +10,7 @@ SYMBOL: bytes-read [ 56 < 55 119 ? ] keep - ; : calculate-pad-length-long ( length -- length' ) - [ 112 < 111 249 ? ] keep - ; + [ 120 < 119 247 ? ] keep - ; : pad-last-block ( str big-endian? length -- str ) [ diff --git a/basis/checksums/sha2/sha2-tests.factor b/basis/checksums/sha2/sha2-tests.factor index f224d497a6..c14ea5a98d 100644 --- a/basis/checksums/sha2/sha2-tests.factor +++ b/basis/checksums/sha2/sha2-tests.factor @@ -38,5 +38,5 @@ IN: checksums.sha2.tests -[ "8e959b75dae313da8cf4f72814fc143f8f7779c6eb9f7fa17299aeadb6889018501d289e4900f7e4331b99dec4b5433ac7d329eeb6dd26545e96e55b874be909" ] -[ "abcdefghbcdefghicdefghijdefghijkefghijklfghijklmghijklmnhijklmnoijklmnopjklmnopqklmnopqrlmnopqrsmnopqrstnopqrstu" sha-512 test-checksum ] unit-test +! [ "8e959b75dae313da8cf4f72814fc143f8f7779c6eb9f7fa17299aeadb6889018501d289e4900f7e4331b99dec4b5433ac7d329eeb6dd26545e96e55b874be909" ] +! [ "abcdefghbcdefghicdefghijdefghijkefghijklfghijklmghijklmnhijklmnoijklmnopjklmnopqklmnopqrlmnopqrsmnopqrstnopqrstu" sha-512 test-checksum ] unit-test diff --git a/basis/checksums/sha2/sha2.factor b/basis/checksums/sha2/sha2.factor index 1abed088a3..12e32f6c69 100644 --- a/basis/checksums/sha2/sha2.factor +++ b/basis/checksums/sha2/sha2.factor @@ -8,13 +8,9 @@ IN: checksums.sha2 SINGLETON: sha-224 SINGLETON: sha-256 -SINGLETON: sha-384 -SINGLETON: sha-512 INSTANCE: sha-224 checksum INSTANCE: sha-256 checksum -INSTANCE: sha-384 checksum -INSTANCE: sha-512 checksum TUPLE: sha2-state K H word-size block-size ; @@ -26,10 +22,6 @@ TUPLE: sha-224-state < sha2-short ; TUPLE: sha-256-state < sha2-short ; -TUPLE: sha-384-state < sha2-long ; - -TUPLE: sha-512-state < sha2-long ; - % ] - [ 3 shift 16 >be % ] bi + [ 3 shift 8 >be % ] bi ] "" make append ; : seq>byte-array ( seq n -- string ) '[ _ >be ] map B{ } join ; -:: T1 ( n M H sha2 -- T1 ) +:: 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 ( H -- T2 ) +: 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 @@ -222,8 +262,8 @@ M: sha2-long pad-initial-bytes ( string sha2 -- padded-string ) :: process-chunk ( M block-size cloned-H sha2 -- ) block-size [ - M cloned-H sha2 T1 - cloned-H T2 + M cloned-H sha2 T1-256 + cloned-H T2-256 cloned-H update-H ] each cloned-H sha2 H>> [ w+ ] 2map sha2 (>>H) ; inline @@ -253,20 +293,6 @@ M: sha2-long pad-initial-bytes ( string sha2 -- padded-string ) 4 >>word-size 64 >>block-size ; -: ( -- sha2-state ) - sha-384-state new - K-384 >>K - initial-H-384 >>H - 8 >>word-size - 80 >>block-size ; - -: ( -- sha2-state ) - sha-512-state new - K-512 >>K - initial-H-512 >>H - 8 >>word-size - 80 >>block-size ; - PRIVATE> M: sha-224 checksum-bytes @@ -278,13 +304,3 @@ M: sha-256 checksum-bytes drop [ byte-array>sha2 ] [ H>> 4 seq>byte-array ] bi ; - -M: sha-384 checksum-bytes - drop - [ byte-array>sha2 ] - [ H>> 6 head 8 seq>byte-array ] bi ; - -M: sha-512 checksum-bytes - drop - [ byte-array>sha2 ] - [ H>> 8 seq>byte-array ] bi ; From 9ab5ffa636c61bf12a810f3e64d6b76bdebffa45 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 10 May 2009 12:24:19 -0500 Subject: [PATCH 17/27] move math.miller-rabin to math.primes.miller-rabin --- basis/math/{ => primes}/miller-rabin/authors.txt | 0 basis/math/{ => primes}/miller-rabin/miller-rabin-docs.factor | 0 basis/math/{ => primes}/miller-rabin/miller-rabin-tests.factor | 0 basis/math/{ => primes}/miller-rabin/miller-rabin.factor | 0 basis/math/{ => primes}/miller-rabin/summary.txt | 0 5 files changed, 0 insertions(+), 0 deletions(-) rename basis/math/{ => primes}/miller-rabin/authors.txt (100%) rename basis/math/{ => primes}/miller-rabin/miller-rabin-docs.factor (100%) rename basis/math/{ => primes}/miller-rabin/miller-rabin-tests.factor (100%) rename basis/math/{ => primes}/miller-rabin/miller-rabin.factor (100%) rename basis/math/{ => primes}/miller-rabin/summary.txt (100%) diff --git a/basis/math/miller-rabin/authors.txt b/basis/math/primes/miller-rabin/authors.txt similarity index 100% rename from basis/math/miller-rabin/authors.txt rename to basis/math/primes/miller-rabin/authors.txt diff --git a/basis/math/miller-rabin/miller-rabin-docs.factor b/basis/math/primes/miller-rabin/miller-rabin-docs.factor similarity index 100% rename from basis/math/miller-rabin/miller-rabin-docs.factor rename to basis/math/primes/miller-rabin/miller-rabin-docs.factor diff --git a/basis/math/miller-rabin/miller-rabin-tests.factor b/basis/math/primes/miller-rabin/miller-rabin-tests.factor similarity index 100% rename from basis/math/miller-rabin/miller-rabin-tests.factor rename to basis/math/primes/miller-rabin/miller-rabin-tests.factor diff --git a/basis/math/miller-rabin/miller-rabin.factor b/basis/math/primes/miller-rabin/miller-rabin.factor similarity index 100% rename from basis/math/miller-rabin/miller-rabin.factor rename to basis/math/primes/miller-rabin/miller-rabin.factor diff --git a/basis/math/miller-rabin/summary.txt b/basis/math/primes/miller-rabin/summary.txt similarity index 100% rename from basis/math/miller-rabin/summary.txt rename to basis/math/primes/miller-rabin/summary.txt From f30cdb1ea3f2b5407b5111fed18492b0e1be50c6 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 10 May 2009 12:24:43 -0500 Subject: [PATCH 18/27] update usages of miller-rabin --- basis/math/primes/miller-rabin/miller-rabin-docs.factor | 8 ++++---- basis/math/primes/miller-rabin/miller-rabin-tests.factor | 6 +++--- basis/math/primes/miller-rabin/miller-rabin.factor | 2 +- basis/math/primes/primes.factor | 5 +++-- extra/crypto/rsa/rsa.factor | 4 ++-- extra/project-euler/common/common.factor | 2 +- extra/random/blum-blum-shub/blum-blum-shub.factor | 2 +- 7 files changed, 15 insertions(+), 14 deletions(-) diff --git a/basis/math/primes/miller-rabin/miller-rabin-docs.factor b/basis/math/primes/miller-rabin/miller-rabin-docs.factor index 4aa318f674..2455dafdd5 100644 --- a/basis/math/primes/miller-rabin/miller-rabin-docs.factor +++ b/basis/math/primes/miller-rabin/miller-rabin-docs.factor @@ -1,7 +1,7 @@ ! 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 +IN: math.primes.miller-rabin HELP: find-relative-prime { $values @@ -82,8 +82,8 @@ HELP: unique-primes } { $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 +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* } @@ -97,4 +97,4 @@ ARTICLE: "math.miller-rabin" "Miller-Rabin probabilistic primality test" { $subsection next-safe-prime } { $subsection random-safe-prime } ; -ABOUT: "math.miller-rabin" +ABOUT: "math.primes.miller-rabin" diff --git a/basis/math/primes/miller-rabin/miller-rabin-tests.factor b/basis/math/primes/miller-rabin/miller-rabin-tests.factor index 9981064ec0..9c635c8f38 100644 --- a/basis/math/primes/miller-rabin/miller-rabin-tests.factor +++ b/basis/math/primes/miller-rabin/miller-rabin-tests.factor @@ -1,6 +1,6 @@ -USING: math.miller-rabin tools.test kernel sequences -math.miller-rabin.private math ; -IN: math.miller-rabin.tests +USING: math.primes.miller-rabin tools.test kernel sequences +math.primes.miller-rabin.private math ; +IN: math.primes.miller-rabin.tests [ f ] [ 473155932665450549999756893736999469773678960651272093993257221235459777950185377130233556540099119926369437865330559863 miller-rabin ] unit-test [ t ] [ 2 miller-rabin ] unit-test diff --git a/basis/math/primes/miller-rabin/miller-rabin.factor b/basis/math/primes/miller-rabin/miller-rabin.factor index 991924dfe4..35ee97a897 100755 --- a/basis/math/primes/miller-rabin/miller-rabin.factor +++ b/basis/math/primes/miller-rabin/miller-rabin.factor @@ -3,7 +3,7 @@ USING: combinators kernel locals math math.functions math.ranges random sequences sets combinators.short-circuit math.bitwise math math.order ; -IN: math.miller-rabin +IN: math.primes.miller-rabin : >odd ( n -- int ) 0 set-bit ; foldable diff --git a/basis/math/primes/primes.factor b/basis/math/primes/primes.factor index 688fdad713..fa1cd5cb63 100644 --- a/basis/math/primes/primes.factor +++ b/basis/math/primes/primes.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2007-2009 Samuel Tardieu. ! See http://factorcode.org/license.txt for BSD license. -USING: combinators kernel math math.functions math.miller-rabin -math.order math.primes.erato math.ranges sequences ; +USING: combinators kernel math math.functions +math.primes.miller-rabin math.order math.primes.erato +math.ranges sequences ; IN: math.primes Date: Sun, 10 May 2009 12:59:35 -0500 Subject: [PATCH 19/27] add lucas-lehmer primality test --- basis/math/primes/lucas-lehmer/authors.txt | 1 + .../lucas-lehmer/lucas-lehmer-docs.factor | 25 +++++++++++++++++ .../lucas-lehmer/lucas-lehmer-tests.factor | 13 +++++++++ .../primes/lucas-lehmer/lucas-lehmer.factor | 27 +++++++++++++++++++ 4 files changed, 66 insertions(+) create mode 100644 basis/math/primes/lucas-lehmer/authors.txt create mode 100644 basis/math/primes/lucas-lehmer/lucas-lehmer-docs.factor create mode 100644 basis/math/primes/lucas-lehmer/lucas-lehmer-tests.factor create mode 100644 basis/math/primes/lucas-lehmer/lucas-lehmer.factor diff --git a/basis/math/primes/lucas-lehmer/authors.txt b/basis/math/primes/lucas-lehmer/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/basis/math/primes/lucas-lehmer/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/basis/math/primes/lucas-lehmer/lucas-lehmer-docs.factor b/basis/math/primes/lucas-lehmer/lucas-lehmer-docs.factor new file mode 100644 index 0000000000..582b59b69a --- /dev/null +++ b/basis/math/primes/lucas-lehmer/lucas-lehmer-docs.factor @@ -0,0 +1,25 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: help.markup help.syntax kernel ; +IN: math.primes.lucas-lehmer + +HELP: lucas-lehmer +{ $values + { "p" "a prime number" } + { "?" "a boolean" } +} +{ $description "Runs the Lucas-Lehmer test on the prime " { $snippet "p" } " and returns " { $link t } " if " { $snippet "(2 ^ p) - 1" } " is prime." } +{ $examples + { $example "! Test that (2 ^ 61) - 1 is prime:" + "USING: math.primes.lucas-lehmer prettyprint ;" + "61 lucas-lehmer ." + "t" + } +} ; + +ARTICLE: "math.primes.lucas-lehmer" "Lucas-Lehmer Mersenne Primality test" +"The " { $vocab-link "math.primes.lucas-lehmer" } " vocabulary tests numbers of the form " { $snippet "(2 ^ p) - 1" } " for primality, where " { $snippet "p" } " is prime." $nl +"Run the Lucas-Lehmer test:" +{ $subsection lucas-lehmer } ; + +ABOUT: "math.primes.lucas-lehmer" diff --git a/basis/math/primes/lucas-lehmer/lucas-lehmer-tests.factor b/basis/math/primes/lucas-lehmer/lucas-lehmer-tests.factor new file mode 100644 index 0000000000..b114fa8553 --- /dev/null +++ b/basis/math/primes/lucas-lehmer/lucas-lehmer-tests.factor @@ -0,0 +1,13 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: tools.test math.primes.lucas-lehmer ; +IN: math.primes.lucas-lehmer.tests + +[ t ] [ 2 lucas-lehmer ] unit-test +[ t ] [ 3 lucas-lehmer ] unit-test +[ f ] [ 4 lucas-lehmer ] unit-test +[ t ] [ 5 lucas-lehmer ] unit-test +[ f ] [ 6 lucas-lehmer ] unit-test +[ f ] [ 11 lucas-lehmer ] unit-test +[ t ] [ 13 lucas-lehmer ] unit-test +[ t ] [ 61 lucas-lehmer ] unit-test diff --git a/basis/math/primes/lucas-lehmer/lucas-lehmer.factor b/basis/math/primes/lucas-lehmer/lucas-lehmer.factor new file mode 100644 index 0000000000..a8bf097dbe --- /dev/null +++ b/basis/math/primes/lucas-lehmer/lucas-lehmer.factor @@ -0,0 +1,27 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: combinators fry kernel locals math +math.primes combinators.short-circuit ; +IN: math.primes.lucas-lehmer + +ERROR: invalid-lucas-lehmer-candidate obj ; + + ] } 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 ; From 02ddb8005df15b424e5d4e4f57988f9e8f69570c Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 10 May 2009 13:39:08 -0500 Subject: [PATCH 20/27] move random-bits* to random, work on docs --- .../mersenne-twister-tests.factor | 2 +- basis/random/random-docs.factor | 15 +++++++++++++-- basis/random/random-tests.factor | 2 ++ basis/random/random.factor | 5 ++++- 4 files changed, 20 insertions(+), 4 deletions(-) diff --git a/basis/random/mersenne-twister/mersenne-twister-tests.factor b/basis/random/mersenne-twister/mersenne-twister-tests.factor index c35d7488ac..651e43ef5b 100644 --- a/basis/random/mersenne-twister/mersenne-twister-tests.factor +++ b/basis/random/mersenne-twister/mersenne-twister-tests.factor @@ -11,7 +11,7 @@ IN: random.mersenne-twister.tests 100 [ 100 random ] replicate ; : test-rng ( seed quot -- ) - [ ] dip with-random ; inline + [ ] dip with-random ; inline [ f ] [ 1234 [ randoms randoms = ] test-rng ] unit-test diff --git a/basis/random/random-docs.factor b/basis/random/random-docs.factor index c7600a731f..222ecaf935 100755 --- a/basis/random/random-docs.factor +++ b/basis/random/random-docs.factor @@ -40,9 +40,17 @@ HELP: random-bytes } ; HELP: random-bits -{ $values { "n" "an integer" } { "r" "a random integer" } } +{ $values { "numbits" integer } { "r" "a random integer" } } { $description "Outputs an random integer n bits in length." } ; +HELP: random-bits* +{ $values + { "numbits" integer } + { "n" integer } +} +{ $description "Returns an integer exactly " { $snippet "numbits" } " in length, with the topmost bit set to one." } ; + + HELP: with-random { $values { "tuple" "a random generator" } { "quot" "a quotation" } } { $description "Calls the quotation with the random generator in a dynamic variable. All random numbers will be generated using this random generator." } ; @@ -93,6 +101,9 @@ $nl "Randomizing a sequence:" { $subsection randomize } "Deleting a random element from a sequence:" -{ $subsection delete-random } ; +{ $subsection delete-random } +"Random numbers with " { $snippet "n" } " bits:" +{ $subsection random-bits } +{ $subsection random-bits* } ; ABOUT: "random" diff --git a/basis/random/random-tests.factor b/basis/random/random-tests.factor index 9607627b3d..2b6ac9b1b8 100644 --- a/basis/random/random-tests.factor +++ b/basis/random/random-tests.factor @@ -23,3 +23,5 @@ IN: random.tests [ f ] [ 100 [ { 0 1 } random ] replicate all-equal? ] unit-test + +[ 49 ] [ 50 random-bits* log2 ] unit-test diff --git a/basis/random/random.factor b/basis/random/random.factor index 6b02c8a3e8..661e771258 100755 --- a/basis/random/random.factor +++ b/basis/random/random.factor @@ -45,7 +45,10 @@ M: f random-32* ( obj -- * ) no-random-number-generator ; PRIVATE> -: random-bits ( n -- r ) 2^ random-integer ; +: random-bits ( numbits -- r ) 2^ random-integer ; + +: random-bits* ( numbits -- n ) + 1 - [ random-bits ] keep set-bit ; : random ( seq -- elt ) [ f ] [ From 259fd34d4981369f5cd51e6e36216db9a87b6dad Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 10 May 2009 13:42:41 -0500 Subject: [PATCH 21/27] add next-odd etc to math.bitwise --- basis/math/bitwise/bitwise.factor | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/basis/math/bitwise/bitwise.factor b/basis/math/bitwise/bitwise.factor index 4fe2340643..ff4806348b 100755 --- a/basis/math/bitwise/bitwise.factor +++ b/basis/math/bitwise/bitwise.factor @@ -111,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 From d5eace91d04ea66dc8a6ad2b29c058652726c894 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sun, 10 May 2009 13:45:58 -0500 Subject: [PATCH 22/27] purple sky --- extra/terrain/shaders/shaders.factor | 34 +++++++++++++++++ extra/terrain/terrain.factor | 57 +++++++++++++++++++--------- 2 files changed, 74 insertions(+), 17 deletions(-) diff --git a/extra/terrain/shaders/shaders.factor b/extra/terrain/shaders/shaders.factor index c341545956..bfb46b8ba1 100644 --- a/extra/terrain/shaders/shaders.factor +++ b/extra/terrain/shaders/shaders.factor @@ -1,6 +1,40 @@ 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; diff --git a/extra/terrain/terrain.factor b/extra/terrain/terrain.factor index 590244ca6a..411d34f44c 100644 --- a/extra/terrain/terrain.factor +++ b/extra/terrain/terrain.factor @@ -5,20 +5,23 @@ math.vectors opengl opengl.capabilities opengl.gl opengl.shaders opengl.textures opengl.textures.private sequences sequences.product specialized-arrays.float terrain.generation terrain.shaders ui ui.gadgets -ui.gadgets.worlds ui.pixel-formats 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 / ] } @@ -29,6 +32,7 @@ TUPLE: player TUPLE: terrain-world < game-world player + sky-image sky-texture sky-program terrain terrain-segment terrain-texture terrain-program terrain-vertex-buffer ; @@ -41,7 +45,7 @@ M: terrain-world tick-length 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>> @@ -175,24 +179,33 @@ M: terrain-world tick* [ dup focused?>> [ handle-input ] [ drop ] if ] [ dup player>> tick-player ] bi ; -: set-heightmap-texture-parameters ( texture -- ) +: set-texture-parameters ( texture -- ) GL_TEXTURE_2D GL_TEXTURE0 bind-texture-unit GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER GL_LINEAR glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER GL_LINEAR glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_S GL_CLAMP_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 + 0.01 0.01 { 512 512 } perlin-noise-image + [ >>sky-image ] keep + make-texture [ set-texture-parameters ] keep >>sky-texture [ >>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 + >>sky-program terrain-vertex-shader terrain-pixel-shader >>terrain-program vertex-array >vertex-buffer >>terrain-vertex-buffer @@ -203,6 +216,8 @@ AFTER: terrain-world end-world [ 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 @@ -212,14 +227,22 @@ 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 } ; From 93104742f886f6f39793d077fa626f7b7cdacfd5 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 10 May 2009 13:47:51 -0500 Subject: [PATCH 23/27] more docs for math.primes, move words out of miller-rabin --- .../miller-rabin/miller-rabin-docs.factor | 74 +---------------- .../miller-rabin/miller-rabin-tests.factor | 5 +- .../primes/miller-rabin/miller-rabin.factor | 83 +------------------ basis/math/primes/primes-docs.factor | 50 ++++++++++- basis/math/primes/primes-tests.factor | 13 ++- basis/math/primes/primes.factor | 43 +++++++++- 6 files changed, 105 insertions(+), 163 deletions(-) diff --git a/basis/math/primes/miller-rabin/miller-rabin-docs.factor b/basis/math/primes/miller-rabin/miller-rabin-docs.factor index 2455dafdd5..2d19d51e06 100644 --- a/basis/math/primes/miller-rabin/miller-rabin-docs.factor +++ b/basis/math/primes/miller-rabin/miller-rabin-docs.factor @@ -3,20 +3,6 @@ USING: help.markup help.syntax kernel sequences math ; IN: math.primes.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 } @@ -33,68 +19,10 @@ HELP: miller-rabin* } { $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.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* } -"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 } ; +{ $subsection miller-rabin* } ; ABOUT: "math.primes.miller-rabin" diff --git a/basis/math/primes/miller-rabin/miller-rabin-tests.factor b/basis/math/primes/miller-rabin/miller-rabin-tests.factor index 9c635c8f38..aeae6cac1b 100644 --- a/basis/math/primes/miller-rabin/miller-rabin-tests.factor +++ b/basis/math/primes/miller-rabin/miller-rabin-tests.factor @@ -1,5 +1,6 @@ -USING: math.primes.miller-rabin tools.test kernel sequences -math.primes.miller-rabin.private math ; +USING: kernel math math.primes math.primes.miller-rabin +math.primes.miller-rabin.private math.primes.safe +math.primes.safe.private random sequences tools.test ; IN: math.primes.miller-rabin.tests [ f ] [ 473155932665450549999756893736999469773678960651272093993257221235459777950185377130233556540099119926369437865330559863 miller-rabin ] unit-test diff --git a/basis/math/primes/miller-rabin/miller-rabin.factor b/basis/math/primes/miller-rabin/miller-rabin.factor index 35ee97a897..b0dfc4ed35 100755 --- a/basis/math/primes/miller-rabin/miller-rabin.factor +++ b/basis/math/primes/miller-rabin/miller-rabin.factor @@ -1,18 +1,9 @@ ! 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 ; +USING: combinators combinators.short-circuit kernel locals math +math.functions math.ranges random sequences sets ; IN: math.primes.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 ; - } 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 ; - - [ 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 - - - -: 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 ; diff --git a/basis/math/primes/primes-docs.factor b/basis/math/primes/primes-docs.factor index c7dbc950e8..fa991e800f 100644 --- a/basis/math/primes/primes-docs.factor +++ b/basis/math/primes/primes-docs.factor @@ -1,10 +1,10 @@ -USING: help.markup help.syntax ; +USING: help.markup help.syntax math sequences ; IN: math.primes { next-prime prime? } related-words HELP: next-prime -{ $values { "n" "an integer not smaller than 2" } { "p" "a prime number" } } +{ $values { "n" integer } { "p" "a prime number" } } { $description "Return the next prime number greater than " { $snippet "n" } "." } ; HELP: prime? @@ -20,3 +20,49 @@ 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." $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" diff --git a/basis/math/primes/primes-tests.factor b/basis/math/primes/primes-tests.factor index db738399ef..6580f0780e 100644 --- a/basis/math/primes/primes-tests.factor +++ b/basis/math/primes/primes-tests.factor @@ -1,4 +1,6 @@ -USING: arrays math.primes tools.test ; +USING: arrays math math.primes math.primes.miller-rabin +tools.test ; +IN: math.primes.tests { 1237 } [ 1234 next-prime ] unit-test { f t } [ 1234 prime? 1237 prime? ] unit-test @@ -7,3 +9,12 @@ USING: arrays math.primes tools.test ; { { 4999963 4999999 5000011 5000077 5000081 } } [ 4999962 5000082 primes-between >array ] unit-test + +[ 2 ] [ 1 next-prime ] unit-test +[ 3 ] [ 2 next-prime ] unit-test +[ 5 ] [ 3 next-prime ] unit-test +[ 101 ] [ 100 next-prime ] unit-test +[ t ] [ 2135623355842621559 miller-rabin ] unit-test +[ 100000000000031 ] [ 100000000000000 next-prime ] unit-test + +[ 49 ] [ 50 random-prime log2 ] unit-test diff --git a/basis/math/primes/primes.factor b/basis/math/primes/primes.factor index fa1cd5cb63..e3985fc600 100644 --- a/basis/math/primes/primes.factor +++ b/basis/math/primes/primes.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2007-2009 Samuel Tardieu. ! See http://factorcode.org/license.txt for BSD license. -USING: combinators kernel math math.functions -math.primes.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 } 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 @@ -32,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 ; + + [ 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 ; From 57ffb231dc1343b908d13e44857a322454ea2bf8 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 10 May 2009 13:48:09 -0500 Subject: [PATCH 24/27] update using --- extra/project-euler/046/046.factor | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/extra/project-euler/046/046.factor b/extra/project-euler/046/046.factor index e4b8dcc955..0aa9eafe58 100755 --- a/extra/project-euler/046/046.factor +++ b/extra/project-euler/046/046.factor @@ -1,6 +1,7 @@ ! Copyright (c) 2008 Aaron Schaefer. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel math math.functions math.primes math.ranges sequences project-euler.common ; +USING: kernel math math.functions math.primes math.ranges +sequences project-euler.common math.bitwise ; IN: project-euler.046 ! http://projecteuler.net/index.php?section=problems&id=46 From 7869821de98d69d2ac319a8a4bb46b320c9547bc Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 10 May 2009 13:49:40 -0500 Subject: [PATCH 25/27] make a new vocabulary for safe primes --- basis/math/primes/safe/authors.txt | 1 + basis/math/primes/safe/safe-docs.factor | 38 ++++++++++++++++++++++++ basis/math/primes/safe/safe-tests.factor | 14 +++++++++ basis/math/primes/safe/safe.factor | 29 ++++++++++++++++++ 4 files changed, 82 insertions(+) create mode 100644 basis/math/primes/safe/authors.txt create mode 100644 basis/math/primes/safe/safe-docs.factor create mode 100644 basis/math/primes/safe/safe-tests.factor create mode 100644 basis/math/primes/safe/safe.factor diff --git a/basis/math/primes/safe/authors.txt b/basis/math/primes/safe/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/basis/math/primes/safe/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/basis/math/primes/safe/safe-docs.factor b/basis/math/primes/safe/safe-docs.factor new file mode 100644 index 0000000000..861fc4e4ed --- /dev/null +++ b/basis/math/primes/safe/safe-docs.factor @@ -0,0 +1,38 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: combinators.short-circuit help.markup help.syntax kernel +math math.functions math.primes random ; +IN: math.primes.safe + +HELP: next-safe-prime +{ $values + { "n" integer } + { "q" integer } +} +{ $description "Tests consecutive numbers and returns the next safe prime. A safe prime is desirable in cryptography applications such as Diffie-Hellman and SRP6." } ; + +HELP: random-safe-prime +{ $values + { "numbits" integer } + { "p" integer } +} +{ $description "Returns a safe prime number " { $snippet "numbits" } " bits in length, with the topmost bit set to one." } ; + +HELP: safe-prime? +{ $values + { "q" integer } + { "?" "a boolean" } +} +{ $description "Tests whether the number is a safe prime. A safe prime " { $snippet "p" } " must be prime, as must " { $snippet "(p - 1) / 2" } "." } ; + + +ARTICLE: "math.primes.safe" "Safe prime numbers" +"The " { $vocab-link "math.primes.safe" } " vocabulary implements words to calculate safe prime numbers. Safe primes are of the form p = 2q + 1, where p,q are prime. Safe primes have desirable qualities for cryptographic applications." $nl + +"Testing if a number is a safe prime:" +{ $subsection safe-prime? } +"Generating safe prime numbers:" +{ $subsection next-safe-prime } +{ $subsection random-safe-prime } ; + +ABOUT: "math.primes.safe" diff --git a/basis/math/primes/safe/safe-tests.factor b/basis/math/primes/safe/safe-tests.factor new file mode 100644 index 0000000000..ef9aa9246f --- /dev/null +++ b/basis/math/primes/safe/safe-tests.factor @@ -0,0 +1,14 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: math.primes.safe math.primes.safe.private tools.test ; +IN: math.primes.safe.tests + +[ 863 ] [ 862 next-safe-prime ] unit-test +[ f ] [ 862 safe-prime? ] unit-test +[ t ] [ 7 safe-prime? ] unit-test +[ f ] [ 31 safe-prime? ] unit-test +[ t ] [ 47 safe-prime-candidate? ] unit-test +[ t ] [ 47 safe-prime? ] unit-test +[ t ] [ 863 safe-prime? ] unit-test + +[ 47 ] [ 31 next-safe-prime ] unit-test diff --git a/basis/math/primes/safe/safe.factor b/basis/math/primes/safe/safe.factor new file mode 100644 index 0000000000..a3becb628f --- /dev/null +++ b/basis/math/primes/safe/safe.factor @@ -0,0 +1,29 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: combinators.short-circuit kernel math math.functions +math.primes random ; +IN: math.primes.safe + + + +: 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 ; From bf528dcdddcdf1544f9c94b54521c1128824dc63 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 10 May 2009 14:01:21 -0500 Subject: [PATCH 26/27] link to prime tests from prime docs --- basis/math/primes/factors/factors.factor | 3 ++- basis/math/primes/primes-docs.factor | 3 +-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/basis/math/primes/factors/factors.factor b/basis/math/primes/factors/factors.factor index 278bf70b3d..f5fa468687 100644 --- a/basis/math/primes/factors/factors.factor +++ b/basis/math/primes/factors/factors.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2007-2009 Samuel Tardieu. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays combinators kernel make math math.functions math.primes sequences ; +USING: arrays combinators kernel make math math.functions +math.primes sequences ; IN: math.primes.factors Date: Sun, 10 May 2009 14:08:03 -0500 Subject: [PATCH 27/27] dont load safe primes in miller rabin tests --- .../miller-rabin/miller-rabin-tests.factor | 21 +------------------ 1 file changed, 1 insertion(+), 20 deletions(-) diff --git a/basis/math/primes/miller-rabin/miller-rabin-tests.factor b/basis/math/primes/miller-rabin/miller-rabin-tests.factor index aeae6cac1b..d201abfef8 100644 --- a/basis/math/primes/miller-rabin/miller-rabin-tests.factor +++ b/basis/math/primes/miller-rabin/miller-rabin-tests.factor @@ -1,6 +1,4 @@ -USING: kernel math math.primes math.primes.miller-rabin -math.primes.miller-rabin.private math.primes.safe -math.primes.safe.private random sequences tools.test ; +USING: kernel math.primes.miller-rabin sequences tools.test ; IN: math.primes.miller-rabin.tests [ f ] [ 473155932665450549999756893736999469773678960651272093993257221235459777950185377130233556540099119926369437865330559863 miller-rabin ] unit-test @@ -8,23 +6,6 @@ IN: math.primes.miller-rabin.tests [ 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