More progress on Uniscribe

README.txt

@@ -113,12 +113,6 @@ the command prompt using the console application:
 
   factor.com -i=boot.<cpu>.image
 
-Before bootstrapping, you will need to download the DLLs for the Pango
-text rendering library. The required DLLs are listed in
-build-support/dlls.txt and are available from the following location:
-
-  <http://factorcode.org/dlls>
-
 Once bootstrapped, double-clicking factor.exe or factor.com starts
 the Factor UI.
 

basis/alien/destructors/destructors.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: functors destructors accessors kernel parser words
-combinators.smart ;
+effects generalizations sequences ;
 IN: alien.destructors
 
 SLOT: alien
@@ -12,6 +12,7 @@ F-destructor DEFINES-CLASS ${F}-destructor
 <F-destructor> DEFINES <${F}-destructor>
 &F DEFINES &${F}
 |F DEFINES |${F}
+N [ F stack-effect out>> length ]
 
 WHERE
 
@@ -19,7 +20,7 @@ TUPLE: F-destructor alien disposed ;
 
 : <F-destructor> ( alien -- destructor ) f F-destructor boa ; inline
 
-M: F-destructor dispose* [ alien>> F ] drop-outputs ;
+M: F-destructor dispose* alien>> F N ndrop ;
 
 : &F ( alien -- alien ) dup <F-destructor> &dispose drop ; inline
 

basis/images/normalization/normalization.factor

@@ -61,6 +61,18 @@ M: ARGB normalize-component-order*
 M: ABGR normalize-component-order*
     drop ARGB>RGBA BGRA>RGBA ;
 
