40 lines
1.0 KiB
Factor
40 lines
1.0 KiB
Factor
! Copyright (C) 2005 Slava Pestov.
|
|
! See http://factor.sf.net/license.txt for BSD license.
|
|
IN: gadgets
|
|
USING: alien hashtables kernel lists namespaces sdl sequences
|
|
strings styles io ;
|
|
|
|
: surface-rect ( x y surface -- rect )
|
|
dup surface-w swap surface-h make-rect ;
|
|
|
|
: draw-surface ( x y surface -- )
|
|
surface get SDL_UnlockSurface
|
|
[
|
|
[ surface-rect ] keep swap surface get 0 0
|
|
] keep surface-rect swap rot SDL_UpperBlit drop
|
|
surface get dup must-lock-surface? [
|
|
SDL_LockSurface
|
|
] when drop ;
|
|
|
|
: 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
|
|
swap *int swap *int
|
|
] ifte ;
|
|
|
|
: draw-string ( font text -- )
|
|
filter-nulls dup empty? [
|
|
2drop
|
|
] [
|
|
fg 3unlist make-color
|
|
bg 3unlist make-color
|
|
TTF_RenderUNICODE_Shaded
|
|
[ >r x get y get r> draw-surface ] keep
|
|
SDL_FreeSurface
|
|
] ifte ;
|