remove paint namespace binding in ui

library/styles.factor

@@ -1,25 +1,21 @@
 ! Copyright (C) 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: styles
-USING: kernel namespaces ;
 
-! Colors are lists of three integers, 0..255.
+! Colors are RGB triples.
+: black [ 0   0   0   ] ;
+: gray  [ 128 128 128 ] ;
+: white [ 255 255 255 ] ;
+: red   [ 255 0   0   ] ;
+: green [ 0   255 0   ] ;
+: blue  [ 0   0   255 ] ;
+
 SYMBOL: foreground ! Used for text and outline shapes.
 SYMBOL: background ! Used for filled shapes.
 SYMBOL: rollover-bg
 SYMBOL: rollover
 SYMBOL: reverse-video
 
-: fg ( -- color )
-    reverse-video get background foreground ? get ;
-
-: bg ( -- color )
-    reverse-video get [
-        foreground
-    ] [
-        rollover get rollover-bg background ?
-    ] ifte get ;
-
 SYMBOL: font
 SYMBOL: font-size
 SYMBOL: font-style

library/ui/borders.factor

@@ -12,7 +12,7 @@ C: border ( child delegate size -- border )
     [ over [ add-gadget ] [ 2drop ] ifte ] keep ;
 
 : line-border ( child -- border )
-    { 0 0 0 } dup <etched-rect> <gadget> { 5 5 0 } <border> ;
+    <etched-gadget> { 5 5 0 } <border> ;
 
 : layout-border-loc ( border -- )
     dup border-size swap gadget-child set-shape-loc ;

library/ui/colors.factor

@@ -1,8 +0,0 @@
-IN: gadgets
-
-: black [ 0   0   0   ] ;
-: gray  [ 128 128 128 ] ;
-: white [ 255 255 255 ] ;
-: red   [ 255 0   0   ] ;
-: green [ 0   255 0   ] ;
-: blue  [ 0   0   255 ] ;

library/ui/editors.factor

@@ -67,7 +67,7 @@ TUPLE: editor line caret ;
     <plain-gadget> dup red background set-paint-prop ;
 
 C: editor ( text -- )
-    <empty-gadget> over set-delegate
+    <gadget> over set-delegate
     [ <line-editor> swap set-editor-line ] keep
     [ <caret> swap set-editor-caret ] keep
     [ set-editor-text ] keep
@@ -93,6 +93,5 @@ M: editor layout* ( editor -- )
     dup editor-caret over caret-dim swap set-gadget-dim
     dup editor-caret swap caret-loc swap set-shape-loc ;
 
-M: editor draw-shape ( editor -- )
-    [ dup gadget-font swap editor-text ] keep
-    [ draw-string ] with-trans ;
+M: editor draw-gadget* ( editor -- )
+    dup editor-text over [ draw-string ] with-trans ;

library/ui/frames.factor

@@ -20,12 +20,12 @@ TUPLE: frame left right top bottom center ;
     dup frame-bottom unparent 2dup set-frame-bottom add-gadget ;
 
 C: frame ( -- frame )
