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 <growing-circular> }
"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" <circular> 5 swap nth-unsafe ] unit-test
[ [ 1 2 3 ] ] [ { 1 2 3 } <circular> [ ] like ] unit-test
+[ [ 2 3 1 ] ] [ { 1 2 3 } <circular> [ rotate-circular ] keep [ ] like ] unit-test
[ [ 2 3 1 ] ] [ { 1 2 3 } <circular> 1 over change-circular-start [ ] like ] unit-test
[ [ 3 1 2 ] ] [ { 1 2 3 } <circular> 1 over change-circular-start 1 over change-circular-start [ ] like ] unit-test
[ [ 3 1 2 ] ] [ { 1 2 3 } <circular> -100 over change-circular-start [ ] like ] unit-test
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 ;
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
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>
<PRIVATE
-: word-inputs ( word -- seq )
- stack-effect [
- [ datastack ] dip in>> 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 ] ;
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 <world> 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* ;
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 ;
-: <predicate-engine> ( methods -- engine ) predicate-engine boa ;
+C: <predicate-engine> predicate-engine
: push-method ( method specializer atomic assoc -- )
- [
- [ H{ } clone <predicate-engine> ] unless*
+ dupd [
+ [ ] [ H{ } clone <predicate-engine> ] ?if
[ methods>> set-at ] keep
] change-at ;
@@ -182,14 +182,27 @@ M: tuple-dispatch-engine compile-engine
[ <enum> 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 ;
-
: <predicate-engine-word> ( -- word )
generic-word get name>> "/predicate-engine" append f <word>
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 ;
[ <predicate-engine-word> ] 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 ]
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> [ >>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 ;
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/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> 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 ;
: <irc-client> ( profile -- irc-client )
@@ -43,8 +44,9 @@ TUPLE: irc-client profile stream in-messages out-messages
<mailbox> >>in-messages
<mailbox> >>out-messages
H{ } clone >>chats
- 15 seconds >>reconnect-time
+ 30 seconds >>reconnect-time
+ 10 >>reconnect-attempts
V{ } clone >>exceptions
- [ <inet> latin1 <client> ] >>connect ;
+ [ <inet> latin1 <client> drop ] >>connect ;
SINGLETONS: irc-chat-end irc-end irc-disconnected irc-connected ;
diff --git a/extra/irc/client/internals/internals-tests.factor b/extra/irc/client/internals/internals-tests.factor
index 27b5648f97..2c26188e04 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 <irc-profile> <irc-client>
- [ 2drop <test-stream> t ] >>connect
+ [ 2drop <test-stream> ] >>connect
[
(connect-irc)
(do-login)
diff --git a/extra/irc/client/internals/internals.factor b/extra/irc/client/internals/internals.factor
index 5bae054e18..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 ;
@@ -52,7 +68,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 ;
@@ -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 ;
diff --git a/extra/irc/logbot/log-line/log-line.factor b/extra/irc/logbot/log-line/log-line.factor
index b3af41ad3d..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 ;
@@ -35,3 +41,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 ;
diff --git a/extra/irc/logbot/logbot.factor b/extra/irc/logbot/logbot.factor
index a389304b14..ff8085a9a9 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 <irc-profile> ;
: 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 ;
@@ -27,7 +27,7 @@ SYMBOL: current-stream
] [
current-stream get [ dispose ] when*
[ day-of-year current-day set ]
- [ timestamp-path latin1 <file-writer> ] bi
+ [ timestamp-path latin1 <file-appender> ] bi
current-stream set
] if current-stream get ;
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/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 ;
diff --git a/extra/irc/messages/parser/parser.factor b/extra/irc/messages/parser/parser.factor
index 1fa07fc772..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
- now >>timestamp dup sender >>sender ;
+ dup sender >>sender ;
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 ;
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..cc055e38d8
--- /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-cpu set ]
+ [ target-os set ]
+ [ message set ]
+ } spread
+ ] input<sequence ;
+
+: find-builder ( -- builder )
+ builder new
+ host-name get >>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" <sqlite-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/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" ? ;
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
<h2><-what-></h2>
diff --git a/extra/redis/assoc/assoc.factor b/extra/redis/assoc/assoc.factor
new file mode 100644
index 0000000000..e8bdbbb935
--- /dev/null
+++ b/extra/redis/assoc/assoc.factor
@@ -0,0 +1,22 @@
+! Copyright (C) 2009 Bruno Deferrari
+! See http://factorcode.org/license.txt for BSD license.
+USING: assocs kernel redis sequences ;
+IN: redis.assoc
+
+INSTANCE: redis assoc
+
+M: redis at* [ redis-get dup >boolean ] with-redis ;
+
+M: redis assoc-size [ redis-dbsize ] with-redis ;
+
+M: redis >alist [ "*" redis-keys dup redis-mget zip ] with-redis ;
+
+M: redis set-at [ redis-set drop ] with-redis ;
+
+M: redis delete-at [ redis-del drop ] with-redis ;
+
+M: redis clear-assoc [ redis-flushdb drop ] with-redis ;
+
+M: redis equal? assoc= ;
+
+M: redis 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
diff --git a/extra/redis/redis.factor b/extra/redis/redis.factor
index 1f6d732407..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 ;
+USING: accessors io io.encodings.8-bit io.sockets
+io.streams.duplex kernel redis.command-writer
+redis.response-parser splitting ;
IN: redis
#! Connection
@@ -23,7 +25,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 ;
@@ -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 )
+ redis new
+ "127.0.0.1" >>host
+ default-redis-port >>port
+ latin1 >>encoding ;
+
+: redis-do-connect ( redis -- stream )
+ [ host>> ] [ port>> ] [ encoding>> ] tri
+ [ <inet> ] dip <client> drop ;
+
+: with-redis ( redis quot -- )
+ [
+ [ redis-do-connect ] [ password>> ] bi
+ [ swap [ [ redis-auth drop ] with-stream* ] keep ] when*
+ ] dip with-stream ; inline
diff --git a/extra/terrain/shaders/shaders.factor b/extra/terrain/shaders/shaders.factor
index e5b517ad59..9233ab3f36 100644
--- a/extra/terrain/shaders/shaders.factor
+++ b/extra/terrain/shaders/shaders.factor
@@ -11,7 +11,8 @@ void main()
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;
+ 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)
diff --git a/extra/terrain/terrain.factor b/extra/terrain/terrain.factor
index 411d34f44c..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
@@ -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,30 +117,53 @@ 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 ;
+
+
+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
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-space keys nth [ player jump ] when
key-escape keys nth [ world close-window ] when
player read-mouse rotate-with-mouse
reset-mouse ;
: apply-friction ( velocity -- velocity' )
- FRICTION v*n ;
+ FRICTION v* ;
: apply-gravity ( velocity -- velocity' )
1 over [ GRAVITY - ] change-nth ;
@@ -170,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*
@@ -197,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
<perlin-noise-table> 0.01 0.01 <scale> { 512 512 } perlin-noise-image
[ >>sky-image ] keep
make-texture [ set-texture-parameters ] keep >>sky-texture
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..ea7040ac6e
--- /dev/null
+++ b/extra/webapps/mason/mason.factor
@@ -0,0 +1,84 @@
+! 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
+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 <pre><-></pre> XML] ;
+
+: git-link ( id -- link )
+ [ "http://github.com/slavapestov/factor/commit/" prepend ] keep
+ [XML <a href=<->><-></a> 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 <a href=<->><-></a> XML] ;
+
+: clean-image-link ( builder -- link )
+ [ os>> ] [ cpu>> ] bi (platform) "http://factorcode.org/images/clean/" prepend
+ dup [XML <a href=<->><-></a> 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
+ <h2><-> / <-></h2>
+ <table border="1">
+ <tr><td>Host name:</td><td><-></td></tr>
+ <tr><td>Current status:</td><td><-></td></tr>
+ <tr><td>Last build:</td><td><-></td></tr>
+ <tr><td>Last clean build:</td><td><-></td></tr>
+ <tr><td>Binaries:</td><td><-></td></tr>
+ <tr><td>Clean images:</td><td><-></td></tr>
+ </table>
+ XML] ;
+
+: 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
+ <html>
+ <head><title>Factor build farm</title></head>
+ <body><h1>Recent events</h1><-> <h1>Machine status</h1><-></body>
+ </html>
+ XML] ;
+
+: <build-farm-report-action> ( -- action )
+ <action>
+ [
+ mason-db [ build-farm-report xml>string ] with-db
+ "text/html" <content>
+ ] >>display ;
\ No newline at end of file