unmaintained/tabs/tabs.factor

   1 ! Copyright (C) 2008 William Schlieper
   2 ! See http://factorcode.org/license.txt for BSD license.
   3
   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 ;
   8
   9 IN: ui.gadgets.tabs
  10
  11 TUPLE: tabbed < frame names toggler content ;
  12
  13 DEFER: (del-page)
  14
  15 :: add-toggle ( n name model toggler -- )
  16   <frame>
  17     n name toggler parent>> '[ drop _ _ _ (del-page) ] "X" swap <bevel-button>
  18       @right grid-add
  19     n model name <toggle-button> @center grid-add
  20   toggler swap add-gadget drop ;
  21
  22 : redo-toggler ( tabbed -- )
  23      [ names>> ] [ model>> ] [ toggler>> ] tri
  24      [ clear-gadget ] keep
  25      [ [ length ] keep ] 2dip
  26      '[ _ _ add-toggle ] 2each ;
  27
  28 : refresh-book ( tabbed -- )
  29     model>> [ ] change-model ;
  30
  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 ]
  37       [ refresh-book ]
  38     } cleave ;
  39
  40 : add-page ( page name tabbed -- )
  41     [ names>> push ] 2keep
  42     [ [ names>> length 1 - swap ]
  43       [ model>> ]
  44       [ toggler>> ] tri add-toggle ]
  45     [ content>> swap add-gadget drop ]
  46     [ refresh-book ] tri ;
  47
  48 : del-page ( name tabbed -- )
  49     [ names>> index ] 2keep (del-page) ;
  50
  51 : new-tabbed ( assoc class -- tabbed )
  52     new-frame
  53     0 <model> >>model
  54     <pile> 1 >>fill >>toggler
  55     dup toggler>> @left grid-add
  56     swap
  57       [ keys >vector >>names ]
  58       [ values over model>> <book> >>content dup content>> @center grid-add ]
  59     bi
  60     dup redo-toggler ;
  61
  62 : <tabbed> ( assoc -- tabbed ) tabbed new-tabbed ;