diff --git a/library/bootstrap/boot-stage2.factor b/library/bootstrap/boot-stage2.factor index 6c14842938..8b9ae69ec7 100644 --- a/library/bootstrap/boot-stage2.factor +++ b/library/bootstrap/boot-stage2.factor @@ -153,9 +153,8 @@ cpu "x86" = [ "/library/ui/line-editor.factor" "/library/ui/console.factor" "/library/ui/shapes.factor" - "/library/ui/paint.factor" "/library/ui/gadgets.factor" - "/library/ui/boxes.factor" + "/library/ui/paint.factor" "/library/ui/gestures.factor" "/library/ui/hand.factor" "/library/ui/world.factor" diff --git a/library/ui/boxes.factor b/library/ui/boxes.factor deleted file mode 100644 index 97f5545dfa..0000000000 --- a/library/ui/boxes.factor +++ /dev/null @@ -1,60 +0,0 @@ -! 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 ; diff --git a/library/ui/gadgets.factor b/library/ui/gadgets.factor index 3840bbba9b..4d04a70660 100644 --- a/library/ui/gadgets.factor +++ b/library/ui/gadgets.factor @@ -6,34 +6,10 @@ USING: generic hashtables kernel lists namespaces ; ! 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 @@ -54,30 +30,26 @@ C: gadget ( shape -- gadget ) : 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 ; diff --git a/library/ui/hand.factor b/library/ui/hand.factor index 8ac4df57c2..16fe9cff91 100644 --- a/library/ui/hand.factor +++ b/library/ui/hand.factor @@ -4,7 +4,41 @@ IN: gadgets 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 @@ -13,7 +47,7 @@ SYMBOL: world TUPLE: hand click-pos clicked buttons delegate ; C: hand ( world -- hand ) - 0 0 + 0 0 over set-hand-delegate [ set-gadget-parent ] keep ; diff --git a/library/ui/layouts.factor b/library/ui/layouts.factor index 98b64764dc..3aa42fce4c 100644 --- a/library/ui/layouts.factor +++ b/library/ui/layouts.factor @@ -3,11 +3,14 @@ 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 r> set-pile-delegate ] keep ; +C: pile ( shape -- pile ) + [ >r r> set-pile-delegate ] keep ; M: pile layout* ( pile -- ) dup gadget-children run-heights >r >r @@ -19,8 +22,8 @@ M: pile layout* ( pile -- ) ! A shelf is a box that lays out its contents horizontally. TUPLE: shelf delegate ; -C: shelf ( gadget -- pile ) - [ >r r> set-shelf-delegate ] keep ; +C: shelf ( shape -- pile ) + [ >r r> set-shelf-delegate ] keep ; M: shelf layout* ( pile -- ) dup gadget-children run-widths >r >r @@ -28,3 +31,24 @@ M: shelf layout* ( pile -- ) 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 ; diff --git a/library/ui/paint.factor b/library/ui/paint.factor index fa47112aa3..c45e6aafaf 100644 --- a/library/ui/paint.factor +++ b/library/ui/paint.factor @@ -84,3 +84,20 @@ M: bevel-rect draw-shape ( rect -- ) [[ 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* ; diff --git a/library/ui/world.factor b/library/ui/world.factor index 739e512867..27ba50ef98 100644 --- a/library/ui/world.factor +++ b/library/ui/world.factor @@ -11,8 +11,7 @@ TUPLE: world running? hand delegate ; : ( -- box ) 0 0 0 0 - dup [ 216 216 216 ] color set-paint-property - ; + dup [ 216 216 216 ] color set-paint-property ; C: world ( -- world ) over set-world-delegate