! 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 fonts alien.c-types windows.usp10
+windows.offscreen windows.gdi32 windows.ole32 windows.types
+windows.fonts opengl.textures locals windows.errors
+classes.struct ;
IN: windows.uniscribe
-TUPLE: script-string pssa size image ;
+TUPLE: script-string < disposable font string metrics ssa size image ;
+
+: 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 + ! 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* ;
-
-: draw-script-string ( script-string -- bitmap )
- ! ssa
- 0 ! iX
- 0 ! iY
- ETO_OPAQUE ! uOptions ... ????
- f ! prc
- 0 ! iMinSel
- 0 ! iMaxSel
- f ! fDisabled
- ScriptStringOut ;
-
-: <script-string> ( string -- script-string )
+ [ ole32-error ] [ |ScriptStringFree *void* ] bi* ;
+
+: 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 -- )
[
- ... 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 ;
-
-M: script-string dispose* pssa>> ScriptStringFree win32-error=0/f ;
-
-: line-offset>x ( offset script-string -- x )
- pssa>> ! ssa
- swap ! icp
- ... ! fTrailing
- 0 <int> [ ScriptStringCPtoX win32-error=0/f ] keep *int ;
-
-: line-x>offset ( x script-string -- offset trailing )
- pssa>> ! ssa
- swap ! iX
- 0 <int> ! pCh
- 0 <int> ! piTrailing
- [ ScriptStringXtoCP win32-error=0/f ] 2keep [ *int ] bi@ ;
\ No newline at end of file
+ ssa>> ! ssa
+ 0 ! iX
+ 0 ! iY
+ ETO_OPAQUE ! uOptions
+ ]
+ [ [ { 0 0 } ] dip size>> <RECT> ]
+ [ selection-start/end ] tri
+ ! iMinSel
+ ! iMaxSel
+ FALSE ! fDisabled
+ ScriptStringOut ole32-error ;
+
+: draw-script-string ( dc script-string -- )
+ [ font>> set-dc-colors ] keep (draw-script-string) ;
+
+:: make-script-string-image ( dc script-string -- image )
+ script-string size>> dc
+ [ dc script-string draw-script-string ] make-bitmap-image ;
+
+: set-dc-font ( dc font -- )
+ cache-font SelectObject win32-error=0/f ;
+
+: script-string-size ( script-string -- dim )
+ ssa>> ScriptString_pSize
+ dup win32-error=0/f
+ SIZE memory>struct
+ [ cx>> ] [ cy>> ] bi 2array ;
+
+: dc-metrics ( dc -- metrics )
+ TEXTMETRICW <struct>
+ [ GetTextMetrics drop ] keep
+ TEXTMETRIC>metrics ;
+
+: <script-string> ( font string -- script-string )
+ [ script-string new-disposable ] 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 ;
+
+PRIVATE>
+
+M: script-string dispose*
+ ssa>> <void*> ScriptStringFree ole32-error ;
+
+SYMBOL: cached-script-strings
+
+: cached-script-string ( font string -- script-string )
+ cached-script-strings get-global [ <script-string> ] 2cache ;
+
+[ <cache-assoc> cached-script-strings set-global ]
+"windows.uniscribe" add-startup-hook
+
+[ cached-script-strings get-global dispose ]
+"windows.uniscribe" add-shutdown-hook