diff --git a/extra/backtrack/backtrack.factor b/extra/backtrack/backtrack.factor index 7ab11abd6d..3c1a794121 100755 --- a/extra/backtrack/backtrack.factor +++ b/extra/backtrack/backtrack.factor @@ -1,20 +1,68 @@ ! Copyright (C) 2008 William Schlieper ! See http://factorcode.org/license.txt for BSD license. -USING: kernel continuations sequences namespaces fry ; +USING: kernel continuations combinators sequences quotations arrays namespaces + fry summary assocs math math.order macros ; IN: backtrack SYMBOL: failure -: amb ( seq -- elt ) - failure get - '[ , _ '[ , '[ failure set , , continue-with ] callcc0 ] each - , continue ] callcc1 ; +ERROR: amb-failure ; + +M: amb-failure summary drop "Backtracking failure" ; : fail ( -- ) - f amb drop ; + failure get [ continue ] + [ amb-failure ] if* ; : require ( ? -- ) [ fail ] unless ; +MACRO: checkpoint ( quot -- quot' ) + '[ failure get , + '[ '[ failure set , continue ] callcc0 + , failure set @ ] callcc0 ] ; + +: number-from ( from -- from+n ) + [ 1 + number-from ] checkpoint ; + + + +: amb-lazy ( seq -- elt ) + [ amb-integer ] [ nth ] bi ; + +: amb ( seq -- elt ) + dup empty? + [ drop fail f ] + [ unsafe-amb ] if ; inline + +MACRO: amb-execute ( seq -- quot ) + [ length 1 - ] [ [ 1quotation ] assoc-map ] bi + '[ , 0 unsafe-number-from-to nip , case ] ; + +: if-amb ( true false -- ) + [ + [ { t f } amb ] + [ '[ @ require t ] ] + [ '[ @ f ] ] + tri* if + ] with-scope ; inline + diff --git a/extra/benchmark/backtrack/backtrack.factor b/extra/benchmark/backtrack/backtrack.factor old mode 100644 new mode 100755 index 0ffaaa4867..df67872b11 --- a/extra/benchmark/backtrack/backtrack.factor +++ b/extra/benchmark/backtrack/backtrack.factor @@ -12,18 +12,6 @@ IN: benchmark.backtrack : nop ; -MACRO: amb-execute ( seq -- quot ) - [ length ] [ [ 1quotation ] assoc-map ] bi - '[ , amb , case ] ; - -: if-amb ( true false -- ) - [ - [ { t f } amb ] - [ '[ @ require t ] ] - [ '[ @ f ] ] - tri* if - ] with-scope ; inline - : do-something ( a b -- c ) { + - * } amb-execute ; diff --git a/extra/irc/client/client-tests.factor b/extra/irc/client/client-tests.factor index 2883e47b81..100724ea58 100644 --- a/extra/irc/client/client-tests.factor +++ b/extra/irc/client/client-tests.factor @@ -1,7 +1,7 @@ USING: kernel tools.test accessors arrays sequences qualified io.streams.string io.streams.duplex namespaces threads calendar irc.client.private irc.client irc.messages.private - concurrency.mailboxes classes ; + concurrency.mailboxes classes assocs ; EXCLUDE: irc.messages => join ; RENAME: join irc.messages => join_ IN: irc.client.tests @@ -20,28 +20,6 @@ IN: irc.client.tests : with-dummy-client ( quot -- ) rot with-variable ; inline -! Parsing tests -irc-message new - ":someuser!n=user@some.where PRIVMSG #factortest :hi" >>line - "someuser!n=user@some.where" >>prefix - "PRIVMSG" >>command - { "#factortest" } >>parameters - "hi" >>trailing -1array -[ ":someuser!n=user@some.where PRIVMSG #factortest :hi" - string>irc-message f >>timestamp ] unit-test - -privmsg new - ":someuser!n=user@some.where PRIVMSG #factortest :hi" >>line - "someuser!n=user@some.where" >>prefix - "PRIVMSG" >>command - { "#factortest" } >>parameters - "hi" >>trailing - "#factortest" >>name -1array -[ ":someuser!n=user@some.where PRIVMSG #factortest :hi" - parse-irc-line f >>timestamp ] unit-test - { "" } make-client dup "factorbot" set-nick current-irc-client [ { t } [ irc> profile>> nickname>> me? ] unit-test @@ -64,21 +42,29 @@ privmsg new ":some.where 001 factorbot :Welcome factorbot" } make-client [ connect-irc ] keep 1 seconds sleep - profile>> nickname>> ] unit-test + profile>> nickname>> ] unit-test { join_ "#factortest" } [ - { ":factorbot!n=factorbo@some.where JOIN :#factortest" + { ":factorbot!n=factorbo@some.where JOIN :#factortest" ":ircserver.net MODE #factortest +ns" ":ircserver.net 353 factorbot @ #factortest :@factorbot " ":ircserver.net 366 factorbot #factortest :End of /NAMES list." ":ircserver.net 477 factorbot #factortest :[ircserver-info] blah blah" } make-client dup "factorbot" set-nick [ connect-irc ] keep 1 seconds sleep - join-messages>> 5 seconds mailbox-get-timeout + join-messages>> 1 seconds mailbox-get-timeout [ class ] [ trailing>> ] bi ] unit-test -! TODO: user join -! ":somedude!n=user@isp.net JOIN :#factortest" + +{ +join+ "somebody" } [ + { ":somebody!n=somebody@some.where JOIN :#factortest" + } make-client dup "factorbot" set-nick + [ listeners>> [ "#factortest" [ ] keep ] dip set-at ] + [ connect-irc ] + [ listeners>> [ "#factortest" ] dip at + [ read-message drop ] [ read-message drop ] [ read-message ] tri ] tri + [ action>> ] [ nick>> ] bi + ] unit-test ! TODO: channel message -! ":somedude!n=user@isp.net PRIVMSG #factortest :hello" +! ":somebody!n=somebody@some.where PRIVMSG #factortest :hello" ! TODO: direct private message ! ":somedude!n=user@isp.net PRIVMSG factorbot2 :hello" \ No newline at end of file diff --git a/extra/irc/client/client.factor b/extra/irc/client/client.factor index 2dbbe8b8f5..405d8ed9ed 100644 --- a/extra/irc/client/client.factor +++ b/extra/irc/client/client.factor @@ -31,6 +31,20 @@ TUPLE: irc-channel-listener < irc-listener name password timeout participants ; TUPLE: irc-nick-listener < irc-listener name ; SYMBOL: +server-listener+ +! participant modes +SYMBOL: +operator+ +SYMBOL: +voice+ +SYMBOL: +normal+ + +: participant-mode ( n -- mode ) + H{ { 64 +operator+ } { 43 +voice+ } { 0 +normal+ } } at ; + +! participant changed actions +SYMBOL: +join+ +SYMBOL: +part+ +SYMBOL: +mode+ + +! listener objects : ( -- irc-listener ) irc-listener boa ; : ( -- irc-server-listener ) @@ -46,6 +60,9 @@ SYMBOL: +server-listener+ ! Message objects ! ====================================== +TUPLE: participant-changed nick action ; +C: participant-changed + SINGLETON: irc-end ! sent when the client isn't running anymore SINGLETON: irc-disconnected ! sent when connection is lost SINGLETON: irc-connected ! sent when connection is established @@ -70,19 +87,27 @@ UNION: irc-broadcasted-message irc-end irc-disconnected irc-connected ; : listener> ( name -- listener/f ) irc> listeners>> at ; : unregister-listener ( name -- ) irc> listeners>> delete-at ; -: to-listener ( message name -- ) +GENERIC: to-listener ( message obj -- ) + +M: string to-listener ( message string -- ) listener> [ +server-listener+ listener> ] unless* - [ in-messages>> mailbox-put ] [ drop ] if* ; + [ to-listener ] [ drop ] if* ; + +M: irc-listener to-listener ( message irc-listener -- ) + in-messages>> mailbox-put ; : remove-participant ( nick channel -- ) listener> [ participants>> delete-at ] [ drop ] if* ; -: remove-participant-from-all ( nick -- ) - irc> listeners>> - [ irc-channel-listener? [ swap remove-participant ] [ 2drop ] if ] with - assoc-each ; +: listeners-with-participant ( nick -- seq ) + irc> listeners>> values + [ dup irc-channel-listener? [ participants>> key? ] [ 2drop f ] if ] + with filter ; -: add-participant ( nick mode channel -- ) +: remove-participant-from-all ( nick -- ) + dup listeners-with-participant [ delete-at ] with each ; + +: add-participant ( mode nick channel -- ) listener> [ participants>> set-at ] [ 2drop ] if* ; DEFER: me? @@ -142,12 +167,31 @@ DEFER: me? dup name>> me? [ prefix>> parse-name ] [ name>> ] if ; : broadcast-message-to-listeners ( message -- ) - irc> listeners>> values [ in-messages>> mailbox-put ] with each ; + irc> listeners>> values [ to-listener ] with each ; + +GENERIC: handle-participant-change ( irc-message -- ) + +M: join handle-participant-change ( join -- ) + [ prefix>> parse-name +join+ ] + [ trailing>> ] bi to-listener ; + +M: part handle-participant-change ( part -- ) + [ prefix>> parse-name +part+ ] + [ channel>> ] bi to-listener ; + +M: kick handle-participant-change ( kick -- ) + [ who>> +part+ ] + [ channel>> ] bi to-listener ; + +M: quit handle-participant-change ( quit -- ) + prefix>> parse-name + [ +part+ ] [ listeners-with-participant ] bi + [ to-listener ] with each ; GENERIC: handle-incoming-irc ( irc-message -- ) M: irc-message handle-incoming-irc ( irc-message -- ) - +server-listener+ listener> [ in-messages>> mailbox-put ] [ drop ] if* ; + +server-listener+ listener> [ to-listener ] [ drop ] if* ; M: logged-in handle-incoming-irc ( logged-in -- ) name>> irc> profile>> (>>nickname) ; @@ -162,34 +206,43 @@ M: privmsg handle-incoming-irc ( privmsg -- ) dup irc-message-origin to-listener ; M: join handle-incoming-irc ( join -- ) - [ maybe-forward-join ] - [ dup trailing>> to-listener ] - [ [ drop f ] [ prefix>> parse-name ] [ trailing>> ] tri add-participant ] - tri ; + { [ maybe-forward-join ] ! keep + [ dup trailing>> to-listener ] + [ [ drop f ] [ prefix>> parse-name ] [ trailing>> ] tri add-participant ] + [ handle-participant-change ] + } cleave ; M: part handle-incoming-irc ( part -- ) - [ dup channel>> to-listener ] keep - [ prefix>> parse-name ] [ channel>> ] bi remove-participant ; - -M: kick handle-incoming-irc ( kick -- ) - [ dup channel>> to-listener ] - [ [ who>> ] [ channel>> ] bi remove-participant ] - [ dup who>> me? [ unregister-listener ] [ drop ] if ] + [ dup channel>> to-listener ] + [ [ prefix>> parse-name ] [ channel>> ] bi remove-participant ] + [ handle-participant-change ] tri ; +M: kick handle-incoming-irc ( kick -- ) + { [ dup channel>> to-listener ] + [ [ who>> ] [ channel>> ] bi remove-participant ] + [ handle-participant-change ] + [ dup who>> me? [ unregister-listener ] [ drop ] if ] + } cleave ; + M: quit handle-incoming-irc ( quit -- ) - [ prefix>> parse-name remove-participant-from-all ] keep - call-next-method ; + { [ dup prefix>> parse-name listeners-with-participant + [ to-listener ] with each ] + [ handle-participant-change ] + [ prefix>> parse-name remove-participant-from-all ] + [ ] + } cleave call-next-method ; : >nick/mode ( string -- nick mode ) - dup first "+@" member? [ unclip ] [ f ] if ; + dup first "+@" member? [ unclip ] [ 0 ] if participant-mode ; : names-reply>participants ( names-reply -- participants ) trailing>> [ blank? ] trim " " split [ >nick/mode 2array ] map >hashtable ; M: names-reply handle-incoming-irc ( names-reply -- ) - [ names-reply>participants ] [ channel>> listener> ] bi (>>participants) ; + [ names-reply>participants ] [ channel>> listener> ] bi + [ (>>participants) ] [ drop ] if* ; M: irc-broadcasted-message handle-incoming-irc ( irc-broadcasted-message -- ) broadcast-message-to-listeners ; @@ -200,8 +253,8 @@ M: irc-broadcasted-message handle-incoming-irc ( irc-broadcasted-message -- ) GENERIC: handle-outgoing-irc ( obj -- ) -! M: irc-message handle-outgoing-irc ( irc-message -- ) -! irc-message>string irc-print ; +M: irc-message handle-outgoing-irc ( irc-message -- ) + irc-message>client-line irc-print ; M: privmsg handle-outgoing-irc ( privmsg -- ) [ name>> ] [ trailing>> ] bi /PRIVMSG ; @@ -213,11 +266,6 @@ M: part handle-outgoing-irc ( part -- ) ! Reader/Writer ! ====================================== -: irc-mailbox-get ( mailbox quot -- ) - [ 5 seconds ] dip - '[ , , , [ mailbox-get-timeout ] dip call ] - [ drop ] recover ; inline - : handle-reader-message ( irc-message -- ) irc> in-messages>> mailbox-put ; @@ -225,7 +273,7 @@ DEFER: (connect-irc) : (handle-disconnect) ( -- ) irc> - [ [ irc-disconnected ] dip in-messages>> mailbox-put ] + [ [ irc-disconnected ] dip to-listener ] [ dup reconnect-time>> sleep (connect-irc) ] [ profile>> nickname>> /LOGIN ] tri ; @@ -247,14 +295,14 @@ DEFER: (connect-irc) [ (reader-loop) ] [ handle-disconnect ] recover ; : writer-loop ( -- ) - irc> out-messages>> [ handle-outgoing-irc ] irc-mailbox-get ; + irc> out-messages>> mailbox-get handle-outgoing-irc ; ! ====================================== ! Processing loops ! ====================================== : in-multiplexer-loop ( -- ) - irc> in-messages>> [ handle-incoming-irc ] irc-mailbox-get ; + irc> in-messages>> mailbox-get handle-incoming-irc ; : strings>privmsg ( name string -- privmsg ) privmsg new [ (>>trailing) ] keep [ (>>name) ] keep ; @@ -267,9 +315,8 @@ DEFER: (connect-irc) } cond ; : listener-loop ( name listener -- ) - out-messages>> swap - '[ , swap maybe-annotate-with-name irc> out-messages>> mailbox-put ] - irc-mailbox-get ; + out-messages>> mailbox-get maybe-annotate-with-name + irc> out-messages>> mailbox-put ; : spawn-irc-loop ( quot name -- ) [ '[ irc> is-running>> [ @ ] when irc> is-running>> ] ] dip diff --git a/extra/irc/messages/messages-tests.factor b/extra/irc/messages/messages-tests.factor new file mode 100644 index 0000000000..1bd6088f82 --- /dev/null +++ b/extra/irc/messages/messages-tests.factor @@ -0,0 +1,37 @@ +USING: kernel tools.test accessors arrays qualified + irc.messages irc.messages.private ; +EXCLUDE: sequences => join ; +IN: irc.messages.tests + +! Parsing tests +irc-message new + ":someuser!n=user@some.where PRIVMSG #factortest :hi" >>line + "someuser!n=user@some.where" >>prefix + "PRIVMSG" >>command + { "#factortest" } >>parameters + "hi" >>trailing +1array +[ ":someuser!n=user@some.where PRIVMSG #factortest :hi" + string>irc-message f >>timestamp ] unit-test + +privmsg new + ":someuser!n=user@some.where PRIVMSG #factortest :hi" >>line + "someuser!n=user@some.where" >>prefix + "PRIVMSG" >>command + { "#factortest" } >>parameters + "hi" >>trailing + "#factortest" >>name +1array +[ ":someuser!n=user@some.where PRIVMSG #factortest :hi" + parse-irc-line f >>timestamp ] unit-test + +join new + ":someuser!n=user@some.where JOIN :#factortest" >>line + "someuser!n=user@some.where" >>prefix + "JOIN" >>command + { } >>parameters + "#factortest" >>trailing +1array +[ ":someuser!n=user@some.where JOIN :#factortest" + parse-irc-line f >>timestamp ] unit-test + diff --git a/extra/irc/messages/messages.factor b/extra/irc/messages/messages.factor index 205630d790..5813c72723 100644 --- a/extra/irc/messages/messages.factor +++ b/extra/irc/messages/messages.factor @@ -21,6 +21,10 @@ TUPLE: mode < irc-message name channel mode ; TUPLE: names-reply < irc-message who = channel ; TUPLE: unhandled < irc-message ; +: ( command parameters trailing -- irc-message ) + irc-message new now >>timestamp + [ [ (>>trailing) ] [ (>>parameters) ] [ (>>command) ] tri ] keep ; + GENERIC: irc-message>client-line ( irc-message -- string ) M: irc-message irc-message>client-line ( irc-message -- string ) @@ -30,6 +34,7 @@ M: irc-message irc-message>client-line ( irc-message -- string ) tri 3array " " sjoin ; GENERIC: irc-message>server-line ( irc-message -- string ) + M: irc-message irc-message>server-line ( irc-message -- string ) drop "not implemented yet" ; @@ -58,6 +63,8 @@ M: irc-message irc-message>server-line ( irc-message -- string ) : split-trailing ( string -- string string/f ) ":" split1 ; +PRIVATE> + : string>irc-message ( string -- object ) dup split-prefix split-trailing [ [ blank? ] trim " " split unclip swap ] dip @@ -82,4 +89,3 @@ M: irc-message irc-message>server-line ( irc-message -- string ) [ [ tuple-slots ] [ parameters>> ] bi append ] dip [ all-slots over [ length ] bi@ min head ] keep slots>tuple ; -PRIVATE> diff --git a/extra/irc/ui/load/load.factor b/extra/irc/ui/load/load.factor index 6655f310e7..e6f4d07b56 100755 --- a/extra/irc/ui/load/load.factor +++ b/extra/irc/ui/load/load.factor @@ -5,7 +5,7 @@ USING: kernel io.files parser editors sequences ; IN: irc.ui.load -: file-or ( path path -- path ) over exists? ? ; +: file-or ( path path -- path ) [ [ exists? ] keep ] dip ? ; : personal-ui-rc ( -- path ) home ".ircui-rc" append-path ; diff --git a/extra/irc/ui/ui.factor b/extra/irc/ui/ui.factor index 12f9d01183..a79920efe5 100755 --- a/extra/irc/ui/ui.factor +++ b/extra/irc/ui/ui.factor @@ -5,8 +5,8 @@ USING: accessors kernel threads combinators concurrency.mailboxes sequences strings hashtables splitting fry assocs hashtables ui ui.gadgets ui.gadgets.panes ui.gadgets.editors ui.gadgets.scrollers ui.commands ui.gadgets.frames ui.gestures - ui.gadgets.tabs ui.gadgets.grids - io io.styles namespaces calendar calendar.format + ui.gadgets.tabs ui.gadgets.grids ui.gadgets.lists ui.gadgets.labels + io io.styles namespaces calendar calendar.format models irc.client irc.client.private irc.messages irc.messages.private irc.ui.commandparser irc.ui.load ; @@ -18,11 +18,18 @@ SYMBOL: client TUPLE: ui-window client tabs ; +TUPLE: irc-tab < frame listener client listmodel ; + : write-color ( str color -- ) foreground associate format ; : red { 0.5 0 0 1 } ; : green { 0 0.5 0 1 } ; : blue { 0 0 1 1 } ; +: black { 0 0 0 1 } ; + +: colors H{ { +operator+ { 0 0.5 0 1 } } + { +voice+ { 0 0 1 1 } } + { +normal+ { 0 0 0 1 } } } ; : dot-or-parens ( string -- string ) dup empty? [ drop "." ] @@ -64,6 +71,14 @@ M: quit write-irc " has left IRC" red write-color trailing>> dot-or-parens red write-color ; +M: mode write-irc + "* " blue write-color + [ name>> write ] keep + " has applied mode " blue write-color + [ mode>> write ] keep + " to " blue write-color + channel>> write ; + M: irc-end write-irc drop "* You have left IRC" red write-color ; @@ -84,20 +99,39 @@ M: irc-message write-irc [ print-irc ] [ listener get write-message ] bi ; -: display ( stream listener -- ) +GENERIC: handle-inbox ( tab message -- ) + +: filter-participants ( assoc val -- alist ) + [ >alist ] dip + '[ second , = ] filter ; + +: update-participants ( tab -- ) + [ listmodel>> ] [ listener>> participants>> ] bi + [ +operator+ filter-participants ] + [ +voice+ filter-participants ] + [ +normal+ filter-participants ] tri + append append swap set-model ; + +M: participant-changed handle-inbox + drop update-participants ; + +M: object handle-inbox + nip print-irc ; + +: display ( stream tab -- ) '[ , [ [ t ] - [ , read-message print-irc ] + [ , dup listener>> read-message handle-inbox ] [ ] while ] with-output-stream ] "ircv" spawn drop ; -: ( listener -- pane ) +: ( tab -- tab pane ) - [ swap display ] keep ; + [ swap display ] 2keep ; TUPLE: irc-editor < editor outstream listener client ; -: ( page pane listener -- client editor ) - irc-editor new-editor - swap >>listener swap >>outstream +: ( tab pane -- tab editor ) + over irc-editor new-editor + swap listener>> >>listener swap >>outstream over client>> >>client ; : editor-send ( irc-editor -- ) @@ -113,25 +147,36 @@ irc-editor "general" f { { T{ key-down f f "ENTER" } editor-send } } define-command-map -TUPLE: irc-page < frame listener client ; +: ( -- gadget model ) + [ drop ] + [ first2 [