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: ui.pens ui.gadgets.tracks ui.gadgets.buttons
   4 ui.gadgets.buttons.private ui.gadgets.books ui.gadgets.packs
   5 ui.gadgets.borders ui.gadgets.icons ui.gadgets ui.pens.image
   6 sequences models accessors kernel colors colors.constants ;
   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: active-tab-background
  17     T{ rgba
  18         f
  19         0.6745098039215687
  20         0.6549019607843137
  21         0.5764705882352941
  22         1.0
  23     }
  24
  25 : <tab-pen> ( -- pen )
  26     "inactive-tab" button-background f <border-button-state-pen> dup dup
  27     "active-tab" active-tab-background f <border-button-state-pen> dup
  28     <button-pen> ;
  29
  30 : tab-theme ( gadget -- gadget )
  31     horizontal >>orientation
  32     <tab-pen> >>interior
  33     dup dup interior>> pen-pref-dim >>min-dim
  34     { 30 0 } >>size ; inline
  35
  36 : <tab> ( value model label -- gadget )
  37     <radio-control> tab-theme ;
  38
  39 : add-tab/book ( tabbed child -- tabbed )
  40     [ dup book>> ] dip add-gadget drop ;
  41
  42 : add-tab/button ( tabbed label -- tabbed )
  43     [ [ dup tabs>> dup children>> length ] [ model>> ] bi ] dip
  44     <tab> add-gadget drop ;
  45
  46 PRIVATE>
  47
  48 : <tabbed-gadget> ( -- gadget )
  49     vertical tabbed-gadget new-track
  50         0 <model> >>model
  51         <shelf> >>tabs
  52         horizontal <track>
  53             over tabs>> f track-add
  54             <lip> 1 track-add
  55         f track-add
  56         dup model>> <empty-book> >>book
  57         dup book>> { 3 3 } <filled-border> 1 track-add ;
  58
  59 : add-tab ( tabbed child label -- tabbed )
  60     [ add-tab/book ] [ add-tab/button ] bi* ;