Merge remote-tracking branch 'origin/master' into modern-harvey3

basis/ui/gadgets/buttons/buttons.factor

@@ -1,11 +1,10 @@
 ! Copyright (C) 2005, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs colors colors.constants combinators
+USING: accessors assocs colors combinators combinators.short-circuit
-combinators.short-circuit combinators.smart fry kernel locals
+combinators.smart fry kernel locals math.vectors memoize models
-math.vectors memoize models namespaces sequences system
+namespaces sequences ui.commands ui.gadgets ui.gadgets.borders
-ui.commands ui.gadgets ui.gadgets.borders ui.gadgets.labels
+ui.gadgets.labels ui.gadgets.packs ui.theme ui.gadgets.worlds
-ui.gadgets.packs ui.gadgets.worlds ui.gestures ui.pens
+ui.gestures ui.pens ui.pens.image ui.pens.solid ui.pens.tile
-ui.pens.image ui.pens.solid ui.pens.tile ui.theme
 ui.theme.images ;
 FROM: models => change-model ;
 IN: ui.gadgets.buttons
@@ -129,7 +128,7 @@ PRIVATE>
     ] 2dip <tile-pen> ;
 
 : <border-button-pen> ( -- pen )
-    "button" os windows? [ color: grey95 ] [ transparent ] if button-text-color
+    "button" transparent button-text-color
     <border-button-state-pen> dup
     "button-clicked" transparent button-clicked-text-color
     <border-button-state-pen> dup dup

basis/ui/gadgets/labeled/labeled.factor

@@ -11,16 +11,10 @@ TUPLE: labeled-gadget < track content ;
 
 M: labeled-gadget focusable-child* content>> ;
 
-! gradients don't work as backgrounds on windows, see #152 and #1397
-: title-bar-interior ( -- interior )
-    os windows?
-    [ toolbar-background <solid> ]
-    [ title-bar-gradient <gradient> ]
-    if ;
-
 : <title-bar> ( title -- title-bar )
     >label [ t >>bold? ] change-font
-    { 0 4 } <border> title-bar-interior >>interior ;
+    { 0 4 } <border>
+    title-bar-gradient <gradient> >>interior ;
 
 PRIVATE>
 

basis/windows/uniscribe/uniscribe.factor

@@ -1,10 +1,13 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.c-types alien.data arrays assocs cache
+USING: accessors alien.c-types alien.data arrays assocs
-classes.struct combinators destructors fonts init io.encodings.string
+byte-arrays cache classes.struct colors colors.constants
-io.encodings.utf16n kernel literals locals math namespaces sequences
+combinators destructors fonts images init io.encodings.string
-windows.errors windows.fonts windows.gdi32 windows.offscreen
+io.encodings.utf16n kernel literals locals math math.bitwise
-windows.ole32 windows.types windows.usp10 ;
+namespaces sequences specialized-arrays windows.errors
+windows.fonts windows.gdi32 windows.offscreen windows.ole32
+windows.types windows.usp10 ;
+SPECIALIZED-ARRAY: uint32_t
 IN: windows.uniscribe
 
 TUPLE: script-string < disposable font string metrics ssa size image ;
@@ -48,8 +51,17 @@ CONSTANT: ssa-dwFlags flags{ SSA_GLYPHS SSA_FALLBACK SSA_TAB }
     [ check-ole32-error ] [ |ScriptStringFree void* deref ] bi* ;
 
 : set-dc-colors ( dc font -- )
+    dup background>> >rgba alpha>> 1 number= [
+        ! No transparency needed, set colors from the font.
         [ background>> color>RGB SetBkColor drop ]
-    [ foreground>> color>RGB SetTextColor drop ] 2bi ;
+        [ foreground>> color>RGB SetTextColor drop ] 2bi
+    ] [
+        ! Draw white text on black background. The resulting grayscale
+        ! image will be used as transparency mask for the actual color.
+        drop
+        [ COLOR: black color>RGB SetBkColor drop ]
+        [ COLOR: white color>RGB SetTextColor drop ] bi
+    ] if ;
 
 : selection-start/end ( script-string -- iMinSel iMaxSel )
     string>> dup selection? [ [ start>> ] [ end>> ] bi ] [ drop 0 0 ] if ;
@@ -67,10 +79,27 @@ CONSTANT: ssa-dwFlags flags{ SSA_GLYPHS SSA_FALLBACK SSA_TAB }
     FALSE ! fDisabled
     ScriptStringOut check-ole32-error ;
 
+! The image is a grayscale rendering of a text string. We want the text to
+! have the given color. Move the blue channel of the image (any color
+! channel will do, since it's grayscale) into its alpha channel, and make
+! the entire image a rectangle of the given color with varying
+! transparency.
+:: color-to-alpha ( image color -- image' )
+    color >rgba-components :> alpha
+    [ 255 * >integer ] tri@ 3byte-array uint32_t deref 24 bits :> rgb
+    image bitmap>> uint32_t cast-array
+        alpha 1 <
+        [ [ 0xff bitand alpha * >integer 24 shift rgb bitor ] map! ]
+        [ [ 0xff bitand                  24 shift rgb bitor ] map! ]
+        if drop
+    image RGBA >>component-order ;
+
 :: render-image ( dc ssa script-string -- image )
     script-string size>> :> size
     size dc
-    [ ssa size script-string draw-script-string ] make-bitmap-image ;
+    [ ssa size script-string draw-script-string ] make-bitmap-image
+    script-string font>> [ foreground>> ] [ background>> ] bi
+    >rgba alpha>> 1 number= [ drop ] [ color-to-alpha ] if ;
 
 : set-dc-font ( dc font -- )
     cache-font SelectObject win32-error=0/f ;

extra/slides/slides.factor

@@ -27,7 +27,7 @@ CONSTANT: stylesheet
         }
         { code-style
             H{
-                { page-color T{ rgba f 0.9 0.9 0.9 1 } }
+                { page-color T{ rgba f 0.4 0.4 0.4 0.3 } }
             }
         }
         { snippet-style
@@ -55,35 +55,23 @@ CONSTANT: stylesheet
         } format
     ] ($block) ;
 
-: divider-interior ( -- interior )
-    os windows? [
-        T{ rgba f 0.25 0.25 0.25 1.0 } <solid>
-    ] [ {
-            T{ rgba f 0.25 0.25 0.25 1.0 }
-            T{ rgba f 1.0 1.0 1.0 0.0 }
-        } <gradient>
-    ] if ;
-
 : $divider ( -- )
     [
         <gadget>
-            divider-interior >>interior
+            {
+                T{ rgba f 0.25 0.25 0.25 1.0 }
+                T{ rgba f 1.0 1.0 1.0 0.0 }
+            } <gradient> >>interior
             array[ default-font-size 67 * default-font-size 5/6 * ] >>dim
             { 1 0 } >>orientation
         gadget.
     ] ($block) ;
 
-: page-interior ( -- interior )
+: page-theme ( gadget -- gadget )
-    os windows? [
+    {
-        T{ rgba f 0.8 0.8 1.0 1.0 } <solid>
-    ] [ {
         T{ rgba f 0.8 0.8 1.0 1.0 }
         T{ rgba f 0.8 1.0 1.0 1.0 }
-        } <gradient>
+    } <gradient> >>interior ;
-    ] if ;
-
-: page-theme ( gadget -- gadget )
-    page-interior >>interior ;
 
 : <page> ( list -- gadget )
     [