-    [ <empty-gadget> swap set-delegate ] keep
-    [ <empty-gadget> swap set-frame-center ] keep
-    [ <empty-gadget> swap set-frame-left ] keep
-    [ <empty-gadget> swap set-frame-right ] keep
-    [ <empty-gadget> swap set-frame-top ] keep
-    [ <empty-gadget> swap set-frame-bottom ] keep ;
+    [ <gadget> swap set-delegate ] keep
+    [ <gadget> swap set-frame-center ] keep
+    [ <gadget> swap set-frame-left ] keep
+    [ <gadget> swap set-frame-right ] keep
+    [ <gadget> swap set-frame-top ] keep
+    [ <gadget> swap set-frame-bottom ] keep ;
 
 : frame-major ( frame -- list )
     [

library/ui/gadgets.factor

@@ -11,16 +11,18 @@ TUPLE: gadget paint gestures relayout? root? parent children ;
 
 : gadget-child gadget-children car ;
 
-C: gadget ( shape -- gadget )
-    [ set-delegate ] keep
+C: gadget ( -- gadget )
+    { 0 0 0 } dup <rectangle> over set-delegate
     <namespace> over set-gadget-paint
     <namespace> over set-gadget-gestures ;
 
-: <empty-gadget> ( -- gadget )
-    { 0 0 0 } dup <rectangle> <gadget> ;
+TUPLE: plain-gadget ;
 
-: <plain-gadget> ( -- gadget )
-    { 0 0 0 } dup <plain-rect> <gadget> ;
+C: plain-gadget <gadget> over set-delegate ;
+
+TUPLE: etched-gadget ;
+
+C: etched-gadget <gadget> over set-delegate ;
 
 DEFER: add-invalid
 
@@ -50,20 +52,6 @@ DEFER: add-invalid
     2dup shape-dim =
     [ 2drop ] [ [ set-shape-dim ] keep relayout-down ] ifte ;
 
-: paint-prop ( gadget key -- value )
-    over [
-        dup pick gadget-paint hash* dup [
-            2nip cdr
-        ] [
-            drop >r gadget-parent r> paint-prop
-        ] ?ifte
-    ] [
-        2drop f
-    ] ifte ;
-
-: set-paint-prop ( gadget value key -- )
-    rot gadget-paint set-hash ;
-
 GENERIC: pref-dim ( gadget -- dim )
 
 M: gadget pref-dim shape-dim ;

library/ui/hand.factor

@@ -38,7 +38,7 @@ DEFER: pick-up
 TUPLE: hand click-loc click-rel clicked buttons gadget focus ;
 
 C: hand ( world -- hand )
-    <empty-gadget> over set-delegate
+    <gadget> over set-delegate
     [ set-gadget-parent ] 2keep
     [ set-hand-gadget ] keep ;
 

library/ui/hierarchy.factor

@@ -25,35 +25,19 @@ sequences ;
     #! Add a gadget to a parent gadget.
     [ (add-gadget) ] keep relayout ;
 
-: (parents) ( gadget -- )
-    [ dup gadget-parent (parents) , ] when* ;
-
 : parents ( gadget -- list )
-    #! A list of all parents of the gadget, including the
-    #! gadget itself.
-    [ (parents) ] make-list ;
-
-: (each-parent) ( list quot -- ? )
-    over [
-        over car gadget-paint [
-            2dup >r >r >r cdr r> (each-parent) [
-                r> car r> call
-            ] [
-                r> r> 2drop f
-            ] ifte
-        ] bind
-    ] [
-        2drop t
-    ] ifte ; inline
+    #! A list of all parents of the gadget, the first element
+    #! is the gadget itself.
+    dup [ dup gadget-parent parents cons ] when ;
 
 : each-parent ( gadget quot -- ? )
     #! Keep executing the quotation on higher and higher
     #! parents until it returns f.
-    >r parents r> (each-parent) ; inline
+    >r parents r> all? ; inline
 
 : screen-loc ( gadget -- point )
     #! The position of the gadget on the screen.
-    { 0 0 0 } swap [ shape-loc v+ t ] each-parent drop ;
+    parents { 0 0 0 } [ shape-loc v+ ] reduce ;
 
 : relative ( g1 g2 -- g2-g1 )
     screen-loc swap screen-loc v- ;

library/ui/init-world.factor

@@ -27,7 +27,9 @@ USING: generic io kernel listener math namespaces styles threads ;
         
         [ [ clear  print-banner listener ] with-stream ] in-thread
         
-        request-focus
+        dup request-focus
+        
+        pane set
     ] bind ;
 
 SYMBOL: first-time

library/ui/labels.factor

@@ -8,7 +8,7 @@ sequences styles vectors ;
 TUPLE: label text ;
 
 C: label ( text -- label )
-    <empty-gadget> over set-delegate [ set-label-text ] keep ;
+    <gadget> over set-delegate [ set-label-text ] keep ;
 
 : label-size ( gadget text -- dim )
     >r gadget-font r> size-string 0 3vector ;
@@ -16,6 +16,5 @@ C: label ( text -- label )
 M: label pref-dim ( label -- dim )
     dup label-text label-size ;
 
-M: label draw-shape ( label -- )
-    [ dup gadget-font swap label-text ] keep
-    [ draw-string ] with-trans ;
+M: label draw-gadget* ( label -- )
+    dup label-text over [ draw-string ] with-trans ;

library/ui/layouts.factor

@@ -11,10 +11,8 @@ namespaces sdl sequences ;
     #! be laid out.
     dup gadget-relayout? [
         f over set-gadget-relayout?
-        dup gadget-paint [
         dup layout*
         gadget-children [ layout ] each
-        ] bind
     ] [
         drop
     ] ifte ;
