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