basis/windows/uniscribe/uniscribe.factor

   1 ! Copyright (C) 2009 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: kernel assocs math sequences fry io.encodings.string
   4 io.encodings.utf16n accessors arrays combinators destructors
   5 cache namespaces init fonts alien.c-types windows.usp10
   6 windows.offscreen windows.gdi32 windows.ole32 windows.types
   7 windows.fonts opengl.textures locals windows.errors
   8 classes.struct ;
   9 IN: windows.uniscribe
  10
  11 TUPLE: script-string < disposable font string metrics ssa size image ;
  12
  13 : line-offset>x ( n script-string -- x )
  14     2dup string>> length = [
  15         ssa>> ! ssa
  16         swap 1 - ! icp
  17         TRUE ! fTrailing
  18     ] [
  19         ssa>>
  20         swap ! icp
  21         FALSE ! fTrailing
  22     ] if
  23     0 <int> [ ScriptStringCPtoX ole32-error ] keep *int ;
  24
  25 : x>line-offset ( x script-string -- n trailing )
  26     ssa>> ! ssa
  27     swap ! iX
  28     0 <int> ! pCh
  29     0 <int> ! piTrailing
  30     [ ScriptStringXtoCP ole32-error ] 2keep [ *int ] bi@ ;
  31
  32 <PRIVATE
  33
  34 : make-script-string ( dc string -- script-string )
  35     dup selection? [ string>> ] when
  36     [ utf16n encode ] ! pString
  37     [ length ] bi ! cString
  38     dup 1.5 * 16 + >integer ! cGlyphs -- MSDN says this is "recommended size"
  39     -1 ! iCharset -- Unicode
  40     SSA_GLYPHS ! dwFlags
  41     0 ! iReqWidth
  42     f ! psControl
  43     f ! psState
  44     f ! piDx
  45     f ! pTabdef
  46     f ! pbInClass
  47     f <void*> ! pssa
  48     [ ScriptStringAnalyse ] keep
  49     [ ole32-error ] [ |ScriptStringFree *void* ] bi* ;
  50
  51 : set-dc-colors ( dc font -- )
  52     [ background>> color>RGB SetBkColor drop ]
  53     [ foreground>> color>RGB SetTextColor drop ] 2bi ;
  54
  55 : selection-start/end ( script-string -- iMinSel iMaxSel )
  56     string>> dup selection? [ [ start>> ] [ end>> ] bi ] [ drop 0 0 ] if ;
  57
  58 : (draw-script-string) ( script-string -- )
  59     [
  60         ssa>> ! ssa
  61         0 ! iX
  62         0 ! iY
  63         ETO_OPAQUE ! uOptions
  64     ]
  65     [ [ { 0 0 } ] dip size>> <RECT> ]
  66     [ selection-start/end ] tri
  67     ! iMinSel
  68     ! iMaxSel
  69     FALSE ! fDisabled
  70     ScriptStringOut ole32-error ;
  71
  72 : draw-script-string ( dc script-string -- )
  73     [ font>> set-dc-colors ] keep (draw-script-string) ;
  74
  75 :: make-script-string-image ( dc script-string -- image )
  76     script-string size>> dc
  77     [ dc script-string draw-script-string ] make-bitmap-image ;
  78
  79 : set-dc-font ( dc font -- )
  80     cache-font SelectObject win32-error=0/f ;
  81
  82 : script-string-size ( script-string -- dim )
  83     ssa>> ScriptString_pSize
  84     dup win32-error=0/f
  85     SIZE memory>struct
  86     [ cx>> ] [ cy>> ] bi 2array ;
  87
  88 : dc-metrics ( dc -- metrics )
  89     TEXTMETRICW <struct>
  90     [ GetTextMetrics drop ] keep
  91     TEXTMETRIC>metrics ;
  92
  93 : <script-string> ( font string -- script-string )
  94     [ script-string new-disposable ] 2dip
  95         [ >>font ] [ >>string ] bi*
  96     [
  97         {
  98             [ over font>> set-dc-font ]
  99             [ dc-metrics >>metrics ]
 100             [ over string>> make-script-string >>ssa ]
 101             [ drop dup script-string-size >>size ]
 102             [ over make-script-string-image >>image ]
 103         } cleave
 104     ] with-memory-dc ;
 105
 106 PRIVATE>
 107
 108 M: script-string dispose*
 109     ssa>> <void*> ScriptStringFree ole32-error ;
 110
 111 SYMBOL: cached-script-strings
 112
 113 : cached-script-string ( font string -- script-string )
 114     cached-script-strings get-global [ <script-string> ] 2cache ;
 115
 116 [ <cache-assoc> &dispose cached-script-strings set-global ]
 117 "windows.uniscribe" add-startup-hook