diff options
Diffstat (limited to 'ui/gadgets/tabs/tabs.factor')
-rw-r--r-- | ui/gadgets/tabs/tabs.factor | 62 |
1 files changed, 62 insertions, 0 deletions
diff --git a/ui/gadgets/tabs/tabs.factor b/ui/gadgets/tabs/tabs.factor new file mode 100644 index 0000000..d05890c --- /dev/null +++ b/ui/gadgets/tabs/tabs.factor @@ -0,0 +1,62 @@ +! 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.product combinators + ui ui.gadgets ui.gadgets.buttons ui.gadgets.frames ui.gadgets.packs + ui.gadgets.grids ui.gadgets.viewports ui.gadgets.books locals ; + +IN: ui.gadgets.tabs + +TUPLE: tabbed < frame names toggler content ; + +DEFER: (del-page) + +:: add-toggle ( n name model toggler -- ) + <frame> + n name toggler parent>> '[ drop _ _ _ (del-page) ] "X" swap <bevel-button> + @right grid-add + n model name <toggle-button> @center grid-add + toggler swap add-gadget drop ; + +: redo-toggler ( tabbed -- ) + [ names>> ] [ model>> ] [ toggler>> ] tri + [ clear-gadget ] keep + [ [ length ] keep ] 2dip + '[ _ _ add-toggle ] 2each ; + +: refresh-book ( tabbed -- ) + model>> [ ] change-model ; + +: (del-page) ( n name tabbed -- ) + { [ [ remove ] change-names redo-toggler ] + [ dupd [ names>> length ] [ model>> ] bi + [ [ = ] keep swap [ 1- ] when + [ < ] keep swap [ 1- ] when ] change-model ] + [ content>> nth-gadget unparent ] + [ refresh-book ] + } cleave ; + +: add-page ( page name tabbed -- ) + [ names>> push ] 2keep + [ [ names>> length 1 - swap ] + [ model>> ] + [ toggler>> ] tri add-toggle ] + [ content>> swap add-gadget drop ] + [ refresh-book ] tri ; + +: del-page ( name tabbed -- ) + [ names>> index ] 2keep (del-page) ; + +: new-tabbed ( assoc class -- tabbed ) + new-frame + 0 <model> >>model + <pile> 1 >>fill >>toggler + dup toggler>> @left grid-add + swap + [ keys >vector >>names ] + [ values over model>> <book> >>content dup content>> @center grid-add ] + bi + dup redo-toggler ; + +: <tabbed> ( assoc -- tabbed ) tabbed new-tabbed ; |