diff --git a/basis/windows/uniscribe/uniscribe.factor b/basis/windows/uniscribe/uniscribe.factor index cfd723ae8f..53d2d9918f 100755 --- a/basis/windows/uniscribe/uniscribe.factor +++ b/basis/windows/uniscribe/uniscribe.factor @@ -1,79 +1,13 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel assocs math sequences fry io.encodings.string -io.encodings.utf16n accessors arrays combinators destructors -cache namespaces init images.normalization alien.c-types locals +io.encodings.utf16n accessors arrays combinators destructors locals +cache namespaces init images.normalization fonts alien.c-types windows windows.usp10 windows.offscreen windows.gdi32 -windows.ole32 windows.types windows.fonts ; +windows.ole32 windows.types windows.fonts opengl.textures ; IN: windows.uniscribe -TUPLE: script-string metrics ssa size image string disposed ; - -: make-script-string ( dc string -- script-string ) - [ utf16n encode ] ! pString - [ length ] bi ! cString - dup 1.5 * 16 + >integer ! cGlyphs -- MSDN says this is "recommended size" - -1 ! iCharset -- Unicode - SSA_GLYPHS ! dwFlags - 0 ! iReqWidth - f ! psControl - f ! psState - f ! piDx - f ! pTabdef - f ! pbInClass - f ! pssa - [ ScriptStringAnalyse ] keep - [ ole32-error ] [ |ScriptStringFree *void* ] bi* ; - -: draw-script-string ( script-string -- ) - ! ssa - 0 ! iX - 0 ! iY - 0 ! uOptions - f ! prc - 0 ! iMinSel - 0 ! iMaxSel - FALSE ! fDisabled - ScriptStringOut ole32-error ; - -: set-dc-font ( dc font -- ) - [ cache-font SelectObject win32-error=0/f ] - [ background>> color>RGB SetBkColor drop ] - [ foreground>> color>RGB SetTextColor drop ] 2tri ; - -: script-string-size ( ssa -- dim ) - ScriptString_pSize - dup win32-error=0/f - [ SIZE-cx ] [ SIZE-cy ] bi 2array ; - -: dc-metrics ( dc -- metrics ) - "TEXTMETRICW" [ GetTextMetrics drop ] keep - TEXTMETRIC>metrics ; - -:: ( font string -- script-string ) - #! Comments annotate BOA constructor arguments - [| dc | - dc font set-dc-font - dc dc-metrics ! metrics - dc string make-script-string dup :> ssa ! ssa - dup script-string-size ! size - dup dc [ ssa draw-script-string ] make-bitmap-image - normalize-image ! image - string ! string - f script-string boa - ] with-memory-dc ; - -: text-position ( script-string -- loc ) drop { 0 0 } ; - -M: script-string dispose* ssa>> ScriptStringFree ole32-error ; - -SYMBOL: cached-script-strings - -: cached-script-string ( string font -- script-string ) - cached-script-strings get-global [ ] 2cache ; - -[ cached-script-strings set-global ] -"windows.uniscribe" add-init-hook +TUPLE: script-string font string metrics ssa size image disposed ; : line-offset>x ( n script-string -- x ) 2dup string>> length = [ @@ -92,4 +26,93 @@ SYMBOL: cached-script-strings swap ! iX 0 ! pCh 0 ! piTrailing - [ ScriptStringXtoCP ole32-error ] 2keep [ *int ] bi@ ; \ No newline at end of file + [ ScriptStringXtoCP ole32-error ] 2keep [ *int ] bi@ ; + +> ] when + [ utf16n encode ] ! pString + [ length ] bi ! cString + dup 1.5 * 16 + >integer ! cGlyphs -- MSDN says this is "recommended size" + -1 ! iCharset -- Unicode + SSA_GLYPHS ! dwFlags + 0 ! iReqWidth + f ! psControl + f ! psState + f ! piDx + f ! pTabdef + f ! pbInClass + f ! pssa + [ ScriptStringAnalyse ] keep + [ ole32-error ] [ |ScriptStringFree *void* ] bi* ; + +: set-dc-colors ( dc font -- ) + [ background>> color>RGB SetBkColor drop ] + [ foreground>> color>RGB SetTextColor drop ] 2bi ; + +: selection-start/end ( script-string -- iMinSel iMaxSel ) + string>> dup selection? [ [ start>> ] [ end>> ] bi ] [ drop 0 0 ] if ; + +: (draw-script-string) ( script-string -- ) + [ + ssa>> ! ssa + 0 ! iX + 0 ! iY + 0 ! uOptions + f ! prc + ] + [ selection-start/end ] bi + ! iMinSel + ! iMaxSel + FALSE ! fDisabled + ScriptStringOut ole32-error ; + +: draw-script-string ( dc script-string -- ) + [ font>> set-dc-colors ] keep (draw-script-string) ; + +: script-string-bitmap-size ( script-string -- dim ) + size>> dup small-texture? [ [ next-power-of-2 ] map ] when ; + +:: make-script-string-image ( dc script-string -- image ) + script-string script-string-bitmap-size dc + [ dc script-string draw-script-string ] make-bitmap-image ; + +: set-dc-font ( dc font -- ) + cache-font SelectObject win32-error=0/f ; + +: script-string-size ( script-string -- dim ) + ssa>> ScriptString_pSize + dup win32-error=0/f + [ SIZE-cx ] [ SIZE-cy ] bi 2array ; + +: dc-metrics ( dc -- metrics ) + "TEXTMETRICW" + [ GetTextMetrics drop ] keep + TEXTMETRIC>metrics ; + +: ( font string -- script-string ) + [ script-string new ] 2dip + [ >>font ] [ >>string ] bi* + [ + { + [ over font>> set-dc-font ] + [ dc-metrics >>metrics ] + [ over string>> make-script-string >>ssa ] + [ drop dup script-string-size >>size ] + [ over make-script-string-image >>image ] + } cleave + ] with-memory-dc ; + +PRIVATE> + +M: script-string dispose* + ssa>> ScriptStringFree ole32-error ; + +SYMBOL: cached-script-strings + +: cached-script-string ( string font -- script-string ) + cached-script-strings get-global [ ] 2cache ; + +[ cached-script-strings set-global ] +"windows.uniscribe" add-init-hook \ No newline at end of file