steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

More progress on Uniscribe

db4
U-SLAVA-DFB8FF805\Slava 2009-04-02 13:05:26 -05:00
parent 0cfa22c276
commit 9c3054c84a
16 changed files with 1536 additions and 120 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
README.txt
View File

@ -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.

5
basis/alien/destructors/destructors.factor Normal file → Executable file
View File

@ -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

12
basis/images/normalization/normalization.factor Normal file → Executable file
View File

@ -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 * '[

1
basis/opengl/textures/textures.factor Normal file → Executable file
View File

@ -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 -- )

7
basis/ui/backend/windows/windows.factor
View File

@ -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+
"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 ;
[ window-loc>> ] [ dim>> ] bi <RECT> ;
: default-position-RECT ( RECT -- )
dup get-RECT-dimensions [ 2drop ] 2dip

3
basis/ui/text/core-text/core-text.factor Normal file → Executable file
View File

@ -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>> ]

3
basis/ui/text/pango/pango.factor
View File

@ -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 ;

20
basis/ui/text/text-tests.factor Normal file → Executable file
View File

@ -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

11
basis/ui/text/text.factor Normal file → Executable file
View File

@ -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
strings fonts colors accessors namespaces ui.gadgets.worlds ;
USING: kernel arrays sequences math math.order cache opengl
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

41
basis/ui/text/uniscribe/uniscribe.factor Executable file
View File

@ -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

37
basis/windows/fonts/fonts.factor Executable file
View File

@ -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 ;

1311
basis/windows/gdi32/gdi32.factor
View File

File diff suppressed because it is too large Load Diff

5
basis/windows/offscreen/offscreen-tests.factor Executable file
View File

@ -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

30
basis/windows/offscreen/offscreen.factor Normal file → Executable file
View File

@ -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 )
f CreateCompatibleDC
: make-bitmap ( dim dc -- hBitmap bits )
[ 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 )
'[
[
make-offscreen-dc-and-bitmap
[ &DeleteDC @ ] [ &DeleteObject drop ] [ ] tri*
] keep bitmap>byte-array
] with-destructors ; inline
: with-memory-dc ( quot: ( hDC -- ) -- )
[ [ f CreateCompatibleDC &DeleteDC ] dip call ] with-destructors ; inline
:: make-bitmap-image ( dim dc quot -- image )
dim dc make-bitmap [ &DeleteObject drop ] dip
quot dip
dim bitmap>image ; inline

64
basis/windows/types/types.factor
View File

@ -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
! { "HDC" " hdc" }
! { "BOOL" "fErase" }
! { "RECT" "rcPaint" }
! { "BOOL" "fRestore" }
! { "BOOL" "fIncUpdate" }
! { "BYTE[32]" "rgbReserved" }
! ;
C-STRUCT: PAINTSTRUCT
{ "HDC" " hdc" }
{ "BOOL" "fErase" }
{ "RECT" "rcPaint" }
{ "BOOL" "fRestore" }
{ "BOOL" "fIncUpdate" }
{ "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

100
basis/windows/uniscribe/uniscribe.factor Normal file → Executable file
View File

@ -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
accessors arrays destructors alien.c-types windows windows.usp10
windows.offscreen ;
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
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
ScriptStringOut ;
FALSE ! fDisabled
ScriptStringOut ole32-error ;
: <script-string> ( string -- script-string )
[
... dim ... [
make-script-string |ScriptStringFree
[ ]
[ 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 ;
: set-dc-font ( dc font -- )
[ cache-font SelectObject win32-error=0/f ]
[ background>> color>RGB SetBkColor drop ]
[ foreground>> color>RGB SetTextColor drop ] 2tri ;
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 )
pssa>> ! ssa
swap ! icp
... ! fTrailing
0 <int> [ ScriptStringCPtoX win32-error=0/f ] keep *int ;
: dc-metrics ( dc -- metrics )
"TEXTMETRICW" <c-object> [ GetTextMetrics drop ] keep
TEXTMETRIC>metrics ;
: line-x>offset ( x script-string -- offset trailing )
pssa>> ! ssa
:: <script-string> ( 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>> <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@ ;