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 colors.constants combinators fonts
   4 kernel make math.functions models namespaces sequences splitting
   5 strings ui.baseline-alignment ui.gadgets ui.gadgets.tracks
   6 ui.pens.solid ui.render ui.text ;
   7 IN: ui.gadgets.labels
   8
   9 ! A label gadget draws a string.
  10 TUPLE: label < aligned-gadget text font ;
  11
  12 SLOT: string
  13
  14 M: label string>> ( label -- string )
  15     text>> dup string? [ "\n" join ] unless ; inline
  16
  17 <PRIVATE
  18
  19 PREDICATE: string-array < array [ string? ] all? ;
  20
  21 PRIVATE>
  22
  23 : ?string-lines ( string -- string/array )
  24     CHAR: \n over member-eq? [ string-lines ] when ;
  25
  26 ERROR: not-a-string object ;
  27
  28 M: label string<< ( string label -- )
  29     [
  30         {
  31             { [ dup string-array? ] [ ] }
  32             { [ dup string? ] [ ?string-lines ] }
  33             [ not-a-string ]
  34         } cond
  35     ] dip text<< ; inline
  36
  37 : label-theme ( gadget -- gadget )
  38     sans-serif-font >>font ; inline
  39
  40 : new-label ( string class -- label )
  41     new
  42     swap >>string
  43     label-theme ; inline
  44
  45 : <label> ( string -- label )
  46     label new-label ;
  47
  48 : >label< ( label -- font text )
  49     [ font>> ] [ text>> ] bi ; inline
  50
  51 M: label pref-dim*
  52     >label< text-dim ;
  53
  54 <PRIVATE
  55
  56 : label-metrics ( label -- metrics )
  57     >label< dup string? [ first ] unless line-metrics ;
  58
  59 PRIVATE>
  60
  61 M: label baseline*
  62     label-metrics ascent>> round ;
  63
  64 M: label cap-height*
  65     label-metrics cap-height>> round ;
  66
  67 M: label draw-gadget*
  68     >label<
  69     [
  70         background get [ font-with-background ] when*
  71         foreground get [ font-with-foreground ] when*
  72     ] dip
  73     draw-text ;
  74
  75 M: label gadget-text* string>> % ;
  76
  77 TUPLE: label-control < label ;
  78
  79 M: label-control model-changed
  80     swap value>> >>string relayout ;
  81
  82 : <label-control> ( model -- gadget )
  83     "" label-control new-label
  84         swap >>model ;
  85
  86 : text-theme ( gadget -- gadget )
  87     monospace-font >>font ;
  88
  89 : reverse-video-theme ( label -- label )
  90     sans-serif-font reverse-video-font >>font
  91     COLOR: black <solid> >>interior ;
  92
  93 GENERIC: >label ( obj -- gadget )
  94 M: string >label <label> ;
  95 M: array >label <label> ;
  96 M: object >label ;
  97 M: f >label drop <gadget> ;
  98
  99 <PRIVATE
 100
 101 : label-on-left/right ( -- track )
 102     horizontal <track>
 103         0 >>fill
 104         +baseline+ >>align
 105         { 5 5 } >>gap ; inline
 106 PRIVATE>
 107
 108 : label-on-left ( gadget label -- track )
 109     label-on-left/right
 110         swap >label f track-add
 111         swap 1 track-add ;
 112
 113 : label-on-right ( label gadget -- track )
 114     label-on-left/right
 115         swap f track-add
 116         swap >label 1 track-add ;