63 lines
1.8 KiB
Factor
63 lines
1.8 KiB
Factor
! 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 ;
|