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