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.text colors colors.constants models combinators ;
   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 <PRIVATE
  18
  19 PREDICATE: string-array < array [ string? ] all? ;
  20
  21 PRIVATE>
  22
  23 : ?string-lines ( string -- string/array )
  24     CHAR: \n over memq? [ 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 ;
  50
  51 M: label pref-dim*
  52     >label< text-dim ;
  53
  54 M: label baseline
  55     >label< dup string? [ first ] unless
  56     line-metrics ascent>> round ;
  57
  58 M: label draw-gadget*
  59     >label<
  60     [
  61         background get [ font-with-background ] when*
  62         foreground get [ font-with-foreground ] when*
  63     ] dip
  64     draw-text ;
  65
  66 M: label gadget-text* string>> % ;
  67
  68 TUPLE: label-control < label ;
  69
  70 M: label-control model-changed
  71     swap value>> >>string relayout ;
  72
  73 : <label-control> ( model -- gadget )
  74     "" label-control new-label
  75         swap >>model ;
  76
  77 : text-theme ( gadget -- gadget )
  78     monospace-font >>font ;
  79
  80 : reverse-video-theme ( label -- label )
  81     sans-serif-font reverse-video-font >>font
  82     COLOR: black <solid> >>interior ;
  83
  84 GENERIC: >label ( obj -- gadget )
  85 M: string >label <label> ;
  86 M: array >label <label> ;
  87 M: object >label ;
  88 M: f >label drop <gadget> ;
  89
  90 <PRIVATE
  91
  92 : label-on-left/right ( -- track )
  93     horizontal <track>
  94         0 >>fill
  95         +baseline+ >>align
  96         { 5 5 } >>gap ; inline
  97 PRIVATE>
  98
  99 : label-on-left ( gadget label -- button )
 100     label-on-left/right
 101         swap >label f track-add
 102         swap 1 track-add ;
 103
 104 : label-on-right ( label gadget -- button )
 105     label-on-left/right
 106         swap f track-add
 107         swap >label 1 track-add ;