refactoring shape protocol for mutability; layouts

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

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 ;

library/sdl/sdl-utils.factor

@@ -159,11 +159,11 @@ global [
         SDL_LockSurface
     ] when drop ;
 
-: draw-string ( x y font text fg bg -- width )
+: draw-string ( x y font text fg -- width )
-    pick str-length 0 = [
+    over str-length 0 = [
-        2drop 2drop 2drop 0
+        2drop 3drop 0
     ] [
-        TTF_RenderText_Shaded
+        TTF_RenderText_Blended
         [ draw-surface ] keep
         [ surface-w ] keep
         SDL_FreeSurface

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 <rect> inside?
+        2030 2040 <point> 10 20 300 400 <rectangle> inside?
     ] with-scope
 ] unit-test
 [ f ] [
     [
         2000 x set
         2000 y set
-        2500 2040 rect> 10 20 300 400 <rect> inside?
+        2500 2040 <point> 10 20 300 400 <rectangle> inside?
     ] with-scope
 ] unit-test
 [ t ] [
     [
         -10 x set
         -20 y set
-        0 0 rect> 10 20 300 400 <rect> inside?
+        0 0 <point> 10 20 300 400 <rectangle> 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 <rect> <gadget> shape>screen
+            10 10 30 30 <rectangle> <gadget> shape>screen
         ] with-scope
     ] bind
 ] unit-test
 [ t ] [
     default-paint [
-        0 0 rect> -10 -10 20 20 <rect> <gadget> [ pick-up ] keep =
+        0 0 <point> -10 -10 20 20 <rectangle> <gadget> [ pick-up ] keep =
     ] bind
 ] unit-test
 
 : funny-rect ( x -- rect )
-    10 10 30 <rect> <gadget>
+    10 10 30 <rectangle> <gadget>
-    dup [ 255 0 0 ] color set-paint-property
+    dup [ 255 0 0 ] color set-paint-property ;
-    dup t filled set-paint-property ;
     
 [ f ] [
     default-paint [
-        35 0 rect>
+        35 0 <point>
         [ 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

library/ui/boxes.factor

@@ -11,17 +11,9 @@ C: box ( gadget -- box )
 
 M: box gadget-children box-children ;
 
-M: general-list draw ( list -- )
+M: box draw-shape ( box -- )
-    [ draw ] each ;
+    dup box-delegate draw-gadget
-
+    dup [ box-children [ draw-gadget ] each ] with-translation ;
-M: box draw ( box -- )
-    dup [
-        dup [
-            dup
-            box-delegate draw
-            box-children draw
-        ] with-gadget
-    ] with-translation ;
 
 M: general-list pick-up* ( point list -- gadget )
     dup [

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 }# )
+: button-event-pos ( event -- point )
-    dup button-event-x swap button-event-y rect> ;
+    dup button-event-x swap button-event-y <point> ;
 
 M: button-down-event handle-event ( event -- )
     dup button-event-pos my-hand set-hand-click-pos

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 -- )
+: draw-gadget ( gadget -- )
-    #! All drawing done inside the quotation is done with the
+    #! 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 ;
+    dup gadget-paint [ draw-shape ] bind ;
-
-M: gadget draw ( gadget -- ) drop ;
 
 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
+    [ move-shape ] keep redraw ;
-    [ set-gadget-delegate ] keep
-    redraw ;
 
 : resize-gadget ( w h gadget -- )
-    [ resize-shape ] keep
+    [ resize-shape ] keep redraw ;
-    [ set-gadget-delegate ] keep
-    redraw ;
-
-! A simple gadget that just draws its shape.
-TUPLE: stamp delegate ;
-
-C: stamp ( shape -- )
-    swap <gadget> over set-stamp-delegate ;
-
-M: stamp draw ( stamp -- )
-    dup [ gadget-delegate draw ] with-gadget ;

library/ui/hand.factor

@@ -13,7 +13,7 @@ SYMBOL: world
 TUPLE: hand click-pos clicked buttons delegate ;
 
 C: hand ( world -- hand )
-    0 <gadget> <box>
+    0 0 <point> <gadget> <box>
     over set-hand-delegate
     [ set-gadget-parent ] keep ;
 

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 ;

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 <box> 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 ;

library/ui/paint.factor

@@ -9,7 +9,6 @@ USING: generic kernel lists math namespaces sdl sdl-gfx ;
 ! "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?
 
 : 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 -- )
+M: rectangle draw-shape drop ;
-    >r surface get r> >rect rgb-color pixelColor ;
 
-M: rectangle draw ( rect -- )
+M: point draw-shape ( point -- )
-    >r surface get r> shape>screen rgb-color
+    >r surface get r> dup point-x swap point-y
-    filled get [ boxColor ] [ rectangleColor ] ifte ;
+    rgb-color pixelColor ;
+
+TUPLE: hollow-rect delegate ;
+
+C: hollow-rect ( x y w h -- rect )
+    [ >r <rectangle> 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 <rectangle> 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 <rectangle> 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 ] ]]
+        [[ color [ 160 160 160 ] ]]
-        [[ filled f ]]
         [[ font [[ "Monospaced" 12 ]] ]]
     }} ;

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: move-shape ( x y shape -- )
-GENERIC: resize-shape ( w h shape -- 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
+! A point is the simplest shape.
-! of shape.
+TUPLE: point x y ;
-M: number inside? = ;
 
-M: number shape-x real ;
+C: point ( x y -- point )
-M: number shape-y imaginary ;
+    [ set-point-y ] keep [ set-point-x ] keep ;
-M: number shape-w drop 0 ;
-M: number shape-h drop 0 ;
 
-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> <point> ;
 
 ! 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 )
+M: rectangle move-shape ( x y rect -- )
-     >rect 2swap <rectangle> ;
+    tuck set-rectangle-y set-rectangle-x ;
 
-M: rectangle move-shape ( x y rect -- rect )
+M: rectangle resize-shape ( w h rect -- )
-    [ rectangle-w ] keep rectangle-h <rectangle> ;
+    tuck set-rectangle-h set-rectangle-w ;
-
-M: rectangle resize-shape ( w h rect -- rect )
-    [ rectangle-x ] keep rectangle-y 2swap <rectangle> ;
 
 : 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 <everywhere> ;
-
-M: everywhere resize-shape ( w h everywhere -- )
-    everywhere-delegate resize-shape <everywhere> ;

library/ui/world.factor

@@ -10,9 +10,8 @@ sdl-video ;
 TUPLE: world running? hand delegate ;
 
 : <world-box> ( -- box )
-    0 0 0 0 <rectangle> <everywhere> <stamp>
+    0 0 0 0 <plain-rect> <everywhere> <gadget>
-    dup blue 3list color set-paint-property
+    dup [ 216 216 216 ] color set-paint-property
-    dup t filled set-paint-property
     <box> ;
 
 C: world ( -- world )
@@ -26,8 +25,8 @@ C: world ( -- world )
     world get dup gadget-redraw? [
         [
             f over set-gadget-redraw?
-            dup draw
+            dup draw-gadget
-            world-hand draw
+            world-hand draw-gadget
         ] with-surface
     ] [
         drop
@@ -40,7 +39,7 @@ DEFER: handle-event
 : run-world ( -- )
     world get world-running? [
         <event> dup SDL_WaitEvent 1 = [
-            handle-event draw-world layout-world run-world
+            handle-event layout-world draw-world run-world
         ] [
             drop
         ] ifte