From 5791ae2e42e4d28a053ec32d7c9bc7f49410eaaf Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 3 Feb 2005 03:00:46 +0000 Subject: [PATCH] refactoring shape protocol for mutability; layouts --- library/bootstrap/boot-stage2.factor | 2 +- library/sdl/sdl-ttf.factor | 2 +- library/sdl/sdl-utils.factor | 8 +-- library/test/gadgets.factor | 22 ++++--- library/ui/boxes.factor | 14 +---- library/ui/events.factor | 4 +- library/ui/gadgets.factor | 25 ++------ library/ui/hand.factor | 2 +- library/ui/labels.factor | 3 +- library/ui/{piles.factor => layouts.factor} | 13 ++++ library/ui/paint.factor | 70 +++++++++++++++++---- library/ui/shapes.factor | 66 ++++++++++--------- library/ui/world.factor | 11 ++-- 13 files changed, 143 insertions(+), 99 deletions(-) rename library/ui/{piles.factor => layouts.factor} (58%) diff --git a/library/bootstrap/boot-stage2.factor b/library/bootstrap/boot-stage2.factor index 499a3b37b2..6c14842938 100644 --- a/library/bootstrap/boot-stage2.factor +++ b/library/bootstrap/boot-stage2.factor @@ -160,7 +160,7 @@ cpu "x86" = [ "/library/ui/hand.factor" "/library/ui/world.factor" "/library/ui/labels.factor" - "/library/ui/piles.factor" + "/library/ui/layouts.factor" "/library/ui/events.factor" ] [ dup print diff --git a/library/sdl/sdl-ttf.factor b/library/sdl/sdl-ttf.factor index 693fae82dd..3627e10e6e 100644 --- a/library/sdl/sdl-ttf.factor +++ b/library/sdl/sdl-ttf.factor @@ -95,7 +95,7 @@ END-STRUCT "surface*" "sdl-ttf" "TTF_RenderGlyph_Shaded" [ "void*" "ushort" "int" "int" ] alien-invoke ; : TTF_RenderText_Blended ( font text fg -- surface ) - "surface*" "sdl-ttf" "TTF_RenderText_Blended" [ "void*" "ushort" "int" ] alien-invoke ; + "surface*" "sdl-ttf" "TTF_RenderText_Blended" [ "void*" "char*" "int" ] alien-invoke ; : TTF_RenderGlyph_Blended ( font text fg -- surface ) "surface*" "sdl-ttf" "TTF_RenderGlyph_Blended" [ "void*" "ushort" "int" ] alien-invoke ; diff --git a/library/sdl/sdl-utils.factor b/library/sdl/sdl-utils.factor index 5113292f7e..9c793e86de 100644 --- a/library/sdl/sdl-utils.factor +++ b/library/sdl/sdl-utils.factor @@ -159,11 +159,11 @@ global [ SDL_LockSurface ] when drop ; -: draw-string ( x y font text fg bg -- width ) - pick str-length 0 = [ - 2drop 2drop 2drop 0 +: draw-string ( x y font text fg -- width ) + over str-length 0 = [ + 2drop 3drop 0 ] [ - TTF_RenderText_Shaded + TTF_RenderText_Blended [ draw-surface ] keep [ surface-w ] keep SDL_FreeSurface diff --git a/library/test/gadgets.factor b/library/test/gadgets.factor index 8e36a5e28f..a2e26ca202 100644 --- a/library/test/gadgets.factor +++ b/library/test/gadgets.factor @@ -5,21 +5,21 @@ USING: gadgets kernel lists math namespaces test ; [ 2000 x set 2000 y set - 2030 2040 rect> 10 20 300 400 inside? + 2030 2040 10 20 300 400 inside? ] with-scope ] unit-test [ f ] [ [ 2000 x set 2000 y set - 2500 2040 rect> 10 20 300 400 inside? + 2500 2040 10 20 300 400 inside? ] with-scope ] unit-test [ t ] [ [ -10 x set -20 y set - 0 0 rect> 10 20 300 400 inside? + 0 0 10 20 300 400 inside? ] with-scope ] unit-test [ 11 11 41 41 ] [ @@ -27,25 +27,29 @@ USING: gadgets kernel lists math namespaces test ; [ 1 x set 1 y set - 10 10 30 30 shape>screen + 10 10 30 30 shape>screen ] with-scope ] bind ] unit-test [ t ] [ default-paint [ - 0 0 rect> -10 -10 20 20 [ pick-up ] keep = + 0 0 -10 -10 20 20 [ pick-up ] keep = ] bind ] unit-test : funny-rect ( x -- rect ) - 10 10 30 - dup [ 255 0 0 ] color set-paint-property - dup t filled set-paint-property ; + 10 10 30 + dup [ 255 0 0 ] color set-paint-property ; [ f ] [ default-paint [ - 35 0 rect> + 35 0 [ 10 30 50 70 ] [ funny-rect ] map pick-up ] bind ] unit-test + +[ 1 3 2 ] [ #{ 1 2 }# #{ 3 4 }# x1/x2/y1 ] unit-test +[ 1 3 4 ] [ #{ 1 2 }# #{ 3 4 }# x1/x2/y2 ] unit-test +[ 1 2 4 ] [ #{ 1 2 }# #{ 3 4 }# x1/y1/y2 ] unit-test +[ 3 2 4 ] [ #{ 1 2 }# #{ 3 4 }# x2/y1/y2 ] unit-test diff --git a/library/ui/boxes.factor b/library/ui/boxes.factor index 37730747c7..97f5545dfa 100644 --- a/library/ui/boxes.factor +++ b/library/ui/boxes.factor @@ -11,17 +11,9 @@ C: box ( gadget -- box ) M: box gadget-children box-children ; -M: general-list draw ( list -- ) - [ draw ] each ; - -M: box draw ( box -- ) - dup [ - dup [ - dup - box-delegate draw - box-children draw - ] with-gadget - ] with-translation ; +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 [ diff --git a/library/ui/events.factor b/library/ui/events.factor index 569aa54d17..da283fac09 100644 --- a/library/ui/events.factor +++ b/library/ui/events.factor @@ -18,8 +18,8 @@ M: resize-event handle-event ( event -- ) 0 SDL_HWSURFACE SDL_RESIZABLE bitor init-screen world get redraw ; -: button-event-pos ( event -- #{ x y }# ) - dup button-event-x swap button-event-y rect> ; +: button-event-pos ( event -- point ) + dup button-event-x swap button-event-y ; M: button-down-event handle-event ( event -- ) dup button-event-pos my-hand set-hand-click-pos diff --git a/library/ui/gadgets.factor b/library/ui/gadgets.factor index 9423d328c4..3840bbba9b 100644 --- a/library/ui/gadgets.factor +++ b/library/ui/gadgets.factor @@ -54,13 +54,11 @@ C: gadget ( shape -- gadget ) : set-action ( gadget quot gesture -- ) rot gadget-gestures set-hash ; -: with-gadget ( gadget quot -- ) - #! All drawing done inside the quotation is done with the +: 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. - >r gadget-paint r> bind ; - -M: gadget draw ( gadget -- ) drop ; + dup gadget-paint [ draw-shape ] bind ; M: gadget pick-up* inside? ; @@ -79,20 +77,7 @@ M: gadget pick-up* inside? ; gadget-parent [ relayout ] when* ; : move-gadget ( x y gadget -- ) - [ move-shape ] keep - [ set-gadget-delegate ] keep - redraw ; + [ move-shape ] keep redraw ; : resize-gadget ( w h gadget -- ) - [ resize-shape ] keep - [ set-gadget-delegate ] keep - redraw ; - -! A simple gadget that just draws its shape. -TUPLE: stamp delegate ; - -C: stamp ( shape -- ) - swap over set-stamp-delegate ; - -M: stamp draw ( stamp -- ) - dup [ gadget-delegate draw ] with-gadget ; + [ resize-shape ] keep redraw ; diff --git a/library/ui/hand.factor b/library/ui/hand.factor index c2c6663bb8..8ac4df57c2 100644 --- a/library/ui/hand.factor +++ b/library/ui/hand.factor @@ -13,7 +13,7 @@ SYMBOL: world TUPLE: hand click-pos clicked buttons delegate ; C: hand ( world -- hand ) - 0 + 0 0 over set-hand-delegate [ set-gadget-parent ] keep ; diff --git a/library/ui/labels.factor b/library/ui/labels.factor index ce78627020..edd1c3a58f 100644 --- a/library/ui/labels.factor +++ b/library/ui/labels.factor @@ -18,11 +18,10 @@ M: label layout* ( label -- ) swap size-string ] keep resize-gadget ; -M: label draw ( label -- ) +M: label draw-shape ( label -- ) dup shape-x x get + over shape-y y get + rot label-text >r font get lookup-font r> color get 3unlist make-color - white make-color draw-string drop ; diff --git a/library/ui/piles.factor b/library/ui/layouts.factor similarity index 58% rename from library/ui/piles.factor rename to library/ui/layouts.factor index 5e8c2f8871..98b64764dc 100644 --- a/library/ui/piles.factor +++ b/library/ui/layouts.factor @@ -15,3 +15,16 @@ M: pile layout* ( pile -- ) gadget-children r> zip [ uncons 0 swap rot move-gadget ] each ; + +! A shelf is a box that lays out its contents horizontally. +TUPLE: shelf delegate ; + +C: shelf ( gadget -- pile ) + [ >r r> set-shelf-delegate ] keep ; + +M: shelf layout* ( pile -- ) + dup gadget-children run-widths >r >r + dup gadget-children max-height r> swap pick resize-gadget + gadget-children r> zip [ + uncons 0 rot move-gadget + ] each ; diff --git a/library/ui/paint.factor b/library/ui/paint.factor index 3885e34e2c..fa47112aa3 100644 --- a/library/ui/paint.factor +++ b/library/ui/paint.factor @@ -7,9 +7,8 @@ USING: generic kernel lists math namespaces sdl sdl-gfx ; ! dynamically-scoped variables. ! "Paint" is a namespace containing some or all of these values. -SYMBOL: color ! a list of three integers, 0..255. -SYMBOL: font ! a list of two elements, a font name and size. -SYMBOL: filled ! is the interior of the shape filled? +SYMBOL: color ! a list of three integers, 0..255. +SYMBOL: font ! a list of two elements, a font name and size. : shape>screen ( shape -- x1 y1 x2 y2 ) [ shape-x x get + ] keep @@ -19,20 +18,69 @@ SYMBOL: filled ! is the interior of the shape filled? : rgb-color ( -- rgba ) color get 3unlist rgb ; -GENERIC: draw ( obj -- ) +GENERIC: draw-shape ( obj -- ) -M: number draw ( point -- ) - >r surface get r> >rect rgb-color pixelColor ; +M: rectangle draw-shape drop ; -M: rectangle draw ( rect -- ) - >r surface get r> shape>screen rgb-color - filled get [ boxColor ] [ rectangleColor ] ifte ; +M: point draw-shape ( point -- ) + >r surface get r> dup point-x swap point-y + rgb-color pixelColor ; + +TUPLE: hollow-rect delegate ; + +C: hollow-rect ( x y w h -- rect ) + [ >r r> set-hollow-rect-delegate ] keep ; + +M: hollow-rect draw-shape ( rect -- ) + >r surface get r> shape>screen rgb-color rectangleColor ; + +TUPLE: plain-rect delegate ; + +C: plain-rect ( x y w h -- rect ) + [ >r r> set-plain-rect-delegate ] keep ; + +M: plain-rect draw-shape ( rect -- ) + >r surface get r> shape>screen rgb-color boxColor ; + +: x1/x2/y1 ( #{ x1 y1 }# #{ x2 y2 }# -- x1 x2 y1 ) + >r >rect r> real swap ; + +: x1/x2/y2 ( #{ x1 y1 }# #{ x2 y2 }# -- x1 x2 y2 ) + >r real r> >rect ; + +: x1/y1/y2 ( #{ x1 y1 }# #{ x2 y2 }# -- x1 y1 y2 ) + >r >rect r> imaginary ; + +: x2/y1/y2 ( #{ x1 y1 }# #{ x2 y2 }# -- x2 y1 y2 ) + >r imaginary r> >rect >r swap r> ; + +: (draw-bevel) ( #{ x1 y1 }# #{ x2 y2 }# -- ) + surface get pick pick x1/x2/y1 240 240 240 rgb hlineColor + surface get pick pick x1/x2/y2 192 192 192 rgb hlineColor + surface get pick pick x1/y1/y2 240 240 240 rgb vlineColor + surface get pick pick x2/y1/y2 192 192 192 rgb vlineColor + 2drop ; + +TUPLE: bevel-rect delegate bevel ; + +C: bevel-rect ( bevel x y w h -- rect ) + [ >r r> set-bevel-rect-delegate ] keep + [ set-bevel-rect-bevel ] keep ; + +: draw-bevel ( #{ x1 y1 }# #{ x2 y2 }# n -- ) + [ + pick over #{ 1 1 }# * + + pick pick #{ 1 1 }# * - + (draw-bevel) + ] repeat 2drop ; + +M: bevel-rect draw-shape ( rect -- ) + shape>screen >r >r rect> r> r> rect> 3 draw-bevel ; : default-paint ( -- paint ) {{ [[ x 0 ]] [[ y 0 ]] - [[ color [ 0 0 0 ] ]] - [[ filled f ]] + [[ color [ 160 160 160 ] ]] [[ font [[ "Monospaced" 12 ]] ]] }} ; diff --git a/library/ui/shapes.factor b/library/ui/shapes.factor index 31a25e6bd1..65001eee5e 100644 --- a/library/ui/shapes.factor +++ b/library/ui/shapes.factor @@ -20,8 +20,8 @@ GENERIC: shape-y GENERIC: shape-w GENERIC: shape-h -GENERIC: move-shape ( x y shape -- shape ) -GENERIC: resize-shape ( w h shape -- shape ) +GENERIC: move-shape ( x y shape -- ) +GENERIC: resize-shape ( w h shape -- ) : with-translation ( shape quot -- ) #! All drawing done inside the quotation is translated @@ -33,31 +33,44 @@ 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 ; +: max-height ( list -- n ) + #! The height of the tallest shape. + [ shape-h ] map [ > ] top ; + +: run-widths ( list -- w list ) + #! Compute a list of running sums of widths of shapes. + [ 0 swap [ over , shape-w + ] each ] make-list ; + : run-heights ( list -- h list ) - #! Compute a list of accumilative sums of heights of shapes. + #! Compute a list of running 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? = ; +! A point is the simplest shape. +TUPLE: point x y ; -M: number shape-x real ; -M: number shape-y imaginary ; -M: number shape-w drop 0 ; -M: number shape-h drop 0 ; +C: point ( x y -- point ) + [ set-point-y ] keep [ set-point-x ] keep ; -M: number move-shape ( x y point -- point ) drop rect> ; +M: point inside? ( point point -- ) + over shape-x over point-x = >r + swap shape-y swap point-y = r> and ; + +M: point shape-x point-x ; +M: point shape-y point-y ; +M: point shape-w drop 0 ; +M: point shape-h drop 0 ; + +M: point move-shape ( x y point -- ) + tuck set-point-y set-point-x ; + +: translate ( point shape -- point ) + #! Translate a point relative to the shape. + over shape-y over shape-y - >r + swap shape-x swap shape-x - r> ; ! A rectangle maps trivially to the shape protocol. TUPLE: rectangle x y w h ; @@ -77,14 +90,11 @@ C: rectangle ( x y w h -- rect ) [ set-rectangle-y ] keep [ set-rectangle-x ] keep ; -M: number resize-shape ( w h point -- rect ) - >rect 2swap ; +M: rectangle move-shape ( x y rect -- ) + tuck set-rectangle-y set-rectangle-x ; -M: rectangle move-shape ( x y rect -- rect ) - [ rectangle-w ] keep rectangle-h ; - -M: rectangle resize-shape ( w h rect -- rect ) - [ rectangle-x ] keep rectangle-y 2swap ; +M: rectangle resize-shape ( w h rect -- ) + tuck set-rectangle-h set-rectangle-w ; : rectangle-x-extents ( rect -- x1 x2 ) dup rectangle-x x get + swap rectangle-w dupd + ; @@ -99,9 +109,3 @@ M: rectangle inside? ( point rect -- ? ) ! 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 326a7acb0a..739e512867 100644 --- a/library/ui/world.factor +++ b/library/ui/world.factor @@ -10,9 +10,8 @@ sdl-video ; TUPLE: world running? hand delegate ; : ( -- box ) - 0 0 0 0 - dup blue 3list color set-paint-property - dup t filled set-paint-property + 0 0 0 0 + dup [ 216 216 216 ] color set-paint-property ; C: world ( -- world ) @@ -26,8 +25,8 @@ C: world ( -- world ) world get dup gadget-redraw? [ [ f over set-gadget-redraw? - dup draw - world-hand draw + dup draw-gadget + world-hand draw-gadget ] with-surface ] [ drop @@ -40,7 +39,7 @@ DEFER: handle-event : run-world ( -- ) world get world-running? [ dup SDL_WaitEvent 1 = [ - handle-event draw-world layout-world run-world + handle-event layout-world draw-world run-world ] [ drop ] ifte