basis/ui/gadgets/tabbed/tabbed.factor

   1 ! Copyright (C) 2008, 2009 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors colors.constants kernel models sequences
   4 ui.gadgets ui.gadgets.books ui.gadgets.borders
   5 ui.gadgets.buttons ui.gadgets.buttons.private ui.gadgets.icons
   6 ui.gadgets.packs ui.gadgets.tracks ui.pens ui.theme.images ;
   7 IN: ui.gadgets.tabbed
   8
   9 TUPLE: tabbed-gadget < track tabs book ;
  10
  11 <PRIVATE
  12
  13 : <lip> ( -- gadget )
  14     "active-tab-lip" theme-image <icon> ;
  15
  16 CONSTANT: button-background COLOR: FactorTan
  17 CONSTANT: active-tab-background COLOR: FactorDarkTan
  18
  19 : <tab-pen> ( -- pen )
  20     "inactive-tab" button-background f <border-button-state-pen> dup dup
  21     "active-tab" active-tab-background f <border-button-state-pen> dup
  22     <button-pen> ;
  23
  24 : tab-theme ( gadget -- gadget )
  25     horizontal >>orientation
  26     <tab-pen> >>interior
  27     dup dup interior>> pen-pref-dim >>min-dim
  28     { 30 0 } >>size ; inline
  29
  30 : <tab> ( value model label -- gadget )
  31     <radio-control> tab-theme ;
  32
  33 : add-tab/book ( tabbed child -- tabbed )
  34     [ dup book>> ] dip add-gadget drop ;
  35
  36 : add-tab/button ( tabbed label -- tabbed )
  37     [ [ dup tabs>> dup children>> length ] [ model>> ] bi ] dip
  38     <tab> add-gadget drop ;
  39
  40 PRIVATE>
  41
  42 : <tabbed-gadget> ( -- gadget )
  43     vertical tabbed-gadget new-track
  44         0 <model> >>model
  45         <shelf> >>tabs
  46         horizontal <track>
  47             over tabs>> f track-add
  48             <lip> 1 track-add
  49         f track-add
  50         dup model>> <empty-book> >>book
  51         dup book>> { 3 3 } <filled-border> 1 track-add ;
  52
  53 : add-tab ( tabbed child label -- tabbed )
  54     [ add-tab/book ] [ add-tab/button ] bi* ;