Paint selection, and create bitmap with power of 2 size as an optimizaion

diff --git a/basis/windows/uniscribe/uniscribe.factor b/basis/windows/uniscribe/uniscribe.factor
index cfd723ae8fa86cd9066c1df7916e805198a4c66d..53d2d9918f840d6707e1f3d5e7a0c7bf04784abc 100755 (executable)
--- a/basis/windows/uniscribe/uniscribe.factor
+++ b/basis/windows/uniscribe/uniscribe.factor
@@ -1,15 +1,37 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 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
+io.encodings.utf16n accessors arrays combinators destructors locals
+cache namespaces init images.normalization fonts alien.c-types
 windows windows.usp10 windows.offscreen windows.gdi32
-windows.ole32 windows.types windows.fonts ;
+windows.ole32 windows.types windows.fonts opengl.textures ;
 IN: windows.uniscribe
 
-TUPLE: script-string metrics ssa size image string disposed ;
+TUPLE: script-string font string metrics ssa size image disposed ;
+
+: 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 ole32-error ] 2keep [ *int ] bi@ ;
+
+<PRIVATE
 
 : make-script-string ( dc string -- script-string )
+    dup selection? [ string>> ] when
     [ utf16n encode ] ! pString
     [ length ] bi ! cString
     dup 1.5 * 16 + >integer ! cGlyphs -- MSDN says this is "recommended size"
@@ -25,47 +47,67 @@ TUPLE: script-string metrics ssa size image string disposed ;
     [ ScriptStringAnalyse ] keep
     [ ole32-error ] [ |ScriptStringFree *void* ] bi* ;
 
-: draw-script-string ( script-string -- )
-    ! ssa
-    0 ! iX
-    0 ! iY
-    0 ! uOptions
-    f ! prc
-    0 ! iMinSel
-    0 ! iMaxSel
+: set-dc-colors ( dc font -- )
+    [ background>> color>RGB SetBkColor drop ]
+    [ foreground>> color>RGB SetTextColor drop ] 2bi ;
+
+: selection-start/end ( script-string -- iMinSel iMaxSel )
+    string>> dup selection? [ [ start>> ] [ end>> ] bi ] [ drop 0 0 ] if ;
+
+: (draw-script-string) ( script-string -- )
+    [
+        ssa>> ! ssa
+        0 ! iX
+        0 ! iY
+        0 ! uOptions
+        f ! prc
+    ]
+    [ selection-start/end ] bi
+    ! iMinSel
+    ! iMaxSel
     FALSE ! fDisabled
     ScriptStringOut ole32-error ;
 
+: draw-script-string ( dc script-string -- )
+    [ font>> set-dc-colors ] keep (draw-script-string) ;
+
+: script-string-bitmap-size ( script-string -- dim )
+    size>> dup small-texture? [ [ next-power-of-2 ] map ] when ;
+
+:: make-script-string-image ( dc script-string -- image )
+    script-string script-string-bitmap-size dc
+    [ dc script-string draw-script-string ] make-bitmap-image ;
+
 : set-dc-font ( dc font -- )
-    [ cache-font SelectObject win32-error=0/f ]
-    [ background>> color>RGB SetBkColor drop ]
-    [ foreground>> color>RGB SetTextColor drop ] 2tri ;
+    cache-font SelectObject win32-error=0/f ;
 
-: script-string-size ( ssa -- dim )
-    ScriptString_pSize
+: script-string-size ( script-string -- dim )
+    ssa>> ScriptString_pSize
     dup win32-error=0/f
     [ SIZE-cx ] [ SIZE-cy ] bi 2array ;
 
 : dc-metrics ( dc -- metrics )
-    "TEXTMETRICW" <c-object> [ GetTextMetrics drop ] keep
+    "TEXTMETRICW" <c-object>
+    [ GetTextMetrics drop ] keep
     TEXTMETRIC>metrics ;
 
-:: <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
+: <script-string> ( font string -- script-string )
+    [ script-string new ] 2dip
+        [ >>font ] [ >>string ] bi*
+    [
+        {
+            [ over font>> set-dc-font ]
+            [ dc-metrics >>metrics ]
+            [ over string>> make-script-string >>ssa ]
+            [ drop dup script-string-size >>size ]
+            [ over make-script-string-image >>image ]
+        } cleave
     ] with-memory-dc ;
 
-: text-position ( script-string -- loc ) drop { 0 0 } ;
+PRIVATE>
 
-M: script-string dispose* ssa>> <void*> ScriptStringFree ole32-error ;
+M: script-string dispose*
+    ssa>> <void*> ScriptStringFree ole32-error ;
 
 SYMBOL: cached-script-strings
 
@@ -73,23 +115,4 @@ SYMBOL: cached-script-strings
     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 ole32-error ] 2keep [ *int ] bi@ ;
\ No newline at end of file
+"windows.uniscribe" add-init-hook
\ No newline at end of file