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