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 [
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 ;
: 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
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
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 ;
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 ;
#! 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 ;
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 ;
: 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 ;
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 ;
: 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 ;
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 ;
#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 */