1 ! Copyright (C) 2005, 2009 Slava Pestov.
2 ! See https://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays classes colors 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
10 ! A label gadget draws a string.
11 TUPLE: label < aligned-gadget text font ;
16 text>> dup string? [ join-lines ] unless ; inline
20 PREDICATE: string-array < array [ string? ] all? ;
24 : ?string-lines ( string -- string/array )
25 CHAR: \n over member-eq? [ split-lines ] when ;
30 string check-instance ?string-lines
32 ] dip [ text<< ] [ relayout ] bi ; inline
34 : label-theme ( gadget -- gadget )
35 sans-serif-font >>font ; inline
37 : new-label ( string class -- label )
42 : <label> ( string -- label )
45 : >label< ( label -- font text )
46 [ font>> ] [ text>> ] bi ; inline
49 >label< text-dim first2 ceiling 2array ;
53 : label-metrics ( label -- metrics )
54 >label< dup string? [ first ] unless line-metrics ;
59 label-metrics ascent>> ;
62 label-metrics cap-height>> ;
66 : label-background ( label -- color )
67 gadget-background [ background get ] unless* ; inline
69 : label-foreground ( label -- color )
70 gadget-foreground [ foreground get ] unless* ; inline
76 [ label-background [ font-with-background ] when* ]
77 [ label-foreground [ font-with-foreground ] when* ]
78 bi-curry compose dip draw-text ;
80 M: label gadget-text* string>> % ;
82 TUPLE: label-control < label ;
84 M: label-control model-changed
85 [ value>> ] [ string<< ] bi* ;
87 : <label-control> ( model -- gadget )
88 "" label-control new-label
91 GENERIC: >label ( obj -- gadget )
92 M: string >label <label> ;
93 M: array >label <label> ;
95 M: f >label drop <gadget> ;
99 : label-on-left/right ( -- track )
103 { 5 5 } >>gap ; inline
106 : label-on-left ( gadget label -- track )
108 swap >label f track-add
111 : label-on-right ( label gadget -- track )
114 swap >label 1 track-add ;