2005-01-31 22:32:06 -05:00
|
|
|
! Copyright (C) 2005 Slava Pestov.
|
|
|
|
! See http://factor.sf.net/license.txt for BSD license.
|
|
|
|
IN: gadgets
|
2005-05-03 20:09:04 -04:00
|
|
|
USING: alien errors generic kernel lists math
|
2005-06-19 17:50:35 -04:00
|
|
|
memory namespaces prettyprint sdl sequences io strings
|
2005-05-14 17:18:45 -04:00
|
|
|
threads sequences ;
|
2005-02-01 19:00:16 -05:00
|
|
|
|
2005-01-31 22:32:06 -05:00
|
|
|
! The world gadget is the top level gadget that all (visible)
|
|
|
|
! gadgets are contained in. The current world is stored in the
|
2005-03-01 22:11:08 -05:00
|
|
|
! world variable. The menu slot ensures that only one menu is
|
|
|
|
! open at any one time.
|
2005-03-08 22:54:59 -05:00
|
|
|
TUPLE: world running? hand menu ;
|
2005-02-01 19:00:16 -05:00
|
|
|
|
2005-01-31 22:32:06 -05:00
|
|
|
C: world ( -- world )
|
2005-06-25 20:39:53 -04:00
|
|
|
f <stack> over set-delegate
|
2005-01-31 22:32:06 -05:00
|
|
|
t over set-world-running?
|
2005-03-06 19:46:29 -05:00
|
|
|
dup <hand> over set-world-hand ;
|
2005-01-31 22:32:06 -05:00
|
|
|
|
2005-02-03 22:21:51 -05:00
|
|
|
M: world inside? ( point world -- ? ) 2drop t ;
|
|
|
|
|
2005-03-03 20:43:55 -05:00
|
|
|
: hand world get world-hand ;
|
2005-01-31 22:32:06 -05:00
|
|
|
|
2005-02-19 17:54:04 -05:00
|
|
|
: draw-world ( world -- )
|
|
|
|
dup gadget-redraw? [
|
2005-04-30 17:17:10 -04:00
|
|
|
[ draw-gadget ] with-surface
|
2005-02-01 19:00:16 -05:00
|
|
|
] [
|
|
|
|
drop
|
|
|
|
] ifte ;
|
|
|
|
|
2005-02-01 21:47:10 -05:00
|
|
|
DEFER: handle-event
|
2005-03-03 20:43:55 -05:00
|
|
|
|
2005-03-01 00:45:50 -05:00
|
|
|
: layout-world ( world -- )
|
|
|
|
dup
|
2005-03-06 19:46:29 -05:00
|
|
|
0 0 width get height get <rectangle> clip set-paint-prop
|
2005-04-30 17:17:10 -04:00
|
|
|
layout ;
|
2005-02-02 19:50:13 -05:00
|
|
|
|
2005-02-19 17:54:04 -05:00
|
|
|
: world-step ( world -- ? )
|
2005-05-03 23:50:04 -04:00
|
|
|
world get dup world-running? [
|
2005-02-19 17:54:04 -05:00
|
|
|
dup layout-world draw-world t
|
|
|
|
] [
|
|
|
|
drop f
|
|
|
|
] ifte ;
|
|
|
|
|
2005-05-03 23:50:04 -04:00
|
|
|
: next-event ( -- event ? )
|
|
|
|
<event> dup SDL_PollEvent ;
|
2005-05-03 20:09:04 -04:00
|
|
|
|
2005-03-01 18:55:25 -05:00
|
|
|
: run-world ( -- )
|
2005-02-03 22:21:51 -05:00
|
|
|
#! Keep polling for events until there are no more events in
|
|
|
|
#! the queue; then block for the next event.
|
2005-05-03 20:09:04 -04:00
|
|
|
next-event [
|
2005-05-03 23:50:04 -04:00
|
|
|
handle-event run-world
|
2005-02-03 22:21:51 -05:00
|
|
|
] [
|
2005-05-03 23:50:04 -04:00
|
|
|
drop world-step [ yield run-world ] when
|
2005-02-19 21:49:37 -05:00
|
|
|
] ifte ;
|
2005-01-31 22:32:06 -05:00
|
|
|
|
2005-03-02 21:26:11 -05:00
|
|
|
: ensure-ui ( -- )
|
|
|
|
#! Raise an error if the UI is not running.
|
|
|
|
world get dup [ world-running? ] when [
|
2005-03-06 19:46:29 -05:00
|
|
|
"UI not running." throw
|
2005-03-02 21:26:11 -05:00
|
|
|
] unless ;
|
2005-05-03 23:50:04 -04:00
|
|
|
|
|
|
|
: start-world ( -- )
|
|
|
|
world get t over set-world-running? relayout ;
|