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 images.normalization alien.c-types locals
   6 windows windows.usp10 windows.offscreen windows.gdi32
   7 windows.ole32 windows.types windows.fonts ;
   8 IN: windows.uniscribe
   9
  10 TUPLE: script-string metrics ssa size image string disposed ;
  11
  12 : make-script-string ( dc string -- script-string )
  13     [ utf16n encode ] ! pString
  14     [ length ] bi ! cString
  15     dup 1.5 * 16 + >integer ! cGlyphs -- MSDN says this is "recommended size"
  16     -1 ! iCharset -- Unicode
  17     SSA_GLYPHS ! dwFlags
  18     0 ! iReqWidth
  19     f ! psControl
  20     f ! psState
  21     f ! piDx
  22     f ! pTabdef
  23     f ! pbInClass
  24     f <void*> ! pssa
  25     [ ScriptStringAnalyse ] keep
  26     [ ole32-error ] [ |ScriptStringFree *void* ] bi* ;
  27
  28 : draw-script-string ( script-string -- )
  29     ! ssa
  30     0 ! iX
  31     0 ! iY
  32     0 ! uOptions
  33     f ! prc
  34     0 ! iMinSel
  35     0 ! iMaxSel
  36     FALSE ! fDisabled
  37     ScriptStringOut ole32-error ;
  38
  39 : set-dc-font ( dc font -- )
  40     [ cache-font SelectObject win32-error=0/f ]
  41     [ background>> color>RGB SetBkColor drop ]
  42     [ foreground>> color>RGB SetTextColor drop ] 2tri ;
  43
  44 : script-string-size ( ssa -- dim )
  45     ScriptString_pSize
  46     dup win32-error=0/f
  47     [ SIZE-cx ] [ SIZE-cy ] bi 2array ;
  48
  49 : dc-metrics ( dc -- metrics )
  50     "TEXTMETRICW" <c-object> [ GetTextMetrics drop ] keep
  51     TEXTMETRIC>metrics ;
  52
  53 :: <script-string> ( font string -- script-string )
  54     #! Comments annotate BOA constructor arguments
  55     [| dc |
  56         dc font set-dc-font
  57         dc dc-metrics ! metrics
  58         dc string make-script-string dup :> ssa ! ssa
  59         dup script-string-size ! size
  60         dup dc [ ssa draw-script-string ] make-bitmap-image
  61         normalize-image ! image
  62         string ! string
  63         f script-string boa
  64     ] with-memory-dc ;
  65
  66 : text-position ( script-string -- loc ) drop { 0 0 } ;
  67
  68 M: script-string dispose* ssa>> <void*> ScriptStringFree ole32-error ;
  69
  70 SYMBOL: cached-script-strings
  71
  72 : cached-script-string ( string font -- script-string )
  73     cached-script-strings get-global [ <script-string> ] 2cache ;
  74
  75 [ <cache-assoc> cached-script-strings set-global ]
  76 "windows.uniscribe" add-init-hook
  77
  78 : line-offset>x ( n script-string -- x )
  79     2dup string>> length = [
  80         ssa>> ! ssa
  81         swap 1- ! icp
  82         TRUE ! fTrailing
  83     ] [
  84         ssa>>
  85         swap ! icp
  86         FALSE ! fTrailing
  87     ] if
  88     0 <int> [ ScriptStringCPtoX ole32-error ] keep *int ;
  89
  90 : x>line-offset ( x script-string -- n trailing )
  91     ssa>> ! ssa
  92     swap ! iX
  93     0 <int> ! pCh
  94     0 <int> ! piTrailing
  95     [ ScriptStringXtoCP ole32-error ] 2keep [ *int ] bi@ ;