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 alien.data
   6 windows.usp10 windows.offscreen windows.gdi32 windows.ole32
   7 windows.types windows.fonts opengl.textures locals
   8 windows.errors 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     { int } [ ScriptStringCPtoX check-ole32-error ] with-out-parameters ;
  24
  25 : x>line-offset ( x script-string -- n trailing )
  26     ssa>> ! ssa
  27     swap ! iX
  28     { int int } [ ScriptStringXtoCP check-ole32-error ] with-out-parameters ;
  29
  30 <PRIVATE
  31
  32 : make-ssa ( dc script-string -- ssa )
  33     dup selection? [ string>> ] when
  34     [ utf16n encode ] ! pString
  35     [ length ] bi ! cString
  36     dup 1.5 * 16 + >integer ! cGlyphs -- MSDN says this is "recommended size"
  37     -1 ! iCharset -- Unicode
  38     SSA_GLYPHS ! dwFlags
  39     0 ! iReqWidth
  40     f ! psControl
  41     f ! psState
  42     f ! piDx
  43     f ! pTabdef
  44     f ! pbInClass
  45     f void* <ref> ! pssa
  46     [ ScriptStringAnalyse ] keep
  47     [ check-ole32-error ] [ |ScriptStringFree void* deref ] bi* ;
  48
  49 : set-dc-colors ( dc font -- )
  50     [ background>> color>RGB SetBkColor drop ]
  51     [ foreground>> color>RGB SetTextColor drop ] 2bi ;
  52
  53 : selection-start/end ( script-string -- iMinSel iMaxSel )
  54     string>> dup selection? [ [ start>> ] [ end>> ] bi ] [ drop 0 0 ] if ;
  55
  56 : draw-script-string ( ssa size script-string -- )
  57     [
  58         0 ! iX
  59         0 ! iY
  60         ETO_OPAQUE ! uOptions
  61     ]
  62     [ [ { 0 0 } ] dip <RECT> ]
  63     [ selection-start/end ] tri*
  64     ! iMinSel
  65     ! iMaxSel
  66     FALSE ! fDisabled
  67     ScriptStringOut check-ole32-error ;
  68
  69 :: render-image ( dc ssa script-string -- image )
  70     script-string size>> :> size
  71     size dc
  72     [ ssa size script-string draw-script-string ] make-bitmap-image ;
  73
  74 : set-dc-font ( dc font -- )
  75     cache-font SelectObject win32-error=0/f ;
  76
  77 : ssa-size ( ssa -- dim )
  78     ScriptString_pSize
  79     dup win32-error=0/f
  80     [ cx>> ] [ cy>> ] bi 2array ;
  81
  82 : dc-metrics ( dc -- metrics )
  83     TEXTMETRICW <struct>
  84     [ GetTextMetrics drop ] keep
  85     TEXTMETRIC>metrics ;
  86
  87 ! DC limit is default soft-limited to 10,000 per process.
  88 : <script-string> ( font string -- script-string )
  89     [ script-string new-disposable ] 2dip
  90         [ >>font ] [ >>string ] bi*
  91     [
  92         {
  93             [ over font>> set-dc-font ]
  94             [ dc-metrics >>metrics ]
  95             [ over string>> make-ssa [ >>ssa ] [ ssa-size >>size ] bi ]
  96         } cleave
  97     ] with-memory-dc ;
  98
  99 PRIVATE>
 100
 101 M: script-string dispose*
 102     ssa>> void* <ref> ScriptStringFree check-ole32-error ;
 103
 104 SYMBOL: cached-script-strings
 105
 106 : cached-script-string ( font string -- script-string )
 107     cached-script-strings get-global [ <script-string> ] 2cache ;
 108
 109 : script-string>image ( script-string -- image )
 110     dup image>> [
 111         [
 112             {
 113                 [ over font>> [ set-dc-font ] [ set-dc-colors ] 2bi ]
 114                 [
 115                     dup pick string>> make-ssa
 116                     dup void* <ref> &ScriptStringFree drop
 117                     pick render-image >>image
 118                 ]
 119             } cleave
 120         ] with-memory-dc
 121     ] unless image>> ;
 122
 123 [ <cache-assoc> &dispose cached-script-strings set-global ]
 124 "windows.uniscribe" add-startup-hook