FreeType debugging
Slava Pestov
parent
3a5aece387
commit
778bfaaf27
|
|
@ -5,6 +5,7 @@ USING: alien errors kernel ;
|
|||
|
||||
LIBRARY: libc
|
||||
FUNCTION: ulong malloc ( ulong size ) ;
|
||||
FUNCTION: ulong calloc ( ulong count, ulong size ) ;
|
||||
FUNCTION: void free ( ulong ptr ) ;
|
||||
FUNCTION: ulong realloc ( ulong ptr, ulong size ) ;
|
||||
FUNCTION: void memcpy ( ulong dst, ulong src, ulong size ) ;
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2005 Slava Pestov.
|
||||
! See http://factor.sf.net/license.txt for BSD license.
|
||||
USING: #<unknown> alien arrays errors hashtables io kernel
|
||||
USING: alien arrays errors hashtables io kernel
|
||||
kernel-internals lists math namespaces opengl prettyprint
|
||||
sequences styles ;
|
||||
IN: freetype
|
||||
|
|
@ -19,14 +19,11 @@ SYMBOL: open-fonts
|
|||
{{ }} clone open-fonts set
|
||||
] bind ;
|
||||
|
||||
! A sprite are a texture and display list.
|
||||
TUPLE: sprite dlist texture ;
|
||||
|
||||
: free-dlists ( seq -- )
|
||||
"Freeing display lists: " print . ;
|
||||
drop ;
|
||||
|
||||
: free-textures ( seq -- )
|
||||
"Freeing textures: " print . ;
|
||||
drop ;
|
||||
|
||||
: free-sprites ( glyphs -- )
|
||||
dup [ sprite-dlist ] map free-dlists
|
||||
|
|
@ -35,11 +32,19 @@ TUPLE: sprite dlist texture ;
|
|||
! A font object from FreeType.
|
||||
! the handle is an FT_Face.
|
||||
! sprites is a vector.
|
||||
TUPLE: font height handle sprites metrics ;
|
||||
TUPLE: font ascent descent height handle sprites ;
|
||||
|
||||
: flush-font ( font -- )
|
||||
#! Only do this after re-creating a GL context!
|
||||
dup font-sprites [ ] subset free-sprites
|
||||
{ } clone swap set-font-sprites ;
|
||||
|
||||
: close-font ( font -- )
|
||||
dup font-sprites [ ] subset free-sprites
|
||||
font-handle FT_Done_Face ;
|
||||
dup flush-font font-handle FT_Done_Face ;
|
||||
|
||||
: flush-fonts ( -- )
|
||||
#! Only do this after re-creating a GL context!
|
||||
open-fonts get hash-values [ flush-font ] each ;
|
||||
|
||||
: close-freetype ( -- )
|
||||
global [
|
||||
|
|
@ -76,23 +81,25 @@ TUPLE: font height handle sprites metrics ;
|
|||
ttf-name ttf-path >r freetype get r>
|
||||
0 f <void*> [ FT_New_Face freetype-error ] keep *void* ;
|
||||
|
||||
: dpi 100 ;
|
||||
: dpi 72 ;
|
||||
|
||||
: fix>float 64 /f ;
|
||||
|
||||
: font-units>pixels ( n font -- n )
|
||||
face-size face-size-y-scale FT_MulFix fix>float ;
|
||||
|
||||
: init-font-height ( font -- )
|
||||
dup font-handle
|
||||
dup face-y-max over face-y-min - swap font-units>pixels
|
||||
swap set-font-height ;
|
||||
: init-ascent ( font face -- )
|
||||
dup face-y-max swap font-units>pixels swap set-font-ascent ;
|
||||
|
||||
: init-descent ( font face -- )
|
||||
dup face-y-min swap font-units>pixels swap set-font-descent ;
|
||||
|
||||
: init-font ( font -- )
|
||||
dup font-handle 2dup init-ascent dupd init-descent
|
||||
dup font-ascent over font-descent - 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 ;
|
||||
[ set-font-handle ] keep dup flush-font dup init-font ;
|
||||
|
||||
: open-font ( { font style ptsize } -- font )
|
||||
#! Open a font and set the point size of the font.
|
||||
|
|
@ -103,60 +110,81 @@ C: font ( handle -- 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 ;
|
||||
: load-glyph ( font char -- glyph )
|
||||
>r font-handle r> dupd 0 FT_Load_Char
|
||||
freetype-error face-glyph ;
|
||||
|
||||
: (char-size) ( font char -- dim )
|
||||
>r font-handle r> load-glyph
|
||||
dup glyph-width fix>float
|
||||
: glyph-size ( glyph -- dim )
|
||||
dup glyph-advance-x 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-glyph ( font char -- bitmap )
|
||||
#! Render a character and return a pointer to the bitmap.
|
||||
load-glyph dup
|
||||
FT_RENDER_MODE_NORMAL FT_Render_Glyph freetype-error ;
|
||||
|
||||
: with-locked-block ( size quot -- | quot: address -- )
|
||||
swap malloc [ swap call ] keep free ; inline
|
||||
swap 1 calloc [ swap call ] keep free ; inline
|
||||
|
||||
: (copy-bitmap) ( bitmap-chase texture-chase width width-pow2 )
|
||||
>r 3dup swapd memcpy tuck >r >r + r> r> r> tuck >r >r + r> r> ;
|
||||
: b/b>w 8 shift bitor ;
|
||||
|
||||
: copy-bitmap ( glyph texture width-pow2 -- )
|
||||
pick glyph-bitmap-rows >r >r over glyph-bitmap-pitch >r >r
|
||||
glyph-bitmap-buffer alien-address r> r> r> r>
|
||||
[ (copy-bitmap) ] times 2drop 2drop ;
|
||||
: copy-pixel ( bit tex -- bit tex )
|
||||
f pick alien-unsigned-1 255 b/b>w
|
||||
f pick set-alien-unsigned-2
|
||||
>r 1+ r> 2 + ;
|
||||
|
||||
: bitmap>texture ( width height glyph -- id )
|
||||
: (copy-row) ( bit tex bitend texend -- bitend texend )
|
||||
>r pick over >= [
|
||||
r> 2swap 2drop
|
||||
] [
|
||||
>r copy-pixel r> r> (copy-row)
|
||||
] if ;
|
||||
|
||||
: copy-row ( bit tex width width2 -- bitend texend width width2 )
|
||||
[ pick + >r pick + r> (copy-row) ] 2keep ;
|
||||
|
||||
: copy-bitmap ( glyph texture -- )
|
||||
over glyph-bitmap-rows >r
|
||||
over glyph-bitmap-width dup next-power-of-2 2 *
|
||||
>r >r >r glyph-bitmap-buffer alien-address r> r> r> r>
|
||||
[ copy-row ] times 2drop 2drop ;
|
||||
|
||||
: bitmap>texture ( glyph sprite -- id )
|
||||
#! Given a glyph bitmap, copy it to a texture with the given
|
||||
#! width/height (which must be powers of two).
|
||||
3drop
|
||||
32 32 * 4 * [
|
||||
<alien> 32 32 * 4 * [
|
||||
128 pick rot set-alien-signed-1
|
||||
] each 32 32 rot gray-texture
|
||||
tuck sprite-size2 * 2 * [
|
||||
[ copy-bitmap ] keep <alien> gray-texture
|
||||
] with-locked-block ;
|
||||
|
||||
: char-texture-size ( bitmap -- width height )
|
||||
dup glyph-bitmap-width swap glyph-bitmap-rows
|
||||
[ next-power-of-2 ] 2apply ;
|
||||
: glyph-texture-loc ( glyph font -- loc )
|
||||
font-ascent swap glyph-hori-bearing-y fix>float -
|
||||
0 swap 0 3array ;
|
||||
|
||||
: <char-sprite> ( face char -- sprite )
|
||||
render-glyph [ char-texture-size 2dup ] keep
|
||||
bitmap>texture [ texture>dlist ] keep <sprite> ;
|
||||
: glyph-texture-size ( glyph -- dim )
|
||||
dup glyph-bitmap-width next-power-of-2
|
||||
swap glyph-bitmap-rows next-power-of-2 0 3array ;
|
||||
|
||||
: <char-sprite> ( font char -- sprite )
|
||||
#! Create a new display list of a rendered glyph. This
|
||||
#! allocates external resources. See free-sprites.
|
||||
over >r render-glyph dup r> glyph-texture-loc
|
||||
over glyph-size pick glyph-texture-size <sprite>
|
||||
[ bitmap>texture ] keep [ init-sprite ] keep ;
|
||||
|
||||
: char-sprite ( open-font char -- sprite )
|
||||
over font-sprites
|
||||
[ >r dup font-handle r> <char-sprite> ] cache-nth nip ;
|
||||
#! Get a cached display list of a FreeType-rendered
|
||||
#! glyph.
|
||||
over font-sprites [ dupd <char-sprite> ] cache-nth nip ;
|
||||
|
||||
: draw-string ( font string -- )
|
||||
GL_TEXTURE_BIT [
|
||||
[ char-sprite sprite-dlist glCallList ] each-with
|
||||
] save-attribs ;
|
||||
: char-width ( open-font char -- w )
|
||||
char-sprite sprite-width ;
|
||||
|
||||
: string-width ( open-font string -- w )
|
||||
0 -rot [ char-width + ] each-with ;
|
||||
|
||||
: draw-string ( open-font string -- )
|
||||
GL_MODELVIEW [
|
||||
GL_TEXTURE_BIT [
|
||||
[ char-sprite sprite-dlist glCallList ] each-with
|
||||
] save-attribs
|
||||
] do-matrix ;
|
||||
|
|
|
|||
|
|
@ -31,10 +31,14 @@ UNION: integer fixnum bignum ;
|
|||
foldable
|
||||
|
||||
: (next-power-of-2) ( i n -- n )
|
||||
2dup >= [ drop ] [ >r 1 shift r> (next-power-of-2) ] if ;
|
||||
2dup >= [
|
||||
drop
|
||||
] [
|
||||
>r 1 shift 1 max r> (next-power-of-2)
|
||||
] if ;
|
||||
|
||||
: next-power-of-2 ( n -- n )
|
||||
2 swap (next-power-of-2) ;
|
||||
0 swap (next-power-of-2) ;
|
||||
|
||||
IN: math-internals
|
||||
|
||||
|
|
|
|||
|
|
@ -35,6 +35,8 @@ M: ratio - ( x y -- x-y ) 2dup scale - -rot ratio+d / ;
|
|||
M: ratio * ( x y -- x*y ) 2>fraction * >r * r> / ;
|
||||
M: ratio / scale / ;
|
||||
M: ratio /i scale /i ;
|
||||
M: ratio /mod 2dup >r >r /i dup r> * r> swap - ;
|
||||
M: ratio mod /mod nip ;
|
||||
M: ratio /f scale /f ;
|
||||
|
||||
M: ratio truncate >fraction /i ;
|
||||
|
|
|
|||
|
|
@ -14,10 +14,16 @@ USING: alien errors kernel math namespaces opengl sdl sequences ;
|
|||
0 0 width get height get glViewport
|
||||
0 width get height get 0 gluOrtho2D
|
||||
GL_SMOOTH glShadeModel
|
||||
GL_TEXTURE_2D glEnable ;
|
||||
GL_TEXTURE_2D glEnable
|
||||
GL_BLEND glEnable
|
||||
GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA glBlendFunc
|
||||
GL_SCISSOR_TEST glEnable ;
|
||||
|
||||
: gl-flags
|
||||
SDL_OPENGL SDL_RESIZABLE bitor SDL_HWSURFACE bitor SDL_DOUBLEBUF bitor ;
|
||||
SDL_OPENGL
|
||||
SDL_RESIZABLE bitor
|
||||
SDL_HWSURFACE bitor
|
||||
SDL_DOUBLEBUF bitor ;
|
||||
|
||||
: gl-resize ( event -- )
|
||||
#! Acts on an SDL resize event.
|
||||
|
|
@ -44,13 +50,13 @@ USING: alien errors kernel math namespaces opengl sdl sequences ;
|
|||
|
||||
: gl-vertex first3 glVertex3d ;
|
||||
|
||||
: top-left drop @{ 0 0 0 }@ gl-vertex ;
|
||||
: top-left drop 0 0 glTexCoord2d @{ 0 0 0 }@ gl-vertex ;
|
||||
|
||||
: top-right @{ 1 0 0 }@ v* gl-vertex ;
|
||||
: top-right 1 0 glTexCoord2d @{ 1 0 0 }@ v* gl-vertex ;
|
||||
|
||||
: bottom-left @{ 0 1 0 }@ v* gl-vertex ;
|
||||
: bottom-left 0 1 glTexCoord2d @{ 0 1 0 }@ v* gl-vertex ;
|
||||
|
||||
: bottom-right gl-vertex ;
|
||||
: bottom-right 1 1 glTexCoord2d gl-vertex ;
|
||||
|
||||
: four-sides ( dim -- )
|
||||
dup top-left dup top-right dup bottom-right bottom-left ;
|
||||
|
|
@ -58,19 +64,17 @@ USING: alien errors kernel math namespaces opengl sdl sequences ;
|
|||
: gl-line ( from to { r g b } -- )
|
||||
gl-color [ gl-vertex ] 2apply ;
|
||||
|
||||
: (gl-rect) swap gl-color [ four-sides ] do-state ;
|
||||
|
||||
: gl-fill-rect ( dim { r g b } -- )
|
||||
: gl-fill-rect ( dim -- )
|
||||
#! Draws a two-dimensional box.
|
||||
GL_QUADS (gl-rect) ;
|
||||
GL_QUADS [ four-sides ] do-state ;
|
||||
|
||||
: gl-rect ( dim { r g b } -- )
|
||||
: gl-rect ( dim -- )
|
||||
#! Draws a two-dimensional box.
|
||||
GL_LINE_LOOP (gl-rect) ;
|
||||
GL_LINE_LOOP [ four-sides ] do-state ;
|
||||
|
||||
: (gl-poly) swap gl-color [ [ gl-vertex ] each ] do-state ;
|
||||
: (gl-poly) [ [ gl-vertex ] each ] do-state ;
|
||||
|
||||
: gl-fill-poly ( points { r g b } -- )
|
||||
: gl-fill-poly ( points -- )
|
||||
#! Draw a filled polygon.
|
||||
GL_POLYGON (gl-poly) ;
|
||||
|
||||
|
|
@ -82,7 +86,9 @@ USING: alien errors kernel math namespaces opengl sdl sequences ;
|
|||
swap glMatrixMode glPushMatrix call glPopMatrix ; inline
|
||||
|
||||
: gl-set-clip ( loc dim -- )
|
||||
[ first2 ] 2apply glScissor ;
|
||||
dup first2 >r >r
|
||||
over second swap second + height get swap - >r
|
||||
first r> r> r> glScissor ;
|
||||
|
||||
: prepare-gradient ( direction dim -- v1 v2 )
|
||||
tuck v* [ v- ] keep ;
|
||||
|
|
@ -104,17 +110,26 @@ USING: alien errors kernel math namespaces opengl sdl sequences ;
|
|||
: save-attribs ( bits quot -- )
|
||||
swap glPushAttrib call glPopAttrib ; inline
|
||||
|
||||
: gray-texture ( width height buffer -- id )
|
||||
! A sprite is a texture and a display list.
|
||||
TUPLE: sprite dlist texture loc dim dim2 ;
|
||||
|
||||
C: sprite ( loc dim dim2 -- )
|
||||
[ set-sprite-dim2 ] keep
|
||||
[ set-sprite-dim ] keep
|
||||
[ set-sprite-loc ] keep ;
|
||||
|
||||
: sprite-size2 sprite-dim2 first2 ;
|
||||
|
||||
: sprite-width sprite-dim first ;
|
||||
|
||||
: gray-texture ( sprite buffer -- id )
|
||||
#! Given a buffer holding a width x height (powers of two)
|
||||
#! grayscale texture, bind it and return the ID.
|
||||
gen-texture [
|
||||
GL_TEXTURE_BIT [
|
||||
GL_TEXTURE_2D swap glBindTexture
|
||||
GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER GL_LINEAR glTexParameteri
|
||||
GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER GL_LINEAR glTexParameteri
|
||||
GL_TEXTURE_2D GL_TEXTURE_WRAP_S GL_CLAMP glTexParameterf
|
||||
GL_TEXTURE_2D GL_TEXTURE_WRAP_T GL_CLAMP glTexParameterf
|
||||
>r >r >r GL_TEXTURE_2D 0 GL_RGBA r> r> 0 GL_RGBA
|
||||
>r >r GL_TEXTURE_2D 0 GL_RGBA r>
|
||||
sprite-size2 0 GL_LUMINANCE_ALPHA
|
||||
GL_UNSIGNED_BYTE r> glTexImage2D
|
||||
] save-attribs
|
||||
] keep ;
|
||||
|
|
@ -127,19 +142,25 @@ USING: alien errors kernel math namespaces opengl sdl sequences ;
|
|||
#! Make a display list.
|
||||
gen-dlist [ rot glNewList call glEndList ] keep ; inline
|
||||
|
||||
: texture>dlist ( width height id -- id )
|
||||
#! Given a texture width/height and ID, make a display list
|
||||
#! for draws a quad with this texture.
|
||||
: init-texture ( -- )
|
||||
GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER GL_LINEAR glTexParameteri
|
||||
GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER GL_LINEAR glTexParameteri
|
||||
GL_TEXTURE_2D GL_TEXTURE_WRAP_S GL_CLAMP glTexParameterf
|
||||
GL_TEXTURE_2D GL_TEXTURE_WRAP_T GL_CLAMP glTexParameterf ;
|
||||
|
||||
: make-sprite-dlist ( sprite -- id )
|
||||
GL_MODELVIEW [
|
||||
GL_COMPILE [
|
||||
1 1 1 glColor3f
|
||||
GL_TEXTURE_2D swap glBindTexture
|
||||
GL_QUADS [
|
||||
0 0 glTexCoord2d 0 0 glVertex2i
|
||||
0 1 glTexCoord2d 0 over glVertex2i
|
||||
1 1 glTexCoord2d 2dup glVertex2i
|
||||
1 0 glTexCoord2d over 0 glVertex2i
|
||||
] do-state
|
||||
drop 0 0 glTranslatef
|
||||
GL_MODELVIEW [
|
||||
dup sprite-loc first3 glTranslatef
|
||||
GL_TEXTURE_2D over sprite-texture glBindTexture
|
||||
init-texture
|
||||
dup sprite-dim2 gl-fill-rect
|
||||
] do-matrix
|
||||
sprite-width 0 0 glTranslatef
|
||||
] make-dlist
|
||||
] do-matrix ;
|
||||
|
||||
: init-sprite ( texture sprite -- )
|
||||
[ set-sprite-texture ] keep
|
||||
[ make-sprite-dlist ] keep set-sprite-dlist ;
|
||||
|
|
|
|||
|
|
@ -10,7 +10,6 @@ USING: alien io kernel parser sequences ;
|
|||
"/library/sdl/sdl.factor"
|
||||
"/library/sdl/sdl-video.factor"
|
||||
"/library/sdl/sdl-event.factor"
|
||||
"/library/sdl/sdl-gfx.factor"
|
||||
"/library/sdl/sdl-keysym.factor"
|
||||
"/library/sdl/sdl-keyboard.factor"
|
||||
"/library/sdl/sdl-utils.factor"
|
||||
|
|
|
|||
|
|
@ -1,108 +0,0 @@
|
|||
! Copyright (C) 2004, 2005 Slava Pestov.
|
||||
! See http://factor.sf.net/license.txt for BSD license.
|
||||
IN: sdl USING: alien ;
|
||||
|
||||
: pixelColor ( surface x y color -- )
|
||||
"void" "sdl-gfx" "pixelColor"
|
||||
[ "surface*" "short" "short" "uint" ]
|
||||
alien-invoke ;
|
||||
|
||||
: hlineColor ( surface x1 x2 y color -- )
|
||||
"void" "sdl-gfx" "hlineColor"
|
||||
[ "surface*" "short" "short" "short" "uint" ]
|
||||
alien-invoke ;
|
||||
|
||||
: vlineColor ( surface x y1 y2 color -- )
|
||||
"void" "sdl-gfx" "vlineColor"
|
||||
[ "surface*" "short" "short" "short" "uint" ]
|
||||
alien-invoke ;
|
||||
|
||||
: rectangleColor ( surface x1 y1 x2 y2 color -- )
|
||||
"void" "sdl-gfx" "rectangleColor"
|
||||
[ "surface*" "short" "short" "short" "short" "uint" ]
|
||||
alien-invoke ;
|
||||
|
||||
: boxColor ( surface x1 y1 x2 y2 color -- )
|
||||
"void" "sdl-gfx" "boxColor"
|
||||
[ "surface*" "short" "short" "short" "short" "uint" ]
|
||||
alien-invoke ;
|
||||
|
||||
: lineColor ( surface x1 y1 x2 y2 color -- )
|
||||
"void" "sdl-gfx" "lineColor"
|
||||
[ "surface*" "short" "short" "short" "short" "uint" ]
|
||||
alien-invoke ;
|
||||
|
||||
: aalineColor ( surface x1 y1 x2 y2 color -- )
|
||||
"void" "sdl-gfx" "aalineColor"
|
||||
[ "surface*" "short" "short" "short" "short" "uint" ]
|
||||
alien-invoke ;
|
||||
|
||||
: circleColor ( surface x y r color -- )
|
||||
"void" "sdl-gfx" "circleColor"
|
||||
[ "surface*" "short" "short" "short" "uint" ]
|
||||
alien-invoke ;
|
||||
|
||||
: aacircleColor ( surface x y r color -- )
|
||||
"void" "sdl-gfx" "aacircleColor"
|
||||
[ "surface*" "short" "short" "short" "uint" ]
|
||||
alien-invoke ;
|
||||
|
||||
: filledCircleColor ( surface x y r color -- )
|
||||
"void" "sdl-gfx" "filledCircleColor"
|
||||
[ "surface*" "short" "short" "short" "uint" ]
|
||||
alien-invoke ;
|
||||
|
||||
: ellipseColor ( surface x y rx ry color -- )
|
||||
"void" "sdl-gfx" "ellipseColor"
|
||||
[ "surface*" "short" "short" "short" "short" "uint" ]
|
||||
alien-invoke ;
|
||||
|
||||
: aaellipseColor ( surface x y rx ry color -- )
|
||||
"void" "sdl-gfx" "aaellipseColor"
|
||||
[ "surface*" "short" "short" "short" "short" "uint" ]
|
||||
alien-invoke ;
|
||||
|
||||
: filledEllipseColor ( surface x y rx ry color -- )
|
||||
"void" "sdl-gfx" "filledEllipseColor"
|
||||
[ "surface*" "short" "short" "short" "short" "uint" ]
|
||||
alien-invoke ;
|
||||
|
||||
: trigonColor ( surface x1 y1 x2 y2 x3 y3 color -- )
|
||||
"void" "sdl-gfx" "trigonColor"
|
||||
[ "surface*" "short" "short" "short" "short" "short" "short" "uint" ]
|
||||
alien-invoke ;
|
||||
|
||||
: aatrigonColor ( surface x1 y1 x2 y2 x3 y3 color -- )
|
||||
"void" "sdl-gfx" "aatrigonColor"
|
||||
[ "surface*" "short" "short" "short" "short" "short" "short" "uint" ]
|
||||
alien-invoke ;
|
||||
|
||||
: filledTrigonColor ( surface x1 y1 x2 y2 x3 y3 color -- )
|
||||
"void" "sdl-gfx" "filledTrigonColor"
|
||||
[ "surface*" "short" "short" "short" "short" "short" "short" "uint" ]
|
||||
alien-invoke ;
|
||||
|
||||
: polygonColor ( surface vx vy n color -- )
|
||||
"void" "sdl-gfx" "polygonColor"
|
||||
[ "surface*" "short*" "short*" "int" "int" ]
|
||||
alien-invoke ;
|
||||
|
||||
: aapolygonColor ( surface vx vy n color -- )
|
||||
"void" "sdl-gfx" "aapolygonColor"
|
||||
[ "surface*" "short*" "short*" "int" "int" ]
|
||||
alien-invoke ;
|
||||
|
||||
: filledPolygonColor ( surface vx vy n color -- )
|
||||
"void" "sdl-gfx" "filledPolygonColor"
|
||||
[ "surface*" "short*" "short*" "int" "int" ]
|
||||
alien-invoke ;
|
||||
|
||||
: characterColor ( surface x y c color -- )
|
||||
"void" "sdl-gfx" "characterColor"
|
||||
[ "surface*" "short" "short" "char" "uint" ]
|
||||
alien-invoke ;
|
||||
|
||||
: stringColor ( surface x y str color -- )
|
||||
"void" "sdl-gfx" "stringColor"
|
||||
[ "surface*" "short" "short" "char*" "uint" ]
|
||||
alien-invoke ;
|
||||
|
|
@ -30,28 +30,6 @@ SYMBOL: bpp
|
|||
[ [ >r init-sdl r> call ] [ SDL_Quit ] cleanup ] with-scope ;
|
||||
inline
|
||||
|
||||
: rgb ( [ r g b ] -- n )
|
||||
first3
|
||||
255
|
||||
swap >fixnum 8 shift bitor
|
||||
swap >fixnum 16 shift bitor
|
||||
swap >fixnum 24 shift bitor ;
|
||||
|
||||
: make-rect ( x y w h -- rect )
|
||||
<sdl-rect>
|
||||
[ set-sdl-rect-h ] keep
|
||||
[ set-sdl-rect-w ] keep
|
||||
[ set-sdl-rect-y ] keep
|
||||
[ set-sdl-rect-x ] keep ;
|
||||
|
||||
: with-pixels ( quot -- )
|
||||
width get [
|
||||
height get [
|
||||
[ rot dup slip swap surface get swap ] 2keep
|
||||
[ rot pixelColor ] 2keep
|
||||
] repeat
|
||||
] repeat drop ; inline
|
||||
|
||||
: must-lock-surface? ( -- ? )
|
||||
#! This is a macro in SDL_video.h.
|
||||
surface get dup surface-offset 0 = [
|
||||
|
|
|
|||
|
|
@ -85,7 +85,8 @@ unit-test
|
|||
[ 0 ] [ -7/8 ceiling ] unit-test
|
||||
[ -1 ] [ -3/2 ceiling ] unit-test
|
||||
|
||||
[ 2 ] [ 1 next-power-of-2 ] unit-test
|
||||
[ 0 ] [ 0 next-power-of-2 ] unit-test
|
||||
[ 1 ] [ 1 next-power-of-2 ] unit-test
|
||||
[ 2 ] [ 2 next-power-of-2 ] unit-test
|
||||
[ 4 ] [ 3 next-power-of-2 ] unit-test
|
||||
[ 16 ] [ 13 next-power-of-2 ] unit-test
|
||||
|
|
|
|||
|
|
@ -54,7 +54,7 @@ TUPLE: editor line caret ;
|
|||
|
||||
: run-char-widths ( font str -- wlist )
|
||||
#! List of x co-ordinates of each character.
|
||||
>array [ char-size drop ] map-with
|
||||
>array [ char-width ] 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-slice >r gadget-font r> string-size drop ;
|
||||
head-slice >r gadget-font r> string-width ;
|
||||
|
||||
: caret-loc ( editor -- x y )
|
||||
dup editor-line [ caret-pos line-text get ] bind offset>x
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factor.sf.net/license.txt for BSD license.
|
||||
IN: gadgets-labels
|
||||
USING: arrays freetype gadgets gadgets-layouts generic
|
||||
hashtables io kernel math namespaces sequences styles ;
|
||||
hashtables io kernel math namespaces opengl sequences styles ;
|
||||
|
||||
! A label gadget draws a string.
|
||||
TUPLE: label text ;
|
||||
|
|
@ -15,13 +15,14 @@ C: label ( text -- label )
|
|||
[ 2dup [ set-label-text ] keep relayout ] unless 2drop ;
|
||||
|
||||
: label-size ( gadget text -- dim )
|
||||
dup gadget-font swap label-text string-size 0 3array ;
|
||||
dup gadget-font dup font-height >r
|
||||
swap label-text string-width r> 0 3array ;
|
||||
|
||||
M: label pref-dim ( label -- dim )
|
||||
label-size ;
|
||||
|
||||
: draw-label ( label -- )
|
||||
dup gadget-font swap label-text draw-string ;
|
||||
dup fg gl-color dup gadget-font swap label-text draw-string ;
|
||||
|
||||
M: label draw-gadget* ( label -- )
|
||||
dup delegate draw-gadget* draw-label ;
|
||||
|
|
|
|||
|
|
@ -81,10 +81,10 @@ TUPLE: solid ;
|
|||
|
||||
! Solid pen
|
||||
M: solid draw-interior
|
||||
drop dup rect-dim swap bg gl-fill-rect ;
|
||||
drop dup bg gl-color rect-dim gl-fill-rect ;
|
||||
|
||||
M: solid draw-boundary
|
||||
drop dup rect-dim @{ 1 1 0 }@ v- swap fg gl-rect ;
|
||||
drop dup fg gl-color rect-dim @{ 1 1 0 }@ v- gl-rect ;
|
||||
|
||||
! Rollover only
|
||||
TUPLE: rollover-only ;
|
||||
|
|
@ -115,10 +115,10 @@ M: gadget draw-gadget* ( gadget -- )
|
|||
TUPLE: polygon points ;
|
||||
|
||||
M: polygon draw-boundary ( gadget polygon -- )
|
||||
polygon-points swap fg gl-poly ;
|
||||
swap fg gl-color polygon-points gl-poly ;
|
||||
|
||||
M: polygon draw-interior ( gadget polygon -- )
|
||||
polygon-points swap bg gl-fill-poly ;
|
||||
swap bg gl-color polygon-points gl-fill-poly ;
|
||||
|
||||
: arrow-up @{ @{ 3 0 0 }@ @{ 6 6 0 }@ @{ 0 6 0 }@ }@ ;
|
||||
: arrow-right @{ @{ 0 0 0 }@ @{ 6 3 0 }@ @{ 0 6 0 }@ }@ ;
|
||||
|
|
|
|||
|
|
@ -1,8 +1,8 @@
|
|||
! Copyright (C) 2005 Slava Pestov.
|
||||
! See http://factor.sf.net/license.txt for BSD license.
|
||||
IN: gadgets
|
||||
USING: alien arrays errors gadgets-layouts generic io kernel
|
||||
lists math memory namespaces opengl prettyprint sdl
|
||||
USING: alien arrays errors freetype gadgets-layouts generic io
|
||||
kernel lists math memory namespaces opengl prettyprint sdl
|
||||
sequences sequences strings styles threads ;
|
||||
|
||||
! The world gadget is the top level gadget that all (visible)
|
||||
|
|
@ -118,5 +118,6 @@ M: quit-event handle-event ( event -- )
|
|||
drop stop-world ;
|
||||
|
||||
M: resize-event handle-event ( event -- )
|
||||
flush-fonts
|
||||
gl-resize
|
||||
width get height get 0 3array world get set-gadget-dim ;
|
||||
|
|
|
|||
Loading…
Reference in New Issue