diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt index 385fa2a008..219225c5cc 100644 --- a/TODO.FACTOR.txt +++ b/TODO.FACTOR.txt @@ -16,6 +16,9 @@ - doc comments of generics - proper ordering for classes - tuples: in/out syntax +- tuples: gracefully handle changing shape +- keep a list of getter/setter words +- default constructor + ffi: @@ -31,6 +34,7 @@ + listener/plugin: +- command to turn repl session into a source file - update plugin docs - extract word keeps indent - word preview for remote words diff --git a/library/bootstrap/boot-stage2.factor b/library/bootstrap/boot-stage2.factor index 06e6201b40..499a3b37b2 100644 --- a/library/bootstrap/boot-stage2.factor +++ b/library/bootstrap/boot-stage2.factor @@ -159,7 +159,8 @@ cpu "x86" = [ "/library/ui/gestures.factor" "/library/ui/hand.factor" "/library/ui/world.factor" - "/library/ui/label.factor" + "/library/ui/labels.factor" + "/library/ui/piles.factor" "/library/ui/events.factor" ] [ dup print diff --git a/library/ui/boxes.factor b/library/ui/boxes.factor index 62f79a8eba..37730747c7 100644 --- a/library/ui/boxes.factor +++ b/library/ui/boxes.factor @@ -4,11 +4,13 @@ IN: gadgets USING: generic hashtables kernel lists namespaces ; ! A box is a gadget holding other gadgets. -TUPLE: box contents delegate ; +TUPLE: box children delegate ; C: box ( gadget -- box ) [ set-box-delegate ] keep ; +M: box gadget-children box-children ; + M: general-list draw ( list -- ) [ draw ] each ; @@ -17,7 +19,7 @@ M: box draw ( box -- ) dup [ dup box-delegate draw - box-contents draw + box-children draw ] with-gadget ] with-translation ; @@ -37,25 +39,23 @@ M: box pick-up* ( point box -- gadget ) #! 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 inside? [ - 2dup box-contents pick-up dup [ - 2nip - ] [ - drop box-delegate pick-up* - ] ifte + 2dup inside? [ + 2dup [ translate ] keep box-children pick-up dup [ + 2nip ] [ - 2drop f + drop box-delegate pick-up* ] ifte - ] with-translation ; + ] [ + 2drop f + ] ifte ; : box- ( gadget box -- ) - [ 2dup box-contents remq swap set-box-contents ] keep - redraw + [ 2dup box-children remq swap set-box-children ] keep + relayout f swap set-gadget-parent ; : (box+) ( gadget box -- ) - [ box-contents cons ] keep set-box-contents ; + [ box-children cons ] keep set-box-children ; : unparent ( gadget -- ) dup gadget-parent dup [ box- ] [ 2drop ] ifte ; @@ -65,4 +65,4 @@ M: box pick-up* ( point box -- gadget ) over unparent dup pick set-gadget-parent tuck (box+) - redraw ; + relayout ; diff --git a/library/ui/gadgets.factor b/library/ui/gadgets.factor index 06c0e66174..9423d328c4 100644 --- a/library/ui/gadgets.factor +++ b/library/ui/gadgets.factor @@ -3,6 +3,11 @@ IN: gadgets 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 ) @@ -11,15 +16,31 @@ GENERIC: pick-up* ( point gadget -- gadget/t ) #! exposed facade issue. tuck pick-up* dup t = [ drop ] [ nip ] ifte ; -! 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 delegate ; +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 ; C: gadget ( shape -- gadget ) [ set-gadget-delegate ] keep [ swap set-gadget-paint ] keep - [ swap set-gadget-gestures ] keep ; + [ swap set-gadget-gestures ] keep + [ t swap set-gadget-relayout? ] keep + [ t swap set-gadget-redraw? ] keep ; : paint-property ( gadget key -- value ) swap gadget-paint hash ; @@ -43,7 +64,19 @@ M: gadget draw ( gadget -- ) drop ; M: gadget pick-up* inside? ; -DEFER: redraw ( gadget -- ) +: 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 diff --git a/library/ui/gestures.factor b/library/ui/gestures.factor index 7c9999996b..844df6343e 100644 --- a/library/ui/gestures.factor +++ b/library/ui/gestures.factor @@ -24,10 +24,6 @@ USING: alien generic hashtables kernel lists sdl-event ; 2drop ] ifte ; -! Redraw gesture. Don't handle this yourself. -: redraw ( gadget -- ) - \ redraw swap handle-gesture ; - ! Mouse gestures are lists where the first element is one of: SYMBOL: motion SYMBOL: button-up diff --git a/library/ui/label.factor b/library/ui/labels.factor similarity index 89% rename from library/ui/label.factor rename to library/ui/labels.factor index 359ba0f6df..ce78627020 100644 --- a/library/ui/label.factor +++ b/library/ui/labels.factor @@ -7,18 +7,17 @@ USING: generic kernel lists math namespaces sdl ; ! box. TUPLE: label text delegate ; -: size-label ( label -- ) +C: label ( text -- ) + 0 0 0 0 over set-label-delegate + [ set-label-text ] keep ; + +M: label layout* ( label -- ) [ dup label-text swap gadget-paint [ font get lookup-font ] bind swap size-string ] keep resize-gadget ; -C: label ( text -- ) - 0 0 0 0 over set-label-delegate - [ set-label-text ] keep - [ size-label ] keep ; - M: label draw ( label -- ) dup shape-x x get + over shape-y y get + diff --git a/library/ui/piles.factor b/library/ui/piles.factor new file mode 100644 index 0000000000..5e8c2f8871 --- /dev/null +++ b/library/ui/piles.factor @@ -0,0 +1,17 @@ +! Copyright (C) 2005 Slava Pestov. +! See http://factor.sf.net/license.txt for BSD license. +IN: gadgets +USING: generic hashtables kernel lists math namespaces ; + +! A pile is a box that lays out its contents vertically. +TUPLE: pile delegate ; + +C: pile ( gadget -- pile ) + [ >r r> set-pile-delegate ] keep ; + +M: pile layout* ( pile -- ) + dup gadget-children run-heights >r >r + dup gadget-children max-width r> pick resize-gadget + gadget-children r> zip [ + uncons 0 swap rot move-gadget + ] each ; diff --git a/library/ui/shapes.factor b/library/ui/shapes.factor index 048ed402f2..31a25e6bd1 100644 --- a/library/ui/shapes.factor +++ b/library/ui/shapes.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2005 Slava Pestov. ! See http://factor.sf.net/license.txt for BSD license. IN: gadgets -USING: generic kernel math namespaces ; +USING: generic kernel lists math namespaces ; ! Shape protocol. Shapes are immutable; moving or resizing a ! shape makes a new shape. @@ -33,6 +33,21 @@ GENERIC: resize-shape ( w h shape -- shape ) r> call ] with-scope ; inline +: translate ( point shape -- point ) + #! Translate a point relative to the shape. + #! The rect>'ing of the given point won't be necessary as + #! soon as all generics delegate. + >r dup shape-x swap shape-y rect> r> + dup shape-x swap shape-y rect> - ; + +: max-width ( list -- n ) + #! The width of the widest shape. + [ shape-w ] map [ > ] top ; + +: run-heights ( list -- h list ) + #! Compute a list of accumilative sums of heights of shapes. + [ 0 swap [ over , shape-h + ] each ] make-list ; + ! A point, represented as a complex number, is the simplest type ! of shape. M: number inside? = ; diff --git a/library/ui/world.factor b/library/ui/world.factor index 91c60135da..326a7acb0a 100644 --- a/library/ui/world.factor +++ b/library/ui/world.factor @@ -7,7 +7,7 @@ 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: world running? hand delegate ; : ( -- box ) 0 0 0 0 @@ -18,15 +18,14 @@ TUPLE: world running? hand delegate redraw? ; C: world ( -- world ) over set-world-delegate t over set-world-running? - t over set-world-redraw? dup over set-world-hand ; : my-hand ( -- hand ) world get world-hand ; : draw-world ( -- ) - world get dup world-redraw? [ + world get dup gadget-redraw? [ [ - f over set-world-redraw? + f over set-gadget-redraw? dup draw world-hand draw ] with-surface @@ -36,10 +35,12 @@ C: world ( -- world ) DEFER: handle-event +: layout-world world get layout ; + : run-world ( -- ) world get world-running? [ dup SDL_WaitEvent 1 = [ - handle-event draw-world run-world + handle-event draw-world layout-world run-world ] [ drop ] ifte @@ -47,8 +48,6 @@ DEFER: handle-event : init-world ( w h -- ) t world get set-world-running? - t world get set-world-redraw? - world get [ t swap set-world-redraw? ] \ redraw set-action world get resize-gadget ; : world-flags SDL_HWSURFACE SDL_RESIZABLE bitor ;