diff --git a/basis/concurrency/messaging/messaging-docs.factor b/basis/concurrency/messaging/messaging-docs.factor index 1219982f51..6c9e530d9b 100755 --- a/basis/concurrency/messaging/messaging-docs.factor +++ b/basis/concurrency/messaging/messaging-docs.factor @@ -56,19 +56,19 @@ ARTICLE: { "concurrency" "synchronous-sends" } "Synchronous sends" "USING: concurrency.messaging kernel threads ;" ": pong-server ( -- )" " receive >r \"pong\" r> reply-synchronous ;" - "[ pong-server t ] spawn-server" + "[ pong-server t ] \"pong-server\" spawn-server" "\"ping\" swap send-synchronous ." "\"pong\"" } ; ARTICLE: { "concurrency" "exceptions" } "Linked exceptions" "A thread can handle exceptions using the standard Factor exception handling mechanism. If an exception is uncaught the thread will terminate. For example:" -{ $code "[ 1 0 / \"This will not print\" print ] spawn" } +{ $code "[ 1 0 / \"This will not print\" print ] \"division-by-zero\" spawn" } "Processes can be linked so that a parent thread can receive the exception that caused the child thread to terminate. In this way 'supervisor' threades can be created that are notified when child threades terminate and possibly restart them." { $subsection spawn-linked } "This will create a unidirectional link, such that if an uncaught exception causes the child to terminate, the parent thread can catch it:" { $code "[" -" [ 1 0 / \"This will not print\" print ] spawn-linked drop" +" [ 1 0 / \"This will not print\" print ] \"linked-division\" spawn-linked drop" " receive" "] [ \"Exception caught.\" print ] recover" } "Exceptions are only raised in the parent when the parent does a " { $link receive } " or " { $link receive-if } ". This is because the exception is sent from the child to the parent as a message." ; diff --git a/basis/help/stylesheet/stylesheet.factor b/basis/help/stylesheet/stylesheet.factor index 68810e2369..50357db8cf 100755 --- a/basis/help/stylesheet/stylesheet.factor +++ b/basis/help/stylesheet/stylesheet.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2005, 2006 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: io.styles namespaces ; +USING: io.styles namespaces colors ; IN: help.stylesheet SYMBOL: default-span-style @@ -17,7 +17,7 @@ H{ SYMBOL: link-style H{ - { foreground { 0 0 0.3 1 } } + { foreground T{ rgba f 0 0 0.3 1 } } { font-style bold } } link-style set-global @@ -33,7 +33,7 @@ H{ { font-size 18 } { font-style bold } { wrap-margin 500 } - { page-color { 0.8 0.8 0.8 1 } } + { page-color T{ rgba f 0.8 0.8 0.8 1 } } { border-width 5 } } title-style set-global @@ -58,12 +58,12 @@ SYMBOL: snippet-style H{ { font "monospace" } { font-size 12 } - { foreground { 0.1 0.1 0.4 1 } } + { foreground T{ rgba f 0.1 0.1 0.4 1 } } } snippet-style set-global SYMBOL: code-style H{ - { page-color { 0.8 0.8 0.8 0.5 } } + { page-color T{ rgba f 0.8 0.8 0.8 0.5 } } { border-width 5 } { wrap-margin f } } code-style set-global @@ -74,13 +74,13 @@ H{ { font-style bold } } input-style set-global SYMBOL: url-style H{ { font "monospace" } - { foreground { 0.0 0.0 1.0 1.0 } } + { foreground T{ rgba f 0.0 0.0 1.0 1.0 } } } url-style set-global SYMBOL: warning-style H{ - { page-color { 0.95 0.95 0.95 1 } } - { border-color { 1 0 0 1 } } + { page-color T{ rgba f 0.95 0.95 0.95 1 } } + { border-color T{ rgba f 1 0 0 1 } } { border-width 5 } { wrap-margin 500 } } warning-style set-global @@ -93,7 +93,7 @@ H{ SYMBOL: table-style H{ { table-gap { 5 5 } } - { table-border { 0.8 0.8 0.8 1.0 } } + { table-border T{ rgba f 0.8 0.8 0.8 1.0 } } } table-style set-global SYMBOL: list-style diff --git a/basis/io/styles/styles.factor b/basis/io/styles/styles.factor index 14827dc7a6..752f413458 100644 --- a/basis/io/styles/styles.factor +++ b/basis/io/styles/styles.factor @@ -1,6 +1,8 @@ ! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: hashtables io ; + +USING: hashtables io colors ; + IN: io.styles SYMBOL: plain @@ -33,7 +35,7 @@ SYMBOL: table-border : standard-table-style ( -- style ) H{ { table-gap { 5 5 } } - { table-border { 0.8 0.8 0.8 1.0 } } + { table-border T{ rgba f 0.8 0.8 0.8 1.0 } } } ; ! Input history diff --git a/basis/listener/listener.factor b/basis/listener/listener.factor index 5ff5830e7a..feddbdc042 100755 --- a/basis/listener/listener.factor +++ b/basis/listener/listener.factor @@ -3,7 +3,8 @@ USING: arrays hashtables io kernel math math.parser memory namespaces parser lexer sequences strings io.styles vectors words generic system combinators continuations debugger -definitions compiler.units accessors ; +definitions compiler.units accessors colors ; + IN: listener SYMBOL: quit-flag @@ -41,7 +42,7 @@ M: object stream-read-quot : prompt. ( -- ) "( " in get " )" 3append - H{ { background { 1 0.7 0.7 1 } } } format bl flush ; + H{ { background T{ rgba f 1 0.7 0.7 1 } } } format bl flush ; SYMBOL: error-hook diff --git a/basis/prettyprint/backend/backend.factor b/basis/prettyprint/backend/backend.factor index 00b38ae4f8..111bcfdafc 100755 --- a/basis/prettyprint/backend/backend.factor +++ b/basis/prettyprint/backend/backend.factor @@ -5,7 +5,7 @@ hashtables io assocs kernel math namespaces sequences strings sbufs io.styles vectors words prettyprint.config prettyprint.sections quotations io io.files math.parser effects classes.tuple math.order classes.tuple.private classes -combinators ; +combinators colors ; IN: prettyprint.backend GENERIC: pprint* ( obj -- ) @@ -89,7 +89,7 @@ M: f pprint* drop \ f pprint-word ; : string-style ( obj -- hash ) [ presented set - { 0.3 0.3 0.3 1.0 } foreground set + T{ rgba f 0.3 0.3 0.3 1.0 } foreground set ] H{ } make-assoc ; : unparse-string ( str prefix suffix -- str ) diff --git a/basis/prettyprint/prettyprint.factor b/basis/prettyprint/prettyprint.factor index 4b5dd8542d..f78d12a310 100755 --- a/basis/prettyprint/prettyprint.factor +++ b/basis/prettyprint/prettyprint.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2003, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -IN: prettyprint + USING: arrays generic generic.standard assocs io kernel math namespaces sequences strings io.styles io.streams.string vectors words prettyprint.backend prettyprint.sections @@ -8,7 +8,9 @@ prettyprint.config sorting splitting grouping math.parser vocabs definitions effects classes.builtin classes.tuple io.files classes continuations hashtables classes.mixin classes.union classes.intersection classes.predicate classes.singleton -combinators quotations sets accessors ; +combinators quotations sets accessors colors ; + +IN: prettyprint : make-pprint ( obj quot -- block in use ) [ @@ -95,7 +97,7 @@ combinators quotations sets accessors ; SYMBOL: -> \ -> -{ { foreground { 1 1 1 1 } } { background { 0 0 0 1 } } } +{ { foreground T{ rgba f 1 1 1 1 } } { background T{ rgba f 0 0 0 1 } } } "word-style" set-word-prop : remove-step-into ( word -- ) diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor index 3d210e0000..0a1a3cb7f2 100755 --- a/core/kernel/kernel-docs.factor +++ b/core/kernel/kernel-docs.factor @@ -437,7 +437,7 @@ HELP: or HELP: xor { $values { "obj1" "a generalized boolean" } { "obj2" "a generalized boolean" } { "?" "a generalized boolean" } } -{ $description "Tests if at exactly one object is not " { $link f } "." } +{ $description "If exactly one input is false, outputs the other input. Otherwise outputs " { $link f } "." } { $notes "This word implements boolean exclusive or, so applying it to integers will not yield useful results (all integers have a true value). Bitwise exclusive or is the " { $link bitxor } " word." } ; HELP: both? diff --git a/core/kernel/kernel-tests.factor b/core/kernel/kernel-tests.factor index 195e9becae..5cb4abc2e9 100755 --- a/core/kernel/kernel-tests.factor +++ b/core/kernel/kernel-tests.factor @@ -50,6 +50,10 @@ IN: kernel.tests [ f ] [ 3 f and ] unit-test [ 4 ] [ 4 6 or ] unit-test [ 6 ] [ f 6 or ] unit-test +[ f ] [ 1 2 xor ] unit-test +[ 1 ] [ 1 f xor ] unit-test +[ 2 ] [ f 2 xor ] unit-test +[ f ] [ f f xor ] unit-test [ slip ] must-fail [ ] [ :c ] unit-test diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor index 47e0d76bf7..337fe6c8b0 100755 --- a/core/kernel/kernel.factor +++ b/core/kernel/kernel.factor @@ -173,7 +173,7 @@ GENERIC: boa ( ... class -- tuple ) : or ( obj1 obj2 -- ? ) dupd ? ; inline -: xor ( obj1 obj2 -- ? ) dup not swap ? ; inline +: xor ( obj1 obj2 -- ? ) [ f swap ? ] when* ; inline : both? ( x y quot -- ? ) bi@ and ; inline diff --git a/extra/automata/tags.txt b/extra/24-game/tags.txt similarity index 100% rename from extra/automata/tags.txt rename to extra/24-game/tags.txt diff --git a/extra/boids/tags.txt b/extra/automata/ui/tags.txt similarity index 100% rename from extra/boids/tags.txt rename to extra/automata/ui/tags.txt diff --git a/extra/balloon-bomber/tags.txt b/extra/balloon-bomber/tags.txt index 4717ffd987..dfed6b33f2 100644 --- a/extra/balloon-bomber/tags.txt +++ b/extra/balloon-bomber/tags.txt @@ -1,2 +1,3 @@ +demos games applications diff --git a/extra/boids/ui/tags.txt b/extra/boids/ui/tags.txt new file mode 100644 index 0000000000..cb5fc203e1 --- /dev/null +++ b/extra/boids/ui/tags.txt @@ -0,0 +1 @@ +demos diff --git a/extra/bubble-chamber/tags.txt b/extra/bubble-chamber/tags.txt new file mode 100644 index 0000000000..cb5fc203e1 --- /dev/null +++ b/extra/bubble-chamber/tags.txt @@ -0,0 +1 @@ +demos diff --git a/extra/cfdg/cfdg.factor b/extra/cfdg/cfdg.factor index 2dfa7fae8f..d821b7c180 100644 --- a/extra/cfdg/cfdg.factor +++ b/extra/cfdg/cfdg.factor @@ -3,40 +3,16 @@ USING: kernel alien.c-types combinators namespaces arrays sequences sequences.lib namespaces.lib splitting math math.functions math.vectors math.trig opengl.gl opengl.glu opengl ui ui.gadgets.slate - vars - random-weighted colors.hsv cfdg.gl ; + vars colors self self.slots + random-weighted colors.hsv cfdg.gl accessors ; IN: cfdg ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! hsba { hue saturation brightness alpha } +SELF-SLOTS: hsva -: 4array ; - -VAR: color - -! ( -- val ) - -: hue>> 0 color> nth ; -: saturation>> 1 color> nth ; -: brightness>> 2 color> nth ; -: alpha>> 3 color> nth ; - -! ( val -- ) - -: >>hue 0 color> set-nth ; -: >>saturation 1 color> set-nth ; -: >>brightness 2 color> set-nth ; -: >>alpha 3 color> set-nth ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: hsva>rgba ( hsva -- rgba ) [ 3 head hsv>rgb ] [ peek ] bi suffix ; - -: gl-set-hsba ( hsva -- ) hsva>rgba gl-color ; - -: gl-clear-hsba ( hsva -- ) hsva>rgba gl-clear ; +: clear-color ( color -- ) set-clear-color GL_COLOR_BUFFER_BIT glClear ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -50,18 +26,18 @@ VAR: color ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: hue ( num -- ) hue>> + 360 mod >>hue ; +: hue ( num -- ) hue-> + 360 mod ->hue ; -: saturation ( num -- ) saturation>> swap adjust >>saturation ; -: brightness ( num -- ) brightness>> swap adjust >>brightness ; -: alpha ( num -- ) alpha>> swap adjust >>alpha ; +: saturation ( num -- ) saturation-> swap adjust ->saturation ; +: brightness ( num -- ) value-> swap adjust ->value ; +: alpha ( num -- ) alpha-> swap adjust ->alpha ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: h hue ; -: sat saturation ; -: b brightness ; -: a alpha ; +: h ( num -- ) hue ; +: sat ( num -- ) saturation ; +: b ( num -- ) brightness ; +: a ( num -- ) alpha ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -69,9 +45,9 @@ VAR: color-stack : init-color-stack ( -- ) V{ } clone >color-stack ; -: push-color ( -- ) color> color-stack> push color> clone >color ; +: push-color ( -- ) self> color-stack> push self> clone >self ; -: pop-color ( -- ) color-stack> pop dup >color gl-set-hsba ; +: pop-color ( -- ) color-stack> pop dup >self set-color ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -102,11 +78,11 @@ VAR: threshold ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : circle ( -- ) - color> gl-set-hsba + self> set-color gluNewQuadric dup 0 0.5 20 10 gluDisk gluDeleteQuadric ; : triangle ( -- ) - color> gl-set-hsba + self> set-color GL_POLYGON glBegin 0 0.577 glVertex2d 0.5 -0.289 glVertex2d @@ -114,7 +90,7 @@ VAR: threshold glEnd ; : square ( -- ) - color> gl-set-hsba + self> set-color GL_POLYGON glBegin -0.5 0.5 glVertex2d 0.5 0.5 glVertex2d @@ -138,10 +114,10 @@ VAR: threshold ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: s size ; -: s* size* ; -: r rotate ; -: f flip ; +: s ( scale -- ) size ; +: s* ( scale-x scale-y -- ) size* ; +: r ( angle -- ) rotate ; +: f ( angle -- ) flip ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -162,12 +138,12 @@ VAR: threshold VAR: background -: set-initial-background ( -- ) { 0 0 1 1 } clone >color ; +: set-initial-background ( -- ) T{ hsva f 0 0 1 1 } clone >self ; : set-background ( -- ) set-initial-background background> call - color> gl-clear-hsba ; + self> clear-color ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -177,7 +153,7 @@ VAR: viewport ! { left width bottom height } VAR: start-shape -: set-initial-color ( -- ) { 0 0 0 1 } clone >color ; +: set-initial-color ( -- ) T{ hsva f 0 0 0 1 } clone >self ; : display ( -- ) @@ -198,7 +174,7 @@ VAR: start-shape set-initial-color - color> gl-set-hsba + self> set-color start-shape> call ; diff --git a/extra/cfdg/models/aqua-star/tags.txt b/extra/cfdg/models/aqua-star/tags.txt new file mode 100644 index 0000000000..cb5fc203e1 --- /dev/null +++ b/extra/cfdg/models/aqua-star/tags.txt @@ -0,0 +1 @@ +demos diff --git a/extra/cfdg/models/chiaroscuro/tags.txt b/extra/cfdg/models/chiaroscuro/tags.txt new file mode 100644 index 0000000000..cb5fc203e1 --- /dev/null +++ b/extra/cfdg/models/chiaroscuro/tags.txt @@ -0,0 +1 @@ +demos diff --git a/extra/cfdg/models/flower6/tags.txt b/extra/cfdg/models/flower6/tags.txt new file mode 100644 index 0000000000..cb5fc203e1 --- /dev/null +++ b/extra/cfdg/models/flower6/tags.txt @@ -0,0 +1 @@ +demos diff --git a/extra/cfdg/models/game1-turn6/tags.txt b/extra/cfdg/models/game1-turn6/tags.txt new file mode 100644 index 0000000000..cb5fc203e1 --- /dev/null +++ b/extra/cfdg/models/game1-turn6/tags.txt @@ -0,0 +1 @@ +demos diff --git a/extra/cfdg/models/lesson/tags.txt b/extra/cfdg/models/lesson/tags.txt new file mode 100644 index 0000000000..cb5fc203e1 --- /dev/null +++ b/extra/cfdg/models/lesson/tags.txt @@ -0,0 +1 @@ +demos diff --git a/extra/cfdg/models/rules08/rules08.factor b/extra/cfdg/models/rules08/rules08.factor new file mode 100644 index 0000000000..d14aa04fb1 --- /dev/null +++ b/extra/cfdg/models/rules08/rules08.factor @@ -0,0 +1,63 @@ + +USING: namespaces sequences math random-weighted cfdg ; + +IN: cfdg.models.rules08 + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: insct ( -- ) + [ 1.5 5.5 size* -1 brightness triangle ] do + 10 + [ [ [ 1 0.9 size* -0.15 y 0.05 brightness ] times 1 5 size* triangle ] do ] + each ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +DEFER: line + +: ligne ( -- ) + { + { 1 [ 4.5 y 1.15 0.8 size* -0.3 b line ] do } + { 0.5 [ ] } + } + call-random-weighted ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: line ( -- ) [ insct ligne ] recursive ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: sole ( -- ) + [ + { + { + 1 [ + [ 1 brightness 0.5 saturation ligne ] do + [ 140 r 1 hue sole ] do + ] + } + { 0.01 [ ] } + } + call-random-weighted + ] + recursive ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: centre ( -- ) + [ 1 b 5 s circle ] do + [ sole ] do ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: run ( -- ) + [ -1 b ] >background + { -20 40 -20 40 } viewport set + [ centre ] >start-shape + 0.0001 >threshold + cfdg-window ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +MAIN: run \ No newline at end of file diff --git a/extra/cfdg/models/rules08/tags.txt b/extra/cfdg/models/rules08/tags.txt new file mode 100644 index 0000000000..cb5fc203e1 --- /dev/null +++ b/extra/cfdg/models/rules08/tags.txt @@ -0,0 +1 @@ +demos diff --git a/extra/cfdg/models/sierpinski/tags.txt b/extra/cfdg/models/sierpinski/tags.txt new file mode 100644 index 0000000000..cb5fc203e1 --- /dev/null +++ b/extra/cfdg/models/sierpinski/tags.txt @@ -0,0 +1 @@ +demos diff --git a/extra/cfdg/models/snowflake/tags.txt b/extra/cfdg/models/snowflake/tags.txt new file mode 100644 index 0000000000..cb5fc203e1 --- /dev/null +++ b/extra/cfdg/models/snowflake/tags.txt @@ -0,0 +1 @@ +demos diff --git a/extra/color-picker/color-picker.factor b/extra/color-picker/color-picker.factor index c3214f5bf2..5400a12f89 100755 --- a/extra/color-picker/color-picker.factor +++ b/extra/color-picker/color-picker.factor @@ -4,7 +4,7 @@ USING: kernel math math.functions math.parser models models.filter models.range models.compose sequences ui ui.gadgets ui.gadgets.frames ui.gadgets.labels ui.gadgets.packs ui.gadgets.sliders ui.render math.geometry.rect accessors - ui.gadgets.grids ; + ui.gadgets.grids colors ; IN: color-picker ! Simple example demonstrating the use of models. @@ -23,7 +23,7 @@ M: color-preview model-changed swap model-value over set-gadget-interior relayout-1 ; : ( model -- model ) - [ [ 256 /f ] map 1 suffix ] ; + [ [ 256 /f ] map 1 suffix first4 rgba boa ] ; : ( -- model gadget ) 3 [ 0 0 0 255 ] replicate diff --git a/extra/colors/colors.factor b/extra/colors/colors.factor index ae3695cf8b..77a1f46c87 100644 --- a/extra/colors/colors.factor +++ b/extra/colors/colors.factor @@ -27,8 +27,6 @@ M: hsva >rgba ( hsva -- rgba ) M: gray >rgba ( gray -- rgba ) [ gray>> dup dup ] [ alpha>> ] bi rgba boa ; -M: array >rgba ( array -- rgba ) first4 rgba boa ; - M: color red>> ( color -- red ) >rgba red>> ; M: color green>> ( color -- green ) >rgba green>> ; M: color blue>> ( color -- blue ) >rgba blue>> ; diff --git a/extra/demos/demos.factor b/extra/demos/demos.factor new file mode 100644 index 0000000000..c8e5a35f9e --- /dev/null +++ b/extra/demos/demos.factor @@ -0,0 +1,22 @@ + +USING: kernel fry sequences + vocabs.loader tools.vocabs.browser + ui ui.gadgets ui.gadgets.buttons ui.gadgets.packs ui.gadgets.scrollers + ui.tools.listener + accessors ; + +IN: demos + +: demo-vocabs ( -- seq ) "demos" tagged [ second ] map concat [ name>> ] map ; + +: ( vocab-name -- button ) + dup '[ drop [ , run ] call-listener ] ; + +: ( -- gadget ) + 1 >>fill demo-vocabs [ add-gadget ] each ; + +: demos ( -- ) [ "Demos" open-window ] with-ui ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +MAIN: demos \ No newline at end of file diff --git a/extra/golden-section/golden-section.factor b/extra/golden-section/golden-section.factor index 05e7f68d0a..8d1e6b49d6 100644 --- a/extra/golden-section/golden-section.factor +++ b/extra/golden-section/golden-section.factor @@ -39,16 +39,15 @@ IN: golden-section ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +: ( -- gadget ) + + { 600 600 } >>pdim + { -400 400 } x-range + { -400 400 } y-range + [ golden-section ] >>action ; + : golden-section-window ( -- ) - [ - - { 600 600 } >>pdim - { -400 400 } x-range - { -400 400 } y-range - [ golden-section ] >>action - "Golden Section" open-window - ] - with-ui ; + [ "Golden Section" open-window ] with-ui ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/extra/irc/client/client-tests.factor b/extra/irc/client/client-tests.factor index 100724ea58..e021ff4ff4 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 assocs ; + concurrency.mailboxes classes assocs combinators ; EXCLUDE: irc.messages => join ; RENAME: join irc.messages => join_ IN: irc.client.tests @@ -11,16 +11,16 @@ IN: irc.client.tests "\n" join ; : make-client ( lines -- irc-client ) - "someserver" irc-port "factorbot" f - swap [ 2nip f ] curry >>connect ; + "someserver" irc-port "factorbot" f + swap [ 2nip f ] curry >>connect ; : set-nick ( irc-client nickname -- ) - swap profile>> (>>nickname) ; + swap profile>> (>>nickname) ; -: with-dummy-client ( quot -- ) - rot with-variable ; inline +: with-dummy-client ( irc-client quot -- ) + [ current-irc-client ] dip with-variable ; inline -{ "" } make-client dup "factorbot" set-nick current-irc-client [ +{ "" } make-client dup "factorbot" set-nick [ { t } [ irc> profile>> nickname>> me? ] unit-test { "factorbot" } [ irc> profile>> nickname>> ] unit-test @@ -32,39 +32,144 @@ IN: irc.client.tests { "someuser" } [ ":someuser!n=user@some.where PRIVMSG factorbot :hi" parse-irc-line irc-message-origin ] unit-test -] with-variable +] with-dummy-client ! Test login and nickname set -{ "factorbot" } [ { "NOTICE AUTH :*** Looking up your hostname..." - "NOTICE AUTH :*** Checking ident" - "NOTICE AUTH :*** Found your hostname" - "NOTICE AUTH :*** No identd (auth) response" - ":some.where 001 factorbot :Welcome factorbot" - } make-client - [ connect-irc ] keep 1 seconds sleep - profile>> nickname>> ] unit-test +{ "factorbot" } [ + { "NOTICE AUTH :*** Looking up your hostname..." + "NOTICE AUTH :*** Checking ident" + "NOTICE AUTH :*** Found your hostname" + "NOTICE AUTH :*** No identd (auth) response" + ":some.where 001 factorbot :Welcome factorbot" + } make-client + { [ connect-irc ] + [ drop 0.1 seconds sleep ] + [ profile>> nickname>> ] + [ terminate-irc ] + } cleave ] unit-test { 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>> 1 seconds mailbox-get-timeout - [ class ] [ trailing>> ] bi ] unit-test + { ":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 + { [ "factorbot" set-nick ] + [ connect-irc ] + [ drop 0.1 seconds sleep ] + [ join-messages>> 0.1 seconds mailbox-get-timeout ] + [ terminate-irc ] + } cleave + [ class ] [ trailing>> ] bi ] unit-test { +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 -! ":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 + { ":somebody!n=somebody@some.where JOIN :#factortest" } make-client + { [ "factorbot" set-nick ] + [ listeners>> + [ "#factortest" [ ] keep ] dip set-at ] + [ connect-irc ] + [ listeners>> [ "#factortest" ] dip at + [ read-message drop ] [ read-message drop ] [ read-message ] tri ] + [ terminate-irc ] + } cleave + [ action>> ] [ nick>> ] bi + ] unit-test + +{ privmsg "#factortest" "hello" } [ + { ":somebody!n=somebody@some.where PRIVMSG #factortest :hello" } make-client + { [ "factorbot" set-nick ] + [ listeners>> + [ "#factortest" [ ] keep ] dip set-at ] + [ connect-irc ] + [ listeners>> [ "#factortest" ] dip at + [ read-message drop ] [ read-message ] bi ] + [ terminate-irc ] + } cleave + [ class ] [ name>> ] [ trailing>> ] tri + ] unit-test + +{ privmsg "factorbot" "hello" } [ + { ":somedude!n=user@isp.net PRIVMSG factorbot :hello" } make-client + { [ "factorbot" set-nick ] + [ listeners>> + [ "somedude" [ ] keep ] dip set-at ] + [ connect-irc ] + [ listeners>> [ "somedude" ] dip at + [ read-message drop ] [ read-message ] bi ] + [ terminate-irc ] + } cleave + [ class ] [ name>> ] [ trailing>> ] tri + ] unit-test + +! Participants lists tests +{ H{ { "somedude" +normal+ } } } [ + { ":somedude!n=user@isp.net JOIN :#factortest" } make-client + { [ "factorbot" set-nick ] + [ listeners>> + [ "#factortest" [ ] keep ] dip set-at ] + [ connect-irc ] + [ drop 0.1 seconds sleep ] + [ listeners>> [ "#factortest" ] dip at participants>> ] + [ terminate-irc ] + } cleave + ] unit-test + +{ H{ { "somedude2" +normal+ } } } [ + { ":somedude!n=user@isp.net PART #factortest" } make-client + { [ "factorbot" set-nick ] + [ listeners>> + [ "#factortest" [ + H{ { "somedude2" +normal+ } + { "somedude" +normal+ } } clone >>participants ] keep + ] dip set-at ] + [ connect-irc ] + [ drop 0.1 seconds sleep ] + [ listeners>> [ "#factortest" ] dip at participants>> ] + [ terminate-irc ] + } cleave + ] unit-test + +{ H{ { "somedude2" +normal+ } } } [ + { ":somedude!n=user@isp.net QUIT" } make-client + { [ "factorbot" set-nick ] + [ listeners>> + [ "#factortest" [ + H{ { "somedude2" +normal+ } + { "somedude" +normal+ } } clone >>participants ] keep + ] dip set-at ] + [ connect-irc ] + [ drop 0.1 seconds sleep ] + [ listeners>> [ "#factortest" ] dip at participants>> ] + [ terminate-irc ] + } cleave + ] unit-test + +{ H{ { "somedude2" +normal+ } } } [ + { ":somedude2!n=user2@isp.net KICK #factortest somedude" } make-client + { [ "factorbot" set-nick ] + [ listeners>> + [ "#factortest" [ + H{ { "somedude2" +normal+ } + { "somedude" +normal+ } } clone >>participants ] keep + ] dip set-at ] + [ connect-irc ] + [ drop 0.1 seconds sleep ] + [ listeners>> [ "#factortest" ] dip at participants>> ] + [ terminate-irc ] + } cleave + ] unit-test + +! Namelist notification +{ T{ participant-changed f f f } } [ + { ":ircserver.net 353 factorbot @ #factortest :@factorbot " + ":ircserver.net 366 factorbot #factortest :End of /NAMES list." } make-client + { [ "factorbot" set-nick ] + [ listeners>> + [ "#factortest" [ ] keep ] dip set-at ] + [ connect-irc ] + [ drop 0.1 seconds sleep ] + [ listeners>> [ "#factortest" ] dip at [ read-message drop ] [ read-message ] bi ] + [ 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 405d8ed9ed..813de0f57c 100644 --- a/extra/irc/client/client.factor +++ b/extra/irc/client/client.factor @@ -12,8 +12,6 @@ IN: irc.client ! Setup and running objects ! ====================================== -SYMBOL: current-irc-client - : irc-port 6667 ; ! Default irc port TUPLE: irc-profile server port nickname password ; @@ -51,7 +49,8 @@ SYMBOL: +mode+ irc-server-listener boa ; : ( name -- irc-channel-listener ) - [ ] dip f 60 seconds H{ } clone irc-channel-listener boa ; + [ ] dip f 60 seconds H{ } clone + irc-channel-listener boa ; : ( name -- irc-nick-listener ) [ ] dip irc-nick-listener boa ; @@ -63,19 +62,24 @@ SYMBOL: +mode+ TUPLE: participant-changed nick action ; C: participant-changed +SINGLETON: irc-listener-end ! send to a listener to stop its execution 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 UNION: irc-broadcasted-message irc-end irc-disconnected irc-connected ; : terminate-irc ( irc-client -- ) - [ [ irc-end ] dip in-messages>> mailbox-put ] - [ [ f ] dip (>>is-running) ] - [ stream>> dispose ] - tri ; + [ is-running>> ] keep and [ + [ [ irc-end ] dip in-messages>> mailbox-put ] + [ [ f ] dip (>>is-running) ] + [ stream>> dispose ] + tri + ] when* ; stream-write ; : irc-print ( s -- ) irc-stream> [ stream-print ] keep stream-flush ; : listener> ( name -- listener/f ) irc> listeners>> at ; -: unregister-listener ( name -- ) irc> listeners>> delete-at ; + +: maybe-mailbox-get ( mailbox quot: ( irc-message -- ) -- ) + [ dup mailbox-empty? [ drop yield ] ] dip '[ mailbox-get @ ] if ; inline GENERIC: to-listener ( message obj -- ) @@ -93,6 +99,12 @@ M: string to-listener ( message string -- ) listener> [ +server-listener+ listener> ] unless* [ to-listener ] [ drop ] if* ; +: unregister-listener ( name -- ) + irc> listeners>> + [ at [ irc-listener-end ] dip to-listener ] + [ delete-at ] + 2bi ; + M: irc-listener to-listener ( message irc-listener -- ) in-messages>> mailbox-put ; @@ -105,7 +117,7 @@ M: irc-listener to-listener ( message irc-listener -- ) with filter ; : remove-participant-from-all ( nick -- ) - dup listeners-with-participant [ delete-at ] with each ; + dup listeners-with-participant [ participants>> delete-at ] with each ; : add-participant ( mode nick channel -- ) listener> [ participants>> set-at ] [ 2drop ] if* ; @@ -206,9 +218,9 @@ M: privmsg handle-incoming-irc ( privmsg -- ) dup irc-message-origin to-listener ; M: join handle-incoming-irc ( join -- ) - { [ maybe-forward-join ] ! keep + { [ maybe-forward-join ] [ dup trailing>> to-listener ] - [ [ drop f ] [ prefix>> parse-name ] [ trailing>> ] tri add-participant ] + [ [ drop +normal+ ] [ prefix>> parse-name ] [ trailing>> ] tri add-participant ] [ handle-participant-change ] } cleave ; @@ -219,19 +231,18 @@ M: part handle-incoming-irc ( part -- ) tri ; M: kick handle-incoming-irc ( kick -- ) - { [ dup channel>> to-listener ] + { [ 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 -- ) - { [ 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 ; + [ dup prefix>> parse-name listeners-with-participant + [ to-listener ] with each ] + [ prefix>> parse-name remove-participant-from-all ] + [ handle-participant-change ] + tri ; : >nick/mode ( string -- nick mode ) dup first "+@" member? [ unclip ] [ 0 ] if participant-mode ; @@ -241,8 +252,10 @@ M: quit handle-incoming-irc ( quit -- ) [ >nick/mode 2array ] map >hashtable ; M: names-reply handle-incoming-irc ( names-reply -- ) - [ names-reply>participants ] [ channel>> listener> ] bi - [ (>>participants) ] [ drop ] if* ; + [ names-reply>participants ] [ channel>> listener> ] bi [ + [ (>>participants) ] + [ [ f f ] dip name>> to-listener ] bi + ] [ drop ] if* ; M: irc-broadcasted-message handle-incoming-irc ( irc-broadcasted-message -- ) broadcast-message-to-listeners ; @@ -256,12 +269,6 @@ GENERIC: handle-outgoing-irc ( obj -- ) M: irc-message handle-outgoing-irc ( irc-message -- ) irc-message>client-line irc-print ; -M: privmsg handle-outgoing-irc ( privmsg -- ) - [ name>> ] [ trailing>> ] bi /PRIVMSG ; - -M: part handle-outgoing-irc ( part -- ) - [ channel>> ] [ trailing>> "" or ] bi /PART ; - ! ====================================== ! Reader/Writer ! ====================================== @@ -273,7 +280,7 @@ DEFER: (connect-irc) : (handle-disconnect) ( -- ) irc> - [ [ irc-disconnected ] dip to-listener ] + [ [ irc-disconnected ] dip in-messages>> mailbox-put ] [ dup reconnect-time>> sleep (connect-irc) ] [ profile>> nickname>> /LOGIN ] tri ; @@ -291,35 +298,37 @@ DEFER: (connect-irc) ] if* ] with-destructors ; -: reader-loop ( -- ) - [ (reader-loop) ] [ handle-disconnect ] recover ; +: reader-loop ( -- ? ) + [ (reader-loop) ] [ handle-disconnect ] recover t ; -: writer-loop ( -- ) - irc> out-messages>> mailbox-get handle-outgoing-irc ; +: writer-loop ( -- ? ) + irc> out-messages>> [ handle-outgoing-irc ] maybe-mailbox-get t ; ! ====================================== ! Processing loops ! ====================================== -: in-multiplexer-loop ( -- ) - irc> in-messages>> mailbox-get handle-incoming-irc ; +: in-multiplexer-loop ( -- ? ) + irc> in-messages>> [ handle-incoming-irc ] maybe-mailbox-get t ; : strings>privmsg ( name string -- privmsg ) privmsg new [ (>>trailing) ] keep [ (>>name) ] keep ; : maybe-annotate-with-name ( name obj -- obj ) - { - { [ dup string? ] [ strings>privmsg ] } - { [ dup privmsg instance? ] [ swap >>name ] } - [ nip ] + { { [ dup string? ] [ strings>privmsg ] } + { [ dup privmsg instance? ] [ swap >>name ] } + [ nip ] } cond ; -: listener-loop ( name listener -- ) - out-messages>> mailbox-get maybe-annotate-with-name - irc> out-messages>> mailbox-put ; +: listener-loop ( name -- ? ) + dup listener> [ + out-messages>> [ maybe-annotate-with-name + irc> out-messages>> mailbox-put ] with + maybe-mailbox-get t + ] [ drop f ] if* ; -: spawn-irc-loop ( quot name -- ) - [ '[ irc> is-running>> [ @ ] when irc> is-running>> ] ] dip +: spawn-irc-loop ( quot: ( -- ? ) name -- ) + [ '[ irc> is-running>> [ @ ] [ f ] if ] ] dip spawn-server drop ; : spawn-irc ( -- ) @@ -332,9 +341,8 @@ DEFER: (connect-irc) ! ====================================== : set+run-listener ( name irc-listener -- ) - [ '[ , , listener-loop ] "listener" spawn-irc-loop ] - [ swap irc> listeners>> set-at ] - 2bi ; + over irc> listeners>> set-at + '[ , listener-loop ] "listener" spawn-irc-loop ; GENERIC: (add-listener) ( irc-listener -- ) @@ -371,16 +379,15 @@ M: irc-server-listener (remove-listener) ( irc-server-listener -- ) t >>is-running in-messages>> [ irc-connected ] dip mailbox-put ; -: with-irc-client ( irc-client quot -- ) +: with-irc-client ( irc-client quot: ( -- ) -- ) [ current-irc-client ] dip with-variable ; inline PRIVATE> : connect-irc ( irc-client -- ) - dup [ - [ (connect-irc) ] [ profile>> nickname>> /LOGIN ] bi - spawn-irc - ] with-irc-client ; + [ irc> + [ (connect-irc) ] [ profile>> nickname>> /LOGIN ] bi + spawn-irc ] with-irc-client ; : add-listener ( irc-listener irc-client -- ) swap '[ , (add-listener) ] with-irc-client ; diff --git a/extra/irc/messages/messages-tests.factor b/extra/irc/messages/messages-tests.factor index 1bd6088f82..7ee0f41ab0 100644 --- a/extra/irc/messages/messages-tests.factor +++ b/extra/irc/messages/messages-tests.factor @@ -35,3 +35,23 @@ join new [ ":someuser!n=user@some.where JOIN :#factortest" parse-irc-line f >>timestamp ] unit-test +mode new + ":ircserver.net MODE #factortest +ns" >>line + "ircserver.net" >>prefix + "MODE" >>command + { "#factortest" "+ns" } >>parameters + "#factortest" >>channel + "+ns" >>mode +1array +[ ":ircserver.net MODE #factortest +ns" + parse-irc-line f >>timestamp ] unit-test + +nick new + ":someuser!n=user@some.where NICK :someuser2" >>line + "someuser!n=user@some.where" >>prefix + "NICK" >>command + { } >>parameters + "someuser2" >>trailing +1array +[ ":someuser!n=user@some.where NICK :someuser2" + parse-irc-line f >>timestamp ] unit-test \ No newline at end of file diff --git a/extra/irc/messages/messages.factor b/extra/irc/messages/messages.factor index 5813c72723..3b9cf0af2c 100644 --- a/extra/irc/messages/messages.factor +++ b/extra/irc/messages/messages.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Bruno Deferrari ! See http://factorcode.org/license.txt for BSD license. USING: kernel fry splitting ascii calendar accessors combinators qualified - arrays classes.tuple math.order ; + arrays classes.tuple math.order quotations ; RENAME: join sequences => sjoin EXCLUDE: sequences => join ; IN: irc.messages @@ -12,12 +12,13 @@ TUPLE: ping < irc-message ; TUPLE: join < irc-message ; TUPLE: part < irc-message channel ; TUPLE: quit < irc-message ; +TUPLE: nick < irc-message ; TUPLE: privmsg < irc-message name ; TUPLE: kick < irc-message channel who ; TUPLE: roomlist < irc-message channel names ; TUPLE: nick-in-use < irc-message asterisk name ; TUPLE: notice < irc-message type ; -TUPLE: mode < irc-message name channel mode ; +TUPLE: mode < irc-message channel mode ; TUPLE: names-reply < irc-message who = channel ; TUPLE: unhandled < irc-message ; @@ -25,12 +26,44 @@ TUPLE: unhandled < irc-message ; irc-message new now >>timestamp [ [ (>>trailing) ] [ (>>parameters) ] [ (>>command) ] tri ] keep ; +> ; +M: ping irc-command-string ( ping -- string ) drop "PING" ; +M: join irc-command-string ( join -- string ) drop "JOIN" ; +M: part irc-command-string ( part -- string ) drop "PART" ; +M: quit irc-command-string ( quit -- string ) drop "QUIT" ; +M: nick irc-command-string ( nick -- string ) drop "NICK" ; +M: privmsg irc-command-string ( privmsg -- string ) drop "PRIVMSG" ; +M: notice irc-command-string ( notice -- string ) drop "NOTICE" ; +M: mode irc-command-string ( mode -- string ) drop "MODE" ; +M: kick irc-command-string ( kick -- string ) drop "KICK" ; + +GENERIC: irc-command-parameters ( irc-message -- seq ) + +M: irc-message irc-command-parameters ( irc-message -- seq ) parameters>> ; +M: ping irc-command-parameters ( ping -- seq ) drop { } ; +M: join irc-command-parameters ( join -- seq ) drop { } ; +M: part irc-command-parameters ( part -- seq ) name>> 1array ; +M: quit irc-command-parameters ( quit -- seq ) drop { } ; +M: nick irc-command-parameters ( nick -- seq ) drop { } ; +M: privmsg irc-command-parameters ( privmsg -- seq ) name>> 1array ; +M: notice irc-command-parameters ( norice -- seq ) type>> 1array ; +M: kick irc-command-parameters ( kick -- seq ) + [ channel>> ] [ who>> ] bi 2array ; +M: mode irc-command-parameters ( mode -- seq ) + [ name>> ] [ channel>> ] [ mode>> ] tri 3array ; + +PRIVATE> + GENERIC: irc-message>client-line ( irc-message -- string ) M: irc-message irc-message>client-line ( irc-message -- string ) - [ command>> ] - [ parameters>> " " sjoin ] - [ trailing>> dup [ CHAR: : prefix ] when ] + [ irc-command-string ] + [ irc-command-parameters " " sjoin ] + [ trailing>> [ CHAR: : prefix ] [ "" ] if* ] tri 3array " " sjoin ; GENERIC: irc-message>server-line ( irc-message -- string ) @@ -73,19 +106,20 @@ PRIVATE> : parse-irc-line ( string -- message ) string>irc-message dup command>> { - { "PING" [ \ ping ] } - { "NOTICE" [ \ notice ] } - { "001" [ \ logged-in ] } - { "433" [ \ nick-in-use ] } - { "353" [ \ names-reply ] } - { "JOIN" [ \ join ] } - { "PART" [ \ part ] } - { "PRIVMSG" [ \ privmsg ] } - { "QUIT" [ \ quit ] } - { "MODE" [ \ mode ] } - { "KICK" [ \ kick ] } - [ drop \ unhandled ] + { "PING" [ ping ] } + { "NOTICE" [ notice ] } + { "001" [ logged-in ] } + { "433" [ nick-in-use ] } + { "353" [ names-reply ] } + { "JOIN" [ join ] } + { "PART" [ part ] } + { "NICK" [ nick ] } + { "PRIVMSG" [ privmsg ] } + { "QUIT" [ quit ] } + { "MODE" [ mode ] } + { "KICK" [ kick ] } + [ drop unhandled ] } case [ [ tuple-slots ] [ parameters>> ] bi append ] dip - [ all-slots over [ length ] bi@ min head ] keep slots>tuple ; - + [ all-slots over [ length ] bi@ min head >quotation ] keep + '[ @ , boa nip ] call ; diff --git a/extra/irc/ui/ui.factor b/extra/irc/ui/ui.factor index 9b8d1a4d11..662fca6d79 100755 --- a/extra/irc/ui/ui.factor +++ b/extra/irc/ui/ui.factor @@ -5,10 +5,12 @@ 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 ui.gadgets.lists ui.gadgets.labels - io io.styles namespaces calendar calendar.format models + 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 ; + irc.ui.commandparser irc.ui.load qualified ; + +RENAME: join sequences => sjoin IN: irc.ui @@ -18,7 +20,7 @@ SYMBOL: client TUPLE: ui-window client tabs ; -TUPLE: irc-tab < frame listener client listmodel ; +TUPLE: irc-tab < frame listener client userlist ; : write-color ( str color -- ) foreground associate format ; @@ -37,12 +39,20 @@ TUPLE: irc-tab < frame listener client listmodel ; GENERIC: write-irc ( irc-message -- ) +M: ping write-irc + drop "* Ping" blue write-color ; + M: privmsg write-irc "<" blue write-color [ prefix>> parse-name write ] keep "> " blue write-color trailing>> write ; +M: notice write-irc + [ type>> blue write-color ] keep + ": " blue write-color + trailing>> write ; + TUPLE: own-message message nick timestamp ; : ( message nick -- own-message ) @@ -71,14 +81,21 @@ M: quit write-irc " has left IRC" red write-color trailing>> dot-or-parens red write-color ; +: full-mode ( message -- mode ) + parameters>> rest " " sjoin ; + M: mode write-irc "* " blue write-color - [ name>> write ] keep + [ prefix>> parse-name write ] keep " has applied mode " blue write-color - [ mode>> write ] keep + [ full-mode write ] keep " to " blue write-color channel>> write ; +M: unhandled write-irc + "UNHANDLED: " write + line>> blue write-color ; + M: irc-end write-irc drop "* You have left IRC" red write-color ; @@ -88,11 +105,17 @@ M: irc-disconnected write-irc M: irc-connected write-irc drop "* Connected" green write-color ; +M: irc-listener-end write-irc + drop ; + M: irc-message write-irc drop ; ! catch all unimplemented writes, THIS WILL CHANGE +: time-happened ( irc-message -- timestamp ) + [ timestamp>> ] [ 2drop now ] recover ; + : print-irc ( irc-message -- ) - [ timestamp>> timestamp>hms write " " write ] + [ time-happened timestamp>hms write " " write ] [ write-irc nl ] bi ; : send-message ( message -- ) @@ -101,16 +124,15 @@ M: irc-message write-irc GENERIC: handle-inbox ( tab message -- ) -: filter-participants ( assoc val -- alist ) - [ >alist ] dip - '[ second , = ] filter ; +: filter-participants ( pack alist val color -- pack ) + '[ , = [