More progress on Uniscribe

[factor.git] / basis / windows / uniscribe / uniscribe.factor

diff --git a/basis/windows/uniscribe/uniscribe.factor b/basis/windows/uniscribe/uniscribe.factor
old mode 100644 (file)
new mode 100755 (executable)
index 5d24601..cfd723a
--- a/basis/windows/uniscribe/uniscribe.factor
+++ b/basis/windows/uniscribe/uniscribe.factor
@@ -1,65 +1,95 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math sequences io.encodings.string io.encodings.utf16n
-accessors arrays destructors alien.c-types windows windows.usp10
-windows.offscreen ;
+USING: kernel assocs math sequences fry io.encodings.string
+io.encodings.utf16n accessors arrays combinators destructors
+cache namespaces init images.normalization alien.c-types locals
+windows windows.usp10 windows.offscreen windows.gdi32
+windows.ole32 windows.types windows.fonts ;
 IN: windows.uniscribe
 
-TUPLE: script-string pssa size image ;
+TUPLE: script-string metrics ssa size image string disposed ;
 
 : make-script-string ( dc string -- script-string )
     [ utf16n encode ] ! pString
     [ length ] bi ! cString
-    dup 1.5 * 16 + ! cGlyphs -- MSDN says this is "recommended size"
+    dup 1.5 * 16 + >integer ! cGlyphs -- MSDN says this is "recommended size"
     -1 ! iCharset -- Unicode
     SSA_GLYPHS ! dwFlags
-    ... ! iReqWidth
+    0 ! iReqWidth
     f ! psControl
     f ! psState
     f ! piDx
     f ! pTabdef
-    ... ! pbInClass
+    f ! pbInClass
     f <void*> ! pssa
     [ ScriptStringAnalyse ] keep
-    [ win32-error=0/f ] [ |ScriptStringFree ] bi* ;
+    [ ole32-error ] [ |ScriptStringFree *void* ] bi* ;
 
-: draw-script-string ( script-string -- bitmap )
+: draw-script-string ( script-string -- )
     ! ssa
     0 ! iX
     0 ! iY
-    ETO_OPAQUE ! uOptions ... ????
+    0 ! uOptions
     f ! prc
     0 ! iMinSel
     0 ! iMaxSel
-    f ! fDisabled
-    ScriptStringOut ;
+    FALSE ! fDisabled
+    ScriptStringOut ole32-error ;
 
-: <script-string> ( string -- script-string )
-    [
-        ... dim ... [
-            make-script-string |ScriptStringFree
-            [ ]
-            [ draw-script-string ]
-            [
-                ScriptString_pSize
-                dup win32-error=0/f
-                [ SIZE-cx ] [ SIZE-cy ] bi 2array
-            ] tri
-        ] make-bitmap-image
-        script-string boa
-    ] with-destructors ;
+: set-dc-font ( dc font -- )
+    [ cache-font SelectObject win32-error=0/f ]
+    [ background>> color>RGB SetBkColor drop ]
+    [ foreground>> color>RGB SetTextColor drop ] 2tri ;
 
-M: script-string dispose* pssa>> ScriptStringFree win32-error=0/f ;
+: script-string-size ( ssa -- dim )
+    ScriptString_pSize
+    dup win32-error=0/f
+    [ SIZE-cx ] [ SIZE-cy ] bi 2array ;
 
-: line-offset>x ( offset script-string -- x )
-    pssa>> ! ssa
-    swap ! icp
-    ... ! fTrailing
-    0 <int> [ ScriptStringCPtoX win32-error=0/f ] keep *int ;
+: dc-metrics ( dc -- metrics )
+    "TEXTMETRICW" <c-object> [ GetTextMetrics drop ] keep
+    TEXTMETRIC>metrics ;
 
-: line-x>offset ( x script-string -- offset trailing )
-    pssa>> ! ssa
+:: <script-string> ( font string -- script-string )
+    #! Comments annotate BOA constructor arguments
+    [| dc |
+        dc font set-dc-font
+        dc dc-metrics ! metrics
+        dc string make-script-string dup :> ssa ! ssa
+        dup script-string-size ! size
+        dup dc [ ssa draw-script-string ] make-bitmap-image
+        normalize-image ! image
+        string ! string
+        f script-string boa
+    ] with-memory-dc ;
+
+: text-position ( script-string -- loc ) drop { 0 0 } ;
+
+M: script-string dispose* ssa>> <void*> ScriptStringFree ole32-error ;
+
+SYMBOL: cached-script-strings
+
+: cached-script-string ( string font -- script-string )
+    cached-script-strings get-global [ <script-string> ] 2cache ;
+
+[ <cache-assoc> cached-script-strings set-global ]
+"windows.uniscribe" add-init-hook
+
+: line-offset>x ( n script-string -- x )
+    2dup string>> length = [
+        ssa>> ! ssa
+        swap 1- ! icp
+        TRUE ! fTrailing
+    ] [
+        ssa>>
+        swap ! icp
+        FALSE ! fTrailing
+    ] if
+    0 <int> [ ScriptStringCPtoX ole32-error ] keep *int ;
+
+: x>line-offset ( x script-string -- n trailing )
+    ssa>> ! ssa
     swap ! iX
     0 <int> ! pCh
     0 <int> ! piTrailing
-    [ ScriptStringXtoCP win32-error=0/f ] 2keep [ *int ] bi@ ;
\ No newline at end of file
+    [ ScriptStringXtoCP ole32-error ] 2keep [ *int ] bi@ ;
\ No newline at end of file