@@ -63,7 +61,7 @@ C: pack ( align fill vector -- pack )
     #! align: 0 left aligns, 1/2 center, 1 right.
     #! gap: between each child.
     #! fill: 0 leaves default width, 1 fills to pack width.
-    [ <empty-gadget> swap set-delegate ] keep
+    [ <gadget> swap set-delegate ] keep
     [ set-pack-vector ] keep
     [ set-pack-fill ] keep
     [ set-pack-align ] keep ;

library/ui/load.factor

@@ -1,8 +1,6 @@
 USING: kernel parser sequences io ;
 [
-    "/library/ui/colors.factor"
     "/library/ui/shapes.factor"
-    "/library/ui/rectangles.factor"
     "/library/ui/gadgets.factor"
     "/library/ui/hierarchy.factor"
     "/library/ui/paint.factor"

library/ui/paint.factor

@@ -2,7 +2,7 @@
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: gadgets
 USING: generic hashtables io kernel lists math matrices
-namespaces sdl sequences strings ;
+namespaces sdl sequences strings styles ;
 
 SYMBOL: clip
 
@@ -26,16 +26,54 @@ SYMBOL: clip
         r> call
     ] with-scope ; inline
 
+GENERIC: draw-gadget* ( gadget -- )
+
 : 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.
-    dup gadget-paint [
     dup [
         [
-                dup draw-shape dup [
+            dup draw-gadget* dup [
                 gadget-children [ draw-gadget ] each
             ] with-trans
         ] [ drop ] ifte
-        ] with-clip
-    ] bind ;
+    ] with-clip ;
+
+M: gadget draw-gadget* ( gadget -- ) drop ;
+
+: paint-prop ( gadget key -- value )
+    over [
+        dup pick gadget-paint hash* dup [
+            2nip cdr
+        ] [
+            drop >r gadget-parent r> paint-prop
+        ] ?ifte
+    ] [
+        2drop f
+    ] ifte ;
+
+: set-paint-prop ( gadget value key -- )
+    rot gadget-paint set-hash ;
+
+: fg ( gadget -- color )
+    dup reverse-video paint-prop
+    background foreground ? paint-prop ;
+
+: bg ( gadget -- color )
+    dup reverse-video paint-prop [
+        foreground
+    ] [
+        dup rollover paint-prop rollover-bg background ?
+    ] ifte paint-prop ;
+
+: plain-rect ( shape -- )
+    #! Draw a filled rect with the bounds of an arbitrary shape.
+    [ rect>screen ] keep bg rgb boxColor ;
+
+M: plain-gadget draw-gadget* ( gadget -- )
+    >r surface get r> plain-rect ;
+
+: hollow-rect ( shape -- )
+    #! Draw a hollow rect with the bounds of an arbitrary shape.
+    [ rect>screen >r 1 - r> 1 - ] keep fg rgb rectangleColor ;
+
+M: etched-gadget draw-gadget* ( gadget -- )
+    >r surface get r> 2dup plain-rect hollow-rect ;

library/ui/rectangles.factor

@@ -1,69 +0,0 @@
-! Copyright (C) 2005 Slava Pestov.
-! See http://factor.sf.net/license.txt for BSD license.
-IN: gadgets
-USING: generic kernel lists math matrices namespaces sdl styles
-vectors ;
-
-TUPLE: rectangle loc dim ;
-
-M: rectangle shape-loc rectangle-loc ;
-M: rectangle set-shape-loc set-rectangle-loc ;
-
-M: rectangle shape-dim rectangle-dim ;
-M: rectangle set-shape-dim set-rectangle-dim ;
-
-: screen-bounds ( shape -- rect )
-    shape-bounds >r origin v+ r> <rectangle> ;
-
-M: rectangle inside? ( loc rect -- ? )
-    screen-bounds shape-bounds { 1 1 1 } v- { 0 0 0 } vmax
-    >r v- { 0 0 0 } r> vbetween? conj ;
-
-M: rectangle draw-shape drop ;
-
-: intersect ( shape shape -- rect )
-    >r shape-extent r> shape-extent
-    swapd vmin >r vmax dup r> swap v- { 0 0 0 } vmax
-    <rectangle> ;
-
-: rect>screen ( shape -- x1 y1 x2 y2 )
-    [ shape-x x get + ] keep
-    [ shape-y y get + ] keep
-    [ shape-w pick + ] keep
-    shape-h pick + ;
-
-! A rectangle only whose outline is visible.
-TUPLE: hollow-rect ;
-
-C: hollow-rect ( loc dim -- rect )
-    [ >r <rectangle> r> set-delegate ] keep ;
-
-: hollow-rect ( shape -- )
-    #! Draw a hollow rect with the bounds of an arbitrary shape.
-    rect>screen >r 1 - r> 1 - fg rgb rectangleColor ;
-
-M: hollow-rect draw-shape ( rect -- )
-    >r surface get r> hollow-rect ;
-
-! A rectangle that is filled.
-TUPLE: plain-rect ;
-
-C: plain-rect ( loc dim -- rect )
-    [ >r <rectangle> r> set-delegate ] keep ;
-
-: plain-rect ( shape -- )
-    #! Draw a filled rect with the bounds of an arbitrary shape.
-    rect>screen bg rgb boxColor ;
-
-M: plain-rect draw-shape ( rect -- )
-    >r surface get r> plain-rect ;
-
-! A rectangle that is filled with the background color and also
-! has an outline.
-TUPLE: etched-rect ;
-
-C: etched-rect ( loc dim -- rect )
-    [ >r <rectangle> r> set-delegate ] keep ;
-
-M: etched-rect draw-shape ( rect -- )
-    >r surface get r> 2dup plain-rect hollow-rect ;

