basis/ui/gadgets/tabs/tabs.factor

   1 ! Copyright (C) 2008 William Schlieper\r
   2 ! See http://factorcode.org/license.txt for BSD license.\r
   3 \r
   4 USING: accessors kernel fry math math.vectors sequences arrays vectors assocs\r
   5        hashtables models models.range models.compose combinators\r
   6        ui ui.gadgets ui.gadgets.buttons ui.gadgets.frames ui.gadgets.packs\r
   7        ui.gadgets.grids ui.gadgets.viewports ui.gadgets.books locals ;\r
   8 \r
   9 IN: ui.gadgets.tabs\r
  10 \r
  11 TUPLE: tabbed < frame names toggler content ;\r
  12 \r
  13 DEFER: (del-page)\r
  14 \r
  15 :: add-toggle ( model n name toggler -- )\r
  16   <frame>\r
  17     n name toggler parent>> '[ , , , (del-page) ] "X" swap <bevel-button>\r
  18       @right grid-add\r
  19     n model name <toggle-button> @center grid-add\r
  20   toggler swap add-gadget drop ;\r
  21 \r
  22 : redo-toggler ( tabbed -- )\r
  23      [ names>> ] [ model>> ] [ toggler>> ] tri\r
  24      [ clear-gadget ] keep\r
  25      [ [ length ] keep ] 2dip\r
  26     '[ , _ _ , add-toggle ] 2each ;\r
  27 \r
  28 : refresh-book ( tabbed -- )\r
  29     model>> [ ] change-model ;\r
  30 \r
  31 : (del-page) ( n name tabbed -- )\r
  32     { [ [ remove ] change-names redo-toggler ]\r
  33       [ dupd [ names>> length ] [ model>> ] bi\r
  34         [ [ = ] keep swap [ 1- ] when\r
  35           [ < ] keep swap [ 1- ] when ] change-model ]\r
  36       [ content>> nth-gadget unparent ]\r
  37       [ refresh-book ]\r
  38     } cleave ;\r
  39 \r
  40 : add-page ( page name tabbed -- )\r
  41     [ names>> push ] 2keep\r
  42     [ [ model>> swap ]\r
  43       [ names>> length 1 - swap ]\r
  44       [ toggler>> ] tri add-toggle ]\r
  45     [ content>> swap add-gadget drop ]\r
  46     [ refresh-book ] tri ;\r
  47 \r
  48 : del-page ( name tabbed -- )\r
  49     [ names>> index ] 2keep (del-page) ;\r
  50 \r
  51 : new-tabbed ( assoc class -- tabbed )\r
  52     new-frame\r
  53     0 <model> >>model\r
  54     <pile> 1 >>fill >>toggler\r
  55     dup toggler>> @left grid-add\r
  56     swap\r
  57       [ keys >vector >>names ]\r
  58       [ values over model>> <book> >>content dup content>> @center grid-add ]\r
  59     bi\r
  60     dup redo-toggler ;\r
  61     \r
  62 : <tabbed> ( assoc -- tabbed ) tabbed new-tabbed ;\r