Added extra/irc/ui and extra/ui/gadgets/tabs

db4
U-WSCHLIEP-PC\wschliep 2008-07-10 02:38:48 -04:00
parent 57e13c5b65
commit 07c38a867d
6 changed files with 185 additions and 0 deletions

1
extra/irc/ui/authors.txt Executable file
View File

@ -0,0 +1 @@
William Schlieper

1
extra/irc/ui/summary.txt Executable file
View File

@ -0,0 +1 @@
A simple IRC client

130
extra/irc/ui/ui.factor Executable file
View File

@ -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 ;
: <irc-pane> ( listener -- pane )
<scrolling-pane>
[ <pane-stream> swap display ] keep ;
TUPLE: irc-editor outstream listener client ;
: <irc-editor> ( pane listener client -- editor )
[ <editor> irc-editor construct-editor
swap >>listener swap <pane-stream> >>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 -- )
[ [ <scroller> @bottom frame, ! editor
<scroller> @center frame, ! pane
] make-frame swap ] dip add-page ;
: join-channel ( name ui-window -- )
[ dup <irc-channel-listener> ] dip
[ client>> add-listener ]
[ drop <irc-pane> dup ]
[ [ <irc-editor> ] keep ] 2tri
tabs>> irc-page ;
: irc-window ( ui-window -- )
[ tabs>> ]
[ client>> profile>> server>> ] bi
open-window ;
: ui-connect ( profile -- ui-window )
<irc-client> ui-window new over >>client swap
[ connect-irc ]
[ listeners>> +server-listener+ swap at <irc-pane> <scroller>
"Server" associate <tabbed> >>tabs ] bi ;
: freenode-connect ( -- ui-window )
"irc.freenode.org" 8001 "factor-irc" f
<irc-profile> ui-connect [ irc-window ] keep ;

View File

@ -0,0 +1 @@
William Schlieper

View File

@ -0,0 +1 @@
Tabbed windows

View File

@ -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
<bevel-button> @right frame, ] 3keep
[ swapd <toggle-button> @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) ;
: <tabbed> ( assoc -- tabbed )
tabbed new
[ <pile> 1 >>fill g-> (>>toggler) @left frame,
[ keys >vector g (>>names) ]
[ values 0 <model> [ <book> g-> (>>content) @center frame, ] keep ] bi
g swap >>model redo-toggler ] build-frame ;