From 07c38a867df3177fa9abe96e16ec76ab04e69c82 Mon Sep 17 00:00:00 2001 From: "U-WSCHLIEP-PC\\wschliep" Date: Thu, 10 Jul 2008 02:38:48 -0400 Subject: [PATCH] Added extra/irc/ui and extra/ui/gadgets/tabs --- extra/irc/ui/authors.txt | 1 + extra/irc/ui/summary.txt | 1 + extra/irc/ui/ui.factor | 130 ++++++++++++++++++++++++++++++ extra/ui/gadgets/tabs/authors.txt | 1 + extra/ui/gadgets/tabs/summary.txt | 1 + extra/ui/gadgets/tabs/tabs.factor | 51 ++++++++++++ 6 files changed, 185 insertions(+) create mode 100755 extra/irc/ui/authors.txt create mode 100755 extra/irc/ui/summary.txt create mode 100755 extra/irc/ui/ui.factor create mode 100755 extra/ui/gadgets/tabs/authors.txt create mode 100755 extra/ui/gadgets/tabs/summary.txt create mode 100755 extra/ui/gadgets/tabs/tabs.factor diff --git a/extra/irc/ui/authors.txt b/extra/irc/ui/authors.txt new file mode 100755 index 0000000000..50c9c38812 --- /dev/null +++ b/extra/irc/ui/authors.txt @@ -0,0 +1 @@ +William Schlieper \ No newline at end of file diff --git a/extra/irc/ui/summary.txt b/extra/irc/ui/summary.txt new file mode 100755 index 0000000000..284672b951 --- /dev/null +++ b/extra/irc/ui/summary.txt @@ -0,0 +1 @@ +A simple IRC client \ No newline at end of file diff --git a/extra/irc/ui/ui.factor b/extra/irc/ui/ui.factor new file mode 100755 index 0000000000..ef2bfd3d55 --- /dev/null +++ b/extra/irc/ui/ui.factor @@ -0,0 +1,130 @@ +! Copyright (C) 2008 William Schlieper +! See http://factorcode.org/license.txt for BSD license. + +USING: accessors kernel threads combinators concurrency.mailboxes + sequences strings hashtables splitting fry assocs hashtables + ui ui.gadgets.panes ui.gadgets.editors ui.gadgets.scrollers + ui.commands ui.gadgets.frames ui.gestures ui.gadgets.tabs + io io.styles namespaces irc.client irc.messages ; + +IN: irc.ui + +SYMBOL: client + +TUPLE: ui-window client tabs ; + +: write-color ( str color -- ) + foreground associate format ; +: red { 0.5 0 0 1 } ; +: green { 0 0.5 0 1 } ; +: blue { 0 0 1 1 } ; + +: prefix>nick ( prefix -- nick ) + "!" split first ; + +GENERIC: write-irc ( irc-message -- ) + +M: privmsg write-irc + "<" blue write-color + [ prefix>> prefix>nick write ] keep + ">" blue write-color + " " write + trailing>> write ; + +M: join write-irc + "* " green write-color + prefix>> prefix>nick write + " has entered the channel." green write-color ; + +M: part write-irc + "* " red write-color + [ prefix>> prefix>nick write ] keep + " has left the channel(" red write-color + trailing>> write + ")" red write-color ; + +M: quit write-irc + "* " red write-color + [ prefix>> prefix>nick write ] keep + " has left IRC(" red write-color + trailing>> write + ")" red write-color ; + +M: irc-end write-irc + drop "* You have left IRC" red write-color ; + +M: irc-disconnected write-irc + drop "* Disconnected" red write-color ; + +M: irc-connected write-irc + drop "* Connected" green write-color ; + +M: irc-message write-irc + drop ; ! catch all unimplemented writes, THIS WILL CHANGE + +: print-irc ( irc-message -- ) + write-irc nl ; + +: send-message ( message listener client -- ) + "<" blue write-color + profile>> nickname>> bold font-style associate format + ">" blue write-color + " " write + over write nl + out-messages>> mailbox-put ; + +: display ( stream listener -- ) + '[ , [ [ t ] + [ , read-message print-irc ] + [ ] while ] with-output-stream ] "ircv" spawn drop ; + +: ( listener -- pane ) + + [ swap display ] keep ; + +TUPLE: irc-editor outstream listener client ; + +: ( pane listener client -- editor ) + [ irc-editor construct-editor + swap >>listener swap >>outstream + ] dip client>> >>client ; + +: editor-send ( irc-editor -- ) + { [ outstream>> ] + [ editor-string ] + [ listener>> ] + [ client>> ] + [ "" swap set-editor-string ] } cleave + '[ , , , send-message ] with-output-stream ; + +irc-editor "general" f { + { T{ key-down f f "RET" } editor-send } + { T{ key-down f f "ENTER" } editor-send } +} define-command-map + +: irc-page ( name pane editor tabbed -- ) + [ [ @bottom frame, ! editor + @center frame, ! pane + ] make-frame swap ] dip add-page ; + +: join-channel ( name ui-window -- ) + [ dup ] dip + [ client>> add-listener ] + [ drop dup ] + [ [ ] keep ] 2tri + tabs>> irc-page ; + +: irc-window ( ui-window -- ) + [ tabs>> ] + [ client>> profile>> server>> ] bi + open-window ; + +: ui-connect ( profile -- ui-window ) + ui-window new over >>client swap + [ connect-irc ] + [ listeners>> +server-listener+ swap at + "Server" associate >>tabs ] bi ; + +: freenode-connect ( -- ui-window ) + "irc.freenode.org" 8001 "factor-irc" f + ui-connect [ irc-window ] keep ; diff --git a/extra/ui/gadgets/tabs/authors.txt b/extra/ui/gadgets/tabs/authors.txt new file mode 100755 index 0000000000..50c9c38812 --- /dev/null +++ b/extra/ui/gadgets/tabs/authors.txt @@ -0,0 +1 @@ +William Schlieper \ No newline at end of file diff --git a/extra/ui/gadgets/tabs/summary.txt b/extra/ui/gadgets/tabs/summary.txt new file mode 100755 index 0000000000..a55610bcc0 --- /dev/null +++ b/extra/ui/gadgets/tabs/summary.txt @@ -0,0 +1 @@ +Tabbed windows \ No newline at end of file diff --git a/extra/ui/gadgets/tabs/tabs.factor b/extra/ui/gadgets/tabs/tabs.factor new file mode 100755 index 0000000000..113ea84443 --- /dev/null +++ b/extra/ui/gadgets/tabs/tabs.factor @@ -0,0 +1,51 @@ +! Copyright (C) 2008 William Schlieper +! See http://factorcode.org/license.txt for BSD license. + +USING: accessors kernel fry math math.vectors sequences arrays vectors assocs + hashtables models models.range models.compose combinators + ui ui.gadgets ui.gadgets.buttons ui.gadgets.frames ui.gadgets.packs + ui.gadgets.incremental ui.gadgets.viewports ui.gadgets.books ; + +IN: ui.gadgets.tabs + +TUPLE: tabbed names model toggler content ; + +DEFER: (del-page) + +: add-toggle ( model n name toggler -- ) + [ [ gadget-parent '[ , , , (del-page) ] "X" swap + @right frame, ] 3keep + [ swapd @center frame, ] dip ] make-frame + swap add-gadget ; + +: redo-toggler ( tabbed -- ) + [ names>> ] [ model>> ] [ toggler>> ] tri + [ clear-gadget ] keep + [ [ length ] keep ] 2dip + '[ , _ _ , add-toggle ] 2each ; + +: (del-page) ( n name tabbed -- ) + { [ [ remove ] change-names redo-toggler ] + [ [ names>> length ] [ model>> ] bi + [ [ = ] keep swap [ 1- ] when + [ > ] keep swap [ 1- ] when dup ] change-model ] + [ content>> nth-gadget unparent ] + [ model>> [ ] change-model ] ! refresh + } cleave ; + +: add-page ( page name tabbed -- ) + [ names>> push ] 2keep + [ [ model>> swap ] + [ names>> length 1 - swap ] + [ toggler>> ] tri add-toggle ] + [ content>> add-gadget ] bi ; + +: del-page ( name tabbed -- ) + [ names>> index ] 2keep (del-page) ; + +: ( assoc -- tabbed ) + tabbed new + [ 1 >>fill g-> (>>toggler) @left frame, + [ keys >vector g (>>names) ] + [ values 0 [ g-> (>>content) @center frame, ] keep ] bi + g swap >>model redo-toggler ] build-frame ;