"/library/ui/line-editor.factor"\r
"/library/ui/console.factor"\r
"/library/ui/shapes.factor"\r
- "/library/ui/paint.factor"\r
"/library/ui/gadgets.factor"\r
- "/library/ui/boxes.factor"\r
+ "/library/ui/paint.factor"\r
"/library/ui/gestures.factor"\r
"/library/ui/hand.factor"\r
"/library/ui/world.factor"\r
+++ /dev/null
-! Copyright (C) 2005 Slava Pestov.
-! See http://factor.sf.net/license.txt for BSD license.
-IN: gadgets
-USING: generic hashtables kernel lists namespaces ;
-
-! A box is a gadget holding other gadgets.
-TUPLE: box children delegate ;
-
-C: box ( gadget -- box )
- [ set-box-delegate ] keep ;
-
-M: box gadget-children box-children ;
-
-M: box draw-shape ( box -- )
- dup box-delegate draw-gadget
- dup [ box-children [ draw-gadget ] each ] with-translation ;
-
-M: general-list pick-up* ( point list -- gadget )
- dup [
- 2dup car pick-up dup [
- 2nip
- ] [
- drop cdr pick-up
- ] ifte
- ] [
- 2drop f
- ] ifte ;
-
-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.
- 2dup inside? [
- 2dup [ translate ] keep box-children pick-up dup [
- 2nip
- ] [
- drop box-delegate pick-up*
- ] ifte
- ] [
- 2drop f
- ] ifte ;
-
-: box- ( gadget box -- )
- [ 2dup box-children remq swap set-box-children ] keep
- relayout
- f swap set-gadget-parent ;
-
-: (box+) ( gadget box -- )
- [ box-children cons ] keep set-box-children ;
-
-: unparent ( gadget -- )
- dup gadget-parent dup [ box- ] [ 2drop ] ifte ;
-
-: box+ ( gadget box -- )
- #! Add a gadget to a box.
- over unparent
- dup pick set-gadget-parent
- tuck (box+)
- relayout ;
! A gadget is a shape, a paint, a mapping of gestures to
! actions, and a reference to the gadget's parent. A gadget
! delegates to its shape.
-TUPLE: gadget paint gestures parent relayout? redraw? delegate ;
-
-! Gadget protocol.
-GENERIC: pick-up* ( point gadget -- gadget/t )
-
-: 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 ;
-
-GENERIC: gadget-children ( gadget -- list )
-M: gadget gadget-children drop f ;
-
-GENERIC: layout* ( gadget -- )
-M: gadget layout* drop ;
-
-: layout ( gadget -- )
- #! Set the gadget's width and height to its preferred width
- #! and height. The gadget's children are laid out first.
- #! Note that nothing is done if the gadget does not need to
- #! be laid out.
- dup gadget-relayout? [
- f over set-gadget-relayout?
- dup gadget-children [ layout ] each
- layout*
- ] [
- drop
- ] ifte ;
+TUPLE: gadget
+ paint gestures
+ relayout? redraw?
+ parent children delegate ;
C: gadget ( shape -- gadget )
[ set-gadget-delegate ] keep
: set-action ( gadget quot gesture -- )
rot gadget-gestures set-hash ;
-: draw-gadget ( gadget -- )
- #! All drawing done inside draw-shape is done with the
- #! gadget's paint. If the gadget does not have any custom
- #! paint, just call the quotation.
- dup gadget-paint [ draw-shape ] bind ;
-
-M: gadget pick-up* inside? ;
-
-: redraw ( gadget -- )
- #! Redraw a gadget before the next iteration of the event
- #! loop.
- t over set-gadget-redraw?
- gadget-parent [ redraw ] when* ;
-
-: relayout ( gadget -- )
- #! Relayout a gadget before the next iteration of the event
- #! loop. Since relayout also implies the visual
- #! representation changed, we redraw the gadget too.
- t over set-gadget-redraw?
- t over set-gadget-relayout?
- gadget-parent [ relayout ] when* ;
-
: move-gadget ( x y gadget -- )
[ move-shape ] keep redraw ;
: resize-gadget ( w h gadget -- )
[ resize-shape ] keep redraw ;
+
+: box- ( gadget box -- )
+ [ 2dup gadget-children remq swap set-gadget-children ] keep
+ relayout
+ f swap set-gadget-parent ;
+
+: (box+) ( gadget box -- )
+ [ gadget-children cons ] keep set-gadget-children ;
+
+: unparent ( gadget -- )
+ dup gadget-parent dup [ box- ] [ 2drop ] ifte ;
+
+: box+ ( gadget box -- )
+ #! Add a gadget to a box.
+ over unparent
+ dup pick set-gadget-parent
+ tuck (box+)
+ relayout ;
USING: alien generic kernel lists math namespaces sdl sdl-event
sdl-video ;
-SYMBOL: world
+DEFER: pick-up*
+
+: pick-up-list ( point list -- gadget )
+ dup [
+ 2dup car pick-up dup [
+ 2nip
+ ] [
+ drop cdr pick-up-list
+ ] ifte
+ ] [
+ 2drop f
+ ] ifte ;
+
+: pick-up* ( point gadget -- gadget/t )
+ #! 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.
+ 2dup inside? [
+ 2dup [ translate ] keep
+ gadget-children pick-up-list dup [
+ 2nip
+ ] [
+ drop inside?
+ ] ifte
+ ] [
+ 2drop f
+ ] ifte ;
+
+: 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 ;
+
+DEFER: world
! The hand is a special gadget that holds mouse position and
! mouse button click state. The hand's parent is the world, but
TUPLE: hand click-pos clicked buttons delegate ;
C: hand ( world -- hand )
- 0 0 <point> <gadget> <box>
+ 0 0 <point> <gadget>
over set-hand-delegate
[ set-gadget-parent ] keep ;
IN: gadgets
USING: generic hashtables kernel lists math namespaces ;
+GENERIC: layout* ( gadget -- )
+M: gadget layout* drop ;
+
! A pile is a box that lays out its contents vertically.
TUPLE: pile delegate ;
-C: pile ( gadget -- pile )
- [ >r <box> r> set-pile-delegate ] keep ;
+C: pile ( shape -- pile )
+ [ >r <gadget> r> set-pile-delegate ] keep ;
M: pile layout* ( pile -- )
dup gadget-children run-heights >r >r
! A shelf is a box that lays out its contents horizontally.
TUPLE: shelf delegate ;
-C: shelf ( gadget -- pile )
- [ >r <box> r> set-shelf-delegate ] keep ;
+C: shelf ( shape -- pile )
+ [ >r <gadget> r> set-shelf-delegate ] keep ;
M: shelf layout* ( pile -- )
dup gadget-children run-widths >r >r
gadget-children r> zip [
uncons 0 rot move-gadget
] each ;
+
+: relayout ( gadget -- )
+ #! Relayout a gadget before the next iteration of the event
+ #! loop. Since relayout also implies the visual
+ #! representation changed, we redraw the gadget too.
+ t over set-gadget-redraw?
+ t over set-gadget-relayout?
+ gadget-parent [ relayout ] when* ;
+
+: layout ( gadget -- )
+ #! Set the gadget's width and height to its preferred width
+ #! and height. The gadget's children are laid out first.
+ #! Note that nothing is done if the gadget does not need to
+ #! be laid out.
+ dup gadget-relayout? [
+ f over set-gadget-relayout?
+ dup gadget-children [ layout ] each
+ layout*
+ ] [
+ drop
+ ] ifte ;
[[ color [ 160 160 160 ] ]]
[[ font [[ "Monospaced" 12 ]] ]]
}} ;
+
+: draw-gadget ( gadget -- )
+ #! All drawing done inside draw-shape is done with the
+ #! gadget's paint. If the gadget does not have any custom
+ #! paint, just call the quotation.
+ dup gadget-paint [
+ dup draw-shape
+ dup [
+ gadget-children [ draw-gadget ] each
+ ] with-translation
+ ] bind ;
+
+: redraw ( gadget -- )
+ #! Redraw a gadget before the next iteration of the event
+ #! loop.
+ t over set-gadget-redraw?
+ gadget-parent [ redraw ] when* ;
: <world-box> ( -- box )
0 0 0 0 <plain-rect> <everywhere> <gadget>
- dup [ 216 216 216 ] color set-paint-property
- <box> ;
+ dup [ 216 216 216 ] color set-paint-property ;
C: world ( -- world )
<world-box> over set-world-delegate
projects / factor.git / commitdiff