From 7e47f5388f8a37f3affe60c708911e101c1cb1fd Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 14 Oct 2005 08:05:02 +0000 Subject: [PATCH] FreeType bindings work --- library/bootstrap/boot-stage2.factor | 1 + .../collections/sequence-combinators.factor | 7 + library/collections/sequences.factor | 4 + library/compiler/stack.factor | 3 - library/freetype/freetype-gl.factor | 152 ++++++++++ library/freetype/freetype.factor | 188 +++++++++++++ library/freetype/load.factor | 8 + library/sdl/load.factor | 1 - library/sdl/sdl-ttf.factor | 84 ------ library/sdl/sdl-utils.factor | 54 +--- library/test/collections/sequences.factor | 14 +- library/ui/editors.factor | 16 +- library/ui/freetype.factor | 260 ------------------ library/ui/labels.factor | 19 +- library/ui/load.factor | 2 - library/ui/paint.factor | 11 +- library/ui/text.factor | 39 --- library/ui/ui.factor | 37 ++- 18 files changed, 419 insertions(+), 481 deletions(-) create mode 100644 library/freetype/freetype-gl.factor create mode 100644 library/freetype/freetype.factor create mode 100644 library/freetype/load.factor delete mode 100644 library/sdl/sdl-ttf.factor delete mode 100644 library/ui/freetype.factor delete mode 100644 library/ui/text.factor diff --git a/library/bootstrap/boot-stage2.factor b/library/bootstrap/boot-stage2.factor index d4adfa7f5f..77d439236b 100644 --- a/library/bootstrap/boot-stage2.factor +++ b/library/bootstrap/boot-stage2.factor @@ -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 diff --git a/library/collections/sequence-combinators.factor b/library/collections/sequence-combinators.factor index eea7407ffb..ef81823481 100644 --- a/library/collections/sequence-combinators.factor +++ b/library/collections/sequence-combinators.factor @@ -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 diff --git a/library/collections/sequences.factor b/library/collections/sequences.factor index c0956bbcaa..9a20e3ecaa 100644 --- a/library/collections/sequences.factor +++ b/library/collections/sequences.factor @@ -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 diff --git a/library/compiler/stack.factor b/library/compiler/stack.factor index 1c4ce61575..336931a0da 100644 --- a/library/compiler/stack.factor +++ b/library/compiler/stack.factor @@ -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 ; diff --git a/library/freetype/freetype-gl.factor b/library/freetype/freetype-gl.factor new file mode 100644 index 0000000000..a64b7fc9ae --- /dev/null +++ b/library/freetype/freetype-gl.factor @@ -0,0 +1,152 @@ +! 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 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 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 [ 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 ; + +: 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 ; + +: ( bitmap -- texture ) + dup glyph-bitmap-width next-power-of-2 + swap glyph-bitmap-rows next-power-of-2 * ; + +: 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 [ copy-glyph ] keep ; + +: ( font char -- sprite ) + 0 0 ; + +: char-sprite ( open-font char -- sprite ) + over font-sprites [ dupd ] cache-nth nip ; + +: draw-string ( font string -- ) + [ char-sprite drop ( sprite-dlist glCallList ) ] each-with ; diff --git a/library/freetype/freetype.factor b/library/freetype/freetype.factor new file mode 100644 index 0000000000..67791a44bc --- /dev/null +++ b/library/freetype/freetype.factor @@ -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 ) ; diff --git a/library/freetype/load.factor b/library/freetype/load.factor new file mode 100644 index 0000000000..c42d11fc83 --- /dev/null +++ b/library/freetype/load.factor @@ -0,0 +1,8 @@ +USING: io kernel parser sequences ; + +[ + "/library/freetype/freetype.factor" + "/library/freetype/freetype-gl.factor" +] [ + dup print run-resource +] each diff --git a/library/sdl/load.factor b/library/sdl/load.factor index 5454f72f05..78c4c54134 100644 --- a/library/sdl/load.factor +++ b/library/sdl/load.factor @@ -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 diff --git a/library/sdl/sdl-ttf.factor b/library/sdl/sdl-ttf.factor deleted file mode 100644 index 7e7a8df359..0000000000 --- a/library/sdl/sdl-ttf.factor +++ /dev/null @@ -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 ; diff --git a/library/sdl/sdl-utils.factor b/library/sdl/sdl-utils.factor index 5c3e75c0a6..a580a9a569 100644 --- a/library/sdl/sdl-utils.factor +++ b/library/sdl/sdl-utils.factor @@ -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. - - [ 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 ) [ 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 diff --git a/library/test/collections/sequences.factor b/library/test/collections/sequences.factor index 8c24fc117a..c8a7bd0516 100644 --- a/library/test/collections/sequences.factor +++ b/library/test/collections/sequences.factor @@ -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 >vector ] unit-test [ 3 ] [ 1 4 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 diff --git a/library/ui/editors.factor b/library/ui/editors.factor index 39a4069f96..b79fa25133 100644 --- a/library/ui/editors.factor +++ b/library/ui/editors.factor @@ -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. diff --git a/library/ui/freetype.factor b/library/ui/freetype.factor deleted file mode 100644 index 92081b10f1..0000000000 --- a/library/ui/freetype.factor +++ /dev/null @@ -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 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 [ 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 ; - -: 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 ; - -: ( bitmap -- texture ) - dup glyph-bitmap-width next-power-of-2 - swap glyph-bitmap-rows next-power-of-2 * ; - -: 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 [ copy-glyph ] keep ; diff --git a/library/ui/labels.factor b/library/ui/labels.factor index c202e2184e..213a20e789 100644 --- a/library/ui/labels.factor +++ b/library/ui/labels.factor @@ -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* ; diff --git a/library/ui/load.factor b/library/ui/load.factor index f80e914419..701e773073 100644 --- a/library/ui/load.factor +++ b/library/ui/load.factor @@ -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" diff --git a/library/ui/paint.factor b/library/ui/paint.factor index db0425e39a..cadf49546a 100644 --- a/library/ui/paint.factor +++ b/library/ui/paint.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 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 ; diff --git a/library/ui/text.factor b/library/ui/text.factor deleted file mode 100644 index 1e0896d6fb..0000000000 --- a/library/ui/text.factor +++ /dev/null @@ -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 0 [ 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 ; diff --git a/library/ui/ui.factor b/library/ui/ui.factor index ccfb524a0c..f0b3140ae4 100644 --- a/library/ui/ui.factor +++ b/library/ui/ui.factor @@ -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 ; - -: init-world ( -- ) - global [ - world set - world get solid-interior - world get world-theme - @{ 800 600 0 }@ world get set-gadget-dim - hand set - listener-application - ] bind ; +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 +: init-world ( -- ) global [ - first-time get [ init-world first-time off ] when + first-time get [ + world set + world get solid-interior + world get world-theme + @{ 800 600 0 }@ world get set-gadget-dim + hand set + listener-application + 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 ;