basis/windows/uniscribe/uniscribe.factor

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