1 ! Copyright (C) 2008 William Schlieper
2 ! See http://factorcode.org/license.txt for BSD license.
4 USING: accessors kernel fry math math.vectors sequences arrays vectors assocs
5 hashtables models models.range models.product combinators
6 ui ui.gadgets ui.gadgets.buttons ui.gadgets.frames ui.gadgets.packs
7 ui.gadgets.grids ui.gadgets.viewports ui.gadgets.books locals ;
11 TUPLE: tabbed < frame names toggler content ;
15 :: add-toggle ( n name model toggler -- )
17 n name toggler parent>> '[ drop _ _ _ (del-page) ] "X" swap <bevel-button>
19 n model name <toggle-button> @center grid-add
20 toggler swap add-gadget drop ;
22 : redo-toggler ( tabbed -- )
23 [ names>> ] [ model>> ] [ toggler>> ] tri
25 [ [ length ] keep ] 2dip
26 '[ _ _ add-toggle ] 2each ;
28 : refresh-book ( tabbed -- )
29 model>> [ ] change-model ;
31 : (del-page) ( n name tabbed -- )
32 { [ [ remove ] change-names redo-toggler ]
33 [ dupd [ names>> length ] [ model>> ] bi
34 [ [ = ] keep swap [ 1- ] when
35 [ < ] keep swap [ 1- ] when ] change-model ]
36 [ content>> nth-gadget unparent ]
40 : add-page ( page name tabbed -- )
41 [ names>> push ] 2keep
42 [ [ names>> length 1 - swap ]
44 [ toggler>> ] tri add-toggle ]
45 [ content>> swap add-gadget drop ]
46 [ refresh-book ] tri ;
48 : del-page ( name tabbed -- )
49 [ names>> index ] 2keep (del-page) ;
51 : new-tabbed ( assoc class -- tabbed )
54 <pile> 1 >>fill >>toggler
55 dup toggler>> @left grid-add
57 [ keys >vector >>names ]
58 [ values over model>> <book> >>content dup content>> @center grid-add ]
62 : <tabbed> ( assoc -- tabbed ) tabbed new-tabbed ;