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 fry
   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 ui.tools.common ;
   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<< ] [ relayout ] bi ; 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 <PRIVATE
  68
  69 : label-background ( label -- color )
  70     gadget-background background get or ; inline
  71
  72 : label-foreground ( label -- color )
  73     gadget-foreground foreground get or ; inline
  74
  75 PRIVATE>
  76
  77 M: label draw-gadget*
  78     [ >label< ] keep
  79     [ label-background [ font-with-background ] when* ]
  80     [ label-foreground [ font-with-foreground ] when* ]
  81     bi-curry compose dip draw-text ;
  82
  83 M: label gadget-text* string>> % ;
  84
  85 TUPLE: label-control < label ;
  86
  87 M: label-control model-changed
  88     [ value>> ] [ string<< ] bi* ;
  89
  90 : <label-control> ( model -- gadget )
  91     "" label-control new-label
  92         swap >>model ;
  93
  94 : text-theme ( gadget -- gadget )
  95     monospace-font >>font theme-font-colors ;
  96
  97 : reverse-video-theme ( label -- label )
  98     sans-serif-font reverse-video-font >>font
  99     COLOR: black <solid> >>interior ;
 100
 101 GENERIC: >label ( obj -- gadget )
 102 M: string >label <label> ;
 103 M: array >label <label> ;
 104 M: object >label ;
 105 M: f >label drop <gadget> ;
 106
 107 <PRIVATE
 108
 109 : label-on-left/right ( -- track )
 110     horizontal <track>
 111         0 >>fill
 112         +baseline+ >>align
 113         { 5 5 } >>gap ; inline
 114 PRIVATE>
 115
 116 : label-on-left ( gadget label -- track )
 117     label-on-left/right
 118         swap >label f track-add
 119         swap 1 track-add ;
 120
 121 : label-on-right ( label gadget -- track )
 122     label-on-left/right
 123         swap f track-add
 124         swap >label 1 track-add ;