some SDL renaming, fix a few typos
parent
2606de8e8e
commit
eb16e7a699
|
@ -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 ;
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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 ;
|
||||
|
||||
|
|
|
@ -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 ;
|
||||
|
||||
|
|
|
@ -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 ;
|
||||
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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 */
|
||||
|
|
Loading…
Reference in New Issue