library/ui/scrolling.factor

@@ -17,7 +17,7 @@ TUPLE: viewport origin ;
     [ fix-scroll ] keep [ set-viewport-origin ] keep relayout ;
 
 C: viewport ( content -- viewport )
-    <empty-gadget> over set-delegate
+    <gadget> over set-delegate
     t over set-gadget-root?
     [ add-gadget ] keep
     { 0 0 0 } over set-viewport-origin ;

library/ui/shapes.factor

@@ -20,8 +20,6 @@ GENERIC: set-shape-dim ( dim shape -- )
 : shape-w shape-dim first ;
 : shape-h shape-dim second ;
 
-GENERIC: draw-shape ( shape -- )
-
 : with-trans ( shape quot -- )
     #! All drawing done inside the quotation is translated
     #! relative to the shape's origin.
@@ -47,3 +45,29 @@ GENERIC: draw-shape ( shape -- )
 
 M: vector shape-loc ;
 M: vector shape-dim drop { 0 0 0 } ;
+
+TUPLE: rectangle loc dim ;
+
+M: rectangle shape-loc rectangle-loc ;
+M: rectangle set-shape-loc set-rectangle-loc ;
+
+M: rectangle shape-dim rectangle-dim ;
+M: rectangle set-shape-dim set-rectangle-dim ;
+
+: screen-bounds ( shape -- rect )
+    shape-bounds >r origin v+ r> <rectangle> ;
+
+M: rectangle inside? ( loc rect -- ? )
+    screen-bounds shape-bounds { 1 1 1 } v- { 0 0 0 } vmax
+    >r v- { 0 0 0 } r> vbetween? conj ;
+
+: intersect ( shape shape -- rect )
+    >r shape-extent r> shape-extent
+    swapd vmin >r vmax dup r> swap v- { 0 0 0 } vmax
+    <rectangle> ;
+
+: rect>screen ( shape -- x1 y1 x2 y2 )
+    [ shape-x x get + ] keep
+    [ shape-y y get + ] keep
+    [ shape-w pick + ] keep
+    shape-h pick + ;

library/ui/text.factor

@@ -27,11 +27,12 @@ strings styles io ;
         swap *int swap *int
     ] ifte ;
 
-: draw-string ( font text -- )
+: draw-string ( gadget text -- )
     filter-nulls dup empty? [
         2drop
     ] [
-        fg 3unlist make-color
+        >r [ gadget-font ] keep r> swap
+        [ fg 3unlist make-color ] keep
         bg 3unlist make-color
         TTF_RenderUNICODE_Shaded
         [ >r x get y get r> draw-surface ] keep

library/ui/world.factor

@@ -36,7 +36,7 @@ C: world ( -- world )
 
 : show-glass ( gadget -- )
     hide-glass
-    <empty-gadget> dup
+    <gadget> dup
     world get 2dup add-gadget set-world-glass
     dupd add-gadget prefer ;
 
@@ -47,9 +47,7 @@ M: world inside? ( point world -- ? ) 2drop t ;
 : draw-world ( world -- )
     [
         dup
-        { 0 0 0 }
-        width get height get 0 3vector <rectangle>
-        clip set-paint-prop
+        { 0 0 0 } width get height get 0 3vector <rectangle> clip set
         draw-gadget
     ] with-surface ;