basis/ui/gadgets/labelled/labelled.factor

   1 ! Copyright (C) 2006, 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: arrays ui.gadgets.buttons ui.gadgets.borders
   4 ui.gadgets.labels ui.gadgets.panes ui.gadgets.scrollers
   5 ui.gadgets.tracks ui.gadgets.theme ui.gadgets.frames
   6 ui.gadgets.grids io kernel math models namespaces
   7 sequences sequences words classes.tuple ui.gadgets ui.render
   8 colors accessors ;
   9 IN: ui.gadgets.labelled
  10
  11 TUPLE: labelled-gadget < track content ;
  12
  13 : <labelled-gadget> ( gadget title -- newgadget )
  14     { 0 1 } labelled-gadget new-track
  15         swap <label> reverse-video-theme f track-add
  16         swap >>content
  17         dup content>> 1 track-add ;
  18
  19 M: labelled-gadget focusable-child* content>> ;
  20
  21 : <labelled-scroller> ( gadget title -- gadget )
  22     [ <scroller> ] dip <labelled-gadget> ;
  23
  24 : <labelled-pane> ( model quot scrolls? title -- gadget )
  25     [ [ <pane-control> ] dip >>scrolls? ] dip
  26     <labelled-scroller> ;
  27
  28 : <close-box> ( quot -- button/f )
  29     gray close-box <polygon-gadget> swap <bevel-button> ;
  30
  31 : title-theme ( gadget -- gadget )
  32     { 1 0 } >>orientation
  33     {
  34         T{ rgba f 0.65 0.65 1.0 1.0 }
  35         T{ rgba f 0.65 0.45 1.0 1.0 }
  36     } <gradient> >>interior ;
  37
  38 : <title-label> ( text -- label ) <label> title-theme ;
  39
  40 : <title-bar> ( title quot -- gadget )
  41     <frame>
  42         swap [ <close-box> @left grid-add ] when*
  43         swap <title-label> @center grid-add ;
  44
  45 TUPLE: closable-gadget < frame content ;
  46
  47 : find-closable-gadget ( parent -- child )
  48     [ closable-gadget? ] find-parent ;
  49
  50 : <closable-gadget> ( gadget title quot -- gadget )
  51     [
  52         [ closable-gadget new-frame ] dip
  53         [ >>content ] [ @center grid-add ] bi
  54     ] 2dip
  55     <title-bar> @top grid-add ;
  56
  57 M: closable-gadget focusable-child* content>> ;