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