factor/library/ui/world.factor

119 lines
3.3 KiB
Factor
Raw Normal View History

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
USING: alien arrays errors gadgets-layouts generic io kernel
lists math memory namespaces prettyprint sdl sequences sequences
strings styles threads ;
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-07-08 01:32:29 -04:00
! world variable. The invalid slot is a list of gadgets that
! need to be layout.
2005-10-08 01:15:14 -04:00
TUPLE: world running? glass status content invalid ;
2005-08-26 00:55:56 -04:00
: add-layer ( gadget -- )
world get add-gadget ;
2005-01-31 22:32:06 -05:00
C: world ( -- world )
<stack> over set-delegate
2005-10-08 01:15:14 -04:00
<frame> over 2dup set-world-content add-gadget
2005-10-07 20:26:21 -04:00
t over set-gadget-root? ;
2005-01-31 22:32:06 -05:00
2005-10-08 01:15:14 -04:00
: set-application ( gadget -- )
world get world-content @center frame-add ;
: set-status ( gadget -- )
world get 2dup set-world-status
world-content @bottom frame-add ;
: add-invalid ( gadget -- )
world get [ world-invalid cons ] keep set-world-invalid ;
2005-07-08 01:32:29 -04:00
: pop-invalid ( -- list )
world get [ world-invalid f ] keep set-world-invalid ;
2005-07-08 01:32:29 -04:00
: layout-world ( -- )
world get world-invalid
[ pop-invalid [ layout ] each layout-world ] when ;
2005-07-08 01:32:29 -04:00
: hide-glass ( -- )
2005-10-01 01:44:49 -04:00
f world get dup world-glass unparent set-world-glass ;
: show-glass ( gadget -- )
hide-glass
2005-08-26 22:22:00 -04:00
<gadget> dup add-layer dup world get set-world-glass
dupd add-gadget prefer ;
: world-clip ( -- rect )
@{ 0 0 0 }@ width get height get 0 3array <rect> ;
2005-10-08 01:15:14 -04:00
: draw-world ( -- )
world get [ world-clip clip set draw-gadget ] with-surface ;
! Status bar protocol
GENERIC: set-message ( string/f status -- )
M: f set-message 2drop ;
: show-message ( string/f -- )
#! Show a message in the status bar.
world get world-status set-message ;
: update-help ( -- )
#! Update mouse-over help message.
hand get hand-gadget
parents-up [ gadget-help ] map [ ] find nip
show-message ;
2005-02-01 19:00:16 -05:00
2005-10-08 01:15:14 -04:00
: move-hand ( loc -- )
hand get dup hand-gadget parents-down >r
2005-10-07 20:26:21 -04:00
2dup set-rect-loc
[ >r world get pick-up r> set-hand-gadget ] keep
2005-10-08 01:15:14 -04:00
dup hand-gadget parents-down r> hand-gestures
update-help ;
2005-10-07 20:26:21 -04:00
M: motion-event handle-event ( event -- )
2005-10-08 01:15:14 -04:00
motion-event-loc move-hand ;
2005-10-07 20:26:21 -04:00
2005-10-08 01:15:14 -04:00
: update-hand ( -- )
2005-10-07 20:26:21 -04:00
#! Called when a gadget is removed or added.
2005-10-08 01:15:14 -04:00
hand get rect-loc move-hand ;
2005-10-07 20:26:21 -04:00
: stop-world ( -- )
f world get set-world-running? ;
: ui-title
[ "Factor " % version % " - " % image % ] "" make ;
: start-world ( -- )
ui-title dup SDL_WM_SetCaption
world get dup relayout t swap set-world-running? ;
2005-03-03 20:43:55 -05:00
2005-10-07 20:26:21 -04:00
: world-step ( -- )
2005-10-08 01:15:14 -04:00
world get world-invalid >r layout-world r>
[ update-hand draw-world ] when ;
2005-02-19 17:54:04 -05:00
2005-08-26 22:22:00 -04:00
: next-event ( -- event ? ) <event> dup SDL_PollEvent ;
2005-05-03 20:09:04 -04:00
2005-10-07 20:26:21 -04:00
: world-loop ( -- )
#! 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-10-07 20:26:21 -04:00
handle-event world-loop
] [
2005-08-23 18:16:42 -04:00
drop world-step do-timers
2005-10-07 20:26:21 -04:00
world get world-running? [ 10 sleep world-loop ] when
2005-09-24 15:21:17 -04:00
] if ;
2005-01-31 22:32:06 -05:00
2005-10-07 20:26:21 -04:00
: run-world ( -- )
[ start-world world-loop ] [ stop-world ] cleanup ;
M: quit-event handle-event ( event -- )
drop stop-world ;
M: resize-event handle-event ( event -- )
dup resize-event-w swap resize-event-h
[ 0 3array world get set-gadget-dim ] 2keep
0 SDL_HWSURFACE SDL_RESIZABLE bitor init-surface
world get relayout ;