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

new structs in font rendering

db4
Doug Coleman 2009-08-29 14:29:46 -05:00
parent 56be96429a
commit 6aeb3614ff
3 changed files with 61 additions and 60 deletions
basis/windows

74
basis/windows/fonts/fonts.factor
View File

@ -1,37 +1,37 @@
USING: assocs memoize locals kernel accessors init fonts math
combinators windows.errors windows.types windows.gdi32 ;
IN: windows.fonts
: windows-font-name ( string -- string' )
H{
{ "sans-serif" "Tahoma" }
{ "serif" "Times New Roman" }
{ "monospace" "Courier New" }
} ?at drop ;
MEMO:: (cache-font) ( font -- HFONT )
font size>> neg ! 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 ;
USING: assocs memoize locals kernel accessors init fonts math
combinators windows.errors windows.types windows.gdi32 ;
IN: windows.fonts
: windows-font-name ( string -- string' )
H{
{ "sans-serif" "Tahoma" }
{ "serif" "Times New Roman" }
{ "monospace" "Courier New" }
} ?at drop ;
MEMO:: (cache-font) ( font -- HFONT )
font size>> neg ! 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 {
[ tmHeight>> >>height ]
[ tmAscent>> >>ascent ]
[ tmDescent>> >>descent ]
} cleave ;

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

@ -380,26 +380,26 @@ TYPEDEF: DWORD* LPCOLORREF
: 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" } ;
STRUCT: TEXTMETRICW
{ tmHeight LONG }
{ tmAscent LONG }
{ tmDescent LONG }
{ tmInternalLeading LONG }
{ tmExternalLeading LONG }
{ tmAveCharWidth LONG }
{ tmMaxCharWidth LONG }
{ tmWeight LONG }
{ tmOverhang LONG }
{ tmDigitizedAspectX LONG }
{ tmDigitizedAspectY LONG }
{ tmFirstChar WCHAR }
{ tmLastChar WCHAR }
{ tmDefaultChar WCHAR }
{ tmBreakChar WCHAR }
{ tmItalic BYTE }
{ tmUnderlined BYTE }
{ tmStruckOut BYTE }
{ tmPitchAndFamily BYTE }
{ tmCharSet BYTE } ;
TYPEDEF: TEXTMETRICW* LPTEXTMETRIC

5
basis/windows/uniscribe/uniscribe.factor
View File

@ -4,7 +4,8 @@ USING: kernel assocs math sequences fry io.encodings.string
io.encodings.utf16n accessors arrays combinators destructors
cache namespaces init fonts alien.c-types windows.usp10
windows.offscreen windows.gdi32 windows.ole32 windows.types
windows.fonts opengl.textures locals windows.errors ;
windows.fonts opengl.textures locals windows.errors
classes.struct ;
IN: windows.uniscribe
TUPLE: script-string < disposable font string metrics ssa size image ;
@ -84,7 +85,7 @@ TUPLE: script-string < disposable font string metrics ssa size image ;
[ SIZE-cx ] [ SIZE-cy ] bi 2array ;
: dc-metrics ( dc -- metrics )
"TEXTMETRICW" <c-object>
TEXTMETRICW <struct>
[ GetTextMetrics drop ] keep
TEXTMETRIC>metrics ;