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 locals
   5 cache namespaces init images.normalization fonts alien.c-types
   6 windows windows.usp10 windows.offscreen windows.gdi32
   7 windows.ole32 windows.types windows.fonts opengl.textures ;
   8 IN: windows.uniscribe
   9
  10 TUPLE: script-string font string metrics ssa size image disposed ;
  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     0 <int> [ ScriptStringCPtoX ole32-error ] keep *int ;
  23
  24 : x>line-offset ( x script-string -- n trailing )
  25     ssa>> ! ssa
  26     swap ! iX
  27     0 <int> ! pCh
  28     0 <int> ! piTrailing
  29     [ ScriptStringXtoCP ole32-error ] 2keep [ *int ] bi@ ;
  30
  31 <PRIVATE
  32
  33 : make-script-string ( dc string -- script-string )
  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_GLYPHS ! dwFlags
  40     0 ! iReqWidth
  41     f ! psControl
  42     f ! psState
  43     f ! piDx
  44     f ! pTabdef
  45     f ! pbInClass
  46     f <void*> ! pssa
  47     [ ScriptStringAnalyse ] keep
  48     [ ole32-error ] [ |ScriptStringFree *void* ] 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) ( script-string -- )
  58     [
  59         ssa>> ! ssa
  60         0 ! iX
  61         0 ! iY
  62         0 ! uOptions
  63         f ! prc
  64     ]
  65     [ selection-start/end ] bi
  66     ! iMinSel
  67     ! iMaxSel
  68     FALSE ! fDisabled
  69     ScriptStringOut ole32-error ;
  70
  71 : draw-script-string ( dc script-string -- )
  72     [ font>> set-dc-colors ] keep (draw-script-string) ;
  73
  74 : script-string-bitmap-size ( script-string -- dim )
  75     size>> dup small-texture? [ [ next-power-of-2 ] map ] when ;
  76
  77 :: make-script-string-image ( dc script-string -- image )
  78     script-string script-string-bitmap-size dc
  79     [ dc script-string draw-script-string ] make-bitmap-image ;
  80
  81 : set-dc-font ( dc font -- )
  82     cache-font SelectObject win32-error=0/f ;
  83
  84 : script-string-size ( script-string -- dim )
  85     ssa>> ScriptString_pSize
  86     dup win32-error=0/f
  87     [ SIZE-cx ] [ SIZE-cy ] bi 2array ;
  88
  89 : dc-metrics ( dc -- metrics )
  90     "TEXTMETRICW" <c-object>
  91     [ GetTextMetrics drop ] keep
  92     TEXTMETRIC>metrics ;
  93
  94 : <script-string> ( font string -- script-string )
  95     [ script-string new ] 2dip
  96         [ >>font ] [ >>string ] bi*
  97     [
  98         {
  99             [ over font>> set-dc-font ]
 100             [ dc-metrics >>metrics ]
 101             [ over string>> make-script-string >>ssa ]
 102             [ drop dup script-string-size >>size ]
 103             [ over make-script-string-image >>image ]
 104         } cleave
 105     ] with-memory-dc ;
 106
 107 PRIVATE>
 108
 109 M: script-string dispose*
 110     ssa>> <void*> ScriptStringFree ole32-error ;
 111
 112 SYMBOL: cached-script-strings
 113
 114 : cached-script-string ( string font -- script-string )
 115     cached-script-strings get-global [ <script-string> ] 2cache ;
 116
 117 [ <cache-assoc> cached-script-strings set-global ]
 118 "windows.uniscribe" add-init-hook