diff --git a/basis/disjoint-sets/disjoint-sets-docs.factor b/basis/disjoint-sets/disjoint-sets-docs.factor new file mode 100644 index 0000000000..b1d7cf685a --- /dev/null +++ b/basis/disjoint-sets/disjoint-sets-docs.factor @@ -0,0 +1,58 @@ +IN: disjoint-sets +USING: help.markup help.syntax kernel assocs math ; + +HELP: +{ $values { "disjoint-set" disjoint-set } } +{ $description "Creates a new disjoint set data structure with no elements." } ; + +HELP: add-atom +{ $values { "a" object } { "disjoint-set" disjoint-set } } +{ $description "Adds a new element to the disjoint set, initially only equivalent to itself." } ; + +HELP: equiv-set-size +{ $values { "a" object } { "disjoint-set" disjoint-set } { "n" integer } } +{ $description "Outputs the number of elements in the equivalence class of " { $snippet "a" } "." } ; + +HELP: equiv? +{ $values { "a" object } { "b" object } { "disjoint-set" disjoint-set } { "?" "a boolean" } } +{ $description "Tests if two elements belong to the same equivalence class." } ; + +HELP: equate +{ $values { "a" object } { "b" object } { "disjoint-set" disjoint-set } } +{ $description "Merges the equivalence classes of two elements, which must previously have been added with " { $link add-atom } "." } ; + +HELP: assoc>disjoint-set +{ $values { "assoc" assoc } { "disjoint-set" disjoint-set } } +{ $description "Given an assoc representation of a graph where the keys are vertices and key/value pairs are edges, creates a disjoint set whose elements are the keys of assoc, and two keys are equvalent if they belong to the same connected component of the graph." } +{ $examples + { $example + "USING: disjoint-sets kernel prettyprint ;" + "H{ { 1 1 } { 2 1 } { 3 4 } { 4 4 } { 5 3 } } assoc>disjoint-set" + "1 2 pick equiv? ." + "4 5 pick equiv? ." + "1 5 pick equiv? ." + "drop" + "t\nt\nf\n" + } +} ; + +ARTICLE: "disjoint-sets" "Disjoint sets" +"The " { $emphasis "disjoint set" } " data structure, also known as " { $emphasis "union-find" } " (after the two main operations which it supports) represents a set of elements partitioned into disjoint equivalence classes, or alternatively, an equivalence relation on a set." +$nl +"The two main supported operations are equating two elements, which joins their equivalence classes, and checking if two elements belong to the same equivalence class. Both operations have the time complexity of the inverse Ackermann function, which for all intents and purposes is constant time." +$nl +"The class of disjoint sets:" +{ $subsection disjoint-set } +"Creating new disjoint sets:" +{ $subsection } +{ $subsection assoc>disjoint-set } +"Queries:" +{ $subsection equiv? } +{ $subsection equiv-set-size } +"Adding elements:" +{ $subsection add-atom } +"Equating elements:" +{ $subsection equate } +"Additionally, disjoint sets implement the " { $link clone } " generic word." ; + +ABOUT: "disjoint-sets" diff --git a/basis/disjoint-sets/disjoint-sets.factor b/basis/disjoint-sets/disjoint-sets.factor index 284d206da4..a885e333c5 100644 --- a/basis/disjoint-sets/disjoint-sets.factor +++ b/basis/disjoint-sets/disjoint-sets.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Eric Mertens. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays hints kernel locals math hashtables -assocs ; +assocs fry ; IN: disjoint-sets @@ -36,8 +36,6 @@ TUPLE: disjoint-set : representative? ( a disjoint-set -- ? ) dupd parent = ; inline -PRIVATE> - GENERIC: representative ( a disjoint-set -- p ) M: disjoint-set representative @@ -45,8 +43,6 @@ M: disjoint-set representative [ [ parent ] keep representative dup ] 2keep set-parent ] if ; -> ] [ ranks>> ] [ counts>> ] tri [ clone ] tri@ disjoint-set boa ; + +: assoc>disjoint-set ( assoc -- disjoint-set ) + + [ '[ drop , add-atom ] assoc-each ] + [ '[ , equate ] assoc-each ] + [ nip ] + 2tri ; diff --git a/extra/irc/client/client-tests.factor b/extra/irc/client/client-tests.factor index e021ff4ff4..1b338df442 100644 --- a/extra/irc/client/client-tests.factor +++ b/extra/irc/client/client-tests.factor @@ -160,7 +160,7 @@ IN: irc.client.tests } cleave ] unit-test -! Namelist notification +! Namelist change notification { T{ participant-changed f f f } } [ { ":ircserver.net 353 factorbot @ #factortest :@factorbot " ":ircserver.net 366 factorbot #factortest :End of /NAMES list." } make-client @@ -172,4 +172,19 @@ IN: irc.client.tests [ listeners>> [ "#factortest" ] dip at [ read-message drop ] [ read-message ] bi ] [ terminate-irc ] } cleave + ] unit-test + +{ T{ participant-changed f "somedude" +part+ } } [ + { ":somedude!n=user@isp.net QUIT" } make-client + { [ "factorbot" set-nick ] + [ listeners>> + [ "#factortest" [ + H{ { "somedude" +normal+ } } clone >>participants ] keep + ] dip set-at ] + [ connect-irc ] + [ drop 0.1 seconds sleep ] + [ listeners>> [ "#factortest" ] dip at + [ read-message drop ] [ read-message drop ] [ read-message ] tri ] + [ terminate-irc ] + } cleave ] unit-test \ No newline at end of file diff --git a/extra/irc/client/client.factor b/extra/irc/client/client.factor index 813de0f57c..99922b1fb5 100644 --- a/extra/irc/client/client.factor +++ b/extra/irc/client/client.factor @@ -88,10 +88,11 @@ SYMBOL: current-irc-client : irc-stream> ( -- stream ) irc> stream>> ; : irc-write ( s -- ) irc-stream> stream-write ; : irc-print ( s -- ) irc-stream> [ stream-print ] keep stream-flush ; +: irc-send ( irc-message -- ) irc> out-messages>> mailbox-put ; : listener> ( name -- listener/f ) irc> listeners>> at ; : maybe-mailbox-get ( mailbox quot: ( irc-message -- ) -- ) - [ dup mailbox-empty? [ drop yield ] ] dip '[ mailbox-get @ ] if ; inline + [ dup mailbox-empty? [ drop 0.1 sleep ] ] dip '[ mailbox-get @ ] if ; inline GENERIC: to-listener ( message obj -- ) @@ -147,24 +148,6 @@ DEFER: me? "JOIN " irc-write [ [ " :" ] dip 3append ] when* irc-print ; -: /PART ( channel text -- ) - [ "PART " irc-write irc-write ] dip - " :" irc-write irc-print ; - -: /KICK ( channel who -- ) - [ "KICK " irc-write irc-write ] dip - " " irc-write irc-print ; - -: /PRIVMSG ( nick line -- ) - [ "PRIVMSG " irc-write irc-write ] dip - " :" irc-write irc-print ; - -: /ACTION ( nick line -- ) - [ 1 , "ACTION " % % 1 , ] "" make /PRIVMSG ; - -: /QUIT ( text -- ) - "QUIT :" irc-write irc-print ; - : /PONG ( text -- ) "PONG " irc-write irc-print ; @@ -240,10 +223,14 @@ M: kick handle-incoming-irc ( kick -- ) M: quit handle-incoming-irc ( quit -- ) [ dup prefix>> parse-name listeners-with-participant [ to-listener ] with each ] - [ prefix>> parse-name remove-participant-from-all ] [ handle-participant-change ] + [ prefix>> parse-name remove-participant-from-all ] tri ; +! FIXME: implement this +! M: mode handle-incoming-irc ( mode -- ) call-next-method ; +! M: nick handle-incoming-irc ( nick -- ) call-next-method ; + : >nick/mode ( string -- nick mode ) dup first "+@" member? [ unclip ] [ 0 ] if participant-mode ; diff --git a/extra/irc/ui/ui.factor b/extra/irc/ui/ui.factor index 662fca6d79..0c9fdee6e0 100755 --- a/extra/irc/ui/ui.factor +++ b/extra/irc/ui/ui.factor @@ -2,13 +2,14 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel threads combinators concurrency.mailboxes - sequences strings hashtables splitting fry assocs hashtables + sequences strings hashtables splitting fry assocs hashtables colors + sorting qualified unicode.case math.order 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 ui.gadgets.packs ui.gadgets.labels io io.styles namespaces calendar calendar.format models continuations irc.client irc.client.private irc.messages irc.messages.private - irc.ui.commandparser irc.ui.load qualified ; + irc.ui.commandparser irc.ui.load ; RENAME: join sequences => sjoin @@ -24,14 +25,8 @@ TUPLE: irc-tab < frame listener client userlist ; : 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 } } } ; +: dark-red T{ rgba f 0.5 0.0 0.0 1 } ; +: dark-green T{ rgba f 0.0 0.5 0.0 1 } ; : dot-or-parens ( string -- string ) dup empty? [ drop "." ] @@ -65,21 +60,21 @@ M: own-message write-irc message>> write ; M: join write-irc - "* " green write-color + "* " dark-green write-color prefix>> parse-name write - " has entered the channel." green write-color ; + " has entered the channel." dark-green write-color ; M: part write-irc - "* " red write-color + "* " dark-red write-color [ prefix>> parse-name write ] keep - " has left the channel" red write-color - trailing>> dot-or-parens red write-color ; + " has left the channel" dark-red write-color + trailing>> dot-or-parens dark-red write-color ; M: quit write-irc - "* " red write-color + "* " dark-red write-color [ prefix>> parse-name write ] keep - " has left IRC" red write-color - trailing>> dot-or-parens red write-color ; + " has left IRC" dark-red write-color + trailing>> dot-or-parens dark-red write-color ; : full-mode ( message -- mode ) parameters>> rest " " sjoin ; @@ -92,18 +87,24 @@ M: mode write-irc " to " blue write-color channel>> write ; +M: nick write-irc + "* " blue write-color + [ prefix>> parse-name write ] keep + " is now known as " blue write-color + trailing>> write ; + M: unhandled write-irc "UNHANDLED: " write line>> blue write-color ; M: irc-end write-irc - drop "* You have left IRC" red write-color ; + drop "* You have left IRC" dark-red write-color ; M: irc-disconnected write-irc - drop "* Disconnected" red write-color ; + drop "* Disconnected" dark-red write-color ; M: irc-connected write-irc - drop "* Connected" green write-color ; + drop "* Connected" dark-green write-color ; M: irc-listener-end write-irc drop ; @@ -124,15 +125,18 @@ M: irc-message write-irc GENERIC: handle-inbox ( tab message -- ) -: filter-participants ( pack alist val color -- pack ) - '[ , = [