ui.theme: updates to color scheme.

[factor.git] / basis / ui / gadgets / labels / labels.factor

diff --git a/basis/ui/gadgets/labels/labels.factor b/basis/ui/gadgets/labels/labels.factor
index 9a6d7d47b38423faa7dea0d68c555e8879d9f810..a4fce2cd57ba57899131af0bbe6ddb10c7cd4f0e 100644 (file)
--- a/basis/ui/gadgets/labels/labels.factor
+++ b/basis/ui/gadgets/labels/labels.factor
@@ -1,14 +1,13 @@
 ! 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.pens.solid
-ui.baseline-alignment ui.text colors colors.constants models
-combinators opengl.gl ;
+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
 
@@ -22,18 +21,18 @@ PREDICATE: string-array < array [ string? ] all? ;
 PRIVATE>
 
 : ?string-lines ( string -- string/array )
-    CHAR: \n over memq? [ string-lines ] when ;
+    CHAR: \n over member-eq? [ string-lines ] when ;
 
 ERROR: not-a-string object ;
 
-M: label (>>string) ( string label -- )
+M: label string<< ( string label -- )
     [
         {
             { [ dup string-array? ] [ ] }
             { [ dup string? ] [ ?string-lines ] }
             [ not-a-string ]
         } cond
-    ] dip (>>text) ; inline
+    ] dip [ text<< ] [ relayout ] bi ; inline
 
 : label-theme ( gadget -- gadget )
     sans-serif-font >>font ; inline
@@ -47,7 +46,7 @@ M: label (>>string) ( string label -- )
     label new-label ;
 
 : >label< ( label -- font text )
-    [ font>> ] [ text>> ] bi ;
+    [ font>> ] [ text>> ] bi ; inline
 
 M: label pref-dim*
     >label< text-dim ;
@@ -59,44 +58,41 @@ M: label pref-dim*
 
 PRIVATE>
 
-M: label baseline
+M: label baseline*
     label-metrics ascent>> round ;
 
-M: label cap-height
+M: label cap-height*
     label-metrics cap-height>> round ;
 
-: draw-text* ( font text fg bg -- )
-    [ rot ] dip
-    [ font-with-background ] when* swap
-    [ font-with-foreground ] when* swap
-    draw-text ;
+<PRIVATE
 
-: draw-shadowed-text ( font text -- )
-    [
-        { 0 1 } [ over shadow>> background get draw-text* ]
-        with-translation
-    ] [ foreground get transparent draw-text* ] 2bi ;
+: label-background ( label -- color )
+    gadget-background background get or ; inline
 
-: draw-normal-text ( font text -- )
-    foreground get background get draw-text* ;
+: label-foreground ( label -- color )
+    gadget-foreground foreground get or ; inline
+
+PRIVATE>
 
 M: label draw-gadget*
-    >label< over shadow>>
-    [ draw-shadowed-text ] [ draw-normal-text ] if ;
+    [ >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
@@ -117,12 +113,12 @@ M: f >label drop <gadget> ;
         { 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 ;