"/library/ui/gadgets.factor"\r
"/library/ui/boxes.factor"\r
"/library/ui/gestures.factor"\r
+ "/library/ui/hand.factor"\r
"/library/ui/world.factor"\r
] [\r
dup print\r
: with-screen ( width height bpp flags quot -- )
#! Set up SDL graphics and call the quotation.
+ SDL_INIT_EVERYTHING SDL_Init drop TTF_Init
[ >r init-screen r> call SDL_Quit ] with-scope ; inline
: rgb ( r g b -- n )
: -rot ( x y z -- z x y ) swap >r swap r> ; inline
: dupd ( x y -- x x y ) >r dup r> ; inline
: swapd ( x y z -- y x z ) >r swap r> ; inline
-: 2swap ( x y z t -- z t x y ) >r rot r> rot ; inline
+: 2swap ( x y z t -- z t x y ) rot >r rot r> ; inline
: nip ( x y -- y ) swap drop ; inline
: 2nip ( x y z -- z ) >r drop drop r> ; inline
: tuck ( x y -- y x y ) dup >r swap r> ; inline
M: box draw ( box -- )
dup [
dup [
- dup box-contents draw
+ dup
box-delegate draw
+ box-contents draw
] with-gadget
] with-translation ;
] with-translation ;
: box- ( gadget box -- )
- 2dup box-contents remove swap set-box-contents
+ 2dup box-contents remove swap tuck set-box-contents redraw
f swap set-gadget-parent ;
+: (box+) ( gadget box -- )
+ [ box-contents cons ] keep set-box-contents ;
+
+: unparent ( gadget -- )
+ dup gadget-parent dup [ box- ] [ 2drop ] ifte ;
+
: box+ ( gadget box -- )
#! Add a gadget to a box.
- over gadget-parent [ pick swap box- ] when*
- [ box-contents cons ] keep set-box-contents ;
+ over unparent
+ dup pick set-gadget-parent
+ tuck (box+)
+ redraw ;
USING: generic hashtables kernel lists namespaces ;
! Gadget protocol.
-
GENERIC: pick-up* ( point gadget -- gadget/t )
GENERIC: handle-gesture* ( gesture gadget -- ? )
M: gadget handle-gesture* 2drop t ;
+GENERIC: redraw ( gadget -- )
+
: move-gadget ( x y gadget -- )
- [ move-shape ] keep set-gadget-delegate ;
+ [ move-shape ] keep
+ [ set-gadget-delegate ] keep
+ redraw ;
+
+: resize-gadget ( w h gadget -- )
+ [ resize-shape ] keep
+ [ set-gadget-delegate ] keep
+ redraw ;
! An invisible gadget.
WRAPPER: ghost
] [
2drop
] ifte ;
+
+TUPLE: redraw-gesture ;
+C: redraw-gesture ;
+
+M: object redraw ( gadget -- )
+ <redraw-gesture> swap handle-gesture ;
--- /dev/null
+! Copyright (C) 2005 Slava Pestov.
+! See http://factor.sf.net/license.txt for BSD license.
+IN: gadgets
+USING: alien generic kernel lists math namespaces sdl sdl-event
+sdl-video ;
+
+! The hand is a special gadget that holds mouse position and
+! mouse button click state. The hand's parent is the world, but
+! it is special in that the world does not list it as part of
+! its contents.
+TUPLE: hand click-pos clicked buttons delegate ;
+
+C: hand ( -- hand )
+ 0 <gadget> <ghost> <box>
+ over set-hand-delegate ;
+
+GENERIC: hand-gesture ( hand gesture -- )
+
+M: object hand-gesture ( hand gesture -- ) 2drop ;
+
+: button/ ( n hand -- )
+ [ hand-buttons unique ] keep set-hand-buttons ;
+
+: button\ ( n hand -- )
+ [ hand-buttons remove ] keep set-hand-buttons ;
+
+M: button-down-event hand-gesture ( hand gesture -- )
+ 2dup
+ dup button-event-x swap button-event-y rect>
+ swap set-hand-click-pos
+ button-event-button swap button/ ;
+
+M: button-up-event hand-gesture ( hand gesture -- )
+ button-event-button swap button\ ;
+
+M: motion-event hand-gesture ( hand gesture -- )
+ dup motion-event-x swap motion-event-y rot move-gadget ;
+
+M: hand redraw ( hand -- )
+ drop world get redraw ;
GENERIC: draw ( obj -- )
-M: rect draw ( rect -- )
+M: ghost draw ( ghost -- )
+ drop ;
+
+M: number draw ( point -- )
+ >r surface get r> >rect rgb-color pixelColor ;
+
+M: rectangle draw ( rect -- )
>r surface get r> shape>screen rgb-color
filled get [ boxColor ] [ rectangleColor ] ifte ;
M: number move-shape ( x y point -- point ) drop rect> ;
! A rectangle maps trivially to the shape protocol.
-TUPLE: rect x y w h ;
-M: rect shape-x rect-x ;
-M: rect shape-y rect-y ;
-M: rect shape-w rect-w ;
-M: rect shape-h rect-h ;
+TUPLE: rectangle x y w h ;
+M: rectangle shape-x rectangle-x ;
+M: rectangle shape-y rectangle-y ;
+M: rectangle shape-w rectangle-w ;
+M: rectangle shape-h rectangle-h ;
: fix-neg ( a b c -- a+c b -c )
dup 0 < [ neg tuck >r >r + r> r> ] when ;
-C: rect ( x y w h -- rect )
+C: rectangle ( x y w h -- rect )
#! We handle negative w/h for convinience.
>r fix-neg >r fix-neg r> r>
- [ set-rect-h ] keep
- [ set-rect-w ] keep
- [ set-rect-y ] keep
- [ set-rect-x ] keep ;
+ [ set-rectangle-h ] keep
+ [ set-rectangle-w ] keep
+ [ set-rectangle-y ] keep
+ [ set-rectangle-x ] keep ;
M: number resize-shape ( w h point -- rect )
- >rect 2swap <rect> ;
+ >rect 2swap <rectangle> ;
-M: rect move-shape ( x y rect -- rect )
- [ rect-w ] keep rect-h <rect> ;
+M: rectangle move-shape ( x y rect -- rect )
+ [ rectangle-w ] keep rectangle-h <rectangle> ;
-M: rect resize-shape ( w h rect -- rect )
- [ rect-x ] keep rect-y 2swap <rect> ;
+M: rectangle resize-shape ( w h rect -- rect )
+ [ rectangle-x ] keep rectangle-y 2swap <rectangle> ;
-: rect-x-extents ( rect -- x1 x2 )
- dup rect-x x get + swap rect-w dupd + ;
+: rectangle-x-extents ( rect -- x1 x2 )
+ dup rectangle-x x get + swap rectangle-w dupd + ;
-: rect-y-extents ( rect -- x1 x2 )
- dup rect-y y get + swap rect-h dupd + ;
+: rectangle-y-extents ( rect -- x1 x2 )
+ dup rectangle-y y get + swap rectangle-h dupd + ;
-M: rect inside? ( point rect -- ? )
- over shape-x over rect-x-extents between? >r
- swap shape-y swap rect-y-extents between? r> and ;
+M: rectangle inside? ( point rect -- ? )
+ over shape-x over rectangle-x-extents between? >r
+ swap shape-y swap rectangle-y-extents between? r> and ;
+
+! Delegates to a bounded shape, but absorbs all points.
+WRAPPER: everywhere
+M: everywhere inside? ( point world -- ? ) 2drop t ;
+
+M: everywhere move-shape ( x y everywhere -- )
+ everywhere-delegate move-shape <everywhere> ;
+
+M: everywhere resize-shape ( w h everywhere -- )
+ everywhere-delegate resize-shape <everywhere> ;
! Copyright (C) 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: gadgets
-USING: alien generic kernel lists math namespaces sdl sdl-event ;
-
-! The hand is a special gadget that holds mouse position and
-! mouse button click state.
-TUPLE: hand clicked buttons delegate ;
-
-C: hand ( -- hand ) 0 <gadget> over set-hand-delegate ;
-
-GENERIC: hand-gesture ( hand gesture -- )
-
-M: alien hand-gesture ( hand gesture -- ) 2drop ;
-
-: button/ ( n hand -- )
- [ hand-buttons unique ] keep set-hand-buttons ;
-
-: button\ ( n hand -- )
- [ hand-buttons remove ] keep set-hand-buttons ;
-
-M: button-down-event hand-gesture ( hand gesture -- )
- 2dup
- dup button-event-x swap button-event-y rect>
- swap set-hand-clicked
- button-event-button swap button/ ;
-
-M: button-up-event hand-gesture ( hand gesture -- )
- button-event-button swap button\ ;
-
-M: motion-event hand-gesture ( hand gesture -- )
- dup motion-event-x swap motion-event-y rot move-gadget ;
+USING: alien generic kernel lists math namespaces sdl sdl-event
+sdl-video ;
! The world gadget is the top level gadget that all (visible)
! gadgets are contained in. The current world is stored in the
! world variable.
TUPLE: world running? hand delegate redraw? ;
-TUPLE: redraw-gesture ;
-C: redraw-gesture ;
-
-: redraw ( gadget -- )
- <redraw-gesture> swap handle-gesture ;
-
M: hand handle-gesture* ( gesture hand -- ? )
2dup swap hand-gesture
world get pick-up handle-gesture* ;
: <world-box> ( -- box )
- 0 0 1000 1000 <rect> <gadget> <box> ;
+ 0 0 0 0 <rectangle> <everywhere> <gadget>
+ dup blue 3list color set-paint-property
+ dup t filled set-paint-property
+ <box> ;
C: world ( -- world )
<world-box> over set-world-delegate
M: quit-event world-gesture ( world gesture -- )
drop f swap set-world-running? ;
+M: resize-event world-gesture ( world gesture -- ? )
+ dup resize-event-w swap resize-event-h
+ [ rot resize-gadget ] 2keep
+ 0 SDL_HWSURFACE SDL_RESIZABLE bitor init-screen
+ world get redraw ;
+
M: redraw-gesture world-gesture ( world gesture -- )
+
drop t swap set-world-redraw? ;
M: world handle-gesture* ( gesture world -- ? )
world get dup world-redraw? [
[
f over set-world-redraw?
- draw
+ dup draw
+ world-hand draw
] with-surface
] [
drop
] ifte
] when ;
+: init-world ( w h -- )
+ t world get set-world-running?
+ t world get set-world-redraw?
+ world get resize-gadget ;
+
+: world-flags SDL_HWSURFACE SDL_RESIZABLE bitor ;
+
+: start-world ( w h -- )
+ #! Start the Factor graphics subsystem with the given screen
+ #! dimensions.
+ 2dup init-world 0 world-flags
+ default-paint [ [ run-world ] with-screen ] bind ;
+
global [ <world> world set ] bind