diff --git a/library/bootstrap/boot-stage2.factor b/library/bootstrap/boot-stage2.factor index e75e4fc963..d88965f0c2 100644 --- a/library/bootstrap/boot-stage2.factor +++ b/library/bootstrap/boot-stage2.factor @@ -157,6 +157,7 @@ cpu "x86" = [ "/library/ui/gadgets.factor" "/library/ui/boxes.factor" "/library/ui/gestures.factor" + "/library/ui/hand.factor" "/library/ui/world.factor" ] [ dup print diff --git a/library/sdl/sdl-utils.factor b/library/sdl/sdl-utils.factor index 9a5234c475..efba5137a9 100644 --- a/library/sdl/sdl-utils.factor +++ b/library/sdl/sdl-utils.factor @@ -55,6 +55,7 @@ SYMBOL: surface : 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 ) diff --git a/library/stack.factor b/library/stack.factor index deff179ff3..2894406aaa 100644 --- a/library/stack.factor +++ b/library/stack.factor @@ -10,7 +10,7 @@ IN: kernel : -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 diff --git a/library/ui/boxes.factor b/library/ui/boxes.factor index a8ccf80cca..37668b581f 100644 --- a/library/ui/boxes.factor +++ b/library/ui/boxes.factor @@ -15,8 +15,9 @@ M: general-list draw ( list -- ) M: box draw ( box -- ) dup [ dup [ - dup box-contents draw + dup box-delegate draw + box-contents draw ] with-gadget ] with-translation ; @@ -49,10 +50,18 @@ M: box pick-up* ( point box -- gadget ) ] 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 ; diff --git a/library/ui/gadgets.factor b/library/ui/gadgets.factor index 966105cdc4..149245999e 100644 --- a/library/ui/gadgets.factor +++ b/library/ui/gadgets.factor @@ -4,7 +4,6 @@ IN: gadgets USING: generic hashtables kernel lists namespaces ; ! Gadget protocol. - GENERIC: pick-up* ( point gadget -- gadget/t ) GENERIC: handle-gesture* ( gesture gadget -- ? ) @@ -40,8 +39,17 @@ M: gadget pick-up* inside? ; 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 diff --git a/library/ui/gestures.factor b/library/ui/gestures.factor index 0d6c4e8bd5..058eee2e39 100644 --- a/library/ui/gestures.factor +++ b/library/ui/gestures.factor @@ -16,3 +16,9 @@ USING: generic kernel lists sdl-event ; ] [ 2drop ] ifte ; + +TUPLE: redraw-gesture ; +C: redraw-gesture ; + +M: object redraw ( gadget -- ) + swap handle-gesture ; diff --git a/library/ui/hand.factor b/library/ui/hand.factor new file mode 100644 index 0000000000..8868b5d743 --- /dev/null +++ b/library/ui/hand.factor @@ -0,0 +1,40 @@ +! 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 + 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 ; diff --git a/library/ui/paint.factor b/library/ui/paint.factor index 6e08f10349..0435cb90ee 100644 --- a/library/ui/paint.factor +++ b/library/ui/paint.factor @@ -21,7 +21,13 @@ SYMBOL: filled ! is the interior of the shape filled? 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 ; diff --git a/library/ui/shapes.factor b/library/ui/shapes.factor index 6c015c12e7..048ed402f2 100644 --- a/library/ui/shapes.factor +++ b/library/ui/shapes.factor @@ -45,38 +45,48 @@ M: number shape-h drop 0 ; 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 2swap ; -M: rect move-shape ( x y rect -- rect ) - [ rect-w ] keep rect-h ; +M: rectangle move-shape ( x y rect -- rect ) + [ rectangle-w ] keep rectangle-h ; -M: rect resize-shape ( w h rect -- rect ) - [ rect-x ] keep rect-y 2swap ; +M: rectangle resize-shape ( w h rect -- rect ) + [ rectangle-x ] keep rectangle-y 2swap ; -: 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 ; + +M: everywhere resize-shape ( w h everywhere -- ) + everywhere-delegate resize-shape ; diff --git a/library/ui/world.factor b/library/ui/world.factor index 740a0f915c..9c380bf527 100644 --- a/library/ui/world.factor +++ b/library/ui/world.factor @@ -1,53 +1,23 @@ ! 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 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 -- ) - swap handle-gesture ; - M: hand handle-gesture* ( gesture hand -- ? ) 2dup swap hand-gesture world get pick-up handle-gesture* ; : ( -- box ) - 0 0 1000 1000 ; + 0 0 0 0 + dup blue 3list color set-paint-property + dup t filled set-paint-property + ; C: world ( -- world ) over set-world-delegate @@ -62,7 +32,14 @@ M: alien world-gesture ( world gesture -- ) 2drop ; 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 -- ? ) @@ -74,7 +51,8 @@ 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 @@ -89,4 +67,17 @@ M: world handle-gesture* ( gesture world -- ? ) ] 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 set ] bind