! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays hashtables io kernel math math.functions
-namespaces make opengl sequences strings splitting ui.gadgets
-ui.gadgets.tracks ui.gadgets.packs fonts ui.render ui.text
-colors colors.constants models ;
+USING: accessors arrays colors.constants combinators fonts fry
+kernel make math.functions models namespaces sequences splitting
+strings ui.baseline-alignment ui.gadgets ui.gadgets.theme
+ui.gadgets.tracks ui.pens.solid ui.render ui.text ;
IN: ui.gadgets.labels
! A label gadget draws a string.
-TUPLE: label < gadget text font ;
+TUPLE: label < aligned-gadget text font ;
SLOT: string
M: label string>> ( label -- string )
text>> dup string? [ "\n" join ] unless ; inline
-M: label (>>string) ( string label -- )
- [ CHAR: \n over memq? [ string-lines ] when ] dip (>>text) ; inline
+<PRIVATE
+
+PREDICATE: string-array < array [ string? ] all? ;
+
+PRIVATE>
+
+: ?string-lines ( string -- string/array )
+ CHAR: \n over member-eq? [ string-lines ] when ;
+
+ERROR: not-a-string object ;
+
+M: label string<< ( string label -- )
+ [
+ {
+ { [ dup string-array? ] [ ] }
+ { [ dup string? ] [ ?string-lines ] }
+ [ not-a-string ]
+ } cond
+ ] dip [ text<< ] [ relayout ] bi ; inline
: label-theme ( gadget -- gadget )
sans-serif-font >>font ; inline
: new-label ( string class -- label )
- new-gadget
+ new
swap >>string
label-theme ; inline
label new-label ;
: >label< ( label -- font text )
- [ font>> ] [ text>> ] bi ;
+ [ font>> ] [ text>> ] bi ; inline
M: label pref-dim*
>label< text-dim ;
-M: label baseline
- >label< dup string? [ first ] unless
- line-metrics ascent>> round ;
+<PRIVATE
+
+: label-metrics ( label -- metrics )
+ >label< dup string? [ first ] unless line-metrics ;
+
+PRIVATE>
+
+M: label baseline*
+ label-metrics ascent>> round ;
+
+M: label cap-height*
+ label-metrics cap-height>> round ;
+
+<PRIVATE
+
+: label-background ( label -- color )
+ gadget-background background get or ; inline
+
+: label-foreground ( label -- color )
+ gadget-foreground foreground get or ; inline
+
+PRIVATE>
M: label draw-gadget*
- >label< origin get draw-text ;
+ [ >label< ] keep
+ [ label-background [ font-with-background ] when* ]
+ [ label-foreground [ font-with-foreground ] when* ]
+ bi-curry compose dip draw-text ;
M: label gadget-text* string>> % ;
TUPLE: label-control < label ;
M: label-control model-changed
- swap value>> >>string relayout ;
+ [ value>> ] [ string<< ] bi* ;
: <label-control> ( model -- gadget )
"" label-control new-label
swap >>model ;
: text-theme ( gadget -- gadget )
- monospace-font >>font ;
+ monospace-font >>font theme-font-colors ;
: reverse-video-theme ( label -- label )
sans-serif-font reverse-video-font >>font
: label-on-left/right ( -- track )
horizontal <track>
+ 0 >>fill
+baseline+ >>align
{ 5 5 } >>gap ; inline
PRIVATE>
-: label-on-left ( gadget label -- button )
+: label-on-left ( gadget label -- track )
label-on-left/right
swap >label f track-add
swap 1 track-add ;
-: label-on-right ( label gadget -- button )
+: label-on-right ( label gadget -- track )
label-on-left/right
swap f track-add
swap >label 1 track-add ;