From: Alexander Iljin <ajsoft@yandex.ru>
Date: Sat, 8 Jun 2019 11:47:06 +0000 (+0200)
Subject: windows.uniscribe: support transparency in text color
X-Git-Tag: 0.99~3813
X-Git-Url: https://gitweb.factorcode.org/gitweb.cgi?p=factor.git;a=commitdiff_plain;h=4a7644e5094b7cef04d4576f8d03e4b8eebfce80

windows.uniscribe: support transparency in text color
---

diff --git a/basis/windows/uniscribe/uniscribe.factor b/basis/windows/uniscribe/uniscribe.factor
index 6f3b436c49..00164ff8b8 100644
--- a/basis/windows/uniscribe/uniscribe.factor
+++ b/basis/windows/uniscribe/uniscribe.factor
@@ -85,11 +85,14 @@ CONSTANT: ssa-dwFlags flags{ SSA_GLYPHS SSA_FALLBACK SSA_TAB }
 ! the entire image a rectangle of the given color with varying
 ! transparency.
 :: color-to-alpha ( image color -- image' )
-    color >rgba-components drop [ 255 * >integer ] tri@
-    3byte-array uint32_t deref 24 bits :> rgb
-    image bitmap>> uint32_t cast-array [
-        0xff bitand 24 shift rgb bitor
-    ] map! drop image RGBA >>component-order ;
+    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