blob: d05890cda52326e3beccdaddc62f5b8ceceddd78 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
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 ;
|
