+++ /dev/null
-William Schlieper
+++ /dev/null
-Tabbed windows
\ No newline at end of file
+++ /dev/null
-! 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 ;
--- /dev/null
+William Schlieper
--- /dev/null
+Tabbed windows
\ No newline at end of file
--- /dev/null
+! 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 ;