drop f
] ifte ; inline
+: lookup-method ( class selector -- method )
+ "methods" word-property hash* ; inline
+
: tuple-dispatch ( object selector -- )
- over class over "methods" word-property hash* [
+ over class over lookup-method [
cdr call ( method is defined )
] [
- over tuple-delegate [
- rot drop swap execute ( check delegate )
+ object over lookup-method [
+ cdr call
] [
- undefined-method ( no delegate )
- ] ifte*
+ over tuple-delegate [
+ rot drop swap execute ( check delegate )
+ ] [
+ undefined-method ( no delegate )
+ ] ifte*
+ ] ?ifte
] ?ifte ;
: add-tuple-dispatch ( word vtable -- )
: -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
: 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
[ t ] [ 10 20 30 40 <rect> dup clone 0 swap [ move ] keep = ] unit-test
+GENERIC: delegation-test
+M: object delegation-test drop 3 ;
+TUPLE: quux-tuple ;
+C: quux-tuple ;
+M: quux-tuple delegation-test drop 4 ;
+WRAPPER: quuux-tuple
+[ 3 ] [ <quux-tuple> <quuux-tuple> delegation-test ] unit-test
] with-gadget
] with-translation ;
-M: general-list pick-up ( point list -- gadget )
+M: general-list pick-up* ( point list -- gadget )
dup [
2dup car pick-up dup [
2nip
2drop f
] ifte ;
-M: box pick-up ( point box -- gadget )
+M: box pick-up* ( point box -- gadget )
#! The logic is thus. If the point is definately outside the
#! box, return f. Otherwise, see if the point is contained
#! in any subgadget. If not, see if it is contained in the
#! box delegate.
dup [
- 2dup gadget-delegate inside? [
+ 2dup inside? [
2dup box-contents pick-up dup [
2nip
] [
- drop box-delegate pick-up
+ drop box-delegate pick-up*
] ifte
] [
2drop f
: box+ ( gadget box -- )
#! Add a gadget to a box.
- swap dup gadget-parent dup [ box- ] [ 2drop ] ifte
+ over gadget-parent [ pick swap box- ] when*
[ box-contents cons ] keep set-box-contents ;
USING: generic hashtables kernel lists namespaces ;
! Gadget protocol.
-GENERIC: pick-up ( point gadget -- gadget )
+
+GENERIC: pick-up* ( point gadget -- gadget/t )
GENERIC: handle-gesture* ( gesture gadget -- ? )
+: pick-up ( point gadget -- gadget )
+ #! pick-up* returns t to mean 'this gadget', avoiding the
+ #! exposed facade issue.
+ tuck pick-up* dup t = [ drop ] [ nip ] ifte ;
+
! A gadget is a shape together with paint, and a reference to
! the gadget's parent. A gadget delegates to its shape.
TUPLE: gadget paint parent delegate ;
M: gadget draw ( gadget -- )
dup [ gadget-delegate draw ] with-gadget ;
-M: gadget pick-up tuck inside? [ drop f ] unless ;
+M: gadget pick-up* inside? ;
M: gadget handle-gesture* 2drop t ;
+: move-gadget ( x y gadget -- )
+ [ move-shape ] keep set-gadget-delegate ;
+
! An invisible gadget.
WRAPPER: ghost
M: ghost draw drop ;
-M: ghost pick-up 2drop f ;
+M: ghost pick-up* 2drop f ;
#! If a gadget's handle-gesture* generic returns t, the
#! event was not consumed and is passed on to the gadget's
#! parent.
- 2dup handle-gesture* [
- gadget-parent dup [
- handle-gesture
+ dup [
+ 2dup handle-gesture* [
+ gadget-parent handle-gesture
] [
2drop
] ifte
IN: gadgets
USING: generic kernel math namespaces ;
-! Shape protocol.
+! Shape protocol. Shapes are immutable; moving or resizing a
+! shape makes a new shape.
! These dynamically-bound variables affect the generic word
! inside?.
-SYMBOL: x ! x translation
-SYMBOL: y ! y translation
+SYMBOL: x
+SYMBOL: y
+
+GENERIC: inside? ( point shape -- ? )
! A shape is an object with a defined bounding
! box, and a notion of interior.
GENERIC: shape-w
GENERIC: shape-h
-GENERIC: inside? ( point shape -- ? )
+GENERIC: move-shape ( x y shape -- shape )
+GENERIC: resize-shape ( w h shape -- shape )
: with-translation ( shape quot -- )
#! All drawing done inside the quotation is translated
! A point, represented as a complex number, is the simplest type
! of shape.
+M: number inside? = ;
+
M: number shape-x real ;
M: number shape-y imaginary ;
M: number shape-w drop 0 ;
M: number shape-h drop 0 ;
-M: number inside? = ;
+
+M: number move-shape ( x y point -- point ) drop rect> ;
! A rectangle maps trivially to the shape protocol.
TUPLE: rect x y w h ;
[ set-rect-y ] keep
[ set-rect-x ] keep ;
+M: number resize-shape ( w h point -- rect )
+ >rect 2swap <rect> ;
+
+M: rect move-shape ( x y rect -- rect )
+ [ rect-w ] keep rect-h <rect> ;
+
+M: rect resize-shape ( w h rect -- rect )
+ [ rect-x ] keep rect-y 2swap <rect> ;
+
: rect-x-extents ( rect -- x1 x2 )
dup rect-x x get + swap rect-w dupd + ;
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 ;
+
! 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 ;
+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
C: world ( -- world )
<world-box> over set-world-delegate
t over set-world-running?
+ t over set-world-redraw?
<hand> over set-world-hand ;
GENERIC: world-gesture ( world gesture -- )
M: quit-event world-gesture ( world gesture -- )
drop f swap set-world-running? ;
+M: redraw-gesture world-gesture ( world gesture -- )
+ drop t swap set-world-redraw? ;
+
M: world handle-gesture* ( gesture world -- ? )
swap world-gesture f ;
: my-hand ( -- hand ) world get world-hand ;
+: draw-world ( -- )
+ world get dup world-redraw? [
+ [
+ f over set-world-redraw?
+ draw
+ ] with-surface
+ ] [
+ drop
+ ] ifte ;
+
: run-world ( -- )
world get world-running? [
<event> dup SDL_WaitEvent 1 = [
- my-hand handle-gesture run-world
+ my-hand handle-gesture draw-world run-world
] [
drop
] ifte