--- /dev/null
+! Copyright (C) 2008 William Schlieper\r
+! See http://factorcode.org/license.txt for BSD license.\r
+\r
+USING: accessors kernel threads combinators concurrency.mailboxes\r
+ sequences strings hashtables splitting fry assocs hashtables\r
+ ui ui.gadgets.panes ui.gadgets.editors ui.gadgets.scrollers\r
+ ui.commands ui.gadgets.frames ui.gestures ui.gadgets.tabs\r
+ io io.styles namespaces irc.client irc.messages ;\r
+\r
+IN: irc.ui\r
+\r
+SYMBOL: client\r
+\r
+TUPLE: ui-window client tabs ;\r
+\r
+: write-color ( str color -- )\r
+ foreground associate format ;\r
+: red { 0.5 0 0 1 } ;\r
+: green { 0 0.5 0 1 } ;\r
+: blue { 0 0 1 1 } ;\r
+\r
+: prefix>nick ( prefix -- nick )\r
+ "!" split first ;\r
+\r
+GENERIC: write-irc ( irc-message -- )\r
+\r
+M: privmsg write-irc\r
+ "<" blue write-color\r
+ [ prefix>> prefix>nick write ] keep\r
+ ">" blue write-color\r
+ " " write\r
+ trailing>> write ;\r
+\r
+M: join write-irc\r
+ "* " green write-color\r
+ prefix>> prefix>nick write\r
+ " has entered the channel." green write-color ;\r
+\r
+M: part write-irc\r
+ "* " red write-color\r
+ [ prefix>> prefix>nick write ] keep\r
+ " has left the channel(" red write-color\r
+ trailing>> write\r
+ ")" red write-color ;\r
+\r
+M: quit write-irc\r
+ "* " red write-color\r
+ [ prefix>> prefix>nick write ] keep\r
+ " has left IRC(" red write-color\r
+ trailing>> write\r
+ ")" red write-color ;\r
+\r
+M: irc-end write-irc\r
+ drop "* You have left IRC" red write-color ;\r
+\r
+M: irc-disconnected write-irc\r
+ drop "* Disconnected" red write-color ;\r
+\r
+M: irc-connected write-irc\r
+ drop "* Connected" green write-color ;\r
+\r
+M: irc-message write-irc\r
+ drop ; ! catch all unimplemented writes, THIS WILL CHANGE \r
+\r
+: print-irc ( irc-message -- )\r
+ write-irc nl ;\r
+\r
+: send-message ( message listener client -- )\r
+ "<" blue write-color\r
+ profile>> nickname>> bold font-style associate format\r
+ ">" blue write-color\r
+ " " write\r
+ over write nl\r
+ out-messages>> mailbox-put ;\r
+\r
+: display ( stream listener -- )\r
+ '[ , [ [ t ]\r
+ [ , read-message print-irc ]\r
+ [ ] while ] with-output-stream ] "ircv" spawn drop ;\r
+\r
+: <irc-pane> ( listener -- pane )\r
+ <scrolling-pane>\r
+ [ <pane-stream> swap display ] keep ;\r
+\r
+TUPLE: irc-editor outstream listener client ;\r
+\r
+: <irc-editor> ( pane listener client -- editor )\r
+ [ <editor> irc-editor construct-editor\r
+ swap >>listener swap <pane-stream> >>outstream\r
+ ] dip client>> >>client ;\r
+\r
+: editor-send ( irc-editor -- )\r
+ { [ outstream>> ]\r
+ [ editor-string ]\r
+ [ listener>> ]\r
+ [ client>> ]\r
+ [ "" swap set-editor-string ] } cleave\r
+ '[ , , , send-message ] with-output-stream ;\r
+\r
+irc-editor "general" f {\r
+ { T{ key-down f f "RET" } editor-send }\r
+ { T{ key-down f f "ENTER" } editor-send }\r
+} define-command-map\r
+\r
+: irc-page ( name pane editor tabbed -- )\r
+ [ [ <scroller> @bottom frame, ! editor\r
+ <scroller> @center frame, ! pane\r
+ ] make-frame swap ] dip add-page ;\r
+\r
+: join-channel ( name ui-window -- )\r
+ [ dup <irc-channel-listener> ] dip\r
+ [ client>> add-listener ]\r
+ [ drop <irc-pane> dup ]\r
+ [ [ <irc-editor> ] keep ] 2tri\r
+ tabs>> irc-page ;\r
+\r
+: irc-window ( ui-window -- )\r
+ [ tabs>> ]\r
+ [ client>> profile>> server>> ] bi\r
+ open-window ;\r
+\r
+: ui-connect ( profile -- ui-window )\r
+ <irc-client> ui-window new over >>client swap\r
+ [ connect-irc ]\r
+ [ listeners>> +server-listener+ swap at <irc-pane> <scroller>\r
+ "Server" associate <tabbed> >>tabs ] bi ;\r
+\r
+: freenode-connect ( -- ui-window )\r
+ "irc.freenode.org" 8001 "factor-irc" f\r
+ <irc-profile> ui-connect [ irc-window ] keep ;\r
--- /dev/null
+! Copyright (C) 2008 William Schlieper\r
+! See http://factorcode.org/license.txt for BSD license.\r
+\r
+USING: accessors kernel fry math math.vectors sequences arrays vectors assocs\r
+ hashtables models models.range models.compose combinators\r
+ ui ui.gadgets ui.gadgets.buttons ui.gadgets.frames ui.gadgets.packs\r
+ ui.gadgets.incremental ui.gadgets.viewports ui.gadgets.books ;\r
+\r
+IN: ui.gadgets.tabs\r
+\r
+TUPLE: tabbed names model toggler content ;\r
+\r
+DEFER: (del-page)\r
+\r
+: add-toggle ( model n name toggler -- )\r
+ [ [ gadget-parent '[ , , , (del-page) ] "X" swap\r
+ <bevel-button> @right frame, ] 3keep \r
+ [ swapd <toggle-button> @center frame, ] dip ] make-frame\r
+ swap add-gadget ;\r
+\r
+: redo-toggler ( tabbed -- )\r
+ [ names>> ] [ model>> ] [ toggler>> ] tri\r
+ [ clear-gadget ] keep\r
+ [ [ length ] keep ] 2dip\r
+ '[ , _ _ , add-toggle ] 2each ;\r
+\r
+: (del-page) ( n name tabbed -- )\r
+ { [ [ remove ] change-names redo-toggler ]\r
+ [ [ names>> length ] [ model>> ] bi\r
+ [ [ = ] keep swap [ 1- ] when\r
+ [ > ] keep swap [ 1- ] when dup ] change-model ]\r
+ [ content>> nth-gadget unparent ]\r
+ [ model>> [ ] change-model ] ! refresh\r
+ } cleave ;\r
+\r
+: add-page ( page name tabbed -- )\r
+ [ names>> push ] 2keep\r
+ [ [ model>> swap ]\r
+ [ names>> length 1 - swap ]\r
+ [ toggler>> ] tri add-toggle ]\r
+ [ content>> add-gadget ] bi ;\r
+\r
+: del-page ( name tabbed -- )\r
+ [ names>> index ] 2keep (del-page) ;\r
+\r
+: <tabbed> ( assoc -- tabbed )\r
+ tabbed new\r
+ [ <pile> 1 >>fill g-> (>>toggler) @left frame,\r
+ [ keys >vector g (>>names) ]\r
+ [ values 0 <model> [ <book> g-> (>>content) @center frame, ] keep ] bi\r
+ g swap >>model redo-toggler ] build-frame ;\r