basis/ui/gadgets/labels/labels.factor

   1 ! Copyright (C) 2005, 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays hashtables io kernel math namespaces
   4 make opengl sequences strings splitting ui.gadgets
   5 ui.gadgets.tracks ui.gadgets.theme ui.render colors models ;
   6 IN: ui.gadgets.labels
   7
   8 ! A label gadget draws a string.
   9 TUPLE: label < gadget text font color ;
  10
  11 : label-string ( label -- string )
  12     text>> dup string? [ "\n" join ] unless ; inline
  13
  14 : set-label-string ( string label -- )
  15     CHAR: \n pick memq? [
  16         >r string-lines r> (>>text)
  17     ] [
  18         (>>text)
  19     ] if ; inline
  20
  21 : label-theme ( gadget -- gadget )
  22     sans-serif-font >>font
  23     black >>color ; inline
  24
  25 : new-label ( string class -- label )
  26     new-gadget
  27     [ set-label-string ] keep
  28     label-theme ; inline
  29
  30 : <label> ( string -- label )
  31     label new-label ;
  32
  33 M: label pref-dim*
  34     [ font>> open-font ] [ text>> ] bi text-dim ;
  35
  36 M: label draw-gadget*
  37     [ color>> set-color ]
  38     [ [ font>> ] [ text>> ] bi origin get draw-text ] bi ;
  39
  40 M: label gadget-text* label-string % ;
  41
  42 TUPLE: label-control < label ;
  43
  44 M: label-control model-changed
  45     swap value>> over set-label-string relayout ;
  46
  47 : <label-control> ( model -- gadget )
  48     "" label-control new-label
  49         swap >>model ;
  50
  51 : text-theme ( gadget -- gadget )
  52     black >>color
  53     monospace-font >>font ;
  54
  55 : reverse-video-theme ( label -- label )
  56     white >>color
  57     black solid-interior ;
  58
  59 GENERIC: >label ( obj -- gadget )
  60 M: string >label <label> ;
  61 M: array >label <label> ;
  62 M: object >label ;
  63 M: f >label drop <gadget> ;
  64
  65 : label-on-left ( gadget label -- button )
  66     { 1 0 } <track>
  67         swap >label f track-add
  68         swap 1 track-add ;
  69
  70 : label-on-right ( label gadget -- button )
  71     { 1 0 } <track>
  72         swap f track-add
  73         swap >label 1 track-add ;