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 ;
9 ! A label gadget draws a string.
10 TUPLE: label < aligned-gadget text font ;
14 M: label string>> ( label -- string )
15 text>> dup string? [ "\n" join ] unless ; inline
19 PREDICATE: string-array < array [ string? ] all? ;
23 : ?string-lines ( string -- string/array )
24 CHAR: \n over member-eq? [ string-lines ] when ;
26 ERROR: not-a-string object ;
28 M: label string<< ( string label -- )
31 { [ dup string-array? ] [ ] }
32 { [ dup string? ] [ ?string-lines ] }
33 [ throw-not-a-string ]
35 ] dip [ text<< ] [ relayout ] bi ; inline
37 : label-theme ( gadget -- gadget )
38 sans-serif-font >>font ; inline
40 : new-label ( string class -- label )
45 : <label> ( string -- label )
48 : >label< ( label -- font text )
49 [ font>> ] [ text>> ] bi ; inline
56 : label-metrics ( label -- metrics )
57 >label< dup string? [ first ] unless line-metrics ;
62 label-metrics ascent>> round ;
65 label-metrics cap-height>> round ;
69 : label-background ( label -- color )
70 gadget-background background get or ; inline
72 : label-foreground ( label -- color )
73 gadget-foreground foreground get or ; inline
79 [ label-background [ font-with-background ] when* ]
80 [ label-foreground [ font-with-foreground ] when* ]
81 bi-curry compose dip draw-text ;
83 M: label gadget-text* string>> % ;
85 TUPLE: label-control < label ;
87 M: label-control model-changed
88 [ value>> ] [ string<< ] bi* ;
90 : <label-control> ( model -- gadget )
91 "" label-control new-label
94 : text-theme ( gadget -- gadget )
95 monospace-font >>font ;
97 : reverse-video-theme ( label -- label )
98 sans-serif-font reverse-video-font >>font
99 COLOR: black <solid> >>interior ;
101 GENERIC: >label ( obj -- gadget )
102 M: string >label <label> ;
103 M: array >label <label> ;
105 M: f >label drop <gadget> ;
109 : label-on-left/right ( -- track )
113 { 5 5 } >>gap ; inline
116 : label-on-left ( gadget label -- track )
118 swap >label f track-add
121 : label-on-right ( label gadget -- track )
124 swap >label 1 track-add ;