basis/windows/uniscribe/uniscribe.factor

   1 ! Copyright (C) 2009 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: kernel math sequences io.encodings.string io.encodings.utf16n
   4 accessors arrays destructors alien.c-types windows windows.usp10
   5 windows.offscreen ;
   6 IN: windows.uniscribe
   7
   8 TUPLE: script-string pssa size image ;
   9
  10 : make-script-string ( dc string -- script-string )
  11     [ utf16n encode ] ! pString
  12     [ length ] bi ! cString
  13     dup 1.5 * 16 + ! cGlyphs -- MSDN says this is "recommended size"
  14     -1 ! iCharset -- Unicode
  15     SSA_GLYPHS ! dwFlags
  16     ... ! iReqWidth
  17     f ! psControl
  18     f ! psState
  19     f ! piDx
  20     f ! pTabdef
  21     ... ! pbInClass
  22     f <void*> ! pssa
  23     [ ScriptStringAnalyse ] keep
  24     [ win32-error=0/f ] [ |ScriptStringFree ] bi* ;
  25
  26 : draw-script-string ( script-string -- bitmap )
  27     ! ssa
  28     0 ! iX
  29     0 ! iY
  30     ETO_OPAQUE ! uOptions ... ????
  31     f ! prc
  32     0 ! iMinSel
  33     0 ! iMaxSel
  34     f ! fDisabled
  35     ScriptStringOut ;
  36
  37 : <script-string> ( string -- script-string )
  38     [
  39         ... dim ... [
  40             make-script-string |ScriptStringFree
  41             [ ]
  42             [ draw-script-string ]
  43             [
  44                 ScriptString_pSize
  45                 dup win32-error=0/f
  46                 [ SIZE-cx ] [ SIZE-cy ] bi 2array
  47             ] tri
  48         ] make-bitmap-image
  49         script-string boa
  50     ] with-destructors ;
  51
  52 M: script-string dispose* pssa>> ScriptStringFree win32-error=0/f ;
  53
  54 : line-offset>x ( offset script-string -- x )
  55     pssa>> ! ssa
  56     swap ! icp
  57     ... ! fTrailing
  58     0 <int> [ ScriptStringCPtoX win32-error=0/f ] keep *int ;
  59
  60 : line-x>offset ( x script-string -- offset trailing )
  61     pssa>> ! ssa
  62     swap ! iX
  63     0 <int> ! pCh
  64     0 <int> ! piTrailing
  65     [ ScriptStringXtoCP win32-error=0/f ] 2keep [ *int ] bi@ ;