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 ; swap bitor ;
: make-rect ( x y w h -- rect ) : make-rect ( x y w h -- rect )
<rect> <sdl-rect>
[ set-rect-h ] keep [ set-sdl-rect-h ] keep
[ set-rect-w ] keep [ set-sdl-rect-w ] keep
[ set-rect-y ] keep [ set-sdl-rect-y ] keep
[ set-rect-x ] keep ; [ set-sdl-rect-x ] keep ;
: with-pixels ( quot -- ) : with-pixels ( quot -- )
width get [ width get [
@ -60,3 +60,16 @@ SYMBOL: bpp
slip slip
] ifte SDL_Flip drop ] ifte SDL_Flip drop
] with-scope ; inline ] 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_SRCALPHA HEX: 00010000 ; ! Blit uses source alpha blending
: SDL_PREALLOC HEX: 01000000 ; ! Surface uses preallocated memory : SDL_PREALLOC HEX: 01000000 ; ! Surface uses preallocated memory
BEGIN-STRUCT: rect BEGIN-STRUCT: sdl-rect
FIELD: short x FIELD: short x
FIELD: short y FIELD: short y
FIELD: ushort w FIELD: ushort w
FIELD: ushort h FIELD: ushort h
END-STRUCT END-STRUCT
BEGIN-STRUCT: color BEGIN-STRUCT: sdl-color
FIELD: uchar r FIELD: uchar r
FIELD: uchar g FIELD: uchar g
FIELD: uchar b FIELD: uchar b
FIELD: uchar unused FIELD: uchar unused
END-STRUCT END-STRUCT
BEGIN-STRUCT: format BEGIN-STRUCT: sdl-format
FIELD: void* palette FIELD: void* palette
FIELD: uchar BitsPerPixel FIELD: uchar BitsPerPixel
FIELD: uchar BytesPerPixel FIELD: uchar BytesPerPixel
@ -58,14 +58,7 @@ BEGIN-STRUCT: format
FIELD: uchar alpha FIELD: uchar alpha
END-STRUCT END-STRUCT
BEGIN-STRUCT: rect BEGIN-STRUCT: sdl-surface
FIELD: short clip-x
FIELD: short clip-y
FIELD: ushort clip-w
FIELD: ushort clip-h
END-STRUCT
BEGIN-STRUCT: surface
FIELD: uint flags FIELD: uint flags
FIELD: format* format FIELD: format* format
FIELD: int w FIELD: int w
@ -85,16 +78,6 @@ BEGIN-STRUCT: surface
FIELD: int refcount FIELD: int refcount
END-STRUCT 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 -- ) : SDL_VideoInit ( driver-name flags -- )
"int" "sdl" "SDL_VideoInit" "int" "sdl" "SDL_VideoInit"
[ "char*" "int" ] alien-invoke ; [ "char*" "int" ] alien-invoke ;

View File

@ -42,13 +42,6 @@ DEFER: next-thread
try stop try stop
] callcc0 drop ; ] callcc0 drop ;
: init-threads ( -- )
global [
<queue> \ run-queue set
10 <vector> \ sleep-queue set
<namespace> \ timers set
] bind ;
TUPLE: timer object delay last ; TUPLE: timer object delay last ;
: timer-now millis swap set-timer-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 #! Takes current time, and a timer. If the timer is set to
#! fire, calls its callback. #! fire, calls its callback.
dup next-time pick <= [ dup next-time pick <= [
[ advance-timer ] keep timer-object tick* [ advance-timer ] keep timer-object tick
] [ ] [
2drop 2drop
] ifte ; ] ifte ;
: do-timers ( -- ) : do-timers ( -- )
millis timers hash-values [ do-timer ] each-with ; 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? dup gadget-visible? not over set-gadget-visible?
relayout ; relayout ;
M: caret tick* ( ms caret -- ) nip toggle-visible ; M: caret tick ( ms caret -- ) nip toggle-visible ;
: caret-blink 500 ; : caret-blink 500 ;

View File

@ -24,7 +24,7 @@ GENERIC: inside? ( loc rect -- ? )
: screen-bounds ( rect -- rect ) : screen-bounds ( rect -- rect )
dup screen-loc swap rect-dim <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 screen-bounds rect-bounds { 1 1 1 } v- { 0 0 0 } vmax
>r v- { 0 0 0 } r> vbetween? conjunction ; >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 dup pack-vector pick rot gadget-children
pick-up-fast tuck inside? [ drop f ] unless ; pick-up-fast tuck inside? [ drop f ] unless ;
! M: pack visible-children* ( rect gadget -- list ) ! M: pack visible-children* ( rect pack -- list )
! gadget-children [ rect-loc origin get v+ intersects? ] subset-with ; ! dup pack-vector -rot gadget-children >r rect-extent r>
! [ rect-loc origin get v+ v- over v. ] binsearch-slice nip ;
TUPLE: stack ; TUPLE: stack ;

View File

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

View File

@ -4,14 +4,11 @@ IN: gadgets
USING: alien hashtables kernel lists namespaces sdl sequences USING: alien hashtables kernel lists namespaces sdl sequences
strings styles io ; strings styles io ;
: surface-rect ( x y surface -- rect )
dup surface-w swap surface-h make-rect ;
: draw-surface ( x y surface -- ) : draw-surface ( x y surface -- )
surface get SDL_UnlockSurface surface get SDL_UnlockSurface
[ [
[ surface-rect ] keep swap surface get 0 0 [ sdl-surface-rect ] keep swap surface get 0 0
] keep surface-rect swap rot SDL_UpperBlit drop ] keep sdl-surface-rect swap rot SDL_UpperBlit drop
surface get dup must-lock-surface? [ surface get dup must-lock-surface? [
SDL_LockSurface SDL_LockSurface
] when drop ; ] when drop ;

View File

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