From 7acff0c906c22bd529bdde24dc4bd39b6705bfa4 Mon Sep 17 00:00:00 2001 From: Bruno Deferrari Date: Thu, 16 Apr 2009 09:32:17 -0300 Subject: [PATCH 01/32] 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 02/32] 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 03/32] 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 04/32] 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 05/32] 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 06/32] 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 07/32] 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 08/32] 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 09/32] 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 d45d63715b0eb653bc76ca87b99c8de64d482d51 Mon Sep 17 00:00:00 2001 From: Bruno Deferrari Date: Mon, 11 May 2009 00:08:34 -0300 Subject: [PATCH 10/32] 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 11/32] 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 12/32] 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 13/32] 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 2b9631075a4d7bf69ce7dde82c8379f221944c77 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 13 May 2009 14:18:10 -0500 Subject: [PATCH 14/32] Graduation! Move game-input and iokit into basis --- {extra => basis}/game-input/authors.txt | 0 {extra => basis}/game-input/dinput/authors.txt | 0 {extra => basis}/game-input/dinput/dinput.factor | 0 {extra => basis}/game-input/dinput/keys-array/keys-array.factor | 0 {extra => basis}/game-input/dinput/summary.txt | 0 {extra => basis}/game-input/dinput/tags.txt | 0 {extra => basis}/game-input/game-input-docs.factor | 0 {extra => basis}/game-input/game-input-tests.factor | 0 {extra => basis}/game-input/game-input.factor | 0 {extra => basis}/game-input/iokit/authors.txt | 0 {extra => basis}/game-input/iokit/iokit.factor | 0 {extra => basis}/game-input/iokit/summary.txt | 0 {extra => basis}/game-input/iokit/tags.txt | 0 {extra => basis}/game-input/scancodes/authors.txt | 0 {extra => basis}/game-input/scancodes/scancodes.factor | 0 {extra => basis}/game-input/scancodes/summary.txt | 0 {extra => basis}/game-input/scancodes/tags.txt | 0 {extra => basis}/game-input/summary.txt | 0 {extra => basis}/game-input/tags.txt | 0 {extra => basis}/iokit/authors.txt | 0 {extra => basis}/iokit/hid/authors.txt | 0 {extra => basis}/iokit/hid/hid.factor | 0 {extra => basis}/iokit/hid/summary.txt | 0 {extra => basis}/iokit/hid/tags.txt | 0 {extra => basis}/iokit/iokit.factor | 0 {extra => basis}/iokit/summary.txt | 0 {extra => basis}/iokit/tags.txt | 0 27 files changed, 0 insertions(+), 0 deletions(-) rename {extra => basis}/game-input/authors.txt (100%) rename {extra => basis}/game-input/dinput/authors.txt (100%) rename {extra => basis}/game-input/dinput/dinput.factor (100%) rename {extra => basis}/game-input/dinput/keys-array/keys-array.factor (100%) rename {extra => basis}/game-input/dinput/summary.txt (100%) rename {extra => basis}/game-input/dinput/tags.txt (100%) rename {extra => basis}/game-input/game-input-docs.factor (100%) rename {extra => basis}/game-input/game-input-tests.factor (100%) rename {extra => basis}/game-input/game-input.factor (100%) rename {extra => basis}/game-input/iokit/authors.txt (100%) rename {extra => basis}/game-input/iokit/iokit.factor (100%) rename {extra => basis}/game-input/iokit/summary.txt (100%) rename {extra => basis}/game-input/iokit/tags.txt (100%) rename {extra => basis}/game-input/scancodes/authors.txt (100%) rename {extra => basis}/game-input/scancodes/scancodes.factor (100%) rename {extra => basis}/game-input/scancodes/summary.txt (100%) rename {extra => basis}/game-input/scancodes/tags.txt (100%) rename {extra => basis}/game-input/summary.txt (100%) rename {extra => basis}/game-input/tags.txt (100%) rename {extra => basis}/iokit/authors.txt (100%) rename {extra => basis}/iokit/hid/authors.txt (100%) rename {extra => basis}/iokit/hid/hid.factor (100%) rename {extra => basis}/iokit/hid/summary.txt (100%) rename {extra => basis}/iokit/hid/tags.txt (100%) rename {extra => basis}/iokit/iokit.factor (100%) rename {extra => basis}/iokit/summary.txt (100%) rename {extra => basis}/iokit/tags.txt (100%) diff --git a/extra/game-input/authors.txt b/basis/game-input/authors.txt similarity index 100% rename from extra/game-input/authors.txt rename to basis/game-input/authors.txt diff --git a/extra/game-input/dinput/authors.txt b/basis/game-input/dinput/authors.txt similarity index 100% rename from extra/game-input/dinput/authors.txt rename to basis/game-input/dinput/authors.txt diff --git a/extra/game-input/dinput/dinput.factor b/basis/game-input/dinput/dinput.factor similarity index 100% rename from extra/game-input/dinput/dinput.factor rename to basis/game-input/dinput/dinput.factor diff --git a/extra/game-input/dinput/keys-array/keys-array.factor b/basis/game-input/dinput/keys-array/keys-array.factor similarity index 100% rename from extra/game-input/dinput/keys-array/keys-array.factor rename to basis/game-input/dinput/keys-array/keys-array.factor diff --git a/extra/game-input/dinput/summary.txt b/basis/game-input/dinput/summary.txt similarity index 100% rename from extra/game-input/dinput/summary.txt rename to basis/game-input/dinput/summary.txt diff --git a/extra/game-input/dinput/tags.txt b/basis/game-input/dinput/tags.txt similarity index 100% rename from extra/game-input/dinput/tags.txt rename to basis/game-input/dinput/tags.txt diff --git a/extra/game-input/game-input-docs.factor b/basis/game-input/game-input-docs.factor similarity index 100% rename from extra/game-input/game-input-docs.factor rename to basis/game-input/game-input-docs.factor diff --git a/extra/game-input/game-input-tests.factor b/basis/game-input/game-input-tests.factor similarity index 100% rename from extra/game-input/game-input-tests.factor rename to basis/game-input/game-input-tests.factor diff --git a/extra/game-input/game-input.factor b/basis/game-input/game-input.factor similarity index 100% rename from extra/game-input/game-input.factor rename to basis/game-input/game-input.factor diff --git a/extra/game-input/iokit/authors.txt b/basis/game-input/iokit/authors.txt similarity index 100% rename from extra/game-input/iokit/authors.txt rename to basis/game-input/iokit/authors.txt diff --git a/extra/game-input/iokit/iokit.factor b/basis/game-input/iokit/iokit.factor similarity index 100% rename from extra/game-input/iokit/iokit.factor rename to basis/game-input/iokit/iokit.factor diff --git a/extra/game-input/iokit/summary.txt b/basis/game-input/iokit/summary.txt similarity index 100% rename from extra/game-input/iokit/summary.txt rename to basis/game-input/iokit/summary.txt diff --git a/extra/game-input/iokit/tags.txt b/basis/game-input/iokit/tags.txt similarity index 100% rename from extra/game-input/iokit/tags.txt rename to basis/game-input/iokit/tags.txt diff --git a/extra/game-input/scancodes/authors.txt b/basis/game-input/scancodes/authors.txt similarity index 100% rename from extra/game-input/scancodes/authors.txt rename to basis/game-input/scancodes/authors.txt diff --git a/extra/game-input/scancodes/scancodes.factor b/basis/game-input/scancodes/scancodes.factor similarity index 100% rename from extra/game-input/scancodes/scancodes.factor rename to basis/game-input/scancodes/scancodes.factor diff --git a/extra/game-input/scancodes/summary.txt b/basis/game-input/scancodes/summary.txt similarity index 100% rename from extra/game-input/scancodes/summary.txt rename to basis/game-input/scancodes/summary.txt diff --git a/extra/game-input/scancodes/tags.txt b/basis/game-input/scancodes/tags.txt similarity index 100% rename from extra/game-input/scancodes/tags.txt rename to basis/game-input/scancodes/tags.txt diff --git a/extra/game-input/summary.txt b/basis/game-input/summary.txt similarity index 100% rename from extra/game-input/summary.txt rename to basis/game-input/summary.txt diff --git a/extra/game-input/tags.txt b/basis/game-input/tags.txt similarity index 100% rename from extra/game-input/tags.txt rename to basis/game-input/tags.txt diff --git a/extra/iokit/authors.txt b/basis/iokit/authors.txt similarity index 100% rename from extra/iokit/authors.txt rename to basis/iokit/authors.txt diff --git a/extra/iokit/hid/authors.txt b/basis/iokit/hid/authors.txt similarity index 100% rename from extra/iokit/hid/authors.txt rename to basis/iokit/hid/authors.txt diff --git a/extra/iokit/hid/hid.factor b/basis/iokit/hid/hid.factor similarity index 100% rename from extra/iokit/hid/hid.factor rename to basis/iokit/hid/hid.factor diff --git a/extra/iokit/hid/summary.txt b/basis/iokit/hid/summary.txt similarity index 100% rename from extra/iokit/hid/summary.txt rename to basis/iokit/hid/summary.txt diff --git a/extra/iokit/hid/tags.txt b/basis/iokit/hid/tags.txt similarity index 100% rename from extra/iokit/hid/tags.txt rename to basis/iokit/hid/tags.txt diff --git a/extra/iokit/iokit.factor b/basis/iokit/iokit.factor similarity index 100% rename from extra/iokit/iokit.factor rename to basis/iokit/iokit.factor diff --git a/extra/iokit/summary.txt b/basis/iokit/summary.txt similarity index 100% rename from extra/iokit/summary.txt rename to basis/iokit/summary.txt diff --git a/extra/iokit/tags.txt b/basis/iokit/tags.txt similarity index 100% rename from extra/iokit/tags.txt rename to basis/iokit/tags.txt From f43667640a52d4f528752ac864b6af1cc232be0c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 13 May 2009 16:58:01 -0500 Subject: [PATCH 15/32] Fix regression with: bad interaction between predicate classes and tuple inheritance, reported by Bruno Deferrari --- core/classes/predicate/predicate-tests.factor | 19 +++++++++-- core/generic/single/single.factor | 32 ++++++++++++++----- 2 files changed, 40 insertions(+), 11 deletions(-) diff --git a/core/classes/predicate/predicate-tests.factor b/core/classes/predicate/predicate-tests.factor index a947b9ddc0..80613f4f2e 100644 --- a/core/classes/predicate/predicate-tests.factor +++ b/core/classes/predicate/predicate-tests.factor @@ -1,5 +1,6 @@ -USING: math tools.test classes.algebra words kernel sequences assocs ; -IN: classes.predicate +USING: math tools.test classes.algebra words kernel sequences assocs +accessors eval definitions compiler.units generic ; +IN: classes.predicate.tests PREDICATE: negative < integer 0 < ; PREDICATE: positive < integer 0 > ; @@ -18,4 +19,16 @@ M: positive abs ; [ 10 ] [ -10 abs ] unit-test [ 10 ] [ 10 abs ] unit-test -[ 0 ] [ 0 abs ] unit-test \ No newline at end of file +[ 0 ] [ 0 abs ] unit-test + +! Bug report from Bruno Deferrari +TUPLE: tuple-a slot ; +TUPLE: tuple-b < tuple-a ; + +PREDICATE: tuple-c < tuple-b slot>> ; + +GENERIC: ptest ( tuple -- ) +M: tuple-a ptest drop ; +IN: classes.predicate.tests USING: kernel ; M: tuple-c ptest drop ; + +[ ] [ tuple-b new ptest ] unit-test diff --git a/core/generic/single/single.factor b/core/generic/single/single.factor index 8d84b21bf7..747963256d 100644 --- a/core/generic/single/single.factor +++ b/core/generic/single/single.factor @@ -58,13 +58,13 @@ M: single-combination make-default-method ] unless ; ! 1. Flatten methods -TUPLE: predicate-engine methods ; +TUPLE: predicate-engine class methods ; -: ( methods -- engine ) predicate-engine boa ; +C: predicate-engine : push-method ( method specializer atomic assoc -- ) - [ - [ H{ } clone ] unless* + dupd [ + [ ] [ H{ } clone ] ?if [ methods>> set-at ] keep ] change-at ; @@ -182,14 +182,27 @@ M: tuple-dispatch-engine compile-engine [ swap update ] keep ] with-variable ; +PREDICATE: predicate-engine-word < word "owner-generic" word-prop ; + +SYMBOL: predicate-engines + : sort-methods ( assoc -- assoc' ) >alist [ keys sort-classes ] keep extract-keys ; : quote-methods ( assoc -- assoc' ) [ 1quotation \ drop prefix ] assoc-map ; +: find-predicate-engine ( classes -- word ) + predicate-engines get [ at ] curry map-find drop ; + +: next-predicate-engine ( engine -- word ) + class>> superclasses + find-predicate-engine + default get or ; + : methods-with-default ( engine -- assoc ) - methods>> clone default get object bootstrap-word pick set-at ; + [ methods>> clone ] [ next-predicate-engine ] bi + object bootstrap-word pick set-at ; : keep-going? ( assoc -- ? ) assumed get swap second first class<= ; @@ -205,8 +218,6 @@ M: tuple-dispatch-engine compile-engine : class-predicates ( assoc -- assoc ) [ [ "predicate" word-prop [ dup ] prepend ] dip ] assoc-map ; -PREDICATE: predicate-engine-word < word "owner-generic" word-prop ; - : ( -- word ) generic-word get name>> "/predicate-engine" append f dup generic-word get "owner-generic" set-word-prop ; @@ -217,7 +228,7 @@ M: predicate-engine-word stack-effect "owner-generic" word-prop stack-effect ; [ ] dip [ define ] [ drop generic-word get "engines" word-prop push ] [ drop ] 2tri ; -M: predicate-engine compile-engine +: compile-predicate-engine ( engine -- word ) methods-with-default sort-methods quote-methods @@ -225,6 +236,10 @@ M: predicate-engine compile-engine class-predicates [ peek ] [ alist>quot picker prepend define-predicate-engine ] if-empty ; +M: predicate-engine compile-engine + [ compile-predicate-engine ] [ class>> ] bi + [ drop ] [ predicate-engines get set-at ] 2bi ; + M: word compile-engine ; M: f compile-engine ; @@ -251,6 +266,7 @@ HOOK: mega-cache-quot combination ( methods -- quot/f ) M: single-combination perform-combination [ + H{ } clone predicate-engines set dup generic-word set dup build-decision-tree [ "decision-tree" set-word-prop ] From ca6cbbb2f9ef1a849bb8a5e40e52a97862d8e171 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 13 May 2009 17:03:41 -0500 Subject: [PATCH 16/32] tools.annotations: now prints a table of values --- basis/tools/annotations/annotations.factor | 28 +++++++--------------- 1 file changed, 8 insertions(+), 20 deletions(-) diff --git a/basis/tools/annotations/annotations.factor b/basis/tools/annotations/annotations.factor index 2639d48be2..3cb74fb00b 100644 --- a/basis/tools/annotations/annotations.factor +++ b/basis/tools/annotations/annotations.factor @@ -43,29 +43,17 @@ PRIVATE> > length tail* - ] [ - datastack - ] if* ; +: stack-values ( names -- alist ) + [ datastack ] dip [ nip ] [ length tail* ] 2bi zip ; -: entering ( str -- ) - "/-- Entering: " write dup . - word-inputs stack. - "\\--" print flush ; +: trace-message ( word quot str -- ) + "--- " write write bl over . + [ stack-effect ] dip '[ @ stack-values ] [ f ] if* + [ simple-table. ] unless-empty flush ; inline -: word-outputs ( word -- seq ) - stack-effect [ - [ datastack ] dip out>> length tail* - ] [ - datastack - ] if* ; +: entering ( str -- ) [ in>> ] "Entering" trace-message ; -: leaving ( str -- ) - "/-- Leaving: " write dup . - word-outputs stack. - "\\--" print flush ; +: leaving ( str -- ) [ out>> ] "Leaving" trace-message ; : (watch) ( word def -- def ) over '[ _ entering @ _ leaving ] ; From c566708612c63a98abcc78bc34fd415a936b5de7 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 13 May 2009 17:29:14 -0500 Subject: [PATCH 17/32] mason.common: fix git-id word on Windows --- extra/mason/common/common.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/mason/common/common.factor b/extra/mason/common/common.factor index bc1b182734..a33e3c5831 100755 --- a/extra/mason/common/common.factor +++ b/extra/mason/common/common.factor @@ -79,8 +79,8 @@ SYMBOL: stamp with-directory ; : git-id ( -- id ) - { "git" "show" } utf8 [ readln ] with-process-reader - " " split second ; + { "git" "show" } utf8 [ lines ] with-process-reader + first " " split second ; : ?prepare-build-machine ( -- ) builds/factor exists? [ prepare-build-machine ] unless ; From 6af3332c4094fa413494b72eb8424ab123126451 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 13 May 2009 18:19:30 -0500 Subject: [PATCH 18/32] New mason.notify.server tool, and fix failure report --- extra/mason/notify/notify.factor | 6 +- extra/mason/notify/server/authors.txt | 1 + extra/mason/notify/server/server.factor | 82 +++++++++++++++++++++++++ extra/mason/report/report.factor | 2 +- 4 files changed, 88 insertions(+), 3 deletions(-) create mode 100644 extra/mason/notify/server/authors.txt create mode 100644 extra/mason/notify/server/server.factor diff --git a/extra/mason/notify/notify.factor b/extra/mason/notify/notify.factor index 30da0c8286..ccabccdf8b 100644 --- a/extra/mason/notify/notify.factor +++ b/extra/mason/notify/notify.factor @@ -42,8 +42,10 @@ IN: mason.notify : notify-report ( status -- ) [ "Build finished with status: " write . flush ] [ - [ "report" utf8 file-contents ] dip email-report - "report" { "report" } status-notify + [ "report" ] dip + [ [ utf8 file-contents ] dip email-report ] + [ "report" swap name>> 2array status-notify ] + 2bi ] bi ; : notify-release ( archive-name -- ) diff --git a/extra/mason/notify/server/authors.txt b/extra/mason/notify/server/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/extra/mason/notify/server/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/extra/mason/notify/server/server.factor b/extra/mason/notify/server/server.factor new file mode 100644 index 0000000000..57c6d04300 --- /dev/null +++ b/extra/mason/notify/server/server.factor @@ -0,0 +1,82 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors combinators combinators.smart command-line db +db.sqlite db.tuples db.types io kernel namespaces sequences ; +IN: mason.notify.server + +CONSTANT: +starting+ "starting" +CONSTANT: +make-vm+ "make-vm" +CONSTANT: +boot+ "boot" +CONSTANT: +test+ "test" +CONSTANT: +clean+ "clean" +CONSTANT: +dirty+ "dirty" + +TUPLE: builder host-name os cpu clean-git-id last-git-id last-report current-git-id status ; + +builder "BUILDERS" { + { "host-name" "HOST_NAME" TEXT +user-assigned-id+ } + { "os" "OS" TEXT +user-assigned-id+ } + { "cpu" "CPU" TEXT +user-assigned-id+ } + { "clean-git-id" "CLEAN_GIT_ID" TEXT } + { "last-git-id" "LAST_GIT_ID" TEXT } + { "last-report" "LAST_REPORT" TEXT } + { "current-git-id" "CURRENT_GIT_ID" TEXT } + { "status" "STATUS" TEXT } +} define-persistent + +SYMBOLS: host-name target-os target-cpu message message-arg ; + +: parse-args ( command-line -- ) + dup peek message-arg set + [ + { + [ host-name set ] + [ target-os set ] + [ target-cpu set ] + [ message set ] + } spread + ] input>host-name + target-os get >>os + target-cpu get >>cpu + dup select-tuple [ ] [ dup insert-tuple ] ?if ; + +: git-id ( builder id -- ) + >>current-git-id +starting+ >>status drop ; + +: make-vm ( builder -- ) +make-vm+ >>status drop ; + +: boot ( report -- ) +boot+ >>status drop ; + +: test ( report -- ) +test+ >>status drop ; + +: report ( builder status content -- ) + [ >>status ] [ >>last-report ] bi* + dup status>> +clean+ = [ dup current-git-id>> >>clean-git-id ] when + dup current-git-id>> >>last-git-id + drop ; + +: update-builder ( builder -- ) + message get { + { "git-id" [ message-arg get git-id ] } + { "make-vm" [ make-vm ] } + { "boot" [ boot ] } + { "test" [ test ] } + { "report" [ message-arg get contents report ] } + } case ; + +: mason-db ( -- db ) "resource:mason.db" ; + +: handle-update ( command-line -- ) + mason-db [ + parse-args find-builder + [ update-builder ] [ update-tuple ] bi + ] with-db ; + +: main ( -- ) + command-line get handle-update ; + +MAIN: main diff --git a/extra/mason/report/report.factor b/extra/mason/report/report.factor index 6e48e7cf04..1b5aaf39ec 100644 --- a/extra/mason/report/report.factor +++ b/extra/mason/report/report.factor @@ -34,7 +34,7 @@ IN: mason.report :: failed-report ( error file what -- status ) [ error [ error. ] with-string-writer :> error - file utf8 file-contents 400 short tail* :> output + file utf8 file-lines 400 short tail* :> output [XML

<-what->

From cce7b36ea3d3dccd305c24015160852f5d3bc73f Mon Sep 17 00:00:00 2001 From: "U-C4\\Administrator" Date: Wed, 13 May 2009 19:21:27 -0500 Subject: [PATCH 19/32] terrain demo allows looking around with keyboard now. used ${ in a few places --- extra/terrain/terrain.factor | 28 ++++++++++++++++++++-------- 1 file changed, 20 insertions(+), 8 deletions(-) diff --git a/extra/terrain/terrain.factor b/extra/terrain/terrain.factor index 411d34f44c..d5ae2df48a 100644 --- a/extra/terrain/terrain.factor +++ b/extra/terrain/terrain.factor @@ -100,10 +100,13 @@ M: terrain-world tick-length : forward-vector ( player -- v ) yaw>> 0.0 - { 0.0 0.0 $ MOVEMENT-SPEED } vneg eye-rotate ; + ${ 0.0 0.0 MOVEMENT-SPEED } vneg eye-rotate ; : rightward-vector ( player -- v ) yaw>> 0.0 - { $ MOVEMENT-SPEED 0.0 0.0 } eye-rotate ; + ${ MOVEMENT-SPEED 0.0 0.0 } eye-rotate ; +: clamp-pitch ( pitch -- pitch' ) + 90.0 min -90.0 max ; + : walk-forward ( player -- ) dup forward-vector [ v+ ] curry change-velocity drop ; @@ -114,15 +117,20 @@ M: terrain-world tick-length : walk-rightward ( player -- ) dup rightward-vector [ v+ ] curry change-velocity drop ; : jump ( player -- ) - [ { 0.0 $ JUMP 0.0 } v+ ] change-velocity drop ; + [ ${ 0.0 JUMP 0.0 } v+ ] change-velocity drop ; +: rotate-leftward ( player x -- ) + [ - ] curry change-yaw drop ; +: rotate-rightward ( player x -- ) + [ + ] curry change-yaw drop ; +: look-horizontally ( player x -- ) + [ + ] curry change-yaw drop ; +: look-vertically ( player x -- ) + [ - clamp-pitch ] curry change-pitch drop ; -: clamp-pitch ( pitch -- pitch' ) - 90.0 min -90.0 max ; : rotate-with-mouse ( player mouse -- ) - [ dx>> MOUSE-SCALE * [ + ] curry change-yaw ] - [ dy>> MOUSE-SCALE * [ + clamp-pitch ] curry change-pitch ] bi - drop ; + [ dx>> MOUSE-SCALE * look-horizontally ] + [ dy>> MOUSE-SCALE * look-vertically ] 2bi ; :: handle-input ( world -- ) world player>> :> player @@ -131,6 +139,10 @@ M: terrain-world tick-length key-s keys nth [ player walk-backward ] when key-a keys nth [ player walk-leftward ] when key-d keys nth [ player walk-rightward ] when + key-left-arrow keys nth [ player -1 look-horizontally ] when + key-right-arrow keys nth [ player 1 look-horizontally ] when + key-down-arrow keys nth [ player -1 look-vertically ] when + key-up-arrow keys nth [ player 1 look-vertically ] when key-space keys nth [ player jump ] when key-escape keys nth [ world close-window ] when player read-mouse rotate-with-mouse From d810905d859b98ae402d89b5d9bc173fb0647083 Mon Sep 17 00:00:00 2001 From: "U-C4\\Administrator" Date: Wed, 13 May 2009 19:26:08 -0500 Subject: [PATCH 20/32] unbassackwardsify the mouse, q and e rotate too --- extra/terrain/terrain.factor | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/extra/terrain/terrain.factor b/extra/terrain/terrain.factor index d5ae2df48a..e459f19e40 100644 --- a/extra/terrain/terrain.factor +++ b/extra/terrain/terrain.factor @@ -125,7 +125,7 @@ M: terrain-world tick-length : look-horizontally ( player x -- ) [ + ] curry change-yaw drop ; : look-vertically ( player x -- ) - [ - clamp-pitch ] curry change-pitch drop ; + [ + clamp-pitch ] curry change-pitch drop ; : rotate-with-mouse ( player mouse -- ) @@ -139,10 +139,12 @@ M: terrain-world tick-length key-s keys nth [ player walk-backward ] when key-a keys nth [ player walk-leftward ] when key-d keys nth [ player walk-rightward ] when + key-q keys nth [ player -1 look-horizontally ] when + key-e keys nth [ player 1 look-horizontally ] when key-left-arrow keys nth [ player -1 look-horizontally ] when key-right-arrow keys nth [ player 1 look-horizontally ] when - key-down-arrow keys nth [ player -1 look-vertically ] when - key-up-arrow keys nth [ player 1 look-vertically ] when + key-down-arrow keys nth [ player 1 look-vertically ] when + key-up-arrow keys nth [ player -1 look-vertically ] when key-space keys nth [ player jump ] when key-escape keys nth [ world close-window ] when player read-mouse rotate-with-mouse From 0483a5044a26ae48224116e1502c06deb30ed39c Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Wed, 13 May 2009 19:31:58 -0500 Subject: [PATCH 21/32] rotate-circular word --- basis/circular/circular-docs.factor | 6 ++++++ basis/circular/circular-tests.factor | 1 + basis/circular/circular.factor | 3 +++ 3 files changed, 10 insertions(+) diff --git a/basis/circular/circular-docs.factor b/basis/circular/circular-docs.factor index c7af57c1fe..235d5db2c7 100644 --- a/basis/circular/circular-docs.factor +++ b/basis/circular/circular-docs.factor @@ -43,6 +43,11 @@ HELP: push-growing-circular { "elt" object } { "circular" circular } } { $description "Pushes an element onto a " { $link growing-circular } " object." } ; +HELP: rotate-circular +{ $values + { "circular" circular } } +{ $description "Advances the start index of a circular object by one." } ; + ARTICLE: "circular" "Circular sequences" "The " { $vocab-link "circular" } " vocabulary implements the " { $link "sequence-protocol" } " to allow an arbitrary start index and wrap-around indexing." $nl "Creating a new circular object:" @@ -51,6 +56,7 @@ ARTICLE: "circular" "Circular sequences" { $subsection } "Changing the start index:" { $subsection change-circular-start } +{ $subsection rotate-circular } "Pushing new elements:" { $subsection push-circular } { $subsection push-growing-circular } ; diff --git a/basis/circular/circular-tests.factor b/basis/circular/circular-tests.factor index 105e3790aa..3a94e14640 100644 --- a/basis/circular/circular-tests.factor +++ b/basis/circular/circular-tests.factor @@ -12,6 +12,7 @@ circular strings ; [ CHAR: e ] [ "test" 5 swap nth-unsafe ] unit-test [ [ 1 2 3 ] ] [ { 1 2 3 } [ ] like ] unit-test +[ [ 2 3 1 ] ] [ { 1 2 3 } [ rotate-circular ] keep [ ] like ] unit-test [ [ 2 3 1 ] ] [ { 1 2 3 } 1 over change-circular-start [ ] like ] unit-test [ [ 3 1 2 ] ] [ { 1 2 3 } 1 over change-circular-start 1 over change-circular-start [ ] like ] unit-test [ [ 3 1 2 ] ] [ { 1 2 3 } -100 over change-circular-start [ ] like ] unit-test diff --git a/basis/circular/circular.factor b/basis/circular/circular.factor index 9f3a71f2a8..909b2ed713 100644 --- a/basis/circular/circular.factor +++ b/basis/circular/circular.factor @@ -27,6 +27,9 @@ M: circular virtual-seq seq>> ; #! change start to (start + n) mod length circular-wrap (>>start) ; +: rotate-circular ( circular -- ) + [ start>> 1 + ] keep circular-wrap (>>start) ; + : push-circular ( elt circular -- ) [ set-first ] [ 1 swap change-circular-start ] bi ; From d50121346d11e820c405eae382df673380638833 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 13 May 2009 19:33:57 -0500 Subject: [PATCH 22/32] mason.notify.server: parameters were wrong way around --- extra/mason/notify/server/server.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/mason/notify/server/server.factor b/extra/mason/notify/server/server.factor index 57c6d04300..cc055e38d8 100644 --- a/extra/mason/notify/server/server.factor +++ b/extra/mason/notify/server/server.factor @@ -31,8 +31,8 @@ SYMBOLS: host-name target-os target-cpu message message-arg ; [ { [ host-name set ] - [ target-os set ] [ target-cpu set ] + [ target-os set ] [ message set ] } spread ] input Date: Wed, 13 May 2009 19:35:46 -0500 Subject: [PATCH 23/32] in game-worlds, open game-input before starting game-loop and close after. otherwise there's a chance the game-loop might tick without game-input available --- extra/game-worlds/game-worlds.factor | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/extra/game-worlds/game-worlds.factor b/extra/game-worlds/game-worlds.factor index c9ea03e333..2fb115b5d0 100644 --- a/extra/game-worlds/game-worlds.factor +++ b/extra/game-worlds/game-worlds.factor @@ -12,12 +12,12 @@ M: game-world draw* swap >>tick-slice draw-world ; M: game-world begin-world + open-game-input dup [ tick-length ] [ ] bi [ >>game-loop ] keep start-loop - drop - open-game-input ; - -M: game-world end-world - close-game-input - [ [ stop-loop ] when* f ] change-game-loop + drop ; + +M: game-world end-world + [ [ stop-loop ] when* f ] change-game-loop + close-game-input drop ; From 96e8006eb323f0e252031d640b138b66caa86a7b Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Wed, 13 May 2009 19:36:06 -0500 Subject: [PATCH 24/32] redundant math is redundant --- extra/terrain/shaders/shaders.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/terrain/shaders/shaders.factor b/extra/terrain/shaders/shaders.factor index e5b517ad59..108856e1dd 100644 --- a/extra/terrain/shaders/shaders.factor +++ b/extra/terrain/shaders/shaders.factor @@ -8,10 +8,10 @@ varying vec3 direction; void main() { - vec4 v = vec4(gl_Vertex.xy, 1.0, 1.0); + vec4 v = vec4(gl_Vertex.xy, -1.0, 1.0); gl_Position = v; - vec4 p = (gl_ProjectionMatrixInverse * v) * vec4(1,1,-1,1); + vec4 p = gl_ProjectionMatrixInverse * v; float s = sin(sky_theta), c = cos(sky_theta); direction = mat3(1, 0, 0, 0, c, s, 0, -s, c) From cd519b1fea84c57cbbfffaa80753df8b564553c9 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 13 May 2009 19:39:26 -0500 Subject: [PATCH 25/32] webapps.mason: preliminary checkin --- extra/webapps/mason/authors.txt | 1 + extra/webapps/mason/mason.factor | 74 ++++++++++++++++++++++++++++++++ 2 files changed, 75 insertions(+) create mode 100644 extra/webapps/mason/authors.txt create mode 100644 extra/webapps/mason/mason.factor diff --git a/extra/webapps/mason/authors.txt b/extra/webapps/mason/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/extra/webapps/mason/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/extra/webapps/mason/mason.factor b/extra/webapps/mason/mason.factor new file mode 100644 index 0000000000..63b042077e --- /dev/null +++ b/extra/webapps/mason/mason.factor @@ -0,0 +1,74 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays combinators db db.tuples furnace.actions +http.server.responses kernel mason.platform mason.notify.server +math.order sequences sorting splitting xml.syntax xml.writer ; +IN: webapps.mason + +: git-link ( id -- link ) + [ "http://github.com/slavapestov/factor/commit/" prepend ] keep + [XML ><-> XML] ; + +: building ( builder string -- xml ) + swap current-git-id>> git-link + [XML <-> for <-> XML] ; + +: current-status ( builder -- xml ) + dup status>> { + { "dirty" [ drop "Dirty" ] } + { "clean" [ drop "Clean" ] } + { "starting" [ "Starting" building ] } + { "make-vm" [ "Compiling VM" building ] } + { "boot" [ "Bootstrapping" building ] } + { "test" [ "Testing" building ] } + [ 2drop "Unknown" ] + } case ; + +: binaries-link ( builder -- link ) + [ os>> ] [ cpu>> ] bi (platform) "http://downloads.factorcode.org/" prepend + dup [XML ><-> XML] ; + +: clean-image-link ( builder -- link ) + [ os>> ] [ cpu>> ] bi (platform) "http://factorcode.org/images/clean/" prepend + dup [XML ><-> XML] ; + +: machine-table ( builder -- xml ) + { + [ os>> ] + [ cpu>> ] + [ host-name>> "." split1 drop ] + [ current-status ] + [ last-git-id>> dup [ git-link ] when ] + [ clean-git-id>> dup [ git-link ] when ] + [ binaries-link ] + [ clean-image-link ] + } cleave + [XML +

<-> / <->

+ + + + + + + +
Host name:<->
Current status:<->
Last build:<->
Last clean build:<->
Binaries:<->
Clean images:<->
+ XML] ; + +: machine-report ( builders -- xml ) + [ machine-table ] map + [XML +

Build farm status

+ <-> + XML] ; + +: ( -- action ) + + [ + mason-db [ + builder new select-tuples + [ [ [ os>> ] [ cpu>> ] bi 2array ] compare ] sort + machine-report xml>string + ] with-db + "text/html" + ] >>display ; \ No newline at end of file From cc96b3bd7e20881169c3e4547e59c28126a4643f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 13 May 2009 19:47:00 -0500 Subject: [PATCH 26/32] Update mason.platform for webapps.mason --- extra/mason/platform/platform.factor | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/extra/mason/platform/platform.factor b/extra/mason/platform/platform.factor index 59c525f5ea..d6be8654c5 100644 --- a/extra/mason/platform/platform.factor +++ b/extra/mason/platform/platform.factor @@ -1,11 +1,14 @@ ! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel system accessors namespaces splitting sequences -mason.config bootstrap.image ; +mason.config bootstrap.image assocs ; IN: mason.platform +: (platform) ( os cpu -- string ) + { { CHAR: . CHAR: - } } substitute "-" glue ; + : platform ( -- string ) - target-os get "-" target-cpu get "." split "-" join 3append ; + target-os get target-cpu get (platform) ; : gnu-make ( -- string ) target-os get { "freebsd" "openbsd" "netbsd" } member? "gmake" "make" ? ; From 9f39a759284528fdf6122a48c0cb839ede8b5409 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 13 May 2009 19:53:52 -0500 Subject: [PATCH 27/32] webapps.mason: work on it some more --- extra/webapps/mason/mason.factor | 30 ++++++++++++++++++++---------- 1 file changed, 20 insertions(+), 10 deletions(-) diff --git a/extra/webapps/mason/mason.factor b/extra/webapps/mason/mason.factor index 63b042077e..6cb24a5f9a 100644 --- a/extra/webapps/mason/mason.factor +++ b/extra/webapps/mason/mason.factor @@ -2,9 +2,15 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays combinators db db.tuples furnace.actions http.server.responses kernel mason.platform mason.notify.server -math.order sequences sorting splitting xml.syntax xml.writer ; +math.order sequences sorting splitting xml.syntax xml.writer +io.pathnames io.encodings.utf8 io.files ; IN: webapps.mason +: log-file ( -- path ) home "mason.log" append-path ; + +: recent-events ( -- xml ) + log-file utf8 file-lines 10 short tail* "\n" join [XML 
<->
XML] ; + : git-link ( id -- link ) [ "http://github.com/slavapestov/factor/commit/" prepend ] keep [XML ><-> XML] ; @@ -55,20 +61,24 @@ IN: webapps.mason XML] ; -: machine-report ( builders -- xml ) - [ machine-table ] map +: machine-report ( -- xml ) + builder new select-tuples + [ [ [ os>> ] [ cpu>> ] bi 2array ] compare ] sort + [ machine-table ] map ; + +: build-farm-report ( -- xml ) + recent-events + machine-report [XML -

Build farm status

- <-> + + Factor build farm +

Recent events

<->

Machine status

<-> + XML] ; : ( -- action ) [ - mason-db [ - builder new select-tuples - [ [ [ os>> ] [ cpu>> ] bi 2array ] compare ] sort - machine-report xml>string - ] with-db + mason-db [ build-farm-report xml>string ] with-db "text/html" ] >>display ; \ No newline at end of file From 5bae938c7e43f266e7086f92dc0a5e69ff48b4c2 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 13 May 2009 19:55:33 -0500 Subject: [PATCH 28/32] Rename a word --- extra/webapps/mason/mason.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/webapps/mason/mason.factor b/extra/webapps/mason/mason.factor index 6cb24a5f9a..ea7040ac6e 100644 --- a/extra/webapps/mason/mason.factor +++ b/extra/webapps/mason/mason.factor @@ -76,7 +76,7 @@ IN: webapps.mason XML] ; -: ( -- action ) +: ( -- action ) [ mason-db [ build-farm-report xml>string ] with-db From 31e3fe5a2f4bba28d243d0664dd48823bec660ba Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 13 May 2009 20:05:22 -0500 Subject: [PATCH 29/32] rename set-fullscreen? to set-fullscreen, add a toggle-fullscreen word, fix windows backend for fullscreen* --- basis/ui/backend/windows/windows.factor | 5 +++++ basis/ui/ui-docs.factor | 4 ++-- basis/ui/ui.factor | 5 ++++- 3 files changed, 11 insertions(+), 3 deletions(-) diff --git a/basis/ui/backend/windows/windows.factor b/basis/ui/backend/windows/windows.factor index afed121fb6..3fc9e66769 100755 --- a/basis/ui/backend/windows/windows.factor +++ b/basis/ui/backend/windows/windows.factor @@ -761,6 +761,11 @@ M: windows-ui-backend (ungrab-input) ( handle -- ) M: windows-ui-backend set-fullscreen* ( ? world -- ) swap [ enter-fullscreen ] [ exit-fullscreen ] if ; +M: windows-ui-backend fullscreen* ( world -- ? ) + [ handle>> hWnd>> hwnd>RECT ] + [ handle>> hWnd>> fullscreen-RECT ] bi + [ get-RECT-dimensions 2array 2nip ] bi@ = ; + windows-ui-backend ui-backend set-global [ "ui.tools" ] main-vocab-hook set-global diff --git a/basis/ui/ui-docs.factor b/basis/ui/ui-docs.factor index e206c7d408..a4bcb8bcdf 100644 --- a/basis/ui/ui-docs.factor +++ b/basis/ui/ui-docs.factor @@ -25,7 +25,7 @@ HELP: world-attributes { { $snippet "pixel-format-attributes" } " is a sequence of " { $link "ui.pixel-formats-attributes" } " that the window will request for its OpenGL pixel format." } } ; -HELP: set-fullscreen? +HELP: set-fullscreen { $values { "?" "a boolean" } { "gadget" gadget } } { $description "Sets and unsets fullscreen mode for the gadget's world." } ; @@ -33,7 +33,7 @@ HELP: fullscreen? { $values { "gadget" gadget } { "?" "a boolean" } } { $description "Queries the gadget's world to see if it is running in fullscreen mode." } ; -{ fullscreen? set-fullscreen? } related-words +{ fullscreen? set-fullscreen } related-words HELP: find-window { $values { "quot" { $quotation "( world -- ? )" } } { "world" { $maybe world } } } diff --git a/basis/ui/ui.factor b/basis/ui/ui.factor index 0a6f26fd5b..e4cf725add 100644 --- a/basis/ui/ui.factor +++ b/basis/ui/ui.factor @@ -209,12 +209,15 @@ PRIVATE> : open-window ( gadget title/attributes -- ) ?attributes open-world-window ; -: set-fullscreen? ( ? gadget -- ) +: set-fullscreen ( ? gadget -- ) find-world set-fullscreen* ; : fullscreen? ( gadget -- ? ) find-world fullscreen* ; +: toggle-fullscreen ( gadget -- ) + [ fullscreen? not ] keep set-fullscreen ; + : raise-window ( gadget -- ) find-world raise-window* ; From f2310df32356af4137fd6346ab2423a94d7600d5 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 13 May 2009 20:06:13 -0500 Subject: [PATCH 30/32] add a velocity-modifier to terrain demo for left shift. alt-enter toggles fullscreen mode --- extra/terrain/terrain.factor | 27 +++++++++++++++++++++------ 1 file changed, 21 insertions(+), 6 deletions(-) diff --git a/extra/terrain/terrain.factor b/extra/terrain/terrain.factor index e459f19e40..d6905144bb 100644 --- a/extra/terrain/terrain.factor +++ b/extra/terrain/terrain.factor @@ -6,7 +6,7 @@ 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 -math.affine-transforms noise ; +math.affine-transforms noise ui.gestures ; IN: terrain CONSTANT: FOV $[ 2.0 sqrt 1+ ] @@ -18,7 +18,7 @@ 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: FRICTION { 0.95 0.99 0.95 } CONSTANT: COMPONENT-SCALE { 0.5 0.01 0.0005 0.0 } CONSTANT: SKY-PERIOD 1200 CONSTANT: SKY-SPEED 0.0005 @@ -28,7 +28,7 @@ CONSTANT: terrain-vertex-distance { $[ 1.0 512.0 / ] $[ 1.0 512.0 / ] } CONSTANT: terrain-vertex-row-length $[ 512 1 + 2 * ] TUPLE: player - location yaw pitch velocity ; + location yaw pitch velocity velocity-modifier ; TUPLE: terrain-world < game-world player @@ -132,9 +132,21 @@ M: terrain-world tick-length [ dx>> MOUSE-SCALE * look-horizontally ] [ dy>> MOUSE-SCALE * look-vertically ] 2bi ; + +terrain-world H{ + { T{ key-up { mods { A+ } } { sym "RET" } } [ toggle-fullscreen ] } +} set-gestures + :: handle-input ( world -- ) world player>> :> player read-keyboard keys>> :> keys + key-left-shift keys nth [ + { 2.0 1.0 2.0 } player (>>velocity-modifier) + ] when + key-left-shift keys nth [ + { 1.0 1.0 1.0 } player (>>velocity-modifier) + ] unless + key-w keys nth [ player walk-forward ] when key-s keys nth [ player walk-backward ] when key-a keys nth [ player walk-leftward ] when @@ -151,7 +163,7 @@ M: terrain-world tick-length reset-mouse ; : apply-friction ( velocity -- velocity' ) - FRICTION v*n ; + FRICTION v* ; : apply-gravity ( velocity -- velocity' ) 1 over [ GRAVITY - ] change-nth ; @@ -184,9 +196,12 @@ M: terrain-world tick-length [ [ 1 ] 2dip [ max ] with change-nth ] [ ] tri ; +: scaled-velocity ( player -- velocity ) + [ velocity>> ] [ velocity-modifier>> ] bi v* ; + : tick-player ( world player -- ) [ apply-friction apply-gravity ] change-velocity - dup velocity>> [ v+ [ terrain-segment>> ] dip collide ] curry with change-location + dup scaled-velocity [ v+ [ terrain-segment>> ] dip collide ] curry with change-location drop ; M: terrain-world tick* @@ -211,7 +226,7 @@ BEFORE: terrain-world begin-world GL_DEPTH_TEST glEnable GL_TEXTURE_2D glEnable GL_VERTEX_ARRAY glEnableClientState - PLAYER-START-LOCATION 0.0 0.0 { 0.0 0.0 0.0 } player boa >>player + PLAYER-START-LOCATION 0.0 0.0 { 0.0 0.0 0.0 } { 1.0 1.0 1.0 } player boa >>player 0.01 0.01 { 512 512 } perlin-noise-image [ >>sky-image ] keep make-texture [ set-texture-parameters ] keep >>sky-texture From 0378c612c64130540a260e685890dd36799c9134 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 13 May 2009 20:15:58 -0500 Subject: [PATCH 31/32] fix the sky --- extra/terrain/shaders/shaders.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/terrain/shaders/shaders.factor b/extra/terrain/shaders/shaders.factor index 108856e1dd..630163c724 100644 --- a/extra/terrain/shaders/shaders.factor +++ b/extra/terrain/shaders/shaders.factor @@ -8,7 +8,7 @@ varying vec3 direction; void main() { - vec4 v = vec4(gl_Vertex.xy, -1.0, 1.0); + vec4 v = vec4(gl_Vertex.xy, 1.0, 1.0); gl_Position = v; vec4 p = gl_ProjectionMatrixInverse * v; From 2da256063f736028a9c95476226296dc339ea203 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Wed, 13 May 2009 21:28:12 -0500 Subject: [PATCH 32/32] MacOS X glFrustum generates -0.0 in W column of projection matrix; Windows glFrustum generates 0.0. This causes sign differences in the gl_ProjectionMatrixInverse between platforms. manually force the z coordinate sign in terrain sky projection to be negative like it ought to be --- extra/terrain/shaders/shaders.factor | 1 + 1 file changed, 1 insertion(+) diff --git a/extra/terrain/shaders/shaders.factor b/extra/terrain/shaders/shaders.factor index 630163c724..9233ab3f36 100644 --- a/extra/terrain/shaders/shaders.factor +++ b/extra/terrain/shaders/shaders.factor @@ -12,6 +12,7 @@ void main() gl_Position = v; vec4 p = gl_ProjectionMatrixInverse * v; + p.z = -abs(p.z); float s = sin(sky_theta), c = cos(sky_theta); direction = mat3(1, 0, 0, 0, c, s, 0, -s, c)