some SDL renaming, fix a few typos

cvs
Slava Pestov 2005-08-24 04:30:07 +00:00
parent 2606de8e8e
commit eb16e7a699
9 changed files with 41 additions and 48 deletions

View File

@ -36,11 +36,11 @@ SYMBOL: bpp
swap bitor ;
: make-rect ( x y w h -- rect )
<rect>
[ set-rect-h ] keep
[ set-rect-w ] keep
[ set-rect-y ] keep
[ set-rect-x ] keep ;
<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 [
@ -60,3 +60,16 @@ SYMBOL: bpp
slip
] ifte SDL_Flip drop
] with-scope ; inline
: must-lock-surface? ( surface -- ? )
#! This is a macro in SDL_video.h.
dup sdl-surface-offset 0 = [
sdl-surface-flags
SDL_HWSURFACE SDL_ASYNCBLIT bitor SDL_RLEACCEL bitor
bitand 0 = not
] [
drop t
] ifte ;
: sdl-surface-rect ( x y surface -- rect )
dup sdl-surface-w swap sdl-surface-h make-rect ;

View File

@ -24,21 +24,21 @@ IN: sdl USING: alien kernel math ;
: SDL_SRCALPHA HEX: 00010000 ; ! Blit uses source alpha blending
: SDL_PREALLOC HEX: 01000000 ; ! Surface uses preallocated memory
BEGIN-STRUCT: rect
BEGIN-STRUCT: sdl-rect
FIELD: short x
FIELD: short y
FIELD: ushort w
FIELD: ushort h
END-STRUCT
BEGIN-STRUCT: color
BEGIN-STRUCT: sdl-color
FIELD: uchar r
FIELD: uchar g
FIELD: uchar b
FIELD: uchar unused
END-STRUCT
BEGIN-STRUCT: format
BEGIN-STRUCT: sdl-format
FIELD: void* palette
FIELD: uchar BitsPerPixel
FIELD: uchar BytesPerPixel
@ -58,14 +58,7 @@ BEGIN-STRUCT: format
FIELD: uchar alpha
END-STRUCT
BEGIN-STRUCT: rect
FIELD: short clip-x
FIELD: short clip-y
FIELD: ushort clip-w
FIELD: ushort clip-h
END-STRUCT
BEGIN-STRUCT: surface
BEGIN-STRUCT: sdl-surface
FIELD: uint flags
FIELD: format* format
FIELD: int w
@ -85,16 +78,6 @@ BEGIN-STRUCT: surface
FIELD: int refcount
END-STRUCT
: must-lock-surface? ( surface -- ? )
#! This is a macro in SDL_video.h.
dup surface-offset 0 = [
surface-flags
SDL_HWSURFACE SDL_ASYNCBLIT bitor SDL_RLEACCEL bitor
bitand 0 = not
] [
drop t
] ifte ;
: SDL_VideoInit ( driver-name flags -- )
"int" "sdl" "SDL_VideoInit"
[ "char*" "int" ] alien-invoke ;

View File

@ -42,13 +42,6 @@ DEFER: next-thread
try stop
] callcc0 drop ;
: init-threads ( -- )
global [
<queue> \ run-queue set
10 <vector> \ sleep-queue set
<namespace> \ timers set
] bind ;
TUPLE: timer object delay last ;
: timer-now millis swap set-timer-last ;
@ -80,10 +73,17 @@ GENERIC: tick ( ms object -- )
#! Takes current time, and a timer. If the timer is set to
#! fire, calls its callback.
dup next-time pick <= [
[ advance-timer ] keep timer-object tick*
[ advance-timer ] keep timer-object tick
] [
2drop
] ifte ;
: do-timers ( -- )
millis timers hash-values [ do-timer ] each-with ;
: init-threads ( -- )
global [
<queue> \ run-queue set
10 <vector> \ sleep-queue set
<namespace> \ timers set
] bind ;

View File

@ -15,7 +15,7 @@ C: caret ( -- caret )
dup gadget-visible? not over set-gadget-visible?
relayout ;
M: caret tick* ( ms caret -- ) nip toggle-visible ;
M: caret tick ( ms caret -- ) nip toggle-visible ;
: caret-blink 500 ;

View File

@ -24,7 +24,7 @@ GENERIC: inside? ( loc rect -- ? )
: screen-bounds ( rect -- rect )
dup screen-loc swap rect-dim <rect> ;
M: rectangle inside? ( loc rect -- ? )
M: rect inside? ( loc rect -- ? )
screen-bounds rect-bounds { 1 1 1 } v- { 0 0 0 } vmax
>r v- { 0 0 0 } r> vbetween? conjunction ;

View File

@ -90,8 +90,9 @@ M: pack pick-up* ( point pack -- gadget )
dup pack-vector pick rot gadget-children
pick-up-fast tuck inside? [ drop f ] unless ;
! M: pack visible-children* ( rect gadget -- list )
! gadget-children [ rect-loc origin get v+ intersects? ] subset-with ;
! M: pack visible-children* ( rect pack -- list )
! dup pack-vector -rot gadget-children >r rect-extent r>
! [ rect-loc origin get v+ v- over v. ] binsearch-slice nip ;
TUPLE: stack ;

View File

@ -31,9 +31,8 @@ GENERIC: draw-gadget* ( gadget -- )
: draw-gadget ( gadget -- )
dup gadget-visible? [
dup [
translate&clip
dup draw-gadget*
[
dup translate&clip dup draw-gadget*
visible-children [ draw-gadget ] each
] with-scope
] [ drop ] ifte ;

View File

@ -4,14 +4,11 @@ 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
[ sdl-surface-rect ] keep swap surface get 0 0
] keep sdl-surface-rect swap rot SDL_UpperBlit drop
surface get dup must-lock-surface? [
SDL_LockSurface
] when drop ;

View File

@ -1,14 +1,14 @@
#define USER_ENV 16
#define CARD_OFF_ENV 1 /* for compiling set-slot */
#define UNUSED_ENV 2
/* 2 is unused */
#define NAMESTACK_ENV 3 /* used by library only */
#define GLOBAL_ENV 4
#define BREAK_ENV 5
#define CATCHSTACK_ENV 6 /* used by library only */
#define CPU_ENV 7
#define BOOT_ENV 8
#define UNUSED_ENV 9
/* 9 is unused */
#define ARGS_ENV 10
#define OS_ENV 11
#define ERROR_ENV 12 /* a marker consed onto kernel errors */