basis/ui/gadgets/labels/labels.factor

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