buttons now update their appearance when pressed

library/bootstrap/boot-stage2.factor

@@ -157,9 +157,9 @@ cpu "x86" = [
         "/library/ui/paint.factor"
         "/library/ui/gestures.factor"
         "/library/ui/hand.factor"
+        "/library/ui/layouts.factor"
         "/library/ui/world.factor"
         "/library/ui/labels.factor"
-        "/library/ui/layouts.factor"
         "/library/ui/events.factor"
     ] [
         dup print

library/sdl/sdl-event.factor

@@ -234,8 +234,8 @@ BEGIN-UNION: event
     MEMBER: user-event
 END-UNION
 
-: SDL_WaitEvent ( event -- )
+: SDL_WaitEvent ( event -- ? )
-    "int" "sdl" "SDL_WaitEvent" [ "event*" ] alien-invoke ;
+    "bool" "sdl" "SDL_WaitEvent" [ "event*" ] alien-invoke ;
 
 : SDL_PollEvent ( event -- ? )
     "bool" "sdl" "SDL_PollEvent" [ "event*" ] alien-invoke ;

library/sdl/sdl-utils.factor

@@ -59,7 +59,8 @@ SYMBOL: surface
     SDL_INIT_EVERYTHING SDL_Init drop  TTF_Init
     [ >r init-screen r> call SDL_Quit ] with-scope ; inline
 
-: rgb ( r g b -- n )
+: rgb ( [ r g b ] -- n )
+    3unlist
     255
     swap 8 shift bitor
     swap 16 shift bitor
@@ -73,11 +74,11 @@ SYMBOL: surface
     swap 8 shift bitor
     swap bitor ;
 
-: black 0 0 0 ;
+: black [ 0   0   0   ] ;
-: white 255 255 255 ;
+: white [ 255 255 255 ] ;
-: red 255 0 0 ;
+: red   [ 255 0   0   ] ;
-: green 0 255 0 ;
+: green [ 0   255 0   ] ;
-: blue 0 0 255 ;
+: blue  [ 0   0   255 ] ;
 
 : clear-surface ( color -- )
     >r surface get 0 0 width get height get r> boxColor ;

library/ui/buttons.factor

@@ -0,0 +1,17 @@
+! Copyright (C) 2005 Slava Pestov.
+! See http://factor.sf.net/license.txt for BSD license.
+IN: gadgets
+USING: generic kernel lists math namespaces sdl ;
+
+: button-pressed  ( button -- )
+    dup f bevel-up? set-paint-property redraw ;
+
+: button-released ( button -- )
+    dup t bevel-up? set-paint-property redraw ;
+
+: <button> ( label quot -- button )
+    >r <label> bevel-border
+    dup [ dup button-released ] r> append
+    [ button-up 1 ] set-action
+    dup [ button-pressed ]
+    [ button-down 1 ] set-action ;

library/ui/console.factor

@@ -121,11 +121,11 @@ SYMBOL: redraw-console
 
 : draw-line ( str -- )
     >r x get y get console-font get r>
-    foreground make-color background make-color draw-string
+    foreground make-color draw-string
     x [ + ] change ;
 
 : clear-display ( -- )
-    surface get 0 0 width get height get background rgb boxColor ;
+    surface get 0 0 width get height get background 3list rgb boxColor ;
 
 : draw-lines ( -- )
     visible-lines available-lines min [
@@ -142,7 +142,7 @@ SYMBOL: redraw-console
     y get
     over 1 +
     y get line-height get +
-    cursor rgb boxColor ;
+    cursor 3list rgb boxColor ;
 
 : draw-current ( -- )
     output-line get sbuf>str draw-line ;
@@ -169,7 +169,7 @@ SYMBOL: redraw-console
     scrollbar-top
     width get
     scrollbar-bottom
-    black rgb boxColor ;
+    black 3list rgb boxColor ;
 
 : draw-console ( -- )
     [

library/ui/gadgets.factor

@@ -30,6 +30,20 @@ C: gadget ( shape -- gadget )
 : set-action ( gadget quot gesture -- )
     rot gadget-gestures set-hash ;
 
+: 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 ;
 

library/ui/hand.factor

@@ -4,7 +4,7 @@ IN: gadgets
 USING: alien generic kernel lists math namespaces sdl sdl-event
 sdl-video ;
 
-DEFER: pick-up*
+DEFER: pick-up
 
 : pick-up-list ( point list -- gadget )
     dup [
@@ -27,7 +27,7 @@ DEFER: pick-up*
         gadget-children pick-up-list dup [
             2nip
         ] [
-            drop inside?
+            3drop t
         ] ifte
     ] [
         2drop f

library/ui/labels.factor

@@ -23,5 +23,5 @@ M: label draw-shape ( label -- )
     over shape-y y get +
     rot label-text
     >r font get lookup-font r>
-    color get 3unlist make-color
+    foreground get 3unlist make-color
     draw-string drop ;

library/ui/layouts.factor

@@ -6,23 +6,17 @@ USING: generic hashtables kernel lists math namespaces ;
 GENERIC: layout* ( gadget -- )
 M: gadget layout* drop ;
 
-: 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-paint [
-        dup gadget-children [ layout ] each
+            f over set-gadget-relayout?
-        layout*
+            dup gadget-children [ layout ] each
+            layout*
+        ] bind
     ] [
         drop
     ] ifte ;

library/ui/paint.factor

@@ -7,7 +7,14 @@ 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.
+
+! Colors are lists of three integers, 0..255.
+SYMBOL: foreground ! Used for text and outline shapes.
+SYMBOL: background ! Used for filled shapes.
+SYMBOL: bevel-1
+SYMBOL: bevel-2
+SYMBOL: bevel-up?
+
 SYMBOL: font  ! a list of two elements, a font name and size.
 
 : shape>screen ( shape -- x1 y1 x2 y2 )
@@ -16,15 +23,13 @@ SYMBOL: font  ! a list of two elements, a font name and size.
     [ dup shape-x swap shape-w + x get + ] keep
     dup shape-y swap shape-h + y get + ;
 
-: rgb-color ( -- rgba ) color get 3unlist rgb ;
-
 GENERIC: draw-shape ( obj -- )
 
 M: rectangle draw-shape drop ;
 
 M: point draw-shape ( point -- )
     >r surface get r> dup point-x swap point-y
-    rgb-color pixelColor ;
+    foreground get rgb pixelColor ;
 
 TUPLE: hollow-rect delegate ;
 
@@ -32,7 +37,8 @@ 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 ;
+    >r surface get r> shape>screen foreground get rgb
+    rectangleColor ;
 
 TUPLE: plain-rect delegate ;
 
@@ -40,7 +46,8 @@ 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 ;
+    >r surface get r> shape>screen background get rgb
+     boxColor ;
 
 : x1/x2/y1 ( #{ x1 y1 }# #{ x2 y2 }# -- x1 x2 y1 )
     >r >rect r> real swap ;
@@ -54,11 +61,17 @@ M: plain-rect draw-shape ( rect -- )
 : x2/y1/y2 ( #{ x1 y1 }# #{ x2 y2 }# -- x2 y1 y2 )
     >r imaginary r> >rect >r swap r> ;
 
+: bevel-up ( -- rgb )
+    bevel-up? get [ bevel-1 get ] [ bevel-2 get ] ifte rgb ;
+
+: bevel-down ( -- rgb )
+    bevel-up? get [ bevel-2 get ] [ bevel-1 get ] ifte rgb ;
+
 : (draw-bevel) ( #{ x1 y1 }# #{ x2 y2 }# -- )
-    surface get pick pick x1/x2/y1 240 240 240 rgb hlineColor
+    surface get pick pick x1/x2/y1 bevel-up   hlineColor
-    surface get pick pick x1/x2/y2 192 192 192 rgb hlineColor
+    surface get pick pick x1/x2/y2 bevel-down hlineColor
-    surface get pick pick x1/y1/y2 240 240 240 rgb vlineColor
+    surface get pick pick x1/y1/y2 bevel-up   vlineColor
-    surface get pick pick x2/y1/y2 192 192 192 rgb vlineColor
+    surface get pick pick x2/y1/y2 bevel-down vlineColor
     2drop ;
 
 TUPLE: bevel-rect delegate bevel ;
@@ -77,14 +90,6 @@ C: bevel-rect ( bevel x y w h -- rect )
 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 [ 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
@@ -95,9 +100,3 @@ M: bevel-rect draw-shape ( rect -- )
             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* ;

library/ui/shapes.factor

@@ -105,7 +105,3 @@ M: rectangle resize-shape ( w h rect -- )
 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 ;

library/ui/world.factor

@@ -10,14 +10,15 @@ sdl-video ;
 TUPLE: world running? hand delegate ;
 
 : <world-box> ( -- box )
-    0 0 0 0 <plain-rect> <everywhere> <gadget>
+    0 0 0 0 <plain-rect> <gadget> ;
-    dup [ 216 216 216 ] color set-paint-property ;
 
 C: world ( -- world )
     <world-box> over set-world-delegate
     t over set-world-running?
     dup <hand> over set-world-hand ;
 
+M: world inside? ( point world -- ? ) 2drop t ;
+
 : my-hand ( -- hand ) world get world-hand ;
 
 : draw-world ( -- )
@@ -25,7 +26,7 @@ C: world ( -- world )
         [
             f over set-gadget-redraw?
             dup draw-gadget
-            world-hand draw-gadget
+            dup gadget-paint [ world-hand draw-gadget ] bind
         ] with-surface
     ] [
         drop
@@ -35,25 +36,45 @@ DEFER: handle-event
 
 : layout-world world get layout ;
 
+: eat-events ( event -- )
+    #! Keep polling for events until there are no more events in
+    #! the queue; then block for the next event.
+    dup SDL_PollEvent [
+        dup handle-event eat-events
+    ] [
+        SDL_WaitEvent
+    ] ifte ;
+
 : run-world ( -- )
     world get world-running? [
-        <event> dup SDL_WaitEvent 1 = [
+        layout-world draw-world
-            handle-event layout-world draw-world run-world
+        <event> dup eat-events [
+            handle-event run-world
         ] [
             drop
         ] ifte
     ] when ;
 
-: init-world ( w h -- )
+: start-world ( -- )
-    t world get set-world-running?
-    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
+    t world get set-world-running?
-    default-paint [ [ run-world ] with-screen ] bind ;
+    world get shape-w world get shape-h 0 SDL_RESIZABLE
+    [
+        0 x set
+        0 y set
+        [ run-world ] with-screen
+    ] with-scope ;
 
-global [ <world> world set ] bind
+global [
+    <world> world set
+    640 480 world get resize-gadget
+    {{
+        [[ background [ 216 216 216 ] ]]
+        [[ foreground [ 0 0 0 ] ]]
+        [[ bevel-1    [ 240 240 240 ] ]]
+        [[ bevel-2    [ 192 192 192 ] ]]
+        [[ bevel-up?  t ]]
+        [[ font       [[ "Monospaced" 12 ]] ]]
+    }} world get set-gadget-paint
+] bind