+: fix-XBGR ( bitmap -- bitmap' )
+    dup 4 <sliced-groups> [ [ 255 0 ] dip set-nth ] each ;
+
+M: XBGR normalize-component-order*
+    drop fix-XBGR ABGR normalize-component-order* ;
+
+: fix-BGRX ( bitmap -- bitmap' )
+    dup 4 <sliced-groups> [ [ 255 3 ] dip set-nth ] each ;
+
+M: BGRX normalize-component-order*
+    drop fix-BGRX BGRA normalize-component-order* ;
+
 : normalize-scan-line-order ( image -- image )
     dup upside-down?>> [
         dup dim>> first 4 * '[

basis/opengl/textures/textures.factor

@@ -17,6 +17,7 @@ M: BGR component-order>format drop GL_BGR GL_UNSIGNED_BYTE ;
 M: RGBA component-order>format drop GL_RGBA GL_UNSIGNED_BYTE ;
 M: ARGB component-order>format drop GL_BGRA_EXT GL_UNSIGNED_INT_8_8_8_8_REV ;
 M: BGRA component-order>format drop GL_BGRA_EXT GL_UNSIGNED_BYTE ;
+M: BGRX component-order>format drop GL_BGRA_EXT GL_UNSIGNED_BYTE ;
 
 GENERIC: draw-texture ( texture -- )
 

basis/ui/backend/windows/windows.factor

@@ -433,12 +433,7 @@ M: windows-ui-backend do-events
     style 0 ex-style AdjustWindowRectEx win32-error=0/f ;
 
 : make-RECT ( world -- RECT )
-    [ window-loc>> dup ] [ dim>> ] bi v+
+    [ window-loc>> ] [ dim>> ] bi <RECT> ;
-    "RECT" <c-object>
-    over first over set-RECT-right
-    swap second over set-RECT-bottom
-    over first over set-RECT-left
-    swap second over set-RECT-top ;
 
 : default-position-RECT ( RECT -- )
     dup get-RECT-dimensions [ 2drop ] 2dip

basis/ui/text/core-text/core-text.factor

@@ -10,9 +10,6 @@ IN: ui.text.core-text
 
 SINGLETON: core-text-renderer
 
-M: core-text-renderer init-text-rendering
-    <cache-assoc> >>text-handle drop ;
-
 M: core-text-renderer string-dim
     [ " " string-dim { 0 1 } v* ]
     [ cached-line dim>> ]

basis/ui/text/pango/pango.factor

@@ -7,9 +7,6 @@ IN: ui.text.pango
 
 SINGLETON: pango-renderer
 
-M: pango-renderer init-text-rendering
-    <cache-assoc> >>text-handle drop ;
-
 M: pango-renderer string-dim
     [ " " string-dim { 0 1 } v* ]
     [ cached-layout logical-rect>> dim>> [ >integer ] map ] if-empty ;

basis/ui/text/text-tests.factor

@@ -1,6 +1,22 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test ui.text fonts ;
+USING: tools.test ui.text fonts math accessors kernel sequences ;
 IN: ui.text.tests
 
-[ 0.0 ] [ 0 sans-serif-font "aaa" offset>x ] unit-test
+[ t ] [ 0 sans-serif-font "aaa" offset>x zero? ] unit-test
+[ t ] [ 1 sans-serif-font "aaa" offset>x 0.0 > ] unit-test
+[ t ] [ 3 sans-serif-font "aaa" offset>x 0.0 > ] unit-test
+[ t ] [ 1 monospace-font "a" offset>x 0.0 > ] unit-test
+[ 0 ] [ 0 sans-serif-font "aaa" x>offset ] unit-test
+[ 3 ] [ 100 sans-serif-font "aaa" x>offset ] unit-test
+[ 0 ] [ 0 sans-serif-font "" x>offset ] unit-test
+
+[ t ] [
+    sans-serif-font "aaa" line-metrics
+    [ [ ascent>> ] [ descent>> ] bi + ] [ height>> ] bi =
+] unit-test
+
+[ f ] [ sans-serif-font "\0a" text-dim first zero? ] unit-test
+[ t ] [ sans-serif-font "" text-dim first zero? ] unit-test
+
+[ f ] [ sans-serif-font font-metrics height>> zero? ] unit-test

basis/ui/text/text.factor

@@ -1,17 +1,16 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel arrays sequences math math.order opengl opengl.gl
+USING: kernel arrays sequences math math.order cache opengl
-strings fonts colors accessors namespaces ui.gadgets.worlds ;
+opengl.gl strings fonts colors accessors namespaces
+ui.gadgets.worlds ;
 IN: ui.text
 
 <PRIVATE
 
 SYMBOL: font-renderer
 
-HOOK: init-text-rendering font-renderer ( world -- )
-
 : world-text-handle ( world -- handle )
-    dup text-handle>> [ dup init-text-rendering ] unless
+    dup text-handle>> [ <cache-assoc> >>text-handle ] unless
     text-handle>> ;
 
 HOOK: flush-layout-cache font-renderer ( -- )
@@ -79,7 +78,7 @@ USING: vocabs.loader namespaces system combinators ;
 "ui-backend" get [
     {
         { [ os macosx? ] [ "core-text" ] }
-        { [ os windows? ] [ "pango" ] }
+        { [ os windows? ] [ "uniscribe" ] }
         { [ os unix? ] [ "pango" ] }
     } cond
 ] unless* "ui.text." prepend require

basis/ui/text/uniscribe/uniscribe.factor

@@ -0,0 +1,41 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs cache kernel math.vectors sequences
+namespaces opengl.textures ui.text ui.text.private ui.gadgets.worlds 
+windows.uniscribe ;
+IN: ui.text.uniscribe
+
+SINGLETON: uniscribe-renderer
+
+M: uniscribe-renderer string-dim
+    [ " " string-dim { 0 1 } v* ]
+    [ cached-script-string size>> ] if-empty ;
+
+M: uniscribe-renderer flush-layout-cache
+    cached-script-strings get purge-cache ;
+
+: rendered-script-string ( font string -- texture )
+    world get world-text-handle
+    [ cached-script-string [ image>> ] [ text-position vneg ] bi <texture> ]
+    2cache ;
+
+M: uniscribe-renderer draw-string ( font string -- )
+    [ drop ] [ rendered-script-string draw-texture ] if-empty ;
+
+M: uniscribe-renderer x>offset ( x font string -- n )
+    [ 2drop 0 ] [
+        cached-script-string x>line-offset drop
+    ] if-empty ;
+
+M: uniscribe-renderer offset>x ( n font string -- x )
+    [ 2drop 0 ] [ cached-script-string line-offset>x ] if-empty ;
+
+M: uniscribe-renderer font-metrics ( font -- metrics )
+    " " cached-script-string metrics>> clone f >>width ;
+
+M: uniscribe-renderer line-metrics ( font string -- metrics )
+    [ " " line-metrics clone 0 >>width ]
+    [ cached-script-string metrics>> 50 >>width 10 >>cap-height 10 >>x-height ]
+    if-empty ;
+
+uniscribe-renderer font-renderer set-global

basis/windows/fonts/fonts.factor

@@ -0,0 +1,37 @@
+USING: assocs memoize locals kernel accessors init fonts
+combinators windows windows.types windows.gdi32 ;
+IN: windows.fonts
+
+: windows-font-name ( string -- string' )
+    H{
+        { "sans-serif" "Tahoma" }
+        { "serif" "Times New Roman" }
+        { "monospace" "Courier New" }
+    } at-default ;
+    
+MEMO:: (cache-font) ( font -- HFONT )
+    font size>> ! nHeight
+    0 0 0 ! nWidth, nEscapement, nOrientation
+    font bold?>> FW_BOLD FW_NORMAL ? ! fnWeight
+    font italic?>> TRUE FALSE ? ! fdwItalic
+    FALSE ! fdwUnderline
+    FALSE ! fdWStrikeOut
+    DEFAULT_CHARSET ! fdwCharSet
+    OUT_OUTLINE_PRECIS ! fdwOutputPrecision
+    CLIP_DEFAULT_PRECIS ! fdwClipPrecision
+    DEFAULT_QUALITY ! fdwQuality
+    DEFAULT_PITCH ! fdwPitchAndFamily
+    font name>> windows-font-name
+    CreateFont
+    dup win32-error=0/f ;
+
+: cache-font ( font -- HFONT ) strip-font-colors (cache-font) ;
+
+[ \ (cache-font) reset-memoized ] "windows.fonts" add-init-hook
+
+: TEXTMETRIC>metrics ( TEXTMETRIC -- metrics )
+    [ metrics new 0 >>width ] dip {
+        [ TEXTMETRICW-tmHeight >>height ]
+        [ TEXTMETRICW-tmAscent >>ascent ]
+        [ TEXTMETRICW-tmDescent >>descent ]
+    } cleave ;

basis/windows/offscreen/offscreen-tests.factor

@@ -0,0 +1,5 @@
+IN: windows.offscreen.tests
+USING: windows.offscreen effects tools.test kernel images ;
+
+{ 1 1 } [ [ [ ] make-bitmap-image ] with-memory-dc ] must-infer-as
+[ t ] [ [ { 10 10 } swap [ ] make-bitmap-image ] with-memory-dc image? ] unit-test

basis/windows/offscreen/offscreen.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien.c-types kernel combinators sequences
 math windows.gdi32 windows.types images destructors
-accessors fry ;
+accessors fry locals ;
 IN: windows.offscreen
 
 : (bitmap-info) ( dim -- BITMAPINFO )
@@ -22,26 +22,32 @@ IN: windows.offscreen
         } 2cleave
     ] keep ;
 
-: make-offscreen-dc-and-bitmap ( dim -- hDC hBitmap bits )
+: make-bitmap ( dim dc -- hBitmap bits )
-    f CreateCompatibleDC
     [ nip ]
     [
         swap (bitmap-info) DIB_RGB_COLORS f <void*>
         [ f 0 CreateDIBSection ] keep *void*
     ] 2bi
-    [ 2dup SelectObject drop ] dip ;
+    [ [ SelectObject drop ] keep ] dip ;
+
+: make-offscreen-dc-and-bitmap ( dim -- dc hBitmap bits )
+    [ f CreateCompatibleDC ] dip over make-bitmap ;
 
 : bitmap>byte-array ( bits dim -- byte-array )
     product 4 * memory>byte-array ;
 
 : bitmap>image ( bits dim -- image )
     [ bitmap>byte-array ] keep
-    <image> swap >>dim swap >>bitmap XBGR >>component-order ;
+    <image>
+        swap >>dim
+        swap >>bitmap
+        BGRX >>component-order
+        t >>upside-down? ;
 
-: make-bitmap-image ( dim quot: ( hDC -- ) -- image )
+: with-memory-dc ( quot: ( hDC -- ) -- )
-    '[
+    [ [ f CreateCompatibleDC &DeleteDC ] dip call ] with-destructors ; inline
-        [
+
-            make-offscreen-dc-and-bitmap
+:: make-bitmap-image ( dim dc quot -- image )
-            [ &DeleteDC @ ] [ &DeleteObject drop ] [ ] tri*
+    dim dc make-bitmap [ &DeleteObject drop ] dip
-        ] keep bitmap>byte-array
+    quot dip
-    ] with-destructors ; inline
+    dim bitmap>image ; inline

basis/windows/types/types.factor

@@ -1,6 +1,7 @@
 ! Copyright (C) 2005, 2006 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.syntax namespaces kernel words ;
+USING: alien alien.c-types alien.syntax namespaces kernel words
+sequences math math.bitwise math.vectors colors ;
 IN: windows.types
 
 TYPEDEF: char                CHAR
@@ -244,14 +245,14 @@ C-STRUCT: RECT
     { "LONG" "right" }
     { "LONG" "bottom" } ;
 
-! C-STRUCT: PAINTSTRUCT
+C-STRUCT: PAINTSTRUCT
-    ! { "HDC" " hdc" }
+    { "HDC" " hdc" }
-    ! { "BOOL" "fErase" }
+    { "BOOL" "fErase" }
-    ! { "RECT" "rcPaint" }
+    { "RECT" "rcPaint" }
-    ! { "BOOL" "fRestore" }
+    { "BOOL" "fRestore" }
-    ! { "BOOL" "fIncUpdate" }
+    { "BOOL" "fIncUpdate" }
-    ! { "BYTE[32]" "rgbReserved" }
+    { "BYTE[32]" "rgbReserved" }
-! ;
+;
 
 C-STRUCT: BITMAPINFOHEADER
     { "DWORD"  "biSize" }
@@ -283,6 +284,10 @@ C-STRUCT: POINT
     { "LONG" "x" }
     { "LONG" "y" } ; 
 
+C-STRUCT: SIZE
+    { "LONG" "cx" }
+    { "LONG" "cy" } ; 
+
 C-STRUCT: MSG
     { "HWND" "hWnd" }
     { "UINT" "message" }
@@ -327,6 +332,14 @@ C-STRUCT: RECT
     { "LONG" "right" }
     { "LONG" "bottom" } ;
 
+: <RECT> ( loc dim -- RECT )
+    over v+
+    "RECT" <c-object>
+    over first over set-RECT-right
+    swap second over set-RECT-bottom
+    over first over set-RECT-left
+    swap second over set-RECT-top ;
+
 TYPEDEF: RECT* PRECT
 TYPEDEF: RECT* LPRECT
 TYPEDEF: PIXELFORMATDESCRIPTOR PFD
@@ -363,3 +376,36 @@ C-STRUCT: ACCEL
     { "WORD" "key" }
     { "WORD" "cmd" } ;
 TYPEDEF: ACCEL* LPACCEL
+
+TYPEDEF: DWORD COLORREF
+TYPEDEF: DWORD* LPCOLORREF
+
+: RGB ( r g b -- COLORREF )
+    { 16 8 0 } bitfield ; inline
+
+: color>RGB ( color -- COLORREF )
+    >rgba-components drop [ 255 * >integer ] tri@ RGB ;
+
+C-STRUCT: TEXTMETRICW
+    { "LONG" "tmHeight" }
+    { "LONG" "tmAscent" }
+    { "LONG" "tmDescent" }
+    { "LONG" "tmInternalLeading" }
+    { "LONG" "tmExternalLeading" }
+    { "LONG" "tmAveCharWidth" }
+    { "LONG" "tmMaxCharWidth" }
+    { "LONG" "tmWeight" }
+    { "LONG" "tmOverhang" }
+    { "LONG" "tmDigitizedAspectX" }
+    { "LONG" "tmDigitizedAspectY" }
+    { "WCHAR" "tmFirstChar" }
+    { "WCHAR" "tmLastChar" }
+    { "WCHAR" "tmDefaultChar" }
+    { "WCHAR" "tmBreakChar" }
+    { "BYTE" "tmItalic" }
+    { "BYTE" "tmUnderlined" }
+    { "BYTE" "tmStruckOut" }
+    { "BYTE" "tmPitchAndFamily" }
+    { "BYTE" "tmCharSet" } ;
+
+TYPEDEF: TEXTMETRICW* LPTEXTMETRIC

basis/windows/uniscribe/uniscribe.factor

@@ -1,65 +1,95 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math sequences io.encodings.string io.encodings.utf16n
+USING: kernel assocs math sequences fry io.encodings.string
-accessors arrays destructors alien.c-types windows windows.usp10
+io.encodings.utf16n accessors arrays combinators destructors
-windows.offscreen ;
+cache namespaces init images.normalization alien.c-types locals
+windows windows.usp10 windows.offscreen windows.gdi32
+windows.ole32 windows.types windows.fonts ;
 IN: windows.uniscribe
 
-TUPLE: script-string pssa size image ;
+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 + ! cGlyphs -- MSDN says this is "recommended size"
+    dup 1.5 * 16 + >integer ! cGlyphs -- MSDN says this is "recommended size"
     -1 ! iCharset -- Unicode
     SSA_GLYPHS ! dwFlags
-    ... ! iReqWidth
+    0 ! iReqWidth
     f ! psControl
     f ! psState
     f ! piDx
     f ! pTabdef
-    ... ! pbInClass
+    f ! pbInClass
     f <void*> ! pssa
     [ ScriptStringAnalyse ] keep
-    [ win32-error=0/f ] [ |ScriptStringFree ] bi* ;
+    [ ole32-error ] [ |ScriptStringFree *void* ] bi* ;
 
-: draw-script-string ( script-string -- bitmap )
+: draw-script-string ( script-string -- )
     ! ssa
     0 ! iX
     0 ! iY
-    ETO_OPAQUE ! uOptions ... ????
+    0 ! uOptions
     f ! prc
     0 ! iMinSel
     0 ! iMaxSel
-    f ! fDisabled
+    FALSE ! fDisabled
-    ScriptStringOut ;
+    ScriptStringOut ole32-error ;
 
-: <script-string> ( string -- script-string )
+: set-dc-font ( dc font -- )
-    [
+    [ cache-font SelectObject win32-error=0/f ]
-        ... dim ... [
+    [ background>> color>RGB SetBkColor drop ]
-            make-script-string |ScriptStringFree
+    [ foreground>> color>RGB SetTextColor drop ] 2tri ;
-            [ ]
-            [ draw-script-string ]
-            [
-                ScriptString_pSize
-                dup win32-error=0/f
-                [ SIZE-cx ] [ SIZE-cy ] bi 2array
-            ] tri
-        ] make-bitmap-image
-        script-string boa
-    ] with-destructors ;
 
-M: script-string dispose* pssa>> ScriptStringFree win32-error=0/f ;
+: script-string-size ( ssa -- dim )
+    ScriptString_pSize
+    dup win32-error=0/f
+    [ SIZE-cx ] [ SIZE-cy ] bi 2array ;
 
-: line-offset>x ( offset script-string -- x )
+: dc-metrics ( dc -- metrics )
-    pssa>> ! ssa
+    "TEXTMETRICW" <c-object> [ GetTextMetrics drop ] keep
-    swap ! icp
+    TEXTMETRIC>metrics ;
-    ... ! fTrailing
-    0 <int> [ ScriptStringCPtoX win32-error=0/f ] keep *int ;
 
-: line-x>offset ( x script-string -- offset trailing )
+:: <script-string> ( font string -- script-string )
-    pssa>> ! ssa
+    #! 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>> <void*> ScriptStringFree ole32-error ;
+
+SYMBOL: cached-script-strings
+
+: cached-script-string ( string font -- script-string )
+    cached-script-strings get-global [ <script-string> ] 2cache ;
+
+[ <cache-assoc> cached-script-strings set-global ]
+"windows.uniscribe" add-init-hook
+
+: line-offset>x ( n script-string -- x )
+    2dup string>> length = [
+        ssa>> ! ssa
+        swap 1- ! icp
+        TRUE ! fTrailing
+    ] [
+        ssa>>
+        swap ! icp
+        FALSE ! fTrailing
+    ] if
+    0 <int> [ ScriptStringCPtoX ole32-error ] keep *int ;
+
+: x>line-offset ( x script-string -- n trailing )
+    ssa>> ! ssa
     swap ! iX
     0 <int> ! pCh
     0 <int> ! piTrailing
-    [ ScriptStringXtoCP win32-error=0/f ] 2keep [ *int ] bi@ ;
+    [ ScriptStringXtoCP ole32-error ] 2keep [ *int ] bi@ ;