From 7acff0c906c22bd529bdde24dc4bd39b6705bfa4 Mon Sep 17 00:00:00 2001 From: Bruno Deferrari Date: Thu, 16 Apr 2009 09:32:17 -0300 Subject: [PATCH 002/133] irc.gitbot: Add formatting for topic change logs --- extra/irc/client/base/base.factor | 2 +- extra/irc/logbot/log-line/log-line.factor | 4 ++++ 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/extra/irc/client/base/base.factor b/extra/irc/client/base/base.factor index f54e18ac4b..318a1ab1e3 100644 --- a/extra/irc/client/base/base.factor +++ b/extra/irc/client/base/base.factor @@ -19,7 +19,7 @@ SYMBOL: current-irc-client UNION: to-target privmsg notice ; UNION: to-channel join part topic kick rpl-channel-modes - rpl-notopic rpl-topic rpl-names rpl-names-end ; + topic rpl-names rpl-names-end ; UNION: to-one-chat to-target to-channel mode ; UNION: to-many-chats nick quit ; UNION: to-all-chats irc-end irc-disconnected irc-connected ; diff --git a/extra/irc/logbot/log-line/log-line.factor b/extra/irc/logbot/log-line/log-line.factor index b3af41ad3d..255c46e5f3 100644 --- a/extra/irc/logbot/log-line/log-line.factor +++ b/extra/irc/logbot/log-line/log-line.factor @@ -35,3 +35,7 @@ M: participant-mode >log-line M: nick >log-line [ "* " % dup sender>> % " is now known as " % nickname>> % ] "" make ; + +M: topic >log-line + [ "* " % dup sender>> % " has set the topic for " % dup channel>> % + ": \"" % topic>> % "\"" % ] "" make ; From 84032835f5b3a1d12f0f749b33b81a38bef62ea3 Mon Sep 17 00:00:00 2001 From: Bruno Deferrari Date: Thu, 16 Apr 2009 17:11:41 -0300 Subject: [PATCH 003/133] irc.messages: Use GMT times when building a message --- extra/irc/messages/parser/parser.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/irc/messages/parser/parser.factor b/extra/irc/messages/parser/parser.factor index 1fa07fc772..ee126b2550 100644 --- a/extra/irc/messages/parser/parser.factor +++ b/extra/irc/messages/parser/parser.factor @@ -32,4 +32,4 @@ PRIVATE> [ >>trailing ] tri* [ (>>prefix) ] [ fill-irc-message-slots ] [ swap >>line ] tri - now >>timestamp dup sender >>sender ; + gmt >>timestamp dup sender >>sender ; From 01f7f560b0877dfc3756d7cbcfafedc56021a990 Mon Sep 17 00:00:00 2001 From: Bruno Deferrari Date: Thu, 16 Apr 2009 17:16:24 -0300 Subject: [PATCH 004/133] irc.logbot: Use make to build timestamped string --- extra/irc/logbot/logbot.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/irc/logbot/logbot.factor b/extra/irc/logbot/logbot.factor index a389304b14..2bf88568f8 100644 --- a/extra/irc/logbot/logbot.factor +++ b/extra/irc/logbot/logbot.factor @@ -16,7 +16,7 @@ SYMBOL: current-stream "irc.freenode.org" 6667 "flogger" f ; : add-timestamp ( string timestamp -- string ) - timestamp>hms "[" prepend "] " append prepend ; + timestamp>hms [ "[" % % "] " % % ] "" make ; : timestamp-path ( timestamp -- path ) timestamp>ymd ".log" append log-directory prepend-path ; From 7f5f8185bf204c151f39c2d70648bf9a9b571d16 Mon Sep 17 00:00:00 2001 From: Bruno Deferrari Date: Thu, 16 Apr 2009 17:21:31 -0300 Subject: [PATCH 005/133] irc.messages: Set timestamp when constructing, not on parser --- extra/irc/client/internals/internals.factor | 2 +- extra/irc/messages/base/base.factor | 3 ++- extra/irc/messages/parser/parser.factor | 4 ++-- 3 files changed, 5 insertions(+), 4 deletions(-) diff --git a/extra/irc/client/internals/internals.factor b/extra/irc/client/internals/internals.factor index 5bae054e18..79aaf6bd5a 100644 --- a/extra/irc/client/internals/internals.factor +++ b/extra/irc/client/internals/internals.factor @@ -52,7 +52,7 @@ M: to-all-chats message-forwards drop chats> ; M: to-many-chats message-forwards sender>> participant-chats ; GENERIC: process-message ( irc-message -- ) -M: object process-message drop ; +M: object process-message drop ; M: ping process-message trailing>> /PONG ; M: join process-message [ sender>> ] [ chat> ] bi join-participant ; M: part process-message [ sender>> ] [ chat> ] bi part-participant ; diff --git a/extra/irc/messages/base/base.factor b/extra/irc/messages/base/base.factor index d67d226d9b..b785970520 100644 --- a/extra/irc/messages/base/base.factor +++ b/extra/irc/messages/base/base.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2009 Bruno Deferrari ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays assocs classes.parser classes.tuple +USING: accessors arrays assocs calendar classes.parser classes.tuple combinators fry generic.parser kernel lexer mirrors namespaces parser sequences splitting strings words ; IN: irc.messages.base @@ -51,6 +51,7 @@ M: irc-message post-process-irc-message drop ; GENERIC: fill-irc-message-slots ( irc-message -- ) M: irc-message fill-irc-message-slots + gmt >>timestamp { [ process-irc-trailing ] [ process-irc-prefix ] diff --git a/extra/irc/messages/parser/parser.factor b/extra/irc/messages/parser/parser.factor index ee126b2550..06a41b0aaa 100644 --- a/extra/irc/messages/parser/parser.factor +++ b/extra/irc/messages/parser/parser.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2009 Bruno Deferrari ! See http://factorcode.org/license.txt for BSD license. -USING: kernel fry splitting ascii calendar accessors combinators +USING: kernel fry splitting ascii accessors combinators arrays classes.tuple math.order words assocs irc.messages.base sequences ; IN: irc.messages.parser @@ -32,4 +32,4 @@ PRIVATE> [ >>trailing ] tri* [ (>>prefix) ] [ fill-irc-message-slots ] [ swap >>line ] tri - gmt >>timestamp dup sender >>sender ; + dup sender >>sender ; From 2c46304c75ae76082e25c59ae7cf0b05143ffa5f Mon Sep 17 00:00:00 2001 From: Bruno Deferrari Date: Thu, 16 Apr 2009 21:33:21 -0300 Subject: [PATCH 006/133] irc.logbot: Use instead of --- extra/irc/logbot/logbot.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/irc/logbot/logbot.factor b/extra/irc/logbot/logbot.factor index 2bf88568f8..ff8085a9a9 100644 --- a/extra/irc/logbot/logbot.factor +++ b/extra/irc/logbot/logbot.factor @@ -27,7 +27,7 @@ SYMBOL: current-stream ] [ current-stream get [ dispose ] when* [ day-of-year current-day set ] - [ timestamp-path latin1 ] bi + [ timestamp-path latin1 ] bi current-stream set ] if current-stream get ; From 34ec9af2ad82d18492c3670b9dad2c0fd5cff0db Mon Sep 17 00:00:00 2001 From: Bruno Deferrari Date: Thu, 16 Apr 2009 21:35:26 -0300 Subject: [PATCH 007/133] irc.client: More robust reconnection --- extra/irc/client/chats/chats.factor | 8 ++-- extra/irc/client/internals/internals.factor | 46 ++++++++++++--------- 2 files changed, 31 insertions(+), 23 deletions(-) diff --git a/extra/irc/client/chats/chats.factor b/extra/irc/client/chats/chats.factor index 7910afb22a..3f6cf4945d 100644 --- a/extra/irc/client/chats/chats.factor +++ b/extra/irc/client/chats/chats.factor @@ -33,7 +33,8 @@ TUPLE: irc-profile server port nickname password ; C: irc-profile TUPLE: irc-client profile stream in-messages out-messages - chats is-running nick connect reconnect-time is-ready + chats is-running nick connect is-ready + reconnect-time reconnect-attempts exceptions ; : ( profile -- irc-client ) @@ -43,8 +44,9 @@ TUPLE: irc-client profile stream in-messages out-messages >>in-messages >>out-messages H{ } clone >>chats - 15 seconds >>reconnect-time + 30 seconds >>reconnect-time + 10 >>reconnect-attempts V{ } clone >>exceptions - [ latin1 ] >>connect ; + [ latin1 drop ] >>connect ; SINGLETONS: irc-chat-end irc-end irc-disconnected irc-connected ; diff --git a/extra/irc/client/internals/internals.factor b/extra/irc/client/internals/internals.factor index 79aaf6bd5a..0a4fe11830 100644 --- a/extra/irc/client/internals/internals.factor +++ b/extra/irc/client/internals/internals.factor @@ -3,10 +3,17 @@ USING: accessors assocs arrays concurrency.mailboxes continuations destructors hashtables io irc.client.base irc.client.chats irc.messages kernel namespaces strings words.symbol irc.messages.base irc.client.participants fry threads -combinators irc.messages.parser ; +combinators irc.messages.parser math ; EXCLUDE: sequences => join ; IN: irc.client.internals +: do-connect ( server port quot: ( host port -- stream ) attempts -- stream/f ) + dup 0 > [ + [ drop call( host port -- stream ) ] + [ drop 15 sleep 1- do-connect ] + recover + ] [ 2drop 2drop f ] if ; + : /NICK ( nick -- ) "NICK " prepend irc-print ; : /PONG ( text -- ) "PONG " prepend irc-print ; @@ -15,18 +22,27 @@ IN: irc.client.internals "USER " prepend " hostname servername :irc.factor" append irc-print ; : /CONNECT ( server port -- stream ) - irc> connect>> call( host port -- stream local ) drop ; + irc> [ connect>> ] [ reconnect-attempts>> ] bi do-connect ; : /JOIN ( channel password -- ) [ " :" swap 3append ] when* "JOIN " prepend irc-print ; +: try-connect ( -- stream/f ) + irc> profile>> [ server>> ] [ port>> ] bi /CONNECT ; + +: (terminate-irc) ( -- ) + irc> dup is-running>> [ + f >>is-running + [ stream>> dispose ] keep + [ in-messages>> ] [ out-messages>> ] bi 2array + [ irc-end swap mailbox-put ] each + ] [ drop ] if ; + : (connect-irc) ( -- ) - irc> { - [ profile>> [ server>> ] [ port>> ] bi /CONNECT ] - [ (>>stream) ] - [ t swap (>>is-running) ] - [ in-messages>> [ irc-connected ] dip mailbox-put ] - } cleave ; + try-connect [ + [ irc> ] dip >>stream t >>is-running + in-messages>> [ irc-connected ] dip mailbox-put + ] [ (terminate-irc) ] if* ; : (do-login) ( -- ) irc> nick>> /LOGIN ; @@ -92,9 +108,7 @@ M: irc-message handle-outgoing-irc irc-message>string irc-print t ; : (handle-disconnect) ( -- ) irc-disconnected irc> in-messages>> mailbox-put - irc> reconnect-time>> sleep - (connect-irc) - (do-login) ; + (connect-irc) (do-login) ; : handle-disconnect ( error -- ? ) [ irc> exceptions>> push ] when* @@ -155,12 +169,4 @@ M: irc-channel-chat remove-chat [ part new annotate-message irc-send ] [ name>> unregister-chat ] bi ; -: (terminate-irc) ( -- ) - irc> dup is-running>> [ - f >>is-running - [ stream>> dispose ] keep - [ in-messages>> ] [ out-messages>> ] bi 2array - [ irc-end swap mailbox-put ] each - ] [ drop ] if ; - -: (speak) ( message irc-chat -- ) swap annotate-message irc-send ; \ No newline at end of file +: (speak) ( message irc-chat -- ) swap annotate-message irc-send ; From 460de5bbef80253c2a1bb0a691871fa7b2436212 Mon Sep 17 00:00:00 2001 From: Bruno Deferrari Date: Thu, 16 Apr 2009 22:19:16 -0300 Subject: [PATCH 008/133] irc.messages: Add predicate classes for ctcp and action messages --- extra/irc/messages/messages-tests.factor | 5 ++++- extra/irc/messages/messages.factor | 16 +++++++++++++--- 2 files changed, 17 insertions(+), 4 deletions(-) diff --git a/extra/irc/messages/messages-tests.factor b/extra/irc/messages/messages-tests.factor index 539fba54eb..347bdd00fa 100644 --- a/extra/irc/messages/messages-tests.factor +++ b/extra/irc/messages/messages-tests.factor @@ -71,4 +71,7 @@ IN: irc.messages.tests { name "nickname" } { trailing "Nickname is already in use" } } } [ ":ircserver.net 433 * nickname :Nickname is already in use" - string>irc-message f >>timestamp ] unit-test \ No newline at end of file + string>irc-message f >>timestamp ] unit-test + +{ t } [ ":someuser!n=user@some.where PRIVMSG #factortest :ACTION jumps!" + string>irc-message action? ] unit-test diff --git a/extra/irc/messages/messages.factor b/extra/irc/messages/messages.factor index a6bf02f8a7..2006cc24c3 100755 --- a/extra/irc/messages/messages.factor +++ b/extra/irc/messages/messages.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2009 Bruno Deferrari ! See http://factorcode.org/license.txt for BSD license. USING: kernel fry splitting ascii calendar accessors combinators -arrays classes.tuple math.order words assocs strings irc.messages.base ; +arrays classes.tuple math.order words assocs strings irc.messages.base +combinators.short-circuit math ; EXCLUDE: sequences => join ; IN: irc.messages @@ -61,8 +62,17 @@ IRC: rpl-names-end "366" nickname channel : comment ; IRC: rpl-nickname-in-use "433" _ name ; IRC: rpl-nick-collision "436" nickname : comment ; +PREDICATE: channel-mode < mode name>> first "#&" member? ; +PREDICATE: participant-mode < channel-mode parameter>> ; +PREDICATE: ctcp < privmsg + trailing>> { [ length 1 > ] [ first 1 = ] [ peek 1 = ] } 1&& ; +PREDICATE: action < ctcp trailing>> rest "ACTION" head? ; + M: rpl-names post-process-irc-message ( rpl-names -- ) [ [ blank? ] trim " " split ] change-nicks drop ; -PREDICATE: channel-mode < mode name>> first "#&" member? ; -PREDICATE: participant-mode < channel-mode parameter>> ; +M: ctcp post-process-irc-message ( ctcp -- ) + [ rest but-last ] change-text drop ; + +M: action post-process-irc-message ( action -- ) + [ 7 tail ] change-text call-next-method ; From 7503c9876809f72d98d97dc94d63138d74cf5703 Mon Sep 17 00:00:00 2001 From: Bruno Deferrari Date: Thu, 16 Apr 2009 22:19:45 -0300 Subject: [PATCH 009/133] irc.logbot: Format for actions --- extra/irc/logbot/log-line/log-line.factor | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/extra/irc/logbot/log-line/log-line.factor b/extra/irc/logbot/log-line/log-line.factor index 255c46e5f3..0960a3cedb 100644 --- a/extra/irc/logbot/log-line/log-line.factor +++ b/extra/irc/logbot/log-line/log-line.factor @@ -11,6 +11,12 @@ GENERIC: >log-line ( object -- line ) M: irc-message >log-line line>> ; +M: ctcp >log-line + [ "CTCP: " % dup sender>> % " " % text>> % ] "" make ; + +M: action >log-line + [ "* " % dup sender>> % " " % text>> % ] "" make ; + M: privmsg >log-line [ "<" % dup sender>> % "> " % text>> % ] "" make ; From 17cbf3dded0dccfea50f3031b54b47b9729ee2ce Mon Sep 17 00:00:00 2001 From: Bruno Deferrari Date: Thu, 16 Apr 2009 22:28:40 -0300 Subject: [PATCH 010/133] irc.client: Update test --- extra/irc/client/internals/internals-tests.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/irc/client/internals/internals-tests.factor b/extra/irc/client/internals/internals-tests.factor index d20ae50bcc..8d48f0c0a1 100644 --- a/extra/irc/client/internals/internals-tests.factor +++ b/extra/irc/client/internals/internals-tests.factor @@ -76,7 +76,7 @@ M: mb-writer dispose drop ; ! Test connect { V{ "NICK factorbot" "USER factorbot hostname servername :irc.factor" } } [ "someserver" irc-port "factorbot" f - [ 2drop t ] >>connect + [ 2drop ] >>connect [ (connect-irc) (do-login) From 1e7506f7c1ee92576d403308f47d0504e8ed1106 Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Thu, 7 May 2009 10:32:32 +0200 Subject: [PATCH 011/133] 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 012/133] 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 8c19ab04c90bafa3ab782d1a790154e962aac82a Mon Sep 17 00:00:00 2001 From: erg Date: Thu, 7 May 2009 16:41:37 -0500 Subject: [PATCH 013/133] use open64 instead of open on linux. use stat64 instead of stat on linux. add word to report if a file is sparse --- basis/io/directories/unix/unix.factor | 15 +++++++-- basis/io/files/info/info.factor | 5 ++- basis/unix/linux/linux.factor | 15 ++++++--- basis/unix/stat/linux/32/32.factor | 47 +++++++++++++-------------- basis/unix/stat/linux/64/64.factor | 44 ++++++++++++------------- basis/unix/types/linux/linux.factor | 4 +++ basis/unix/unix.factor | 7 ++-- 7 files changed, 79 insertions(+), 58 deletions(-) diff --git a/basis/io/directories/unix/unix.factor b/basis/io/directories/unix/unix.factor index 395ce73d7c..0db91f1153 100644 --- a/basis/io/directories/unix/unix.factor +++ b/basis/io/directories/unix/unix.factor @@ -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" f [ readdir_r 0 = [ (io-error) ] unless ] 2keep @@ -53,9 +55,16 @@ M: unix copy-file ( from to -- ) [ drop +unknown+ ] } case ; +TUPLE: unix-directory-entry < directory-entry ino off reclen ; + 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_name utf8 alien>string ] + [ dirent-d_type dirent-type>file-type ] + [ dirent-d_ino ] + [ dirent-d_off ] + [ dirent-d_reclen ] + } cleave unix-directory-entry boa ; M: unix (directory-entries) ( path -- seq ) [ diff --git a/basis/io/files/info/info.factor b/basis/io/files/info/info.factor index 5c5d2c93d2..f16db428a8 100644 --- a/basis/io/files/info/info.factor +++ b/basis/io/files/info/info.factor @@ -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 ) diff --git a/basis/unix/linux/linux.factor b/basis/unix/linux/linux.factor index 0cf33be1bf..5a05e5c207 100644 --- a/basis/unix/linux/linux.factor +++ b/basis/unix/linux/linux.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.syntax ; +USING: alien.syntax alien system ; IN: unix ! Linux. @@ -93,13 +93,20 @@ C-STRUCT: passwd { "char*" "pw_dir" } { "char*" "pw_shell" } ; -C-STRUCT: dirent - { "__ino_t" "d_ino" } - { "__off_t" "d_off" } +! dirent64 +C-STRUCT: dirent64 + { "ulonglong" "d_ino" } + { "longlong" "d_off" } { "ushort" "d_reclen" } { "uchar" "d_type" } { { "char" 256 } "d_name" } ; +FUNCTION: int open64 ( char* path, int flags, int prot ) ; +FUNCTION: dirent64* readdir64 ( DIR* dirp ) ; +FUNCTION: int readdir64_r ( void* dirp, dirent64* entry, dirent64** result ) ; + +M: linux open-file [ open64 ] unix-system-call ; + CONSTANT: EPERM 1 CONSTANT: ENOENT 2 CONSTANT: ESRCH 3 diff --git a/basis/unix/stat/linux/32/32.factor b/basis/unix/stat/linux/32/32.factor index 35963cf4ed..98c4b90f32 100644 --- a/basis/unix/stat/linux/32/32.factor +++ b/basis/unix/stat/linux/32/32.factor @@ -1,29 +1,28 @@ -USING: kernel alien.syntax math ; +USING: kernel alien.syntax math sequences unix +alien.c-types arrays accessors combinators ; IN: unix.stat -! Ubuntu 8.04 32-bit - +! stat64 C-STRUCT: stat - { "dev_t" "st_dev" } - { "ushort" "__pad1" } - { "ino_t" "st_ino" } - { "mode_t" "st_mode" } - { "nlink_t" "st_nlink" } - { "uid_t" "st_uid" } - { "gid_t" "st_gid" } - { "dev_t" "st_rdev" } - { "ushort" "__pad2" } - { "off_t" "st_size" } - { "blksize_t" "st_blksize" } - { "blkcnt_t" "st_blocks" } - { "timespec" "st_atimespec" } - { "timespec" "st_mtimespec" } - { "timespec" "st_ctimespec" } - { "ulong" "unused4" } - { "ulong" "unused5" } ; + { "dev_t" "st_dev" } + { "ushort" "__pad1" } + { "__ino_t" "__st_ino" } + { "mode_t" "st_mode" } + { "nlink_t" "st_nlink" } + { "uid_t" "st_uid" } + { "gid_t" "st_gid" } + { "dev_t" "st_rdev" } + { { "ushort" 2 } "__pad2" } + { "off64_t" "st_size" } + { "blksize_t" "st_blksize" } + { "blkcnt64_t" "st_blocks" } + { "timespec" "st_atimespec" } + { "timespec" "st_mtimespec" } + { "timespec" "st_ctimespec" } + { "ulonglong" "st_ino" } ; -FUNCTION: int __xstat ( int ver, char* pathname, stat* buf ) ; -FUNCTION: int __lxstat ( int ver, char* pathname, stat* buf ) ; +FUNCTION: int __xstat64 ( int ver, char* pathname, stat* buf ) ; +FUNCTION: int __lxstat64 ( int ver, char* pathname, stat* buf ) ; -: stat ( pathname buf -- int ) [ 3 ] 2dip __xstat ; -: lstat ( pathname buf -- int ) [ 3 ] 2dip __lxstat ; +: stat ( pathname buf -- int ) [ 1 ] 2dip __xstat64 ; +: lstat ( pathname buf -- int ) [ 1 ] 2dip __lxstat64 ; diff --git a/basis/unix/stat/linux/64/64.factor b/basis/unix/stat/linux/64/64.factor index 81b33f3227..98c4b90f32 100644 --- a/basis/unix/stat/linux/64/64.factor +++ b/basis/unix/stat/linux/64/64.factor @@ -2,29 +2,27 @@ USING: kernel alien.syntax math sequences unix alien.c-types arrays accessors combinators ; IN: unix.stat -! Ubuntu 7.10 64-bit - +! stat64 C-STRUCT: stat - { "dev_t" "st_dev" } - { "ino_t" "st_ino" } - { "nlink_t" "st_nlink" } - { "mode_t" "st_mode" } - { "uid_t" "st_uid" } - { "gid_t" "st_gid" } - { "int" "pad0" } - { "dev_t" "st_rdev" } - { "off_t" "st_size" } - { "blksize_t" "st_blksize" } - { "blkcnt_t" "st_blocks" } - { "timespec" "st_atimespec" } - { "timespec" "st_mtimespec" } - { "timespec" "st_ctimespec" } - { "long" "__unused0" } - { "long" "__unused1" } - { "long" "__unused2" } ; + { "dev_t" "st_dev" } + { "ushort" "__pad1" } + { "__ino_t" "__st_ino" } + { "mode_t" "st_mode" } + { "nlink_t" "st_nlink" } + { "uid_t" "st_uid" } + { "gid_t" "st_gid" } + { "dev_t" "st_rdev" } + { { "ushort" 2 } "__pad2" } + { "off64_t" "st_size" } + { "blksize_t" "st_blksize" } + { "blkcnt64_t" "st_blocks" } + { "timespec" "st_atimespec" } + { "timespec" "st_mtimespec" } + { "timespec" "st_ctimespec" } + { "ulonglong" "st_ino" } ; -FUNCTION: int __xstat ( int ver, char* pathname, stat* buf ) ; -FUNCTION: int __lxstat ( int ver, char* pathname, stat* buf ) ; +FUNCTION: int __xstat64 ( int ver, char* pathname, stat* buf ) ; +FUNCTION: int __lxstat64 ( int ver, char* pathname, stat* buf ) ; -: stat ( pathname buf -- int ) [ 1 ] 2dip __xstat ; -: lstat ( pathname buf -- int ) [ 1 ] 2dip __lxstat ; +: stat ( pathname buf -- int ) [ 1 ] 2dip __xstat64 ; +: lstat ( pathname buf -- int ) [ 1 ] 2dip __lxstat64 ; diff --git a/basis/unix/types/linux/linux.factor b/basis/unix/types/linux/linux.factor index bf5d4b7f1d..b0340c1778 100644 --- a/basis/unix/types/linux/linux.factor +++ b/basis/unix/types/linux/linux.factor @@ -23,7 +23,11 @@ TYPEDEF: __slongword_type blkcnt_t TYPEDEF: __sword_type ssize_t TYPEDEF: __s32_type pid_t TYPEDEF: __slongword_type time_t +TYPEDEF: __slongword_type __time_t TYPEDEF: ssize_t __SWORD_TYPE +TYPEDEF: ulonglong blkcnt64_t TYPEDEF: ulonglong __fsblkcnt64_t TYPEDEF: ulonglong __fsfilcnt64_t +TYPEDEF: ulonglong ino64_t +TYPEDEF: ulonglong off64_t diff --git a/basis/unix/unix.factor b/basis/unix/unix.factor index 10fb2ad64f..95dca2cb34 100644 --- a/basis/unix/unix.factor +++ b/basis/unix/unix.factor @@ -140,9 +140,11 @@ FUNCTION: int shutdown ( int fd, int how ) ; FUNCTION: int open ( char* path, int flags, int prot ) ; -FUNCTION: DIR* opendir ( char* path ) ; +HOOK: open-file os ( path flags mode -- fd ) -: open-file ( path flags mode -- fd ) [ open ] unix-system-call ; +M: unix open-file [ open ] unix-system-call ; + +FUNCTION: DIR* opendir ( char* path ) ; C-STRUCT: utimbuf { "time_t" "actime" } @@ -165,7 +167,6 @@ FUNCTION: ssize_t read ( int fd, void* buf, size_t nbytes ) ; FUNCTION: dirent* readdir ( DIR* dirp ) ; FUNCTION: int readdir_r ( void* dirp, dirent* entry, dirent** result ) ; - FUNCTION: ssize_t readlink ( char* path, char* buf, size_t bufsize ) ; CONSTANT: PATH_MAX 1024 From 3bf8e41eefa45cec95bd69b8be71903b05bea2b3 Mon Sep 17 00:00:00 2001 From: erg Date: Thu, 7 May 2009 16:53:32 -0500 Subject: [PATCH 014/133] fix bootstrap errors, add missing files --- basis/io/directories/unix/linux/linux.factor | 10 ++++++++++ basis/io/directories/unix/linux/tags.txt | 1 + basis/io/directories/unix/unix.factor | 4 +++- basis/unix/linux/linux.factor | 4 ++-- 4 files changed, 16 insertions(+), 3 deletions(-) create mode 100644 basis/io/directories/unix/linux/linux.factor create mode 100644 basis/io/directories/unix/linux/tags.txt diff --git a/basis/io/directories/unix/linux/linux.factor b/basis/io/directories/unix/linux/linux.factor new file mode 100644 index 0000000000..ba5b27dacd --- /dev/null +++ b/basis/io/directories/unix/linux/linux.factor @@ -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" + f + [ readdir64_r 0 = [ (io-error) ] unless ] 2keep + *void* [ drop f ] unless ; diff --git a/basis/io/directories/unix/linux/tags.txt b/basis/io/directories/unix/linux/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/io/directories/unix/linux/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/io/directories/unix/unix.factor b/basis/io/directories/unix/unix.factor index 0db91f1153..5e2fda5848 100644 --- a/basis/io/directories/unix/unix.factor +++ b/basis/io/directories/unix/unix.factor @@ -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 ) @@ -72,3 +72,5 @@ M: unix (directory-entries) ( path -- seq ) [ >directory-entry ] produce nip ] with-unix-directory ; + +os linux? [ "io.directories.unix.linux" require ] when diff --git a/basis/unix/linux/linux.factor b/basis/unix/linux/linux.factor index 5a05e5c207..43a66f2dbe 100644 --- a/basis/unix/linux/linux.factor +++ b/basis/unix/linux/linux.factor @@ -94,7 +94,7 @@ C-STRUCT: passwd { "char*" "pw_shell" } ; ! dirent64 -C-STRUCT: dirent64 +C-STRUCT: dirent { "ulonglong" "d_ino" } { "longlong" "d_off" } { "ushort" "d_reclen" } @@ -103,7 +103,7 @@ C-STRUCT: dirent64 FUNCTION: int open64 ( char* path, int flags, int prot ) ; FUNCTION: dirent64* readdir64 ( DIR* dirp ) ; -FUNCTION: int readdir64_r ( void* dirp, dirent64* entry, dirent64** result ) ; +FUNCTION: int readdir64_r ( void* dirp, dirent* entry, dirent** result ) ; M: linux open-file [ open64 ] unix-system-call ; From e3d5d8bef08e231f0579ffe6fe5432675cd878d2 Mon Sep 17 00:00:00 2001 From: Alec Berryman Date: Thu, 7 May 2009 22:45:02 -0400 Subject: [PATCH 015/133] bloom-filters: compact, probabilistic membership testing --- extra/bloom-filters/authors.txt | 1 + extra/bloom-filters/bloom-filters-docs.factor | 36 ++++ .../bloom-filters/bloom-filters-tests.factor | 71 ++++++++ extra/bloom-filters/bloom-filters.factor | 161 ++++++++++++++++++ 4 files changed, 269 insertions(+) create mode 100644 extra/bloom-filters/authors.txt create mode 100644 extra/bloom-filters/bloom-filters-docs.factor create mode 100644 extra/bloom-filters/bloom-filters-tests.factor create mode 100644 extra/bloom-filters/bloom-filters.factor diff --git a/extra/bloom-filters/authors.txt b/extra/bloom-filters/authors.txt new file mode 100644 index 0000000000..528e5dfe6b --- /dev/null +++ b/extra/bloom-filters/authors.txt @@ -0,0 +1 @@ +Alec Berryman diff --git a/extra/bloom-filters/bloom-filters-docs.factor b/extra/bloom-filters/bloom-filters-docs.factor new file mode 100644 index 0000000000..4af1a82af6 --- /dev/null +++ b/extra/bloom-filters/bloom-filters-docs.factor @@ -0,0 +1,36 @@ +USING: help.markup help.syntax kernel math ; +IN: bloom-filters + +HELP: +{ $values { "error-rate" "The desired false positive rate. A " { $link float } " between 0 and 1." } + { "number-objects" "The expected number of object in the set. An " { $link integer } "." } + { "bloom-filter" bloom-filter } } +{ $description "Creates an empty Bloom filter." } ; + +HELP: bloom-filter-insert +{ $values { "object" object } + { "bloom-filter" bloom-filter } } +{ $description "Records the item as a member of the filter." } +{ $side-effects "bloom-filter" } ; + +HELP: bloom-filter-member? +{ $values { "object" object } + { "bloom-filter" bloom-filter } + { "?" boolean } } +{ $description "Returns " { $link t } " if the object may be a member of Bloom filter, " { $link f } " otherwise. The false positive rate is configurable; there are no false negatives." } ; + +HELP: bloom-filter +{ $class-description "This is the class for Bloom filters. These provide constant-time insertion and probabilistic membership-testing operations, but do not actually store any elements." } ; + +ARTICLE: "bloom-filters" "Bloom filters" +"This is a library for Bloom filters, sets that provide a constant-time insertion operation and probabilistic membership tests, but do not actually store any elements." +$nl +"The accuracy of the membership test is configurable; a Bloom filter will never incorrectly report an item is not a member of the set, but may incorrectly report than an item is a member of the set." +$nl +"Bloom filters cannot be resized and do not support removal." +$nl +{ $subsection } +{ $subsection bloom-filter-insert } +{ $subsection bloom-filter-member? } ; + +ABOUT: "bloom-filters" diff --git a/extra/bloom-filters/bloom-filters-tests.factor b/extra/bloom-filters/bloom-filters-tests.factor new file mode 100644 index 0000000000..b7a5d7ebc2 --- /dev/null +++ b/extra/bloom-filters/bloom-filters-tests.factor @@ -0,0 +1,71 @@ +USING: accessors bit-arrays bloom-filters bloom-filters.private kernel layouts +math random sequences tools.test ; +IN: bloom-filters.tests + +! The sizing information was generated using the subroutine +! calculate_shortest_filter_length from +! http://www.perl.com/pub/a/2004/04/08/bloom_filters.html. + +! Test bloom-filter creation +[ 47965 ] [ 7 0.01 5000 bits-to-satisfy-error-rate ] unit-test +[ 7 47965 ] [ 0.01 5000 size-bloom-filter ] unit-test +[ 7 ] [ 0.01 5000 n-hashes>> ] unit-test +[ 47965 ] [ 0.01 5000 bits>> length ] unit-test +[ 5000 ] [ 0.01 5000 maximum-n-objects>> ] unit-test +[ 0 ] [ 0.01 5000 current-n-objects>> ] unit-test + +! Should return the fewest hashes to satisfy the bits requested, not the most. +[ 32 ] [ 4 0.05 5 bits-to-satisfy-error-rate ] unit-test +[ 32 ] [ 5 0.05 5 bits-to-satisfy-error-rate ] unit-test +[ 4 32 ] [ 0.05 5 size-bloom-filter ] unit-test + +! This is a lot of bits. On linux-x86-32, max-array-capacity is 134217727, +! which is about 16MB (assuming I can do math), which is sort of pithy. I'm +! not sure how to handle this case. Returning a smaller-than-requested +! arrays is not the least surprising behavior, but is still surprising. +[ 383718189 ] [ 7 0.01 40000000 bits-to-satisfy-error-rate ] unit-test +! [ 7 383718189 ] [ 0.01 40000000 size-bloom-filter ] unit-test +! [ 383718189 ] [ 0.01 40000000 bits>> length ] unit-test + +! Should not generate bignum hash codes. Enhanced double hashing may generate a +! lot of hash codes, and it's better to do this earlier than later. +[ t ] [ 10000 iota [ hashcodes-from-object [ fixnum? ] both? ] map [ t = ] all? ] unit-test + +[ ?{ t f t f t f } ] [ { 0 2 4 } 6 [ set-indices ] keep ] unit-test + +: empty-bloom-filter ( -- bloom-filter ) + 0.01 2000 ; + +[ 1 ] [ empty-bloom-filter [ increment-n-objects ] keep current-n-objects>> ] unit-test + +: basic-insert-test-setup ( -- bloom-filter ) + 1 empty-bloom-filter [ bloom-filter-insert ] keep ; + +! Basic tests that insert does something +[ t ] [ basic-insert-test-setup bits>> [ t = ] any? ] unit-test +[ 1 ] [ basic-insert-test-setup current-n-objects>> ] unit-test + +: non-empty-bloom-filter ( -- bloom-filter ) + 1000 iota + empty-bloom-filter + [ [ bloom-filter-insert ] curry each ] keep ; + +: full-bloom-filter ( -- bloom-filter ) + 2000 iota + empty-bloom-filter + [ [ bloom-filter-insert ] curry each ] keep ; + +! Should find what we put in there. +[ t ] [ 2000 iota + full-bloom-filter + [ bloom-filter-member? ] curry map + [ t = ] all? ] unit-test + +! We shouldn't have more than 0.01 false-positive rate. +[ t ] [ 1000 iota [ drop most-positive-fixnum random 1000 + ] map + full-bloom-filter + [ bloom-filter-member? ] curry map + [ t = ] filter + ! TODO: This should be 10, but the false positive rate is currently very + ! high. It shouldn't be much more than this. + length 150 <= ] unit-test diff --git a/extra/bloom-filters/bloom-filters.factor b/extra/bloom-filters/bloom-filters.factor new file mode 100644 index 0000000000..94d0dd070f --- /dev/null +++ b/extra/bloom-filters/bloom-filters.factor @@ -0,0 +1,161 @@ +! Copyright (C) 2009 Alec Berryman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays assocs bit-arrays kernel layouts locals math +math.functions math.ranges multiline sequences ; +IN: bloom-filters + +/* + +TODO: + +- How to singal an error when too many bits? It looks like a built-in for some + types of arrays, but bit-array just returns a zero-length array. What we do + now is completely broken: -1 hash codes? Really? + +- The false positive rate is 10x what it should be, based on informal testing. + Better object hashes or a better method of generating extra hash codes would + help. Another way is to increase the number of bits used. + + - Try something smarter than the bitwise complement for a second hash code. + + - http://spyced.blogspot.com/2009/01/all-you-ever-wanted-to-know-about.html + makes a case for http://murmurhash.googlepages.com/ instead of enhanced + double-hashing. + + - Be sure to adjust the test that asserts the number of false positives isn't + unreasonable. + +- Should round bits up to next power of two, use wrap instead of mod. + +- Should allow user to specify the hash codes, either as inputs to enhanced + double hashing or for direct use. + +- Support for serialization. + +- Wrappers for combining filters. + +- Should we signal an error when inserting past the number of objects the filter + is sized for? The filter will continue to work, just not very well. + +- The other TODOs sprinkled through the code. + +*/ + +TUPLE: bloom-filter +{ n-hashes fixnum read-only } +{ bits bit-array read-only } +{ maximum-n-objects fixnum read-only } +{ current-n-objects fixnum } ; + +integer ; ! should check that it's below max-array-capacity + +! TODO: this should be a constant +! +! TODO: after very little experimentation, I never see this increase after about +! 20 or so. Maybe it should be smaller. +: n-hashes-range ( -- range ) + 100 [1,b] ; + +! Ends up with a list of arrays - { n-bits position } +: find-bloom-filter-sizes ( error-rate number-objects -- seq ) + [ bits-to-satisfy-error-rate ] 2curry + n-hashes-range swap + map + n-hashes-range zip ; + +:: smallest-first ( seq1 seq2 -- seq ) + seq1 first seq2 first <= [ seq1 ] [ seq2 ] if ; + +! The consensus on the tradeoff between increasing the number of bits and +! increasing the number of hash functions seems to be "go for the smallest +! number of bits", probably because most implementations just generate one hash +! value and cheaply mangle it into the number of hashes they need. I have not +! seen any usage studies from the implementations that made this tradeoff to +! support it, and I haven't done my own, but we'll go with it anyway. +! +! TODO: check that error-rate is reasonable. +: size-bloom-filter ( error-rate number-objects -- number-hashes number-bits ) + find-bloom-filter-sizes + max-array-capacity -1 2array + [ smallest-first ] + reduce + [ second ] [ first ] bi ; + +PRIVATE> + +: ( error-rate number-objects -- bloom-filter ) + [ size-bloom-filter ] keep + 0 ! initially empty + bloom-filter boa ; + +fixnum bitxor ; + +! TODO: This code calls abs because all the double-hashing stuff outputs array +! indices and those aren't good negative. Are we throwing away bits? -1000 +! b. actually prints -1111101000, which confuses me. +: hashcodes-from-object ( obj -- n n ) + hashcode abs hashcodes-from-hashcode ; + +: set-indices ( indices bit-array -- ) + [ [ drop t ] change-nth ] curry each ; + +: increment-n-objects ( bloom-filter -- ) + dup current-n-objects>> 1 + >>current-n-objects drop ; + +! This would be better as an each-relevant-hash that didn't cons. +: relevant-indices ( value bloom-filter -- indices ) + [ n-hashes>> ] [ bits>> length ] bi ! value n array-size + swapd [ hashcodes-from-object ] dip ! n value1 value2 array-size + enhanced-double-hashes ; + +PRIVATE> + +: bloom-filter-insert ( object bloom-filter -- ) + [ relevant-indices ] + [ bits>> set-indices ] + [ increment-n-objects ] + tri ; + +: bloom-filter-member? ( value bloom-filter -- ? ) + [ relevant-indices ] + [ bits>> [ nth ] curry map [ t = ] all? ] + bi ; From c2482fe2bf1cf03b8f3a100ecc23db6f3e49adc2 Mon Sep 17 00:00:00 2001 From: Alec Berryman Date: Fri, 8 May 2009 22:14:07 -0400 Subject: [PATCH 016/133] bloom-filters: simplify several functions --- .../bloom-filters/bloom-filters-tests.factor | 10 +++--- extra/bloom-filters/bloom-filters.factor | 35 +++++++++---------- 2 files changed, 21 insertions(+), 24 deletions(-) diff --git a/extra/bloom-filters/bloom-filters-tests.factor b/extra/bloom-filters/bloom-filters-tests.factor index b7a5d7ebc2..40fd1469b2 100644 --- a/extra/bloom-filters/bloom-filters-tests.factor +++ b/extra/bloom-filters/bloom-filters-tests.factor @@ -29,20 +29,20 @@ IN: bloom-filters.tests ! Should not generate bignum hash codes. Enhanced double hashing may generate a ! lot of hash codes, and it's better to do this earlier than later. -[ t ] [ 10000 iota [ hashcodes-from-object [ fixnum? ] both? ] map [ t = ] all? ] unit-test +[ t ] [ 10000 iota [ hashcodes-from-object [ fixnum? ] both? ] map [ ] all? ] unit-test [ ?{ t f t f t f } ] [ { 0 2 4 } 6 [ set-indices ] keep ] unit-test : empty-bloom-filter ( -- bloom-filter ) 0.01 2000 ; -[ 1 ] [ empty-bloom-filter [ increment-n-objects ] keep current-n-objects>> ] unit-test +[ 1 ] [ empty-bloom-filter increment-n-objects current-n-objects>> ] unit-test : basic-insert-test-setup ( -- bloom-filter ) 1 empty-bloom-filter [ bloom-filter-insert ] keep ; ! Basic tests that insert does something -[ t ] [ basic-insert-test-setup bits>> [ t = ] any? ] unit-test +[ t ] [ basic-insert-test-setup bits>> [ ] any? ] unit-test [ 1 ] [ basic-insert-test-setup current-n-objects>> ] unit-test : non-empty-bloom-filter ( -- bloom-filter ) @@ -59,13 +59,13 @@ IN: bloom-filters.tests [ t ] [ 2000 iota full-bloom-filter [ bloom-filter-member? ] curry map - [ t = ] all? ] unit-test + [ ] all? ] unit-test ! We shouldn't have more than 0.01 false-positive rate. [ t ] [ 1000 iota [ drop most-positive-fixnum random 1000 + ] map full-bloom-filter [ bloom-filter-member? ] curry map - [ t = ] filter + [ ] filter ! TODO: This should be 10, but the false positive rate is currently very ! high. It shouldn't be much more than this. length 150 <= ] unit-test diff --git a/extra/bloom-filters/bloom-filters.factor b/extra/bloom-filters/bloom-filters.factor index 94d0dd070f..3e0aba175c 100644 --- a/extra/bloom-filters/bloom-filters.factor +++ b/extra/bloom-filters/bloom-filters.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2009 Alec Berryman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays assocs bit-arrays kernel layouts locals math -math.functions math.ranges multiline sequences ; +USING: accessors arrays bit-arrays fry kernel layouts locals math math.functions +math.ranges multiline sequences ; IN: bloom-filters /* @@ -70,8 +70,8 @@ TUPLE: bloom-filter map n-hashes-range zip ; -:: smallest-first ( seq1 seq2 -- seq ) - seq1 first seq2 first <= [ seq1 ] [ seq2 ] if ; +: smallest-first ( seq1 seq2 -- seq ) + [ [ first ] bi@ <= ] most ; ! The consensus on the tradeoff between increasing the number of bits and ! increasing the number of hash functions seems to be "go for the smallest @@ -118,9 +118,7 @@ PRIVATE> array-size mod ; : enhanced-double-hashes ( n hash0 hash1 array-size -- seq ) - [ enhanced-double-hash ] 3curry - [ [0,b) ] dip - map ; + '[ _ _ _ enhanced-double-hash ] [ [0,b) ] dip map ; ! Stupid, should pick something good. : hashcodes-from-hashcode ( n -- n n ) @@ -138,24 +136,23 @@ PRIVATE> : set-indices ( indices bit-array -- ) [ [ drop t ] change-nth ] curry each ; -: increment-n-objects ( bloom-filter -- ) - dup current-n-objects>> 1 + >>current-n-objects drop ; +: increment-n-objects ( bloom-filter -- bloom-filter ) + [ 1 + ] change-current-n-objects ; + +: n-hashes-and-bits ( bloom-filter -- n-hashes n-bits ) + [ n-hashes>> ] [ bits>> length ] bi ; -! This would be better as an each-relevant-hash that didn't cons. : relevant-indices ( value bloom-filter -- indices ) - [ n-hashes>> ] [ bits>> length ] bi ! value n array-size - swapd [ hashcodes-from-object ] dip ! n value1 value2 array-size + n-hashes-and-bits + [ swap hashcodes-from-object ] dip enhanced-double-hashes ; PRIVATE> : bloom-filter-insert ( object bloom-filter -- ) - [ relevant-indices ] - [ bits>> set-indices ] - [ increment-n-objects ] - tri ; + increment-n-objects + [ relevant-indices ] [ bits>> set-indices ] bi ; : bloom-filter-member? ( value bloom-filter -- ? ) - [ relevant-indices ] - [ bits>> [ nth ] curry map [ t = ] all? ] - bi ; + [ relevant-indices ] keep + bits>> nths [ ] all? ; From 3e3f08c6e5b70633d400a57c836debd46b0adba7 Mon Sep 17 00:00:00 2001 From: Alec Berryman Date: Fri, 8 May 2009 23:30:01 -0400 Subject: [PATCH 017/133] bloom-filters: clean up creation More readable, less allocation, signals invalid input. --- extra/bloom-filters/bloom-filters-docs.factor | 6 +- .../bloom-filters/bloom-filters-tests.factor | 24 +++++-- extra/bloom-filters/bloom-filters.factor | 66 ++++++++++++------- 3 files changed, 63 insertions(+), 33 deletions(-) diff --git a/extra/bloom-filters/bloom-filters-docs.factor b/extra/bloom-filters/bloom-filters-docs.factor index 4af1a82af6..bc5df8611c 100644 --- a/extra/bloom-filters/bloom-filters-docs.factor +++ b/extra/bloom-filters/bloom-filters-docs.factor @@ -3,9 +3,11 @@ IN: bloom-filters HELP: { $values { "error-rate" "The desired false positive rate. A " { $link float } " between 0 and 1." } - { "number-objects" "The expected number of object in the set. An " { $link integer } "." } + { "number-objects" "The expected number of object in the set. A positive " { $link integer } "." } { "bloom-filter" bloom-filter } } -{ $description "Creates an empty Bloom filter." } ; +{ $description "Creates an empty Bloom filter." } +{ $errors "Throws a " { $link capacity-error } " when unable to produce a filter meeting the given constraints. Throws a " { $link invalid-error-rate } " or a " { $link invalid-n-objects } " when input is invalid." } ; + HELP: bloom-filter-insert { $values { "object" object } diff --git a/extra/bloom-filters/bloom-filters-tests.factor b/extra/bloom-filters/bloom-filters-tests.factor index 40fd1469b2..b4fd69d849 100644 --- a/extra/bloom-filters/bloom-filters-tests.factor +++ b/extra/bloom-filters/bloom-filters-tests.factor @@ -2,6 +2,10 @@ USING: accessors bit-arrays bloom-filters bloom-filters.private kernel layouts math random sequences tools.test ; IN: bloom-filters.tests + +[ { 200 5 } ] [ { 100 7 } { 200 5 } smaller-second ] unit-test +[ { 200 5 } ] [ { 200 5 } { 100 7 } smaller-second ] unit-test + ! The sizing information was generated using the subroutine ! calculate_shortest_filter_length from ! http://www.perl.com/pub/a/2004/04/08/bloom_filters.html. @@ -19,13 +23,19 @@ IN: bloom-filters.tests [ 32 ] [ 5 0.05 5 bits-to-satisfy-error-rate ] unit-test [ 4 32 ] [ 0.05 5 size-bloom-filter ] unit-test -! This is a lot of bits. On linux-x86-32, max-array-capacity is 134217727, -! which is about 16MB (assuming I can do math), which is sort of pithy. I'm -! not sure how to handle this case. Returning a smaller-than-requested -! arrays is not the least surprising behavior, but is still surprising. -[ 383718189 ] [ 7 0.01 40000000 bits-to-satisfy-error-rate ] unit-test -! [ 7 383718189 ] [ 0.01 40000000 size-bloom-filter ] unit-test -! [ 383718189 ] [ 0.01 40000000 bits>> length ] unit-test +! This is a lot of bits. +: oversized-filter-params ( -- error-rate n-objects ) + 0.00000001 400000000000000 ; +[ oversized-filter-params size-bloom-filter ] [ capacity-error? ] must-fail-with +[ oversized-filter-params ] [ capacity-error? ] must-fail-with + +! Other error conditions. +[ 1.0 2000 ] [ invalid-error-rate? ] must-fail-with +[ 20 2000 ] [ invalid-error-rate? ] must-fail-with +[ 0.0 2000 ] [ invalid-error-rate? ] must-fail-with +[ -2 2000 ] [ invalid-error-rate? ] must-fail-with +[ 0.5 0 ] [ invalid-n-objects? ] must-fail-with +[ 0.5 -5 ] [ invalid-n-objects? ] must-fail-with ! Should not generate bignum hash codes. Enhanced double hashing may generate a ! lot of hash codes, and it's better to do this earlier than later. diff --git a/extra/bloom-filters/bloom-filters.factor b/extra/bloom-filters/bloom-filters.factor index 3e0aba175c..5440461892 100644 --- a/extra/bloom-filters/bloom-filters.factor +++ b/extra/bloom-filters/bloom-filters.factor @@ -1,17 +1,16 @@ ! Copyright (C) 2009 Alec Berryman. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays bit-arrays fry kernel layouts locals math math.functions -math.ranges multiline sequences ; +multiline sequences ; IN: bloom-filters +FROM: math.ranges => [1,b] [0,b) ; +FROM: math.intervals => (a,b) interval-contains? ; + /* TODO: -- How to singal an error when too many bits? It looks like a built-in for some - types of arrays, but bit-array just returns a zero-length array. What we do - now is completely broken: -1 hash codes? Really? - - The false positive rate is 10x what it should be, based on informal testing. Better object hashes or a better method of generating extra hash codes would help. Another way is to increase the number of bits used. @@ -25,7 +24,9 @@ TODO: - Be sure to adjust the test that asserts the number of false positives isn't unreasonable. -- Should round bits up to next power of two, use wrap instead of mod. +- Could round bits up to next power of two and use wrap instead of mod. This + would cost a lot of bits on 32-bit platforms, though, and limit the bit-array + to 8MB. - Should allow user to specify the hash codes, either as inputs to enhanced double hashing or for direct use. @@ -47,6 +48,10 @@ TUPLE: bloom-filter { maximum-n-objects fixnum read-only } { current-n-objects fixnum } ; +ERROR: capacity-error ; +ERROR: invalid-error-rate ; +ERROR: invalid-n-objects ; + integer ; ! should check that it's below max-array-capacity -! TODO: this should be a constant -! -! TODO: after very little experimentation, I never see this increase after about -! 20 or so. Maybe it should be smaller. +! 100 hashes ought to be enough for anybody. : n-hashes-range ( -- range ) 100 [1,b] ; -! Ends up with a list of arrays - { n-bits position } -: find-bloom-filter-sizes ( error-rate number-objects -- seq ) - [ bits-to-satisfy-error-rate ] 2curry - n-hashes-range swap - map - n-hashes-range zip ; +! { n-hashes n-bits } +: identity-configuration ( -- 2seq ) + 0 max-array-capacity 2array ; -: smallest-first ( seq1 seq2 -- seq ) - [ [ first ] bi@ <= ] most ; +: smaller-second ( 2seq 2seq -- 2seq ) + [ [ second ] bi@ <= ] most ; + +! If the number of hashes isn't positive, we haven't found anything smaller than the +! identity configuration. +: validate-sizes ( 2seq -- ) + first 0 <= [ capacity-error ] when* ; ! The consensus on the tradeoff between increasing the number of bits and ! increasing the number of hash functions seems to be "go for the smallest @@ -80,17 +84,31 @@ TUPLE: bloom-filter ! seen any usage studies from the implementations that made this tradeoff to ! support it, and I haven't done my own, but we'll go with it anyway. ! -! TODO: check that error-rate is reasonable. : size-bloom-filter ( error-rate number-objects -- number-hashes number-bits ) - find-bloom-filter-sizes - max-array-capacity -1 2array - [ smallest-first ] - reduce - [ second ] [ first ] bi ; + '[ _ _ bits-to-satisfy-error-rate ] + '[ dup _ call 2array smaller-second ] + '[ n-hashes-range identity-configuration _ reduce ] + call + dup validate-sizes + first2 ; + +: validate-n-objects ( n-objects -- ) + 0 <= [ invalid-n-objects ] when ; + +: valid-error-rate-interval ( -- interval ) + 0 1 (a,b) ; + +: validate-error-rate ( error-rate -- ) + valid-error-rate-interval interval-contains? + [ invalid-error-rate ] unless ; + +: validate-constraints ( error-rate n-objects -- ) + validate-n-objects validate-error-rate ; PRIVATE> : ( error-rate number-objects -- bloom-filter ) + [ validate-constraints ] 2keep [ size-bloom-filter ] keep 0 ! initially empty bloom-filter boa ; From e6f8aafe5f27c52f7cd3611aae4032aa3c3fd56a Mon Sep 17 00:00:00 2001 From: Alec Berryman Date: Sun, 10 May 2009 11:58:57 -0400 Subject: [PATCH 018/133] bloom-filters: use infix syntax --- extra/bloom-filters/bloom-filters.factor | 32 ++++++++---------------- 1 file changed, 10 insertions(+), 22 deletions(-) diff --git a/extra/bloom-filters/bloom-filters.factor b/extra/bloom-filters/bloom-filters.factor index 5440461892..b82bf46d36 100644 --- a/extra/bloom-filters/bloom-filters.factor +++ b/extra/bloom-filters/bloom-filters.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2009 Alec Berryman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays bit-arrays fry kernel layouts locals math math.functions -multiline sequences ; +USING: accessors arrays bit-arrays fry infix kernel layouts locals math +math.functions multiline sequences ; IN: bloom-filters FROM: math.ranges => [1,b] [0,b) ; @@ -54,12 +54,13 @@ ERROR: invalid-n-objects ; integer ; ! should check that it's below max-array-capacity +! infix doesn't like ^ +: pow ( x y -- z ) + ^ ; inline + +:: bits-to-satisfy-error-rate ( hashes error objects -- size ) + [infix -(objects * hashes) / log(1 - pow(error, (1/hashes))) infix] + ceiling >integer ; ! 100 hashes ought to be enough for anybody. : n-hashes-range ( -- range ) @@ -118,21 +119,8 @@ PRIVATE> ! See "Bloom Filters in Probabilistic Verification" by Peter C. Dillinger and ! Panagiotis Manolios, section 5.2, "Enhanced Double Hashing": ! http://www.cc.gatech.edu/~manolios/research/bloom-filters-verification.html -! -! This is taken from the definition at the top of page 12: -! -! F(i) = (A(s) + (i * B(s)) + ((i^3 - i) / 6)) mod m -! -! Where i is the hash number, A and B are hash functions for object s, and m is -! the length of the array. - :: enhanced-double-hash ( index hash0 hash1 array-size -- hash ) - hash0 - index hash1 * - + - index 3 ^ index - - 6 / - + + [infix hash0 + (index * hash1) + ((pow(index, 3) - index) / 6) infix] array-size mod ; : enhanced-double-hashes ( n hash0 hash1 array-size -- seq ) From 8c267834557aa5b73e777553c4af7e99f36abf05 Mon Sep 17 00:00:00 2001 From: Alec Berryman Date: Sun, 10 May 2009 12:50:26 -0400 Subject: [PATCH 019/133] bloom-filters: clean help-lint --- extra/bloom-filters/bloom-filters.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/bloom-filters/bloom-filters.factor b/extra/bloom-filters/bloom-filters.factor index b82bf46d36..de7aa75a06 100644 --- a/extra/bloom-filters/bloom-filters.factor +++ b/extra/bloom-filters/bloom-filters.factor @@ -159,6 +159,6 @@ PRIVATE> increment-n-objects [ relevant-indices ] [ bits>> set-indices ] bi ; -: bloom-filter-member? ( value bloom-filter -- ? ) +: bloom-filter-member? ( object bloom-filter -- ? ) [ relevant-indices ] keep bits>> nths [ ] all? ; From dc1b97e70ab9eaa8b9453b30ce57a5399582ad88 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 8 May 2009 09:51:57 -0500 Subject: [PATCH 020/133] 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 021/133] 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 022/133] 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 023/133] 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 024/133] 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 025/133] 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 026/133] 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 027/133] 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 028/133] 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 029/133] 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 030/133] 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 031/133] 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 032/133] 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 033/133] 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 034/133] 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 035/133] 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 036/133] 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 037/133] 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 038/133] 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 039/133] 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 040/133] 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 041/133] 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 042/133] 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 043/133] 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 044/133] 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 From 713f0db0a2ba2b5fb1234d9d2fbed5278e277de5 Mon Sep 17 00:00:00 2001 From: Alec Berryman Date: Sun, 10 May 2009 18:04:47 -0400 Subject: [PATCH 045/133] bloom-filters: clean up indices code Extricating mod from hash creation makes it a little nicer. --- .../bloom-filters/bloom-filters-tests.factor | 2 +- extra/bloom-filters/bloom-filters.factor | 42 ++++++++----------- 2 files changed, 19 insertions(+), 25 deletions(-) diff --git a/extra/bloom-filters/bloom-filters-tests.factor b/extra/bloom-filters/bloom-filters-tests.factor index b4fd69d849..90fbc81f55 100644 --- a/extra/bloom-filters/bloom-filters-tests.factor +++ b/extra/bloom-filters/bloom-filters-tests.factor @@ -46,7 +46,7 @@ IN: bloom-filters.tests : empty-bloom-filter ( -- bloom-filter ) 0.01 2000 ; -[ 1 ] [ empty-bloom-filter increment-n-objects current-n-objects>> ] unit-test +[ 1 ] [ empty-bloom-filter dup increment-n-objects current-n-objects>> ] unit-test : basic-insert-test-setup ( -- bloom-filter ) 1 empty-bloom-filter [ bloom-filter-insert ] keep ; diff --git a/extra/bloom-filters/bloom-filters.factor b/extra/bloom-filters/bloom-filters.factor index de7aa75a06..46c2a3f8c1 100644 --- a/extra/bloom-filters/bloom-filters.factor +++ b/extra/bloom-filters/bloom-filters.factor @@ -38,8 +38,6 @@ TODO: - Should we signal an error when inserting past the number of objects the filter is sized for? The filter will continue to work, just not very well. -- The other TODOs sprinkled through the code. - */ TUPLE: bloom-filter @@ -76,7 +74,7 @@ ERROR: invalid-n-objects ; ! If the number of hashes isn't positive, we haven't found anything smaller than the ! identity configuration. : validate-sizes ( 2seq -- ) - first 0 <= [ capacity-error ] when* ; + first 0 <= [ capacity-error ] when ; ! The consensus on the tradeoff between increasing the number of bits and ! increasing the number of hash functions seems to be "go for the smallest @@ -119,45 +117,41 @@ PRIVATE> ! See "Bloom Filters in Probabilistic Verification" by Peter C. Dillinger and ! Panagiotis Manolios, section 5.2, "Enhanced Double Hashing": ! http://www.cc.gatech.edu/~manolios/research/bloom-filters-verification.html -:: enhanced-double-hash ( index hash0 hash1 array-size -- hash ) - [infix hash0 + (index * hash1) + ((pow(index, 3) - index) / 6) infix] - array-size mod ; +:: enhanced-double-hash ( index hash0 hash1 -- hash ) + [infix hash0 + (index * hash1) + ((pow(index, 3) - index) / 6) infix] ; -: enhanced-double-hashes ( n hash0 hash1 array-size -- seq ) - '[ _ _ _ enhanced-double-hash ] [ [0,b) ] dip map ; +: enhanced-double-hashes ( hash0 hash1 n -- seq ) + [0,b) + [ '[ _ _ enhanced-double-hash ] ] dip + swap map ; -! Stupid, should pick something good. +! Make sure it's a fixnum here to speed up double-hashing. : hashcodes-from-hashcode ( n -- n n ) - dup - ! we could be running this through a lot of double hashing, make sure it's a - ! fixnum here - most-positive-fixnum >fixnum bitxor ; + dup most-positive-fixnum >fixnum bitxor ; -! TODO: This code calls abs because all the double-hashing stuff outputs array -! indices and those aren't good negative. Are we throwing away bits? -1000 -! b. actually prints -1111101000, which confuses me. : hashcodes-from-object ( obj -- n n ) hashcode abs hashcodes-from-hashcode ; : set-indices ( indices bit-array -- ) [ [ drop t ] change-nth ] curry each ; -: increment-n-objects ( bloom-filter -- bloom-filter ) - [ 1 + ] change-current-n-objects ; +: increment-n-objects ( bloom-filter -- ) + [ 1 + ] change-current-n-objects drop ; -: n-hashes-and-bits ( bloom-filter -- n-hashes n-bits ) +: n-hashes-and-length ( bloom-filter -- n-hashes length ) [ n-hashes>> ] [ bits>> length ] bi ; : relevant-indices ( value bloom-filter -- indices ) - n-hashes-and-bits - [ swap hashcodes-from-object ] dip - enhanced-double-hashes ; + [ hashcodes-from-object ] [ n-hashes-and-length ] bi* + [ enhanced-double-hashes ] dip '[ _ mod ] map ; PRIVATE> : bloom-filter-insert ( object bloom-filter -- ) - increment-n-objects - [ relevant-indices ] [ bits>> set-indices ] bi ; + [ increment-n-objects ] + [ relevant-indices ] + [ bits>> set-indices ] + tri ; : bloom-filter-member? ( object bloom-filter -- ? ) [ relevant-indices ] keep From 5a9aa07f15a409afb85c2230c1144fbb23996a09 Mon Sep 17 00:00:00 2001 From: Alec Berryman Date: Sun, 10 May 2009 19:41:39 -0400 Subject: [PATCH 046/133] bloom-filters: fewer fried quots --- extra/bloom-filters/bloom-filters.factor | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/extra/bloom-filters/bloom-filters.factor b/extra/bloom-filters/bloom-filters.factor index 46c2a3f8c1..308d10ad84 100644 --- a/extra/bloom-filters/bloom-filters.factor +++ b/extra/bloom-filters/bloom-filters.factor @@ -84,10 +84,10 @@ ERROR: invalid-n-objects ; ! support it, and I haven't done my own, but we'll go with it anyway. ! : size-bloom-filter ( error-rate number-objects -- number-hashes number-bits ) - '[ _ _ bits-to-satisfy-error-rate ] - '[ dup _ call 2array smaller-second ] - '[ n-hashes-range identity-configuration _ reduce ] - call + [ n-hashes-range identity-configuration ] 2dip + '[ dup [ _ _ bits-to-satisfy-error-rate ] + call 2array smaller-second ] + reduce dup validate-sizes first2 ; From 9de34ab3cd7ff621a2be49dbfcaa3ebff2d68b95 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 10 May 2009 21:33:13 -0500 Subject: [PATCH 047/133] Fix deployment of UI apps and implement various tricks to make deployed images smaller --- basis/cocoa/messages/messages.factor | 2 +- basis/tools/deploy/deploy-docs.factor | 2 + basis/tools/deploy/deploy-tests.factor | 4 ++ basis/tools/deploy/shaker/shaker.factor | 68 +++++++++++--------- basis/tools/deploy/shaker/strip-cocoa.factor | 9 ++- basis/ui/gadgets/worlds/worlds.factor | 2 +- basis/ui/gestures/gestures.factor | 12 ++-- basis/ui/pixel-formats/pixel-formats.factor | 4 +- extra/spheres/deploy.factor | 19 +++--- extra/terrain/deploy.factor | 15 +++++ 10 files changed, 87 insertions(+), 50 deletions(-) create mode 100644 extra/terrain/deploy.factor diff --git a/basis/cocoa/messages/messages.factor b/basis/cocoa/messages/messages.factor index 65bb2c02ef..fdd4ba81d7 100644 --- a/basis/cocoa/messages/messages.factor +++ b/basis/cocoa/messages/messages.factor @@ -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 diff --git a/basis/tools/deploy/deploy-docs.factor b/basis/tools/deploy/deploy-docs.factor index 4c03047eb8..71701b6a56 100644 --- a/basis/tools/deploy/deploy-docs.factor +++ b/basis/tools/deploy/deploy-docs.factor @@ -29,6 +29,8 @@ ARTICLE: "tools.deploy.caveats" "Deploy tool caveats" "In deployed applications, the " { $link boa } " word does not verify that the parameters on the stack satisfy the tuple's slot declarations, if any. This reduces deploy image size but can make bugs harder to track down. Make sure your program is fully debugged before deployment." { $heading "Behavior of " { $link POSTPONE: execute( } } "Similarly, the " { $link POSTPONE: execute( } " word does not check word stack effects in deployed applications, since stack effects are stripped out, and so it behaves exactly like " { $link POSTPONE: execute-effect-unsafe } "." +{ $heading "Behavior of " { $link POSTPONE: call-next-method } } +"The " { $link POSTPONE: call-next-method } " word does not check if the input is of the right type in deployed applications." { $heading "Error reporting" } "If the " { $link deploy-reflection } " level in the configuration is low enough, the debugger is stripped out, and error messages can be rather cryptic. Increase the reflection level to get readable error messages." { $heading "Choosing the right deploy flags" } diff --git a/basis/tools/deploy/deploy-tests.factor b/basis/tools/deploy/deploy-tests.factor index 3bebf7236d..1c12e8b781 100644 --- a/basis/tools/deploy/deploy-tests.factor +++ b/basis/tools/deploy/deploy-tests.factor @@ -20,6 +20,10 @@ io.directories tools.deploy.test ; [ t ] [ "tetris" shake-and-bake 1500000 small-enough? ] unit-test +[ t ] [ "spheres" shake-and-bake 1500000 small-enough? ] unit-test + +[ t ] [ "terrain" shake-and-bake 1600000 small-enough? ] unit-test + [ t ] [ "bunny" shake-and-bake 2500000 small-enough? ] unit-test os macosx? [ diff --git a/basis/tools/deploy/shaker/shaker.factor b/basis/tools/deploy/shaker/shaker.factor index 816dbb7979..7bbc726d30 100755 --- a/basis/tools/deploy/shaker/shaker.factor +++ b/basis/tools/deploy/shaker/shaker.factor @@ -1,13 +1,11 @@ ! Copyright (C) 2007, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors io.backend io.streams.c init fry -namespaces make assocs kernel parser lexer strings.parser vocabs -sequences words memory kernel.private -continuations io vocabs.loader system strings sets -vectors quotations byte-arrays sorting compiler.units -definitions generic generic.standard tools.deploy.config ; +USING: arrays accessors io.backend io.streams.c init fry namespaces +make assocs kernel parser lexer strings.parser vocabs sequences words +memory kernel.private continuations io vocabs.loader system strings +sets vectors quotations byte-arrays sorting compiler.units definitions +generic generic.standard tools.deploy.config combinators classes ; QUALIFIED: bootstrap.stage2 -QUALIFIED: classes QUALIFIED: command-line QUALIFIED: compiler.errors QUALIFIED: continuations @@ -193,6 +191,11 @@ IN: tools.deploy.shaker strip-word-names? [ dup strip-word-names ] when 2drop ; +: strip-compiler-classes ( -- ) + "Stripping compiler classes" show + "compiler" child-vocabs [ words ] map concat [ class? ] filter + [ dup implementors [ "methods" word-prop delete-at ] with each ] each ; + : strip-default-methods ( -- ) strip-debugger? [ "Stripping default methods" show @@ -255,14 +258,14 @@ IN: tools.deploy.shaker { gensym name>char-hook - classes:next-method-quot-cache - classes:class-and-cache - classes:class-not-cache - classes:class-or-cache - classes:class<=-cache - classes:classes-intersect-cache - classes:implementors-map - classes:update-map + next-method-quot-cache + class-and-cache + class-not-cache + class-or-cache + class<=-cache + classes-intersect-cache + implementors-map + update-map command-line:main-vocab-hook compiled-crossref compiled-generic-crossref @@ -334,8 +337,16 @@ IN: tools.deploy.shaker [ instances dup H{ } clone [ [ ] cache ] curry map ] dip call become ; inline -: compress-byte-arrays ( -- ) - [ byte-array? ] [ ] "byte arrays" compress ; +: compress-objects ( -- ) + [ + { + [ dup array? [ empty? ] [ drop f ] if ] + [ byte-array? ] + [ string? ] + [ wrapper? ] + } cleave + or or or + ] [ ] "objects" compress ; : remain-compiled ( old new -- old new ) #! Quotations which were formerly compiled must remain @@ -349,12 +360,6 @@ IN: tools.deploy.shaker [ quotation? ] [ remain-compiled ] "quotations" compress [ quotation? ] instances [ f >>cached-effect f >>cache-counter drop ] each ; -: compress-strings ( -- ) - [ string? ] [ ] "strings" compress ; - -: compress-wrappers ( -- ) - [ wrapper? ] [ ] "wrappers" compress ; - SYMBOL: deploy-vocab : [:c] ( -- word ) ":c" "debugger" lookup ; @@ -385,18 +390,23 @@ SYMBOL: deploy-vocab t "quiet" set-global f output-stream set-global ; +: unsafe-next-method-quot ( method -- quot ) + [ "method-class" word-prop ] + [ "method-generic" word-prop ] bi + next-method 1quotation ; + : compute-next-methods ( -- ) [ standard-generic? ] instances [ "methods" word-prop [ - nip - dup next-method-quot "next-method-quot" set-word-prop + nip dup + unsafe-next-method-quot + "next-method-quot" set-word-prop ] assoc-each ] each "vocab:tools/deploy/shaker/next-methods.factor" run-file ; : strip ( -- ) init-stripper - strip-default-methods strip-libc strip-call strip-cocoa @@ -404,14 +414,14 @@ SYMBOL: deploy-vocab compute-next-methods strip-init-hooks strip-c-io + strip-compiler-classes + strip-default-methods f 5 setenv ! we can't use the Factor debugger or Factor I/O anymore deploy-vocab get vocab-main deploy-boot-quot stripped-word-props stripped-globals strip-globals - compress-byte-arrays + compress-objects compress-quotations - compress-strings - compress-wrappers strip-words ; : deploy-error-handler ( quot -- ) diff --git a/basis/tools/deploy/shaker/strip-cocoa.factor b/basis/tools/deploy/shaker/strip-cocoa.factor index df64443b7b..133308b732 100644 --- a/basis/tools/deploy/shaker/strip-cocoa.factor +++ b/basis/tools/deploy/shaker/strip-cocoa.factor @@ -1,8 +1,8 @@ -! Copyright (C) 2007, 2008 Slava Pestov +! Copyright (C) 2007, 2009 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: cocoa cocoa.messages cocoa.application cocoa.nibs assocs namespaces kernel kernel.private words compiler.units sequences -init vocabs ; +init vocabs memoize accessors ; IN: tools.deploy.shaker.cocoa : pool ( obj -- obj' ) \ pool get [ ] cache ; @@ -42,3 +42,8 @@ H{ } clone \ pool [ [ get values compile ] each ] bind ] with-variable + +\ make-prepare-send reset-memoized +\ reset-memoized + +\ (send) def>> second clear-assoc \ No newline at end of file diff --git a/basis/ui/gadgets/worlds/worlds.factor b/basis/ui/gadgets/worlds/worlds.factor index eec5666f0e..2e7b84ef6e 100755 --- a/basis/ui/gadgets/worlds/worlds.factor +++ b/basis/ui/gadgets/worlds/worlds.factor @@ -4,7 +4,7 @@ USING: accessors arrays assocs continuations kernel math models namespaces opengl opengl.textures sequences io combinators combinators.short-circuit fry math.vectors math.rectangles cache ui.gadgets ui.gestures ui.render ui.backend ui.gadgets.tracks -ui.commands ui.pixel-formats destructors literals ; +ui.pixel-formats destructors literals ; IN: ui.gadgets.worlds CONSTANT: default-world-pixel-format-attributes diff --git a/basis/ui/gestures/gestures.factor b/basis/ui/gestures/gestures.factor index 7e038ef2e0..073b2d5e26 100644 --- a/basis/ui/gestures/gestures.factor +++ b/basis/ui/gestures/gestures.factor @@ -3,8 +3,8 @@ USING: accessors arrays assocs kernel math math.order models namespaces make sequences words strings system hashtables math.parser math.vectors classes.tuple classes boxes calendar alarms combinators -sets columns fry deques ui.gadgets ui.gadgets.private unicode.case -unicode.categories combinators.short-circuit ; +sets columns fry deques ui.gadgets ui.gadgets.private ascii +combinators.short-circuit ; IN: ui.gestures GENERIC: handle-gesture ( gesture gadget -- ? ) @@ -296,10 +296,10 @@ HOOK: modifiers>string os ( modifiers -- string ) M: macosx modifiers>string [ { - { A+ [ "\u{place-of-interest-sign}" ] } - { M+ [ "\u{option-key}" ] } - { S+ [ "\u{upwards-white-arrow}" ] } - { C+ [ "\u{up-arrowhead}" ] } + { A+ [ "\u002318" ] } + { M+ [ "\u002325" ] } + { S+ [ "\u0021e7" ] } + { C+ [ "\u002303" ] } } case ] map "" join ; diff --git a/basis/ui/pixel-formats/pixel-formats.factor b/basis/ui/pixel-formats/pixel-formats.factor index 52abf44362..a280ab0666 100644 --- a/basis/ui/pixel-formats/pixel-formats.factor +++ b/basis/ui/pixel-formats/pixel-formats.factor @@ -1,6 +1,6 @@ USING: accessors assocs classes destructors functors kernel lexer math parser sequences specialized-arrays.int ui.backend -words.symbol ; +words ; IN: ui.pixel-formats SYMBOLS: @@ -71,7 +71,7 @@ GENERIC: >PFA ( attribute -- pfas ) M: object >PFA drop { } ; -M: symbol >PFA +M: word >PFA TABLE at [ { } ] unless* ; M: pixel-format-attribute >PFA dup class TABLE at diff --git a/extra/spheres/deploy.factor b/extra/spheres/deploy.factor index d6591a1a26..22c5de0963 100644 --- a/extra/spheres/deploy.factor +++ b/extra/spheres/deploy.factor @@ -1,14 +1,15 @@ USING: tools.deploy.config ; H{ - { deploy-reflection 1 } - { deploy-word-defs? f } - { deploy-word-props? f } - { deploy-name "Spheres" } - { deploy-compiler? t } - { deploy-math? t } - { deploy-io 1 } - { deploy-threads? t } - { "stop-after-last-window?" t } { deploy-ui? t } + { deploy-reflection 1 } + { deploy-unicode? f } + { deploy-math? t } + { deploy-io 2 } { deploy-c-types? f } + { deploy-name "Spheres" } + { deploy-word-props? f } + { deploy-word-defs? f } + { "stop-after-last-window?" t } + { deploy-compiler? t } + { deploy-threads? t } } diff --git a/extra/terrain/deploy.factor b/extra/terrain/deploy.factor new file mode 100644 index 0000000000..e51f8d13e6 --- /dev/null +++ b/extra/terrain/deploy.factor @@ -0,0 +1,15 @@ +USING: tools.deploy.config ; +H{ + { deploy-ui? t } + { deploy-reflection 1 } + { deploy-unicode? f } + { deploy-math? t } + { deploy-io 2 } + { deploy-c-types? f } + { deploy-name "Terrain" } + { deploy-word-props? f } + { deploy-word-defs? f } + { "stop-after-last-window?" t } + { deploy-compiler? t } + { deploy-threads? t } +} From d45d63715b0eb653bc76ca87b99c8de64d482d51 Mon Sep 17 00:00:00 2001 From: Bruno Deferrari Date: Mon, 11 May 2009 00:08:34 -0300 Subject: [PATCH 048/133] extra.redis.assoc: Assoc protocol implementation for Redis --- extra/redis/assoc/assoc.factor | 41 ++++++++++++++++++++++++++++++++++ extra/redis/assoc/authors.txt | 1 + extra/redis/assoc/summary.txt | 1 + 3 files changed, 43 insertions(+) create mode 100644 extra/redis/assoc/assoc.factor create mode 100644 extra/redis/assoc/authors.txt create mode 100644 extra/redis/assoc/summary.txt diff --git a/extra/redis/assoc/assoc.factor b/extra/redis/assoc/assoc.factor new file mode 100644 index 0000000000..2ddf746344 --- /dev/null +++ b/extra/redis/assoc/assoc.factor @@ -0,0 +1,41 @@ +! Copyright (C) 2009 Bruno Deferrari +! See http://factorcode.org/license.txt for BSD license. +USING: accessors assocs io.encodings.8-bit io.sockets +io.streams.duplex kernel redis sequences ; +IN: redis.assoc + +TUPLE: redis-assoc host port encoding password ; + +CONSTANT: default-redis-port 6379 + +: ( -- redis-assoc ) + redis-assoc new + "127.0.0.1" >>host + default-redis-port >>port + latin1 >>encoding ; + +INSTANCE: redis-assoc assoc + +: with-redis-assoc ( redis-assoc quot -- ) + [ + [ host>> ] [ port>> ] [ encoding>> ] tri + [ ] dip drop + ] dip with-stream ; inline + +M: redis-assoc at* [ redis-get dup >boolean ] with-redis-assoc ; + +M: redis-assoc assoc-size [ redis-dbsize ] with-redis-assoc ; + +M: redis-assoc >alist + [ "*" redis-keys dup redis-mget zip ] with-redis-assoc ; + +M: redis-assoc set-at [ redis-set drop ] with-redis-assoc ; + +M: redis-assoc delete-at [ redis-del drop ] with-redis-assoc ; + +M: redis-assoc clear-assoc + [ "*" redis-keys [ redis-del drop ] each ] with-redis-assoc ; + +M: redis-assoc equal? assoc= ; + +M: redis-assoc hashcode* assoc-hashcode ; diff --git a/extra/redis/assoc/authors.txt b/extra/redis/assoc/authors.txt new file mode 100644 index 0000000000..f4a8cb1dc2 --- /dev/null +++ b/extra/redis/assoc/authors.txt @@ -0,0 +1 @@ +Bruno Deferrari diff --git a/extra/redis/assoc/summary.txt b/extra/redis/assoc/summary.txt new file mode 100644 index 0000000000..72a76ab9f0 --- /dev/null +++ b/extra/redis/assoc/summary.txt @@ -0,0 +1 @@ +Assoc protocol implementation for Redis From 462b66a696368d0121ec4e808a8ee3f2b96f9d2e Mon Sep 17 00:00:00 2001 From: Bruno Deferrari Date: Mon, 11 May 2009 00:09:32 -0300 Subject: [PATCH 049/133] extra.redis: Make redis-keys return an array of keys instead of a space separated string of keys --- extra/redis/redis.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/redis/redis.factor b/extra/redis/redis.factor index 1f6d732407..a5e7d74d46 100644 --- a/extra/redis/redis.factor +++ b/extra/redis/redis.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2009 Bruno Deferrari ! See http://factorcode.org/license.txt for BSD license. -USING: io redis.response-parser redis.command-writer ; +USING: io redis.response-parser redis.command-writer splitting ; IN: redis #! Connection @@ -23,7 +23,7 @@ IN: redis : redis-type ( key -- response ) type flush read-response ; #! Key space -: redis-keys ( pattern -- response ) keys flush read-response ; +: redis-keys ( pattern -- response ) keys flush read-response " " split ; : redis-randomkey ( -- response ) randomkey flush read-response ; : redis-rename ( newkey key -- response ) rename flush read-response ; : redis-renamenx ( newkey key -- response ) renamenx flush read-response ; From 7edcc651593967de799df3d711d5f603474e25ec Mon Sep 17 00:00:00 2001 From: Bruno Deferrari Date: Mon, 11 May 2009 00:44:09 -0300 Subject: [PATCH 050/133] extra.redis: Replace 'redis-assoc' with the more general 'redis' type (now in the redis vocab), add support for automatic authentification when calling 'with-redis' --- extra/redis/assoc/assoc.factor | 39 +++++++++------------------------- extra/redis/redis.factor | 25 +++++++++++++++++++++- 2 files changed, 34 insertions(+), 30 deletions(-) diff --git a/extra/redis/assoc/assoc.factor b/extra/redis/assoc/assoc.factor index 2ddf746344..2830e93b25 100644 --- a/extra/redis/assoc/assoc.factor +++ b/extra/redis/assoc/assoc.factor @@ -1,41 +1,22 @@ ! Copyright (C) 2009 Bruno Deferrari ! See http://factorcode.org/license.txt for BSD license. -USING: accessors assocs io.encodings.8-bit io.sockets -io.streams.duplex kernel redis sequences ; +USING: assocs kernel redis sequences ; IN: redis.assoc -TUPLE: redis-assoc host port encoding password ; +INSTANCE: redis assoc -CONSTANT: default-redis-port 6379 +M: redis at* [ redis-get dup >boolean ] with-redis ; -: ( -- redis-assoc ) - redis-assoc new - "127.0.0.1" >>host - default-redis-port >>port - latin1 >>encoding ; +M: redis assoc-size [ redis-dbsize ] with-redis ; -INSTANCE: redis-assoc assoc +M: redis >alist [ "*" redis-keys dup redis-mget zip ] with-redis ; -: with-redis-assoc ( redis-assoc quot -- ) - [ - [ host>> ] [ port>> ] [ encoding>> ] tri - [ ] dip drop - ] dip with-stream ; inline +M: redis set-at [ redis-set drop ] with-redis ; -M: redis-assoc at* [ redis-get dup >boolean ] with-redis-assoc ; +M: redis delete-at [ redis-del drop ] with-redis ; -M: redis-assoc assoc-size [ redis-dbsize ] with-redis-assoc ; +M: redis clear-assoc [ "*" redis-keys [ redis-del drop ] each ] with-redis ; -M: redis-assoc >alist - [ "*" redis-keys dup redis-mget zip ] with-redis-assoc ; +M: redis equal? assoc= ; -M: redis-assoc set-at [ redis-set drop ] with-redis-assoc ; - -M: redis-assoc delete-at [ redis-del drop ] with-redis-assoc ; - -M: redis-assoc clear-assoc - [ "*" redis-keys [ redis-del drop ] each ] with-redis-assoc ; - -M: redis-assoc equal? assoc= ; - -M: redis-assoc hashcode* assoc-hashcode ; +M: redis hashcode* assoc-hashcode ; diff --git a/extra/redis/redis.factor b/extra/redis/redis.factor index a5e7d74d46..466fdc9937 100644 --- a/extra/redis/redis.factor +++ b/extra/redis/redis.factor @@ -1,6 +1,8 @@ ! Copyright (C) 2009 Bruno Deferrari ! See http://factorcode.org/license.txt for BSD license. -USING: io redis.response-parser redis.command-writer splitting ; +USING: accessors io io.encodings.8-bit io.sockets +io.streams.duplex kernel redis.command-writer +redis.response-parser splitting ; IN: redis #! Connection @@ -72,3 +74,24 @@ IN: redis #! Remote server control : redis-info ( -- response ) info flush read-response ; : redis-monitor ( -- response ) monitor flush read-response ; + +#! Redis object +TUPLE: redis host port encoding password ; + +CONSTANT: default-redis-port 6379 + +: ( -- redis ) + redis new + "127.0.0.1" >>host + default-redis-port >>port + latin1 >>encoding ; + +: redis-do-connect ( redis -- stream ) + [ host>> ] [ port>> ] [ encoding>> ] tri + [ ] dip drop ; + +: with-redis ( redis quot -- ) + [ + [ redis-do-connect ] [ password>> ] bi + [ swap [ [ redis-auth drop ] with-stream* ] keep ] when* + ] dip with-stream ; inline From cb76bddd8fb523d90d447d95b2fd9bf82c974c69 Mon Sep 17 00:00:00 2001 From: Bruno Deferrari Date: Mon, 11 May 2009 00:50:22 -0300 Subject: [PATCH 051/133] redis.assoc: Use redis-flushdb in clear-assoc --- extra/redis/assoc/assoc.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/redis/assoc/assoc.factor b/extra/redis/assoc/assoc.factor index 2830e93b25..e8bdbbb935 100644 --- a/extra/redis/assoc/assoc.factor +++ b/extra/redis/assoc/assoc.factor @@ -15,7 +15,7 @@ M: redis set-at [ redis-set drop ] with-redis ; M: redis delete-at [ redis-del drop ] with-redis ; -M: redis clear-assoc [ "*" redis-keys [ redis-del drop ] each ] with-redis ; +M: redis clear-assoc [ redis-flushdb drop ] with-redis ; M: redis equal? assoc= ; From 3fe5bb872b515cf5cc60fa1e6597498096448882 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 11 May 2009 00:32:22 -0500 Subject: [PATCH 052/133] Deploy tool always uses optimizing compiler now --- basis/none/deploy.factor | 1 - basis/tools/deploy/backend/backend.factor | 16 ++++++++-------- basis/tools/deploy/config/config-docs.factor | 6 ------ basis/tools/deploy/config/config.factor | 2 -- basis/tools/deploy/deploy-tests.factor | 3 +-- basis/tools/deploy/shaker/shaker.factor | 19 ++++++++++--------- basis/tools/deploy/test/1/deploy.factor | 1 - basis/tools/deploy/test/10/deploy.factor | 1 - basis/tools/deploy/test/11/deploy.factor | 1 - basis/tools/deploy/test/12/deploy.factor | 1 - basis/tools/deploy/test/13/deploy.factor | 1 - basis/tools/deploy/test/2/deploy.factor | 1 - basis/tools/deploy/test/3/deploy.factor | 1 - basis/tools/deploy/test/4/deploy.factor | 1 - basis/tools/deploy/test/5/deploy.factor | 1 - basis/tools/deploy/test/6/deploy.factor | 1 - basis/tools/deploy/test/7/deploy.factor | 1 - basis/tools/deploy/test/8/8.factor | 11 ----------- basis/tools/deploy/test/8/deploy.factor | 15 --------------- basis/tools/deploy/test/9/deploy.factor | 1 - basis/ui/tools/deploy/deploy.factor | 1 - extra/4DNav/deploy.factor | 1 - extra/benchmark/fib6/deploy.factor | 1 - extra/benchmark/regex-dna/deploy.factor | 1 - extra/bunny/deploy.factor | 1 - extra/chicago-talk/deploy.factor | 1 - extra/color-picker/deploy.factor | 1 - extra/drills/deployed/deploy.factor | 1 - extra/gesture-logger/deploy.factor | 1 - extra/hello-ui/deploy.factor | 18 +++++++++--------- extra/hello-unicode/deploy.factor | 1 - extra/hello-world/deploy.factor | 1 - extra/jamshred/deploy.factor | 1 - extra/joystick-demo/deploy.factor | 1 - extra/maze/deploy.factor | 18 +++++++++--------- extra/merger/deploy.factor | 1 - extra/minneapolis-talk/deploy.factor | 1 - extra/nehe/deploy.factor | 1 - extra/spheres/deploy.factor | 1 - extra/sudoku/deploy.factor | 1 - extra/terrain/deploy.factor | 1 - extra/tetris/deploy.factor | 1 - extra/webkit-demo/deploy.factor | 1 - 43 files changed, 37 insertions(+), 105 deletions(-) delete mode 100644 basis/tools/deploy/test/8/8.factor delete mode 100644 basis/tools/deploy/test/8/deploy.factor diff --git a/basis/none/deploy.factor b/basis/none/deploy.factor index f604beab3f..06cc8c6a20 100644 --- a/basis/none/deploy.factor +++ b/basis/none/deploy.factor @@ -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 } diff --git a/basis/tools/deploy/backend/backend.factor b/basis/tools/deploy/backend/backend.factor index b74548a65f..ba82276927 100755 --- a/basis/tools/deploy/backend/backend.factor +++ b/basis/tools/deploy/backend/backend.factor @@ -43,14 +43,14 @@ CONSTANT: theme-path "basis/ui/gadgets/theme/" [ my-arch make-image ] unless ; : bootstrap-profile ( -- profile ) - { - { "math" deploy-math? } - { "compiler" deploy-compiler? } - { "threads" deploy-threads? } - { "ui" deploy-ui? } - { "unicode" deploy-unicode? } - } [ nip get ] assoc-filter keys - native-io? [ "io" suffix ] when ; + [ + deploy-math? get [ "math" , ] when + deploy-threads? get [ "threads" , ] when + "compiler" , + deploy-ui? get [ "ui" , ] when + deploy-unicode? get [ "unicode" , ] when + native-io? [ "io" , ] when + ] { } make ; : staging-image-name ( profile -- name ) "staging." diff --git a/basis/tools/deploy/config/config-docs.factor b/basis/tools/deploy/config/config-docs.factor index c8249e4e41..bd612c644a 100644 --- a/basis/tools/deploy/config/config-docs.factor +++ b/basis/tools/deploy/config/config-docs.factor @@ -5,7 +5,6 @@ IN: tools.deploy.config ARTICLE: "deploy-flags" "Deployment flags" "There are two sets of deployment flags. The first set controls the major subsystems which are to be included in the deployment image:" { $subsection deploy-math? } -{ $subsection deploy-compiler? } { $subsection deploy-unicode? } { $subsection deploy-threads? } { $subsection deploy-ui? } @@ -53,11 +52,6 @@ HELP: deploy-math? $nl "On by default. Often the programmer will use rationals without realizing it. A small amount of space can be saved by stripping these features out, but some code may require changes to work properly." } ; -HELP: deploy-compiler? -{ $description "Deploy flag. If set, words in the deployed image will be compiled with the optimizing compiler when possible." -$nl -"On by default. Most programs should be compiled, not only for performance but because features which depend on the C library interface only function after compilation." } ; - HELP: deploy-unicode? { $description "Deploy flag. If set, full Unicode " { $link POSTPONE: CHAR: } " syntax is included." $nl diff --git a/basis/tools/deploy/config/config.factor b/basis/tools/deploy/config/config.factor index 63c8393b51..89d1fe3821 100644 --- a/basis/tools/deploy/config/config.factor +++ b/basis/tools/deploy/config/config.factor @@ -7,7 +7,6 @@ IN: tools.deploy.config SYMBOL: deploy-name SYMBOL: deploy-ui? -SYMBOL: deploy-compiler? SYMBOL: deploy-math? SYMBOL: deploy-unicode? SYMBOL: deploy-threads? @@ -55,7 +54,6 @@ SYMBOL: deploy-image { deploy-ui? f } { deploy-io 2 } { deploy-reflection 1 } - { deploy-compiler? t } { deploy-threads? t } { deploy-unicode? f } { deploy-math? t } diff --git a/basis/tools/deploy/deploy-tests.factor b/basis/tools/deploy/deploy-tests.factor index 1c12e8b781..842faba640 100644 --- a/basis/tools/deploy/deploy-tests.factor +++ b/basis/tools/deploy/deploy-tests.factor @@ -11,7 +11,7 @@ io.directories tools.deploy.test ; [ t ] [ "hello-ui" shake-and-bake 1300000 small-enough? ] unit-test -[ "staging.math-compiler-threads-ui-strip.image" ] [ +[ "staging.math-threads-compiler-ui-strip.image" ] [ "hello-ui" deploy-config [ bootstrap-profile staging-image-name file-name ] bind ] unit-test @@ -88,7 +88,6 @@ M: quit-responder call-responder* { "tools.deploy.test.6" "tools.deploy.test.7" - "tools.deploy.test.8" "tools.deploy.test.9" "tools.deploy.test.10" "tools.deploy.test.11" diff --git a/basis/tools/deploy/shaker/shaker.factor b/basis/tools/deploy/shaker/shaker.factor index 7bbc726d30..d79326ddc4 100755 --- a/basis/tools/deploy/shaker/shaker.factor +++ b/basis/tools/deploy/shaker/shaker.factor @@ -337,16 +337,17 @@ IN: tools.deploy.shaker [ instances dup H{ } clone [ [ ] cache ] curry map ] dip call become ; inline +: compress-object? ( obj -- ? ) + { + { [ dup array? ] [ empty? ] } + { [ dup byte-array? ] [ drop t ] } + { [ dup string? ] [ drop t ] } + { [ dup wrapper? ] [ drop t ] } + [ drop f ] + } cond ; + : compress-objects ( -- ) - [ - { - [ dup array? [ empty? ] [ drop f ] if ] - [ byte-array? ] - [ string? ] - [ wrapper? ] - } cleave - or or or - ] [ ] "objects" compress ; + [ compress-object? ] [ ] "objects" compress ; : remain-compiled ( old new -- old new ) #! Quotations which were formerly compiled must remain diff --git a/basis/tools/deploy/test/1/deploy.factor b/basis/tools/deploy/test/1/deploy.factor index 6d6a1c1bd3..509024a5c3 100644 --- a/basis/tools/deploy/test/1/deploy.factor +++ b/basis/tools/deploy/test/1/deploy.factor @@ -8,7 +8,6 @@ H{ { deploy-math? t } { deploy-io 2 } { deploy-name "tools.deploy.test.1" } - { deploy-compiler? t } { deploy-reflection 1 } { "stop-after-last-window?" t } } diff --git a/basis/tools/deploy/test/10/deploy.factor b/basis/tools/deploy/test/10/deploy.factor index 3f5940651d..c42063f644 100644 --- a/basis/tools/deploy/test/10/deploy.factor +++ b/basis/tools/deploy/test/10/deploy.factor @@ -4,7 +4,6 @@ H{ { deploy-unicode? f } { deploy-io 2 } { deploy-word-props? f } - { deploy-compiler? f } { deploy-threads? f } { deploy-word-defs? f } { "stop-after-last-window?" t } diff --git a/basis/tools/deploy/test/11/deploy.factor b/basis/tools/deploy/test/11/deploy.factor index 42f707b332..4828f70d90 100644 --- a/basis/tools/deploy/test/11/deploy.factor +++ b/basis/tools/deploy/test/11/deploy.factor @@ -9,7 +9,6 @@ H{ { deploy-math? f } { deploy-unicode? f } { deploy-threads? f } - { deploy-compiler? f } { deploy-io 2 } { deploy-ui? f } } diff --git a/basis/tools/deploy/test/12/deploy.factor b/basis/tools/deploy/test/12/deploy.factor index 638e1ca000..a3aaa3bca2 100644 --- a/basis/tools/deploy/test/12/deploy.factor +++ b/basis/tools/deploy/test/12/deploy.factor @@ -9,7 +9,6 @@ H{ { deploy-io 2 } { deploy-ui? f } { deploy-name "tools.deploy.test.12" } - { deploy-compiler? f } { deploy-word-defs? f } { deploy-threads? f } } diff --git a/basis/tools/deploy/test/13/deploy.factor b/basis/tools/deploy/test/13/deploy.factor index 9513192311..d175075c14 100644 --- a/basis/tools/deploy/test/13/deploy.factor +++ b/basis/tools/deploy/test/13/deploy.factor @@ -1,7 +1,6 @@ USING: tools.deploy.config ; H{ { deploy-threads? t } - { deploy-compiler? t } { deploy-math? t } { deploy-io 2 } { "stop-after-last-window?" t } diff --git a/basis/tools/deploy/test/2/deploy.factor b/basis/tools/deploy/test/2/deploy.factor index 1457769ce1..10cd7a85d9 100644 --- a/basis/tools/deploy/test/2/deploy.factor +++ b/basis/tools/deploy/test/2/deploy.factor @@ -8,7 +8,6 @@ H{ { deploy-math? t } { deploy-io 2 } { deploy-name "tools.deploy.test.2" } - { deploy-compiler? t } { deploy-reflection 1 } { "stop-after-last-window?" t } } diff --git a/basis/tools/deploy/test/3/deploy.factor b/basis/tools/deploy/test/3/deploy.factor index f3131237bf..b72b00d1e4 100644 --- a/basis/tools/deploy/test/3/deploy.factor +++ b/basis/tools/deploy/test/3/deploy.factor @@ -6,7 +6,6 @@ H{ { "stop-after-last-window?" t } { deploy-word-defs? f } { deploy-reflection 1 } - { deploy-compiler? t } { deploy-threads? t } { deploy-io 3 } { deploy-math? t } diff --git a/basis/tools/deploy/test/4/deploy.factor b/basis/tools/deploy/test/4/deploy.factor index 981bbcf982..b2f22055c4 100644 --- a/basis/tools/deploy/test/4/deploy.factor +++ b/basis/tools/deploy/test/4/deploy.factor @@ -8,7 +8,6 @@ H{ { deploy-math? t } { deploy-io 2 } { deploy-name "tools.deploy.test.4" } - { deploy-compiler? t } { deploy-reflection 1 } { "stop-after-last-window?" t } } diff --git a/basis/tools/deploy/test/5/deploy.factor b/basis/tools/deploy/test/5/deploy.factor index 22f5021497..3f9b7f1599 100644 --- a/basis/tools/deploy/test/5/deploy.factor +++ b/basis/tools/deploy/test/5/deploy.factor @@ -8,7 +8,6 @@ H{ { deploy-math? t } { deploy-io 3 } { deploy-name "tools.deploy.test.5" } - { deploy-compiler? t } { deploy-reflection 1 } { "stop-after-last-window?" t } } diff --git a/basis/tools/deploy/test/6/deploy.factor b/basis/tools/deploy/test/6/deploy.factor index c474fcdadf..b86bfdb31a 100644 --- a/basis/tools/deploy/test/6/deploy.factor +++ b/basis/tools/deploy/test/6/deploy.factor @@ -5,7 +5,6 @@ H{ { deploy-io 1 } { deploy-name "tools.deploy.test.6" } { deploy-math? t } - { deploy-compiler? t } { deploy-ui? f } { deploy-c-types? f } { deploy-word-defs? f } diff --git a/basis/tools/deploy/test/7/deploy.factor b/basis/tools/deploy/test/7/deploy.factor index bc374f1088..d1e93fc7c2 100644 --- a/basis/tools/deploy/test/7/deploy.factor +++ b/basis/tools/deploy/test/7/deploy.factor @@ -6,7 +6,6 @@ H{ { deploy-io 2 } { deploy-math? t } { "stop-after-last-window?" t } - { deploy-compiler? t } { deploy-unicode? f } { deploy-c-types? f } { deploy-reflection 1 } diff --git a/basis/tools/deploy/test/8/8.factor b/basis/tools/deploy/test/8/8.factor deleted file mode 100644 index c495928bf2..0000000000 --- a/basis/tools/deploy/test/8/8.factor +++ /dev/null @@ -1,11 +0,0 @@ -USING: kernel ; -IN: tools.deploy.test.8 - -: literal-merge-test-1 ( -- x ) H{ { "lil" "wayne" } } ; -: literal-merge-test-2 ( -- x ) H{ { "lil" "wayne" } } ; - -: literal-merge-test ( -- ) - literal-merge-test-1 - literal-merge-test-2 eq? t assert= ; - -MAIN: literal-merge-test diff --git a/basis/tools/deploy/test/8/deploy.factor b/basis/tools/deploy/test/8/deploy.factor deleted file mode 100644 index 3bea1edfc7..0000000000 --- a/basis/tools/deploy/test/8/deploy.factor +++ /dev/null @@ -1,15 +0,0 @@ -USING: tools.deploy.config ; -H{ - { deploy-name "tools.deploy.test.8" } - { deploy-c-types? f } - { deploy-word-props? f } - { deploy-ui? f } - { deploy-reflection 1 } - { deploy-compiler? f } - { deploy-unicode? f } - { deploy-io 1 } - { deploy-word-defs? f } - { deploy-threads? f } - { "stop-after-last-window?" t } - { deploy-math? f } -} diff --git a/basis/tools/deploy/test/9/deploy.factor b/basis/tools/deploy/test/9/deploy.factor index 91b1da5697..caddbe36d0 100644 --- a/basis/tools/deploy/test/9/deploy.factor +++ b/basis/tools/deploy/test/9/deploy.factor @@ -6,7 +6,6 @@ H{ { "stop-after-last-window?" t } { deploy-word-defs? f } { deploy-reflection 1 } - { deploy-compiler? t } { deploy-threads? f } { deploy-io 1 } { deploy-math? t } diff --git a/basis/ui/tools/deploy/deploy.factor b/basis/ui/tools/deploy/deploy.factor index 6a8322ac02..d3c1278bf5 100644 --- a/basis/ui/tools/deploy/deploy.factor +++ b/basis/ui/tools/deploy/deploy.factor @@ -29,7 +29,6 @@ TUPLE: deploy-gadget < pack vocab settings ; : advanced-settings ( parent -- parent ) "Advanced:"