FreeType bindings work
Slava Pestov
parent
0eae8ef151
commit
7e47f5388f
|
|
@ -74,6 +74,7 @@ t [
|
|||
"/library/httpd/load.factor"
|
||||
"/library/sdl/load.factor"
|
||||
"/library/opengl/load.factor"
|
||||
"/library/freetype/load.factor"
|
||||
"/library/ui/load.factor"
|
||||
"/library/help/tutorial.factor"
|
||||
] pull-in
|
||||
|
|
|
|||
|
|
@ -152,3 +152,10 @@ M: object find ( seq quot -- i elt )
|
|||
swap dup length 1- [
|
||||
pick pick >r >r (monotonic) r> r> rot
|
||||
] all? 2nip ; inline
|
||||
|
||||
: cache-nth ( i seq quot -- elt | quot: i -- elt )
|
||||
pick pick ?nth dup [
|
||||
>r 3drop r>
|
||||
] [
|
||||
drop swap >r over >r call dup r> r> set-nth
|
||||
] if ; inline
|
||||
|
|
|
|||
|
|
@ -49,6 +49,10 @@ GENERIC: resize ( n seq -- seq )
|
|||
: bounds-check? ( n seq -- ? )
|
||||
over 0 >= [ length < ] [ 2drop f ] if ;
|
||||
|
||||
: ?nth ( n seq/f -- elt/f )
|
||||
#! seq can even be f, since f answers with zero length.
|
||||
2dup length >= [ 2drop f ] [ nth ] if ;
|
||||
|
||||
IN: sequences-internals
|
||||
|
||||
! Unsafe sequence protocol for inner loops
|
||||
|
|
|
|||
|
|
@ -79,9 +79,6 @@ SYMBOL: live-r
|
|||
live-r get literals/computed
|
||||
swapd (vregs>stacks) (vregs>stacks) ;
|
||||
|
||||
: ?nth ( n seq -- elt/f )
|
||||
2dup length >= [ 2drop f ] [ nth ] if ;
|
||||
|
||||
: live-stores ( instack outstack -- stack )
|
||||
#! Avoid storing a value into its former position.
|
||||
dup length [ pick ?nth dupd eq? [ drop f ] when ] 2map nip ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1,152 @@
|
|||
! Copyright (C) 2005 Slava Pestov.
|
||||
! See http://factor.sf.net/license.txt for BSD license.
|
||||
USING: #<unknown> alien arrays errors hashtables io kernel lists
|
||||
math namespaces opengl prettyprint sequences styles ;
|
||||
IN: freetype
|
||||
|
||||
! Memory management: freetype is allocated and freed by
|
||||
! with-freetype.
|
||||
SYMBOL: freetype
|
||||
SYMBOL: open-fonts
|
||||
|
||||
: freetype-error ( n -- ) 0 = [ "FreeType error" throw ] unless ;
|
||||
|
||||
: init-freetype ( -- )
|
||||
global [
|
||||
f <void*> dup FT_Init_FreeType freetype-error
|
||||
*void* freetype set
|
||||
{{ }} clone open-fonts set
|
||||
] bind ;
|
||||
|
||||
! A sprite are a texture and display list.
|
||||
TUPLE: sprite width height dlist texture ;
|
||||
|
||||
: free-dlists ( seq -- )
|
||||
"Freeing display lists: " print . ;
|
||||
|
||||
: free-textures ( seq -- )
|
||||
"Freeing textures: " print . ;
|
||||
|
||||
: free-sprites ( glyphs -- )
|
||||
dup [ sprite-dlist ] map free-dlists
|
||||
[ sprite-texture ] map free-textures ;
|
||||
|
||||
! A font object from FreeType.
|
||||
! the handle is an FT_Face.
|
||||
! sprites is a vector.
|
||||
TUPLE: font height handle sprites metrics ;
|
||||
|
||||
: close-font ( font -- )
|
||||
dup font-sprites [ ] subset free-sprites
|
||||
font-handle FT_Done_Face ;
|
||||
|
||||
: close-freetype ( -- )
|
||||
global [
|
||||
open-fonts get hash-values [ close-font ] each
|
||||
open-fonts off
|
||||
freetype get FT_Done_FreeType
|
||||
] bind ;
|
||||
|
||||
: with-freetype ( quot -- )
|
||||
init-freetype [ close-freetype ] cleanup ; inline
|
||||
|
||||
: ttf-name ( font style -- name )
|
||||
cons {{
|
||||
[[ [[ "Monospaced" plain ]] "VeraMono" ]]
|
||||
[[ [[ "Monospaced" bold ]] "VeraMoBd" ]]
|
||||
[[ [[ "Monospaced" bold-italic ]] "VeraMoBI" ]]
|
||||
[[ [[ "Monospaced" italic ]] "VeraMoIt" ]]
|
||||
[[ [[ "Sans Serif" plain ]] "Vera" ]]
|
||||
[[ [[ "Sans Serif" bold ]] "VeraBd" ]]
|
||||
[[ [[ "Sans Serif" bold-italic ]] "VeraBI" ]]
|
||||
[[ [[ "Sans Serif" italic ]] "VeraIt" ]]
|
||||
[[ [[ "Serif" plain ]] "VeraSe" ]]
|
||||
[[ [[ "Serif" bold ]] "VeraSeBd" ]]
|
||||
[[ [[ "Serif" bold-italic ]] "VeraBI" ]]
|
||||
[[ [[ "Serif" italic ]] "VeraIt" ]]
|
||||
}} hash ;
|
||||
|
||||
: ttf-path ( name -- string )
|
||||
[ "/fonts/" % % ".ttf" % ] "" make resource-path ;
|
||||
|
||||
: open-face ( font style -- face )
|
||||
#! Open a TrueType font with the given logical name and
|
||||
#! style.
|
||||
ttf-name ttf-path >r freetype get r>
|
||||
0 f <void*> [ FT_New_Face freetype-error ] keep *void* ;
|
||||
|
||||
: dpi 100 ;
|
||||
|
||||
: font-units>pixels ( n font-size -- n )
|
||||
face-size-y-scale FT_MulFix fix>float ;
|
||||
|
||||
: init-font-height ( font -- )
|
||||
dup font-handle face-size
|
||||
dup face-y-max over face-y-min - swap font-units>pixels
|
||||
swap set-font-height ;
|
||||
|
||||
C: font ( handle -- font )
|
||||
{ } clone over set-font-sprites
|
||||
{ } clone over set-font-metrics
|
||||
[ set-font-handle ] keep
|
||||
dup init-font-height ;
|
||||
|
||||
: open-font ( { font style ptsize } -- font )
|
||||
#! Open a font and set the point size of the font.
|
||||
first3 >r open-face dup 0 r> 6 shift
|
||||
dpi dpi FT_Set_Char_Size freetype-error <font> ;
|
||||
|
||||
: lookup-font ( font style ptsize -- font )
|
||||
#! Cache open fonts.
|
||||
3array open-fonts get [ open-font ] cache ;
|
||||
|
||||
: load-glyph ( face char -- glyph )
|
||||
dupd 0 FT_Load_Char freetype-error face-glyph ;
|
||||
|
||||
: fix>float 64 /f ;
|
||||
|
||||
: (char-size) ( font char -- dim )
|
||||
>r font-handle r> load-glyph
|
||||
dup glyph-width fix>float
|
||||
swap glyph-height fix>float 0 3array ;
|
||||
|
||||
: char-size ( open-font char -- w h )
|
||||
over font-metrics [ dupd (char-size) ] cache-nth nip first2 ;
|
||||
|
||||
: string-size ( font string -- w h )
|
||||
0 pick font-height
|
||||
2swap [ char-size >r rot + swap r> max ] each-with ;
|
||||
|
||||
: render-glyph ( face char -- bitmap )
|
||||
#! Render a character and return a pointer to the bitmap.
|
||||
load-glyph dup
|
||||
FT_RENDER_MODE_NORMAL FT_Render_Glyph freetype-error ;
|
||||
|
||||
: copy-row ( width texture bitmap row -- )
|
||||
#! Copy a row of the bitmap to the texture.
|
||||
2drop 2drop ;
|
||||
|
||||
: <glyph-texture> ( bitmap -- texture )
|
||||
dup glyph-bitmap-width next-power-of-2
|
||||
swap glyph-bitmap-rows next-power-of-2 * <c-object> ;
|
||||
|
||||
: copy-glyph ( bitmap texture -- )
|
||||
#! Copy a bitmap into a texture whose width/height are
|
||||
#! the width/height of the bitmap rounded up to the nearest
|
||||
#! power of 2.
|
||||
>r [ bitmap-width next-power-of-2 ] keep r>
|
||||
over bitmap-rows [ >r 3dup r> copy-row ] each 3drop ;
|
||||
|
||||
: glyph>texture ( bitmap -- texture )
|
||||
#! Given a glyph bitmap, copy it to a texture whose size is
|
||||
#! a power of two.
|
||||
dup <glyph-texture> [ copy-glyph ] keep ;
|
||||
|
||||
: <char-sprite> ( font char -- sprite )
|
||||
0 0 <sprite> ;
|
||||
|
||||
: char-sprite ( open-font char -- sprite )
|
||||
over font-sprites [ dupd <char-sprite> ] cache-nth nip ;
|
||||
|
||||
: draw-string ( font string -- )
|
||||
[ char-sprite drop ( sprite-dlist glCallList ) ] each-with ;
|
||||
|
|
@ -0,0 +1,188 @@
|
|||
! Copyright (C) 2005 Slava Pestov.
|
||||
! See http://factor.sf.net/license.txt for BSD license.
|
||||
USING: alien ;
|
||||
IN: freetype
|
||||
|
||||
! Some code to render TrueType fonts with OpenGL.
|
||||
|
||||
LIBRARY: freetype
|
||||
|
||||
TYPEDEF: uchar FT_Byte
|
||||
TYPEDEF: uchar* FT_Bytes
|
||||
TYPEDEF: char FT_Char
|
||||
TYPEDEF: int FT_Int
|
||||
TYPEDEF: int FT_Int32
|
||||
TYPEDEF: uint FT_UInt
|
||||
TYPEDEF: short FT_Short
|
||||
TYPEDEF: ushort FT_UShort
|
||||
TYPEDEF: long FT_Long
|
||||
TYPEDEF: ulong FT_ULong
|
||||
TYPEDEF: uchar FT_Bool
|
||||
TYPEDEF: cell FT_Offset
|
||||
TYPEDEF: int FT_PtrDist
|
||||
TYPEDEF: char FT_String
|
||||
TYPEDEF: int FT_Tag
|
||||
TYPEDEF: int FT_Error
|
||||
TYPEDEF: long FT_Fixed
|
||||
TYPEDEF: void* FT_Pointer
|
||||
TYPEDEF: long FT_Pos
|
||||
TYPEDEF: ushort FT_UFWord
|
||||
TYPEDEF: short FT_F2Dot14
|
||||
TYPEDEF: long FT_F26Dot6
|
||||
|
||||
FUNCTION: FT_Error FT_Init_FreeType ( void* library ) ;
|
||||
|
||||
BEGIN-STRUCT: bitmap
|
||||
FIELD: int rows
|
||||
FIELD: int width
|
||||
FIELD: int pitch
|
||||
FIELD: uchar* buffer
|
||||
FIELD: short num-grays
|
||||
FIELD: char pixel-mode
|
||||
FIELD: char palette-mode
|
||||
FIELD: void* palette
|
||||
END-STRUCT
|
||||
|
||||
! circular reference between glyph and face
|
||||
TYPEDEF: void face
|
||||
TYPEDEF: void glyph
|
||||
|
||||
BEGIN-STRUCT: glyph
|
||||
FIELD: void* library
|
||||
FIELD: face* face
|
||||
FIELD: glyph* next
|
||||
FIELD: FT_UInt reserved
|
||||
FIELD: void* generic
|
||||
FIELD: void* generic
|
||||
|
||||
FIELD: FT_Pos width
|
||||
FIELD: FT_Pos height
|
||||
|
||||
FIELD: FT_Pos hori-bearing-x
|
||||
FIELD: FT_Pos hori-bearing-y
|
||||
FIELD: FT_Pos hori-advance
|
||||
|
||||
FIELD: FT_Pos vert-bearing-x
|
||||
FIELD: FT_Pos vert-bearing-y
|
||||
FIELD: FT_Pos vert-advance
|
||||
|
||||
FIELD: FT_Fixed linear-hori-advance
|
||||
FIELD: FT_Fixed linear-vert-advance
|
||||
FIELD: FT_Pos advance-x
|
||||
FIELD: FT_Pos advance-y
|
||||
|
||||
FIELD: int format
|
||||
|
||||
FIELD: int bitmap-rows
|
||||
FIELD: int bitmap-width
|
||||
FIELD: int bitmap-pitch
|
||||
FIELD: uchar* bitmap-buffer
|
||||
FIELD: short bitmap-num-grays
|
||||
FIELD: char bitmap-pixel-mode
|
||||
FIELD: char bitmap-palette-mode
|
||||
FIELD: void* bitmap-palette
|
||||
|
||||
FIELD: FT_Int bitmap-left
|
||||
FIELD: FT_Int bitmap-top
|
||||
|
||||
FIELD: short n-contours
|
||||
FIELD: short n-points
|
||||
|
||||
FIELD: void* points
|
||||
FIELD: char* tags
|
||||
FIELD: short* contours
|
||||
|
||||
FIELD: int outline-flags
|
||||
|
||||
FIELD: FT_UInt num_subglyphs
|
||||
FIELD: void* subglyphs
|
||||
|
||||
FIELD: void* control-data
|
||||
FIELD: long control-len
|
||||
|
||||
FIELD: FT_Pos lsb-delta
|
||||
FIELD: FT_Pos rsb-delta
|
||||
|
||||
FIELD: void* other
|
||||
END-STRUCT
|
||||
|
||||
BEGIN-STRUCT: face-size
|
||||
FIELD: face* face
|
||||
FIELD: void* generic
|
||||
FIELD: void* generic
|
||||
|
||||
FIELD: FT_UShort x-ppem
|
||||
FIELD: FT_UShort y-ppem
|
||||
|
||||
FIELD: FT_Fixed x-scale
|
||||
FIELD: FT_Fixed y-scale
|
||||
|
||||
FIELD: FT_Pos ascender
|
||||
FIELD: FT_Pos descender
|
||||
FIELD: FT_Pos height
|
||||
FIELD: FT_Pos max-advance
|
||||
END-STRUCT
|
||||
|
||||
BEGIN-STRUCT: face
|
||||
FIELD: FT_Long num-faces
|
||||
FIELD: FT_Long index
|
||||
|
||||
FIELD: FT_Long flags
|
||||
FIELD: FT_Long style-flags
|
||||
|
||||
FIELD: FT_Long num-glyphs
|
||||
|
||||
FIELD: FT_Char* family-name
|
||||
FIELD: FT_Char* style-name
|
||||
|
||||
FIELD: FT_Int num-fixed-sizes
|
||||
FIELD: void* available-sizes
|
||||
|
||||
FIELD: FT_Int num-charmaps
|
||||
FIELD: void* charmaps
|
||||
|
||||
FIELD: void* generic
|
||||
FIELD: void* generic
|
||||
|
||||
FIELD: FT_Pos x-min
|
||||
FIELD: FT_Pos y-min
|
||||
FIELD: FT_Pos x-max
|
||||
FIELD: FT_Pos y-max
|
||||
|
||||
FIELD: FT_UShort units-per-em
|
||||
FIELD: FT_Short ascender
|
||||
FIELD: FT_Short descender
|
||||
FIELD: FT_Short height
|
||||
|
||||
FIELD: FT_Short max-advance-width
|
||||
FIELD: FT_Short max-advance-height
|
||||
|
||||
FIELD: FT_Short underline-position
|
||||
FIELD: FT_Short underline-thickness
|
||||
|
||||
FIELD: glyph* glyph
|
||||
FIELD: face-size* size
|
||||
FIELD: void* charmap
|
||||
END-STRUCT
|
||||
|
||||
FUNCTION: FT_Error FT_New_Face ( void* library, FT_Char* font, FT_Long index, face* face ) ;
|
||||
|
||||
FUNCTION: FT_Error FT_Set_Char_Size ( face* face, FT_F26Dot6 char_width, FT_F26Dot6 char_height, FT_UInt horizontal_dpi, FT_UInt vertical_dpi ) ;
|
||||
|
||||
FUNCTION: FT_Error FT_Load_Char ( face* face, FT_ULong charcode, FT_Int32 load_flags ) ;
|
||||
|
||||
BEGIN-ENUM: 0
|
||||
ENUM: FT_RENDER_MODE_NORMAL
|
||||
ENUM: FT_RENDER_MODE_LIGHT
|
||||
ENUM: FT_RENDER_MODE_MONO
|
||||
ENUM: FT_RENDER_MODE_LCD
|
||||
ENUM: FT_RENDER_MODE_LCD_V
|
||||
END-ENUM
|
||||
|
||||
FUNCTION: int FT_Render_Glyph ( glyph* slot, int render_mode ) ;
|
||||
|
||||
FUNCTION: void FT_Done_Face ( face* face ) ;
|
||||
|
||||
FUNCTION: void FT_Done_FreeType ( void* library ) ;
|
||||
|
||||
FUNCTION: FT_Long FT_MulFix ( FT_Long a, FT_Long b ) ;
|
||||
|
|
@ -0,0 +1,8 @@
|
|||
USING: io kernel parser sequences ;
|
||||
|
||||
[
|
||||
"/library/freetype/freetype.factor"
|
||||
"/library/freetype/freetype-gl.factor"
|
||||
] [
|
||||
dup print run-resource
|
||||
] each
|
||||
|
|
@ -6,7 +6,6 @@ USING: kernel parser sequences io ;
|
|||
"/library/sdl/sdl-gfx.factor"
|
||||
"/library/sdl/sdl-keysym.factor"
|
||||
"/library/sdl/sdl-keyboard.factor"
|
||||
"/library/sdl/sdl-ttf.factor"
|
||||
"/library/sdl/sdl-utils.factor"
|
||||
] [
|
||||
dup print run-resource
|
||||
|
|
|
|||
|
|
@ -1,84 +0,0 @@
|
|||
! Copyright (C) 2004, 2005 Slava Pestov.
|
||||
! See http://factor.sf.net/license.txt for BSD license.
|
||||
IN: sdl
|
||||
USE: alien
|
||||
|
||||
: UNICODE_BOM_NATIVE HEX: FEFF ;
|
||||
: UNICODE_BOM_SWAPPED HEX: FFFE ;
|
||||
|
||||
: TTF_ByteSwappedUNICODE ( swapped -- )
|
||||
"void" "sdl-ttf" "TTF_ByteSwappedUNICODE" [ "int" ] alien-invoke ;
|
||||
|
||||
: TTF_Init ( -- n )
|
||||
"int" "sdl-ttf" "TTF_Init" [ ] alien-invoke ;
|
||||
|
||||
: TTF_OpenFont ( file ptsize -- font )
|
||||
"void*" "sdl-ttf" "TTF_OpenFont" [ "char*" "int" ] alien-invoke ;
|
||||
|
||||
: TTF_OpenFontIndex ( file ptsize index -- font )
|
||||
"void*" "sdl-ttf" "TTF_OpenFont" [ "char*" "int" "long" ] alien-invoke ;
|
||||
|
||||
: TTF_STYLE_NORMAL HEX: 00 ;
|
||||
: TTF_STYLE_BOLD HEX: 01 ;
|
||||
: TTF_STYLE_ITALIC HEX: 02 ;
|
||||
: TTF_STYLE_UNDERLINE HEX: 04 ;
|
||||
|
||||
: TTF_GetFontStyle ( font -- style )
|
||||
"int" "sdl-ttf" "TTF_GetFontStyle" [ "void*" ] alien-invoke ;
|
||||
|
||||
: TTF_SetFontStyle ( font style -- )
|
||||
"void" "sdl-ttf" "TTF_SetFontStyle" [ "void*" "int" ] alien-invoke ;
|
||||
|
||||
: TTF_FontHeight ( font -- n )
|
||||
"int" "sdl-ttf" "TTF_FontHeight" [ "void*" ] alien-invoke ;
|
||||
|
||||
: TTF_FontAscent ( font -- n )
|
||||
"int" "sdl-ttf" "TTF_FontAscent" [ "void*" ] alien-invoke ;
|
||||
|
||||
: TTF_FontDescent ( font -- n )
|
||||
"int" "sdl-ttf" "TTF_FontDescent" [ "void*" ] alien-invoke ;
|
||||
|
||||
: TTF_FontLineSkip ( font -- n )
|
||||
"int" "sdl-ttf" "TTF_FontLineSkip" [ "void*" ] alien-invoke ;
|
||||
|
||||
: TTF_FontFaces ( font -- n )
|
||||
"long" "sdl-ttf" "TTF_FontFaces" [ "void*" ] alien-invoke ;
|
||||
|
||||
: TTF_FontFaceIsFixedWidth ( font -- ? )
|
||||
"bool" "sdl-ttf" "TTF_FontFaceIsFixedWidth" [ "void*" ] alien-invoke ;
|
||||
|
||||
: TTF_FontFaceFamilyName ( font -- n )
|
||||
"char*" "sdl-ttf" "TTF_FontFaceFamilyName" [ "void*" ] alien-invoke ;
|
||||
|
||||
: TTF_FontFaceStyleName ( font -- n )
|
||||
"char*" "sdl-ttf" "TTF_FontFaceStyleName" [ "void*" ] alien-invoke ;
|
||||
|
||||
: TTF_SizeUNICODE ( font text w h -- ? )
|
||||
"bool" "sdl-ttf" "TTF_SizeUNICODE" [ "void*" "ushort*" "void*" "void*" ] alien-invoke ;
|
||||
|
||||
: TTF_RenderUNICODE_Solid ( font text fg -- surface )
|
||||
"surface*" "sdl-ttf" "TTF_RenderUNICODE_Solid" [ "void*" "ushort*" "int" ] alien-invoke ;
|
||||
|
||||
: TTF_RenderGlyph_Solid ( font text fg -- surface )
|
||||
"surface*" "sdl-ttf" "TTF_RenderText_Solid" [ "void*" "ushort" "int" ] alien-invoke ;
|
||||
|
||||
: TTF_RenderUNICODE_Shaded ( font text fg bg -- surface )
|
||||
"surface*" "sdl-ttf" "TTF_RenderUNICODE_Shaded" [ "void*" "ushort*" "int" "int" ] alien-invoke ;
|
||||
|
||||
: TTF_RenderGlyph_Shaded ( font text fg bg -- surface )
|
||||
"surface*" "sdl-ttf" "TTF_RenderGlyph_Shaded" [ "void*" "ushort" "int" "int" ] alien-invoke ;
|
||||
|
||||
: TTF_RenderUNICODE_Blended ( font text fg -- surface )
|
||||
"surface*" "sdl-ttf" "TTF_RenderUNICODE_Blended" [ "void*" "ushort*" "int" ] alien-invoke ;
|
||||
|
||||
: TTF_RenderGlyph_Blended ( font text fg -- surface )
|
||||
"surface*" "sdl-ttf" "TTF_RenderGlyph_Blended" [ "void*" "ushort" "int" ] alien-invoke ;
|
||||
|
||||
: TTF_CloseFont ( font -- )
|
||||
"void" "sdl-ttf" "TTF_CloseFont" [ "void*" ] alien-invoke ;
|
||||
|
||||
: TTF_Quit ( -- )
|
||||
"void" "sdl-ttf" "TTF_CloseFont" [ ] alien-invoke ;
|
||||
|
||||
: TTF_WasInit ( -- ? )
|
||||
"bool" "sdl-ttf" "TTF_WasInit" [ ] alien-invoke ;
|
||||
|
|
@ -12,40 +12,6 @@ SYMBOL: bpp
|
|||
: sdl-error ( 0/-1 -- )
|
||||
0 = [ SDL_GetError throw ] unless ;
|
||||
|
||||
: ttf-name ( font style -- name )
|
||||
cons {{
|
||||
[[ [[ "Monospaced" plain ]] "VeraMono" ]]
|
||||
[[ [[ "Monospaced" bold ]] "VeraMoBd" ]]
|
||||
[[ [[ "Monospaced" bold-italic ]] "VeraMoBI" ]]
|
||||
[[ [[ "Monospaced" italic ]] "VeraMoIt" ]]
|
||||
[[ [[ "Sans Serif" plain ]] "Vera" ]]
|
||||
[[ [[ "Sans Serif" bold ]] "VeraBd" ]]
|
||||
[[ [[ "Sans Serif" bold-italic ]] "VeraBI" ]]
|
||||
[[ [[ "Sans Serif" italic ]] "VeraIt" ]]
|
||||
[[ [[ "Serif" plain ]] "VeraSe" ]]
|
||||
[[ [[ "Serif" bold ]] "VeraSeBd" ]]
|
||||
[[ [[ "Serif" bold-italic ]] "VeraBI" ]]
|
||||
[[ [[ "Serif" italic ]] "VeraIt" ]]
|
||||
}} hash ;
|
||||
|
||||
: ttf-path ( name -- string )
|
||||
[ "/fonts/" % % ".ttf" % ] "" make resource-path ;
|
||||
|
||||
: open-font ( { font style ptsize } -- alien )
|
||||
first3 >r ttf-name ttf-path r> TTF_OpenFont
|
||||
dup alien-address 0 = [ SDL_GetError throw ] when ;
|
||||
|
||||
SYMBOL: open-fonts
|
||||
|
||||
: lookup-font ( font style ptsize -- font )
|
||||
3array open-fonts get [ open-font ] cache ;
|
||||
|
||||
: init-ttf ( -- )
|
||||
TTF_Init sdl-error
|
||||
global [
|
||||
open-fonts [ [ cdr expired? not ] hash-subset ] change
|
||||
] bind ;
|
||||
|
||||
: init-keyboard ( -- )
|
||||
1 SDL_EnableUNICODE drop
|
||||
SDL_DEFAULT_REPEAT_DELAY SDL_DEFAULT_REPEAT_INTERVAL
|
||||
|
|
@ -57,7 +23,7 @@ SYMBOL: open-fonts
|
|||
|
||||
: init-sdl ( width height bpp flags -- )
|
||||
SDL_INIT_EVERYTHING SDL_Init sdl-error
|
||||
init-keyboard init-surface init-ttf ;
|
||||
init-keyboard init-surface ;
|
||||
|
||||
: with-screen ( width height bpp flags quot -- )
|
||||
#! Set up SDL graphics and call the quotation.
|
||||
|
|
@ -71,15 +37,6 @@ SYMBOL: open-fonts
|
|||
swap >fixnum 16 shift bitor
|
||||
swap >fixnum 24 shift bitor ;
|
||||
|
||||
: make-color ( r g b -- color )
|
||||
#! Make an SDL_Color struct. This will go away soon in favor
|
||||
#! of pass-by-value support in the FFI.
|
||||
<sdl-color>
|
||||
[ set-sdl-color-b ] keep
|
||||
[ set-sdl-color-g ] keep
|
||||
[ set-sdl-color-r ] keep
|
||||
0 alien-unsigned-4 ;
|
||||
|
||||
: make-rect ( x y w h -- rect )
|
||||
<sdl-rect>
|
||||
[ set-sdl-rect-h ] keep
|
||||
|
|
@ -117,12 +74,3 @@ SYMBOL: open-fonts
|
|||
[ lock-surface call ]
|
||||
[ unlock-surface surface get SDL_Flip ]
|
||||
cleanup ; inline
|
||||
|
||||
: with-unlocked-surface ( quot -- )
|
||||
must-lock-surface?
|
||||
[ unlock-surface call lock-surface ] [ call ] if ; inline
|
||||
|
||||
: surface-rect ( x y surface -- rect )
|
||||
dup surface-w swap surface-h make-rect ;
|
||||
|
||||
{{ }} clone open-fonts global set-hash
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
IN: temporary
|
||||
USING: kernel lists math sequences sequences-internals strings
|
||||
test vectors ;
|
||||
USING: kernel lists math namespaces sequences
|
||||
sequences-internals strings test vectors ;
|
||||
|
||||
[ { 1 2 3 4 } ] [ 1 5 <range> >vector ] unit-test
|
||||
[ 3 ] [ 1 4 <range> length ] unit-test
|
||||
|
|
@ -193,3 +193,13 @@ unit-test
|
|||
|
||||
[ -1 ] [ "ab" "abc" lexi ] unit-test
|
||||
[ 1 ] [ "abc" "ab" lexi ] unit-test
|
||||
|
||||
[ 1 4 9 16 16 { f 1 4 9 16 } ] [
|
||||
{ } clone "cache-test" set
|
||||
1 "cache-test" get [ sq ] cache-nth
|
||||
2 "cache-test" get [ sq ] cache-nth
|
||||
3 "cache-test" get [ sq ] cache-nth
|
||||
4 "cache-test" get [ sq ] cache-nth
|
||||
4 "cache-test" get [ "wrong" ] cache-nth
|
||||
"cache-test" get
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2005 Slava Pestov.
|
||||
! See http://factor.sf.net/license.txt for BSD license.
|
||||
IN: gadgets-editors
|
||||
USING: arrays gadgets gadgets-labels gadgets-layouts
|
||||
USING: arrays freetype gadgets gadgets-labels gadgets-layouts
|
||||
gadgets-menus gadgets-scrolling gadgets-theme generic kernel
|
||||
lists math namespaces sequences strings styles threads ;
|
||||
|
||||
|
|
@ -54,7 +54,7 @@ TUPLE: editor line caret ;
|
|||
|
||||
: run-char-widths ( font str -- wlist )
|
||||
#! List of x co-ordinates of each character.
|
||||
>array [ ch>string size-string drop ] map-with
|
||||
>array [ char-size drop ] map-with
|
||||
dup 0 [ + ] accumulate swap 2 v/n v+ ;
|
||||
|
||||
: x>offset ( x font str -- offset )
|
||||
|
|
@ -122,7 +122,7 @@ C: editor ( text -- )
|
|||
dup editor-actions ;
|
||||
|
||||
: offset>x ( gadget offset str -- x )
|
||||
head >r gadget-font r> size-string drop ;
|
||||
head-slice >r gadget-font r> string-size drop ;
|
||||
|
||||
: caret-loc ( editor -- x y )
|
||||
dup editor-line [ caret-pos line-text get ] bind offset>x
|
||||
|
|
@ -135,17 +135,17 @@ M: editor user-input* ( ch editor -- ? )
|
|||
[ insert-char ] with-editor f ;
|
||||
|
||||
M: editor pref-dim ( editor -- dim )
|
||||
dup editor-text label-size @{ 1 0 0 }@ v+ ;
|
||||
label-size @{ 1 0 0 }@ v+ ;
|
||||
|
||||
M: editor layout* ( editor -- )
|
||||
dup editor-caret over caret-dim swap set-gadget-dim
|
||||
dup editor-caret swap caret-loc swap set-rect-loc ;
|
||||
|
||||
M: editor label-text ( editor -- string )
|
||||
editor-text ;
|
||||
|
||||
M: editor draw-gadget* ( editor -- )
|
||||
drop
|
||||
! dup delegate draw-gadget*
|
||||
! dup editor-text draw-string
|
||||
;
|
||||
dup delegate draw-gadget* draw-label ;
|
||||
|
||||
: set-possibilities ( possibilities editor -- )
|
||||
#! Set completion possibilities.
|
||||
|
|
|
|||
|
|
@ -1,260 +0,0 @@
|
|||
! Copyright (C) 2005 Slava Pestov.
|
||||
! See http://factor.sf.net/license.txt for BSD license.
|
||||
USING: alien arrays errors hashtables io kernel lists math
|
||||
namespaces sequences styles ;
|
||||
IN: freetype
|
||||
|
||||
! Some code to render TrueType fonts with OpenGL.
|
||||
|
||||
LIBRARY: freetype
|
||||
|
||||
TYPEDEF: uchar FT_Byte
|
||||
TYPEDEF: uchar* FT_Bytes
|
||||
TYPEDEF: char FT_Char
|
||||
TYPEDEF: int FT_Int
|
||||
TYPEDEF: int FT_Int32
|
||||
TYPEDEF: uint FT_UInt
|
||||
TYPEDEF: short FT_Short
|
||||
TYPEDEF: ushort FT_UShort
|
||||
TYPEDEF: long FT_Long
|
||||
TYPEDEF: ulong FT_ULong
|
||||
TYPEDEF: uchar FT_Bool
|
||||
TYPEDEF: cell FT_Offset
|
||||
TYPEDEF: int FT_PtrDist
|
||||
TYPEDEF: char FT_String
|
||||
TYPEDEF: int FT_Tag
|
||||
TYPEDEF: int FT_Error
|
||||
TYPEDEF: long FT_Fixed
|
||||
TYPEDEF: void* FT_Pointer
|
||||
TYPEDEF: long FT_Pos
|
||||
TYPEDEF: ushort FT_UFWord
|
||||
TYPEDEF: short FT_F2Dot14
|
||||
TYPEDEF: long FT_F26Dot6
|
||||
|
||||
FUNCTION: FT_Error FT_Init_FreeType ( void* library ) ;
|
||||
|
||||
BEGIN-STRUCT: bitmap
|
||||
FIELD: int rows
|
||||
FIELD: int width
|
||||
FIELD: int pitch
|
||||
FIELD: uchar* buffer
|
||||
FIELD: short num-grays
|
||||
FIELD: char pixel-mode
|
||||
FIELD: char palette-mode
|
||||
FIELD: void* palette
|
||||
END-STRUCT
|
||||
|
||||
! circular reference between glyph and face
|
||||
TYPEDEF: void face
|
||||
TYPEDEF: void glyph
|
||||
|
||||
BEGIN-STRUCT: glyph
|
||||
FIELD: void* library
|
||||
FIELD: face* face
|
||||
FIELD: glyph* next
|
||||
FIELD: FT_UInt reserved
|
||||
FIELD: void* generic
|
||||
FIELD: void* generic
|
||||
|
||||
FIELD: FT_Pos width
|
||||
FIELD: FT_Pos height
|
||||
|
||||
FIELD: FT_Pos hori-bearing-x
|
||||
FIELD: FT_Pos hori-bearing-y
|
||||
FIELD: FT_Pos hori-advance
|
||||
|
||||
FIELD: FT_Pos vert-bearing-x
|
||||
FIELD: FT_Pos vert-bearing-y
|
||||
FIELD: FT_Pos vert-advance
|
||||
|
||||
FIELD: FT_Fixed linear-hori-advance
|
||||
FIELD: FT_Fixed linear-vert-advance
|
||||
FIELD: FT_Pos advance-x
|
||||
FIELD: FT_Pos advance-y
|
||||
|
||||
FIELD: int format
|
||||
|
||||
FIELD: int bitmap-rows
|
||||
FIELD: int bitmap-width
|
||||
FIELD: int bitmap-pitch
|
||||
FIELD: uchar* bitmap-buffer
|
||||
FIELD: short bitmap-num-grays
|
||||
FIELD: char bitmap-pixel-mode
|
||||
FIELD: char bitmap-palette-mode
|
||||
FIELD: void* bitmap-palette
|
||||
|
||||
FIELD: FT_Int bitmap-left
|
||||
FIELD: FT_Int bitmap-top
|
||||
|
||||
FIELD: short n-contours
|
||||
FIELD: short n-points
|
||||
|
||||
FIELD: void* points
|
||||
FIELD: char* tags
|
||||
FIELD: short* contours
|
||||
|
||||
FIELD: int outline-flags
|
||||
|
||||
FIELD: FT_UInt num_subglyphs
|
||||
FIELD: void* subglyphs
|
||||
|
||||
FIELD: void* control-data
|
||||
FIELD: long control-len
|
||||
|
||||
FIELD: FT_Pos lsb-delta
|
||||
FIELD: FT_Pos rsb-delta
|
||||
|
||||
FIELD: void* other
|
||||
END-STRUCT
|
||||
|
||||
BEGIN-STRUCT: face
|
||||
FIELD: FT_Long num-faces
|
||||
FIELD: FT_Long index
|
||||
|
||||
FIELD: FT_Long flags
|
||||
FIELD: FT_Long style-flags
|
||||
|
||||
FIELD: FT_Long num-glyphs
|
||||
|
||||
FIELD: FT_Char* family-name
|
||||
FIELD: FT_Char* style-name
|
||||
|
||||
FIELD: FT_Int num-fixed-sizes
|
||||
FIELD: void* available-sizes
|
||||
|
||||
FIELD: FT_Int num-charmaps
|
||||
FIELD: void* charmaps
|
||||
|
||||
FIELD: void* generic
|
||||
FIELD: void* generic
|
||||
|
||||
FIELD: FT_Pos x-min
|
||||
FIELD: FT_Pos y-min
|
||||
FIELD: FT_Pos x-max
|
||||
FIELD: FT_Pos y-max
|
||||
|
||||
FIELD: FT_UShort units-per-em
|
||||
FIELD: FT_Short ascender
|
||||
FIELD: FT_Short descender
|
||||
FIELD: FT_Short height
|
||||
|
||||
FIELD: FT_Short max-advance-width
|
||||
FIELD: FT_Short max-advance-height
|
||||
|
||||
FIELD: FT_Short underline-position
|
||||
FIELD: FT_Short underline-thickness
|
||||
|
||||
FIELD: glyph* glyph
|
||||
FIELD: void* size
|
||||
FIELD: void* charmap
|
||||
END-STRUCT
|
||||
|
||||
FUNCTION: FT_Error FT_New_Face ( void* library, FT_Char* font, FT_Long index, face* face ) ;
|
||||
|
||||
FUNCTION: FT_Error FT_Set_Char_Size ( face* face, FT_F26Dot6 char_width, FT_F26Dot6 char_height, FT_UInt horizontal_dpi, FT_UInt vertical_dpi ) ;
|
||||
|
||||
FUNCTION: FT_Error FT_Load_Char ( face* face, FT_ULong charcode, FT_Int32 load_flags ) ;
|
||||
|
||||
BEGIN-ENUM: 0
|
||||
ENUM: FT_RENDER_MODE_NORMAL
|
||||
ENUM: FT_RENDER_MODE_LIGHT
|
||||
ENUM: FT_RENDER_MODE_MONO
|
||||
ENUM: FT_RENDER_MODE_LCD
|
||||
ENUM: FT_RENDER_MODE_LCD_V
|
||||
END-ENUM
|
||||
|
||||
FUNCTION: int FT_Render_Glyph ( glyph* slot, int render_mode ) ;
|
||||
|
||||
FUNCTION: void FT_Done_Face ( face* face ) ;
|
||||
|
||||
FUNCTION: void FT_Done_FreeType ( void* library ) ;
|
||||
|
||||
SYMBOL: freetype
|
||||
|
||||
: freetype-error ( n -- ) 0 = [ "FreeType error" throw ] unless ;
|
||||
|
||||
SYMBOL: open-fonts
|
||||
|
||||
TUPLE: font handle glyphs ;
|
||||
|
||||
C: font ( handle -- font )
|
||||
{ } clone over set-font-glyphs
|
||||
[ set-font-handle ] keep ;
|
||||
|
||||
: init-freetype ( -- )
|
||||
global [
|
||||
f <void*> dup FT_Init_FreeType freetype-error
|
||||
*void* freetype set
|
||||
{{ }} clone open-fonts set
|
||||
] bind ;
|
||||
|
||||
: close-freetype ( -- )
|
||||
global [
|
||||
open-fonts get hash-values [ font-handle FT_Done_Face ] each
|
||||
open-fonts off
|
||||
freetype get FT_Done_FreeType
|
||||
] bind ;
|
||||
|
||||
: with-freetype ( quot -- )
|
||||
init-freetype [ close-freetype ] cleanup ; inline
|
||||
|
||||
: ttf-name ( font style -- name )
|
||||
cons {{
|
||||
[[ [[ "Monospaced" plain ]] "VeraMono" ]]
|
||||
[[ [[ "Monospaced" bold ]] "VeraMoBd" ]]
|
||||
[[ [[ "Monospaced" bold-italic ]] "VeraMoBI" ]]
|
||||
[[ [[ "Monospaced" italic ]] "VeraMoIt" ]]
|
||||
[[ [[ "Sans Serif" plain ]] "Vera" ]]
|
||||
[[ [[ "Sans Serif" bold ]] "VeraBd" ]]
|
||||
[[ [[ "Sans Serif" bold-italic ]] "VeraBI" ]]
|
||||
[[ [[ "Sans Serif" italic ]] "VeraIt" ]]
|
||||
[[ [[ "Serif" plain ]] "VeraSe" ]]
|
||||
[[ [[ "Serif" bold ]] "VeraSeBd" ]]
|
||||
[[ [[ "Serif" bold-italic ]] "VeraBI" ]]
|
||||
[[ [[ "Serif" italic ]] "VeraIt" ]]
|
||||
}} hash ;
|
||||
|
||||
: ttf-path ( name -- string )
|
||||
[ "/fonts/" % % ".ttf" % ] "" make resource-path ;
|
||||
|
||||
: open-face ( font style -- face )
|
||||
#! Open a TrueType font with the given logical name and
|
||||
#! style.
|
||||
ttf-name ttf-path >r freetype get r>
|
||||
0 f <void*> [ FT_New_Face freetype-error ] keep *void* ;
|
||||
|
||||
: dpi 100 ;
|
||||
|
||||
: open-font ( { font style ptsize } -- font )
|
||||
#! Open a font and set the point size of the font.
|
||||
first3 >r open-face dup 0 r> 6 shift
|
||||
dpi dpi FT_Set_Char_Size freetype-error <font> ;
|
||||
|
||||
: lookup-font ( font style ptsize -- font )
|
||||
#! Cache open fonts.
|
||||
3array open-fonts get [ open-font ] cache ;
|
||||
|
||||
: render-glyph ( face char -- bitmap )
|
||||
#! Render a character and return a pointer to the bitmap.
|
||||
dupd 0 FT_Load_Char freetype-error face-glyph dup
|
||||
FT_RENDER_MODE_NORMAL FT_Render_Glyph freetype-error ;
|
||||
|
||||
: copy-row ( width texture bitmap row -- )
|
||||
#! Copy a row of the bitmap to the texture.
|
||||
2drop 2drop ;
|
||||
|
||||
: <glyph-texture> ( bitmap -- texture )
|
||||
dup glyph-bitmap-width next-power-of-2
|
||||
swap glyph-bitmap-rows next-power-of-2 * <c-object> ;
|
||||
|
||||
: copy-glyph ( bitmap texture -- )
|
||||
#! Copy a bitmap into a texture whose width/height are
|
||||
#! the width/height of the bitmap rounded up to the nearest
|
||||
#! power of 2.
|
||||
>r [ bitmap-width next-power-of-2 ] keep r>
|
||||
over bitmap-rows [ >r 3dup r> copy-row ] each 3drop ;
|
||||
|
||||
: glyph>texture ( bitmap -- texture )
|
||||
#! Given a glyph bitmap, copy it to a texture whose size is
|
||||
#! a power of two.
|
||||
dup <glyph-texture> [ copy-glyph ] keep ;
|
||||
|
|
@ -1,8 +1,8 @@
|
|||
! Copyright (C) 2005 Slava Pestov.
|
||||
! See http://factor.sf.net/license.txt for BSD license.
|
||||
IN: gadgets-labels
|
||||
USING: arrays gadgets gadgets-layouts generic hashtables io
|
||||
kernel math namespaces sequences styles ;
|
||||
USING: arrays freetype gadgets gadgets-layouts generic
|
||||
hashtables io kernel math namespaces sequences styles ;
|
||||
|
||||
! A label gadget draws a string.
|
||||
TUPLE: label text ;
|
||||
|
|
@ -10,18 +10,21 @@ TUPLE: label text ;
|
|||
C: label ( text -- label )
|
||||
dup delegate>gadget [ set-label-text ] keep ;
|
||||
|
||||
: label-size ( gadget text -- dim )
|
||||
>r gadget-font r> size-string 0 3array ;
|
||||
|
||||
: set-label-text* ( text label -- )
|
||||
2dup label-text =
|
||||
[ 2dup [ set-label-text ] keep relayout ] unless 2drop ;
|
||||
|
||||
: label-size ( gadget text -- dim )
|
||||
dup gadget-font swap label-text string-size 0 3array ;
|
||||
|
||||
M: label pref-dim ( label -- dim )
|
||||
dup label-text label-size ;
|
||||
label-size ;
|
||||
|
||||
: draw-label ( label -- )
|
||||
dup label-text swap gadget-font draw-string ;
|
||||
|
||||
M: label draw-gadget* ( label -- )
|
||||
dup delegate draw-gadget* drop ; ! label-text draw-string ;
|
||||
dup delegate draw-gadget* draw-label ;
|
||||
|
||||
M: label set-message ( string/f label -- )
|
||||
>r [ "" ] unless* r> set-label-text* ;
|
||||
set-label-text* ;
|
||||
|
|
|
|||
|
|
@ -1,6 +1,5 @@
|
|||
USING: kernel parser sequences io ;
|
||||
[
|
||||
"/library/ui/freetype.factor"
|
||||
"/library/ui/gadgets.factor"
|
||||
"/library/ui/layouts.factor"
|
||||
"/library/ui/hierarchy.factor"
|
||||
|
|
@ -11,7 +10,6 @@ USING: kernel parser sequences io ;
|
|||
"/library/ui/events.factor"
|
||||
"/library/ui/frames.factor"
|
||||
"/library/ui/world.factor"
|
||||
"/library/ui/text.factor"
|
||||
"/library/ui/borders.factor"
|
||||
"/library/ui/labels.factor"
|
||||
"/library/ui/buttons.factor"
|
||||
|
|
|
|||
|
|
@ -1,7 +1,8 @@
|
|||
! Copyright (C) 2005 Slava Pestov.
|
||||
! See http://factor.sf.net/license.txt for BSD license.
|
||||
USING: alien arrays gadgets-layouts generic hashtables io kernel
|
||||
lists math namespaces opengl sdl sequences strings styles vectors ;
|
||||
USING: alien arrays freetype gadgets-layouts generic hashtables
|
||||
io kernel lists math namespaces opengl sdl sequences strings
|
||||
styles vectors ;
|
||||
IN: gadgets
|
||||
|
||||
SYMBOL: clip
|
||||
|
|
@ -140,3 +141,9 @@ M: polygon draw-interior ( gadget polygon -- )
|
|||
dup max-dim @{ 1 1 0 }@ v+
|
||||
>r <polygon> <gadget> r> over set-rect-dim
|
||||
dup rot interior set-paint-prop ;
|
||||
|
||||
: gadget-font ( gadget -- font )
|
||||
[ font paint-prop ] keep
|
||||
[ font-style paint-prop ] keep
|
||||
[ font-size paint-prop ] keep
|
||||
>r lookup-font r> drop ;
|
||||
|
|
|
|||
|
|
@ -1,39 +0,0 @@
|
|||
! Copyright (C) 2005 Slava Pestov.
|
||||
! See http://factor.sf.net/license.txt for BSD license.
|
||||
IN: gadgets
|
||||
USING: alien hashtables io kernel lists math namespaces sdl
|
||||
sequences strings styles ;
|
||||
|
||||
: draw-surface ( x y surface -- )
|
||||
[
|
||||
[ [ surface-rect ] keep swap surface get 0 0 ] keep
|
||||
surface-rect swap rot SDL_UpperBlit drop
|
||||
] with-unlocked-surface ;
|
||||
|
||||
: filter-nulls ( str -- str )
|
||||
[ dup 0 = [ drop CHAR: \s ] when ] map ;
|
||||
|
||||
: size-string ( font text -- w h )
|
||||
filter-nulls dup empty? [
|
||||
drop 0 swap TTF_FontHeight
|
||||
] [
|
||||
0 <int> 0 <int> [ TTF_SizeUNICODE drop ] 2keep
|
||||
[ *int ] 2apply
|
||||
] if ;
|
||||
|
||||
: gadget-font ( gadget -- font )
|
||||
[ font paint-prop ] keep
|
||||
[ font-style paint-prop ] keep
|
||||
[ font-size paint-prop ] keep
|
||||
>r lookup-font r> drop ;
|
||||
|
||||
: draw-string ( gadget text -- )
|
||||
filter-nulls dup empty? [
|
||||
2drop
|
||||
] [
|
||||
>r [ gadget-font ] keep r> swap
|
||||
fg first3 make-color
|
||||
TTF_RenderUNICODE_Blended
|
||||
[ >r origin get first2 r> draw-surface ] keep
|
||||
SDL_FreeSurface
|
||||
] if ;
|
||||
|
|
@ -1,27 +1,26 @@
|
|||
! Copyright (C) 2005 Slava Pestov.
|
||||
! See http://factor.sf.net/license.txt for BSD license.
|
||||
IN: gadgets
|
||||
USING: errors gadgets-layouts gadgets-listener gadgets-theme
|
||||
generic help io kernel listener lists math memory namespaces
|
||||
opengl prettyprint sdl sequences shells styles threads words ;
|
||||
USING: errors freetype gadgets-layouts gadgets-listener
|
||||
gadgets-theme generic help io kernel listener lists math memory
|
||||
namespaces opengl prettyprint sdl sequences shells styles
|
||||
threads words ;
|
||||
|
||||
SYMBOL: first-time
|
||||
|
||||
global [ first-time on ] bind
|
||||
|
||||
: init-world ( -- )
|
||||
global [
|
||||
first-time get [
|
||||
<world> world set
|
||||
world get solid-interior
|
||||
world get world-theme
|
||||
@{ 800 600 0 }@ world get set-gadget-dim
|
||||
<hand> hand set
|
||||
listener-application
|
||||
] bind ;
|
||||
|
||||
SYMBOL: first-time
|
||||
|
||||
global [ first-time on ] bind
|
||||
|
||||
: ?init-world
|
||||
global [
|
||||
first-time get [ init-world first-time off ] when
|
||||
first-time off
|
||||
] when
|
||||
] bind ;
|
||||
|
||||
: check-running
|
||||
|
|
@ -35,7 +34,7 @@ IN: shells
|
|||
: ui ( -- )
|
||||
#! Start the Factor graphics subsystem with the given screen
|
||||
#! dimensions.
|
||||
init-ttf
|
||||
?init-world
|
||||
check-running world get rect-dim first2
|
||||
0 gl-flags [ run-world ] with-screen ;
|
||||
[
|
||||
init-world check-running
|
||||
world get rect-dim first2 0 gl-flags [ run-world ] with-screen
|
||||
] with-freetype ;
|
||||
|
|
|
|||
Loading…
Reference in New Issue