removed remaining 2-dimensional point code from UI, minor enhancements to matrices library

library/collections/sequences.factor

@@ -62,6 +62,9 @@ DEFER: subseq
 : third 2 swap nth ; inline
 : fourth 3 swap nth ; inline
 
+: 2unseq ( { x y } -- x y )
+    dup first swap second ;
+
 : 3unseq ( { x y z } -- x y z )
     dup first over second rot third ;
 

library/math/matrices.factor

@@ -14,19 +14,31 @@ vectors ;
 : v- ( v v -- v ) [ - ] 2map ;
 : v* ( v v -- v ) [ * ] 2map ;
 : v/ ( v v -- v ) [ / ] 2map ;
-: v** ( v v -- v ) [ conjugate * ] 2map ;
+: vand ( v v -- v ) [ and ] 2map ;
+: vor ( v v -- v ) [ or ] 2map ;
 : vmax ( v v -- v ) [ max ] 2map ;
 : vmin ( v v -- v ) [ min ] 2map ;
+: v< ( v v -- v ) [ < ] 2map ;
+: v<= ( v v -- v ) [ <= ] 2map ;
+: v> ( v v -- v ) [ > ] 2map ;
+: v>= ( v v -- v ) [ >= ] 2map ;
+
+: vbetween? ( v from to -- v )
+    >r over >r v>= r> r> v<= vand ;
+
 : vneg ( v -- v ) [ neg ] map ;
 
 : sum ( v -- n ) 0 [ + ] reduce ;
 : product 1 [ * ] reduce ;
+: conj ( v -- ? ) t [ and ] reduce ;
+: disj ( v -- ? ) f [ or ] reduce ;
 
 : set-axis ( x y axis -- v )
     2dup v* >r >r drop dup r> v* v- r> v+ ;
 
 ! Later, this will fixed when 2each works properly
 ! : v. ( v v -- x ) 0 swap [ conjugate * + ] 2each ;
+: v** ( v v -- v ) [ conjugate * ] 2map ;
 : v. ( v v -- x ) v** sum ;
 
 : norm-sq ( v -- n ) 0 [ absq + ] reduce ;

library/test/gadgets.factor

@@ -1,82 +0,0 @@
-IN: temporary
-USING: gadgets kernel lists math namespaces test sequences ;
-
-[ t ] [
-    [
-        2000 x set
-        2000 y set
-        2030 2040 rect> 10 20 300 400 <rectangle> inside?
-    ] with-scope
-] unit-test
-[ f ] [
-    [
-        2000 x set
-        2000 y set
-        2500 2040 rect> 10 20 300 400 <rectangle> inside?
-    ] with-scope
-] unit-test
-[ t ] [
-    [
-        -10 x set
-        -20 y set
-        0 0 rect> 10 20 300 400 <rectangle> inside?
-    ] with-scope
-] unit-test
-[ 11 11 41 41 ] [
-    [
-        1 x set
-        1 y set
-        10 10 30 30 <rectangle> <gadget> rect>screen
-    ] with-scope
-] unit-test
-[ t ] [
-    [
-        0 x set
-        0 y set
-        0 0 rect> -10 -10 20 20 <rectangle> <gadget> [ pick-up ] keep =
-    ] with-scope
-] unit-test
-
-: funny-rect ( x -- rect )
-    10 10 30 <rectangle> <gadget>
-    dup [ 255 0 0 ] foreground set-paint-prop ;
-    
-[ f ] [
-    [
-        0 x set
-        0 y set
-        35 0 rect>
-        [ 10 30 50 70 ] [ funny-rect ] map
-        pick-up-list
-    ] with-scope
-] unit-test
-
-[ -90 ] [ 10 10 -100 -200 <line> shape-x ] unit-test
-[ 20 ] [ 10 10 100 200 <line> [ 20 30 rot move-shape ] keep shape-x ] unit-test
-[ 30 ] [ 10 10 100 200 <line> [ 20 30 rot move-shape ] keep shape-y ] unit-test
-[ 20 ] [ 110 110 -100 -200 <line> [ 20 30 rot move-shape ] keep shape-x ] unit-test
-[ 30 ] [ 110 110 -100 -200 <line> [ 20 30 rot move-shape ] keep shape-y ] unit-test
-[ 10 ] [ 110 110 -100 -200 <line> [ 400 400 rot resize-shape ] keep shape-x ] unit-test
-[ 400 ] [ 110 110 -100 -200 <line> [ 400 400 rot resize-shape ] keep shape-w ] unit-test
-
-[ t ] [
-    [
-        100 x set
-        100 y set
-        #{ 110 115 }# << line f 0 0 100 150 >> inside?
-    ] with-scope
-] unit-test
-
-[ ] [ "pile" get layout* ] unit-test
-
-[
-    1 15
-] [
-    1 15 << line [ ] 0 0 0 14 >> [ resize-shape ] keep shape-size
-] unit-test
-
-[
-    1 15
-] [
-    1 15 << line [ ] 0 22 -1 14 >> [ resize-shape ] keep shape-size
-] unit-test

library/test/math/matrices.factor

@@ -136,3 +136,11 @@ unit-test
     M[ [ 1 2 3 ] [ 4 5 6 ] [ 7 8 9 ] ]M
     5 [ 2 - swap <diagonal> ] project-with [ >list ] map
 ] unit-test
+
+[ { t t t } ]
+[ { 1 2 3 } { -1 -2 -3 } { 4 5 6 } vbetween? ]
+unit-test
+
+[ { t f t } ]
+[ { 1 10 3 } { -1 -2 -3 } { 4 5 6 } vbetween? ]
+unit-test

library/test/test.factor

@@ -91,7 +91,7 @@ SYMBOL: failures
         "crashes" "sbuf" "threads" "parsing-word"
         "inference" "interpreter"
         "alien"
-        "line-editor" "gadgets" "memory" "redefine"
+        "line-editor" "gadgets/rectangles" "memory" "redefine"
         "annotate" "sequences" "binary" "inspector"
     ] run-tests ;
 

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 0 <etched-rect> <gadget> { 5 5 0 } <border> ;
+    { 0 0 0 } dup <etched-rect> <gadget> { 5 5 0 } <border> ;
 
 : layout-border-loc ( border -- )
     dup border-size swap gadget-child set-shape-loc ;

library/ui/editors.factor

@@ -27,28 +27,27 @@ TUPLE: editor line caret ;
 : unfocus-editor ( editor -- )
     editor-caret unparent ;
 
-: run-char-widths ( str -- wlist )
+: run-char-widths ( font str -- wlist )
     #! List of x co-ordinates of each character.
-    0 swap >list
+    >list [ ch>string size-string drop ] map-with
-    [ ch>string shape-w [ + dup ] keep 2 /i - ] map nip ;
+    dup 0 [ + ] accumulate swap 2 v/n v+ ;
 
 : (x>offset) ( n x wlist -- offset )
     dup [
-        uncons >r over > [
+        uncons >r over >
-            r> 2drop
+        [ r> 2drop ] [ >r 1 + r> r> (x>offset) ] ifte
-        ] [
-            >r 1 + r> r> (x>offset)
-        ] ifte
     ] [
         2drop
     ] ifte ;
 
-: x>offset ( x str -- offset )
+: x>offset ( x font str -- offset )
-    0 -rot run-char-widths (x>offset) ;
+    run-char-widths 0 -rot (x>offset) ;
 
 : set-caret-x ( x editor -- )
     #! Move the caret to a clicked location.
-    [ line-text get x>offset caret set ] with-editor ;
+    dup [
+        gadget-font line-text get x>offset caret set
+    ] with-editor ;
 
 : click-editor ( editor -- )
     dup hand relative shape-x over set-caret-x request-focus ;

library/ui/events.factor

@@ -29,11 +29,11 @@ M: button-up-event handle-event ( event -- )
     button-event-button dup hand button\
     [ button-up ] button-gesture ;
 
-: motion-event-pos ( event -- x y )
+: motion-event-loc ( event -- loc )
-    dup motion-event-x swap motion-event-y ;
+    dup motion-event-x swap motion-event-y 0 3vector ;
 
 M: motion-event handle-event ( event -- )
-    motion-event-pos hand move-hand ;
+    motion-event-loc hand move-hand ;
 
 M: key-down-event handle-event ( event -- )
     dup keyboard-event>binding

library/ui/frames.factor

@@ -82,6 +82,9 @@ SYMBOL: frame-bottom-run
     dup var-frame-right
     var-frame-bottom ;
 
+: move-gadget ( x y gadget -- )
+    >r 0 3vector r> set-shape-loc ;
+
 : reshape-gadget ( x y w h gadget -- )
     [ >r 0 3vector r> set-gadget-dim ] keep move-gadget ;
 

library/ui/gadgets.factor

@@ -16,9 +16,11 @@ C: gadget ( shape -- gadget )
     <namespace> over set-gadget-paint
     <namespace> over set-gadget-gestures ;
 
-: <empty-gadget> ( -- gadget ) 0 0 0 0 <rectangle> <gadget> ;
+: <empty-gadget> ( -- gadget )
+    { 0 0 0 } dup <rectangle> <gadget> ;
 
-: <plain-gadget> ( -- gadget ) 0 0 0 0 <plain-rect> <gadget> ;
+: <plain-gadget> ( -- gadget )
+    { 0 0 0 } dup <plain-rect> <gadget> ;
 
 DEFER: add-invalid
 
@@ -44,9 +46,6 @@ DEFER: add-invalid
     #! Relayout a gadget and its children.
     dup add-invalid (relayout-down) ;
 
-: move-gadget ( x y gadget -- )
-    >r 0 3vector r> set-shape-loc ;
-
 : set-gadget-dim ( dim gadget -- )
     2dup shape-dim =
     [ 2drop ] [ [ set-shape-dim ] keep relayout-down ] ifte ;
@@ -73,9 +72,7 @@ GENERIC: layout* ( gadget -- )
 
 : prefer ( gadget -- ) dup pref-dim swap set-gadget-dim ;
 
-M: gadget layout*
+M: gadget layout* drop ;
-    #! Trivial layout gives each child its preferred size.
-    gadget-children [ prefer ] each ;
 
 GENERIC: user-input* ( ch gadget -- ? )
 

library/ui/gestures.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: gadgets
-USING: alien generic hashtables kernel lists math sdl
+USING: alien generic hashtables kernel lists math matrices sdl
 sequences ;
 
 : action ( gadget gesture -- quot )
@@ -14,11 +14,8 @@ sequences ;
     swap [ unswons set-action ] each-with ;
 
 : handle-gesture* ( gesture gadget -- ? )
-    tuck gadget-gestures hash* dup [
+    tuck gadget-gestures hash* dup
-        cdr call f
+    [ cdr call f ] [ 2drop t ] ifte ;
-    ] [
-        2drop t
-    ] ifte ;
 
 : handle-gesture ( gesture gadget -- ? )
     #! If a gadget's handle-gesture* generic returns t, the
@@ -41,18 +38,14 @@ SYMBOL: button-up
 SYMBOL: button-down
 
 : hierarchy-gesture ( gadget ? gesture -- ? )
-    swap [
+    swap [ 2drop f ] [ swap handle-gesture* drop t ] ifte ;
-        2drop f
-    ] [
-        swap handle-gesture* drop t
-    ] ifte ;
 
 : mouse-enter ( point gadget -- )
     #! If the old point is inside the new gadget, do not fire an
     #! enter gesture, since the mouse did not enter. Otherwise,
     #! fire an enter gesture and go on to the parent.
     [
-        [ shape-pos + ] keep
+        [ shape-loc v+ ] keep
         2dup inside? [ mouse-enter ] hierarchy-gesture
     ] each-parent 2drop ;
 
@@ -61,7 +54,7 @@ SYMBOL: button-down
     #! leave gesture, since the mouse did not leave. Otherwise,
     #! fire a leave gesture and go on to the parent.
     [
-        [ shape-pos + ] keep
+        [ shape-loc v+ ] keep
         2dup inside? [ mouse-leave ] hierarchy-gesture
     ] each-parent 2drop ;
 

library/ui/hand.factor

@@ -1,18 +1,15 @@
 ! Copyright (C) 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: gadgets
-USING: alien generic io kernel lists math namespaces prettyprint
+USING: alien generic io kernel lists math matrices namespaces
-sdl sequences vectors ;
+prettyprint sdl sequences vectors ;
 
 DEFER: pick-up
 
 : pick-up-list ( point list -- gadget )
     dup [
-        2dup car pick-up dup [
+        2dup car pick-up dup
-            2nip
+        [ 2nip ] [ drop cdr pick-up-list ] ifte
-        ] [
-            drop cdr pick-up-list
-        ] ifte
     ] [
         2drop f
     ] ifte ;
@@ -24,11 +21,8 @@ DEFER: pick-up
     #! box delegate.
     2dup inside? [
         2dup [ translate ] keep
-        gadget-children reverse pick-up-list dup [
+        gadget-children reverse pick-up-list dup
-            2nip
+        [ 2nip ] [ 3drop t ] ifte
-        ] [
-            3drop t
-        ] ifte
     ] [
         2drop f
     ] ifte ;
@@ -45,13 +39,13 @@ DEFER: pick-up
 ! - hand-gadget is the gadget under the mouse position
 ! - hand-clicked is the most recently clicked gadget
 ! - hand-focus is the gadget holding keyboard focus
-TUPLE: hand world
+TUPLE: hand
+    world
     click-loc click-rel clicked buttons
     gadget focus ;
 
 C: hand ( world -- hand )
-    <empty-gadget>
+    <empty-gadget> over set-delegate
-    over set-delegate
     [ set-hand-world ] 2keep
     [ set-gadget-parent ] 2keep
     [ set-hand-gadget ] keep ;
@@ -66,10 +60,10 @@ C: hand ( world -- hand )
     [ hand-buttons remove ] keep set-hand-buttons ;
 
 : fire-leave ( hand gadget -- )
-    [ swap shape-pos swap screen-pos - ] keep mouse-leave ;
+    [ swap shape-loc swap screen-loc v- ] keep mouse-leave ;
 
 : fire-enter ( oldpos hand -- )
-    hand-gadget [ screen-pos - ] keep mouse-enter ;
+    hand-gadget [ screen-loc v- ] keep mouse-enter ;
 
 : update-hand-gadget ( hand -- )
     dup dup hand-world pick-up swap set-hand-gadget ;
@@ -83,15 +77,12 @@ C: hand ( world -- hand )
     #! and if a mouse button is down, fire a drag gesture to the
     #! gadget that was clicked.
     [ motion ] over hand-gadget handle-gesture drop
-    dup hand-buttons [
+    dup hand-buttons
-        dup hand-clicked [ drag ] motion-gesture
+    [ dup hand-clicked [ drag ] motion-gesture ] [ drop ] ifte ;
-    ] [
-        drop
-    ] ifte ;
 
-: move-hand ( x y hand -- )
+: move-hand ( loc hand -- )
-    dup shape-pos >r
+    dup shape-loc >r
-    [ move-gadget ] keep
+    [ set-shape-loc ] keep
     dup hand-gadget >r
     dup update-hand-gadget
     dup r> fire-leave
@@ -100,7 +91,7 @@ C: hand ( world -- hand )
 
 : update-hand ( hand -- )
     #! Called when a gadget is removed or added.
-    [ dup shape-x swap shape-y ] keep move-hand ;
+    dup shape-loc swap move-hand ;
 
 : request-focus ( gadget -- )
     focusable-child

library/ui/hierarchy.factor

@@ -51,10 +51,6 @@ sequences ;
     #! parents until it returns f.
     >r parents r> (each-parent) ; inline
 
-: screen-pos ( gadget -- point )
-    #! The position of the gadget on the screen.
-    0 swap [ shape-pos + t ] each-parent drop ;
-
 : screen-loc ( gadget -- point )
     #! The position of the gadget on the screen.
     { 0 0 0 } swap [ shape-loc v+ t ] each-parent drop ;

library/ui/init-world.factor

@@ -25,7 +25,7 @@ USING: generic io kernel listener math namespaces styles threads ;
         
         <scroller> "Stack display goes here" <label> 3/4 <y-splitter> add-layer
         
-        dup [ [ clear  print-banner listener ] in-thread ] with-stream
+        [ [ clear  print-banner listener ] with-stream ] in-thread
         
         request-focus
     ] bind ;

library/ui/line-editor.factor

@@ -1,37 +1,7 @@
-! :folding=indent:collapseFolds=1:
-
-! $Id$
-!
 ! Copyright (C) 2005 Slava Pestov.
-! 
+! See http://factor.sf.net/license.txt for BSD license.
-! Redistribution and use in source and binary forms, with or without
-! modification, are permitted provided that the following conditions are met:
-! 
-! 1. Redistributions of source code must retain the above copyright notice,
-!    this list of conditions and the following disclaimer.
-! 
-! 2. Redistributions in binary form must reproduce the above copyright notice,
-!    this list of conditions and the following disclaimer in the documentation
-!    and/or other materials provided with the distribution.
-! 
-! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
-! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
-! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
-! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
-! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
-! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
-! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
-! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
-! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-
 IN: line-editor
-USE: namespaces
+USING: kernel math namespaces sequences strings vectors ;
-USE: strings
-USE: kernel
-USE: math
-USE: sequences
-USE: vectors
 
 SYMBOL: line-text
 SYMBOL: caret
@@ -52,7 +22,7 @@ SYMBOL: history-index
 : commit-history ( -- )
     #! Call this in the line editor scope. Adds the currently
     #! entered text to the history.
-    line-text get dup "" = [
+    line-text get dup empty? [
         drop
     ] [
         history-index get history get set-nth

library/ui/load.factor

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

library/ui/menus.factor

@@ -4,9 +4,7 @@ IN: gadgets
 USING: generic kernel lists math namespaces sequences ;
 
 : show-menu ( menu -- )
-    hide-glass
+    hand screen-loc over set-shape-loc show-glass ;
-    hand screen-loc over set-shape-loc
-    show-glass ;
 
 : menu-item-border ( child -- border )
     <plain-gadget> { 1 1 0 } <border> ;

library/ui/paint.factor

@@ -1,54 +1,21 @@
 ! Copyright (C) 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: gadgets
-USING: generic hashtables kernel lists math namespaces sdl
+USING: generic hashtables io kernel lists math matrices
-io strings sequences ;
+namespaces sdl sequences strings ;
-
-! Clipping
 
 SYMBOL: clip
 
-: intersect* ( gadget rect quot -- t1 t2 )
-    call >r >r max r> r> min 2dup > [ drop dup ] when ; inline
-
-: intersect-x ( gadget rect -- x1 x2 )
-    [
-        0 rectangle-x-extents >r swap 0 rectangle-x-extents r>
-    ] intersect* ;
-
-: intersect-y ( gadget rect -- y1 y2 )
-    [
-        0 rectangle-y-extents >r swap 0 rectangle-y-extents r>
-    ] intersect* ;
-
-: screen-bounds ( shape -- rect )
-    [ shape-x x get + ] keep
-    [ shape-y y get + ] keep
-    [ shape-w ] keep
-    shape-h
-    <rectangle> ;
-
-: clip-rect ( x1 x2 y1 y2 -- rect )
-    over - 0 max >r >r over - 0 max r> swap r>
-    <rectangle> ;
-
-: intersect ( rect rect -- rect )
-    [ intersect-x ] 2keep intersect-y clip-rect ;
-
 : >sdl-rect ( rectangle -- sdlrect )
-    [ rectangle-x ] keep
+    [ shape-x ] keep [ shape-y ] keep [ shape-w ] keep shape-h
-    [ rectangle-y ] keep
-    [ rectangle-w ] keep
-    rectangle-h
     make-rect ;
 
 : set-clip ( rect -- ? )
     #! The top/left corner of the clip rectangle is the location
     #! of the gadget on the screen. The bottom/right is the
-    #! intersected clip rectangle. Return t if the clip region
+    #! intersected clip rectangle. Return f if the clip region
     #! is an empty region.
-    surface get swap [ >sdl-rect SDL_SetClipRect drop ] keep
+    surface get swap >sdl-rect SDL_SetClipRect ;
-    dup shape-w 0 = swap shape-h 0 = or ;
 
 : with-clip ( shape quot -- )
     #! All drawing done inside the quotation is clipped to the
@@ -66,11 +33,9 @@ SYMBOL: clip
     dup gadget-paint [
         dup [
             [
-                drop
-            ] [
                 dup draw-shape dup [
                     gadget-children [ draw-gadget ] each
                 ] with-trans
-            ] ifte
+            ] [ drop ] ifte
         ] with-clip
     ] bind ;

library/ui/points.factor

@@ -1,25 +0,0 @@
-! Copyright (C) 2005 Slava Pestov.
-! See http://factor.sf.net/license.txt for BSD license.
-IN: gadgets
-USING: generic kernel lists math namespaces sdl sequences
-vectors ;
-
-M: number inside? ( point point -- )
-    >r shape-pos r> = ;
-
-M: number shape-x real ;
-M: number shape-y imaginary ;
-M: number shape-w drop 0 ;
-M: number shape-h drop 0 ;
-
-: translate ( point shape -- point )
-    #! Translate a point relative to the shape.
-    swap shape-pos swap shape-pos - ;
-
-M: vector inside? ( point point -- )
-    >r shape-loc r> = ;
-
-M: vector shape-x first ;
-M: vector shape-y second ;
-M: vector shape-w drop 0 ;
-M: vector shape-h drop 0 ;

library/ui/rectangles.factor

@@ -1,58 +1,41 @@
 ! Copyright (C) 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: gadgets
-USING: generic kernel lists math namespaces sdl styles ;
+USING: generic kernel lists math matrices namespaces sdl styles
+vectors ;
 
-! A rectangle maps trivially to the shape protocol.
+TUPLE: rectangle loc dim ;
-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 ;
 
-: rect>screen ( shape -- x1 y1 x2 y2 )
+M: rectangle shape-loc rectangle-loc ;
-    [ rectangle-x x get + ] keep
+M: rectangle set-shape-loc set-rectangle-loc ;
-    [ rectangle-y y get + ] keep
-    [ rectangle-w pick + ] keep
-    rectangle-h pick + ;
 
-: fix-neg ( a b c -- a+c b -c )
+M: rectangle shape-dim rectangle-dim ;
-    dup 0 < [ neg tuck >r >r + r> r> ] when ;
+M: rectangle set-shape-dim set-rectangle-dim ;
 
-C: rectangle ( x y w h -- rect )
+: screen-bounds ( shape -- rect )
-    #! We handle negative w/h for convinience.
+    shape-bounds >r origin v+ r> <rectangle> ;
-    >r fix-neg >r fix-neg r> r>
-    [ set-rectangle-h ] keep
-    [ set-rectangle-w ] keep
-    [ set-rectangle-y ] keep
-    [ set-rectangle-x ] keep ;
 
-M: rectangle move-shape ( x y rect -- )
+M: rectangle inside? ( loc rect -- ? )
-    tuck set-rectangle-y set-rectangle-x ;
+    screen-bounds shape-bounds
-
+    >r v- { 0 0 0 } r> vbetween? conj ;
-M: rectangle resize-shape ( w h rect -- )
-    tuck set-rectangle-h set-rectangle-w ;
-
-: rectangle-x-extents ( rect x0 -- x1 x2 )
-    >r dup shape-x r> + swap shape-w dupd + ;
-
-: rectangle-y-extents ( rect y0 -- y1 y2 )
-    >r dup shape-y r> + swap shape-h dupd + ;
-
-: inside-rect? ( point rect -- ? )
-    over shape-x over x get rectangle-x-extents 1 - between? >r
-    swap shape-y swap y get rectangle-y-extents 1 - between? r>
-    and ;
-
-M: rectangle inside? ( point rect -- ? )
-    inside-rect? ;
 
 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 ( x y w h -- rect )
+C: hollow-rect ( loc dim -- rect )
     [ >r <rectangle> r> set-delegate ] keep ;
 
 : hollow-rect ( shape -- )
@@ -65,7 +48,7 @@ M: hollow-rect draw-shape ( rect -- )
 ! A rectangle that is filled.
 TUPLE: plain-rect ;
 
-C: plain-rect ( x y w h -- rect )
+C: plain-rect ( loc dim -- rect )
     [ >r <rectangle> r> set-delegate ] keep ;
 
 : plain-rect ( shape -- )
@@ -79,7 +62,7 @@ M: plain-rect draw-shape ( rect -- )
 ! has an outline.
 TUPLE: etched-rect ;
 
-C: etched-rect ( x y w h -- rect )
+C: etched-rect ( loc dim -- rect )
     [ >r <rectangle> r> set-delegate ] keep ;
 
 M: etched-rect draw-shape ( rect -- )

library/ui/scrolling.factor

@@ -8,11 +8,6 @@ threads vectors styles ;
 
 TUPLE: viewport origin ;
 
-: viewport-x viewport-origin first ;
-: viewport-y viewport-origin second ;
-: set-viewport-x [ viewport-y 0 3vector ] keep set-viewport-origin ;
-: set-viewport-y [ viewport-x swap 0 3vector ] keep set-viewport-origin ;
-
 : viewport-dim ( viewport -- h ) gadget-child pref-dim ;
 
 : fix-scroll ( origin viewport -- origin )

library/ui/shapes.factor

@@ -1,42 +1,26 @@
 ! Copyright (C) 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: gadgets
-USING: generic kernel lists math namespaces sdl sequences
+USING: generic kernel lists math matrices namespaces sdl
-vectors ;
+sequences vectors ;
 
-! Shape protocol. Shapes are immutable; moving or resizing a
-! shape makes a new shape.
-
-! These dynamically-bound variables affect the generic word
-! inside? and others.
 SYMBOL: x
 SYMBOL: y
 
-GENERIC: inside? ( point shape -- ? )
+: origin ( -- loc ) x get y get 0 3vector ;
 
-! A shape is an object with a defined bounding
+GENERIC: inside? ( loc shape -- ? )
-! box, and a notion of interior.
+GENERIC: shape-loc ( shape -- loc )
-GENERIC: shape-x
+GENERIC: set-shape-loc ( loc shape -- )
-GENERIC: shape-y
+GENERIC: shape-dim ( shape -- dim )
-GENERIC: shape-w
+GENERIC: set-shape-dim ( dim shape -- )
-GENERIC: shape-h
 
-GENERIC: move-shape ( x y shape -- )
+: shape-x shape-loc first ;
+: shape-y shape-loc second ;
+: shape-w shape-dim first ;
+: shape-h shape-dim second ;
 
-: set-shape-loc ( loc shape -- )
+GENERIC: draw-shape ( shape -- )
-    >r 3unseq drop r> move-shape ;
-
-GENERIC: resize-shape ( w h shape -- )
-
-: set-shape-dim ( loc shape -- )
-    >r 3unseq drop r> resize-shape ;
-
-! The painting protocol. Painting is controlled by various
-! dynamically-scoped variables. See library/styles.factor.
-
-GENERIC: draw-shape ( obj -- )
-
-! Utility words
 
 : with-trans ( shape quot -- )
     #! All drawing done inside the quotation is translated
@@ -51,11 +35,15 @@ GENERIC: draw-shape ( obj -- )
 : shape-pos ( shape -- pos )
     dup shape-x swap shape-y rect> ;
 
-: shape-size ( shape -- w h )
+: shape-bounds ( shape -- loc dim )
-    dup shape-w swap shape-h ;
+    dup shape-loc swap shape-dim ;
 
-: shape-dim ( shape -- dim )
+: shape-extent ( shape -- loc dim )
-    dup shape-w swap shape-h 0 3vector ;
+    dup shape-loc dup rot shape-dim v+ ;
 
-: shape-loc ( shape -- loc )
+: translate ( shape shape -- point )
-    dup shape-x swap shape-y 0 3vector ;
+    #! Translate a point relative to the shape.
+    swap shape-loc swap shape-loc v- ;
+
+M: vector shape-loc ;
+M: vector shape-dim drop { 0 0 0 } ;

library/ui/ui.factor

@@ -9,7 +9,7 @@ IN: shells
     #! Start the Factor graphics subsystem with the given screen
     #! dimensions.
     ?init-world
-    world get shape-size 0 SDL_RESIZABLE [
+    world get shape-dim 2unseq 0 SDL_RESIZABLE [
         0 x set 0 y set [
             "Factor " version append dup SDL_WM_SetCaption
             ttf-init

library/ui/world.factor

@@ -1,9 +1,9 @@
 ! Copyright (C) 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: gadgets
-USING: alien errors generic kernel lists math
+USING: alien errors generic io kernel lists math memory
-memory namespaces prettyprint sdl sequences io strings
+namespaces prettyprint sdl sequences sequences strings threads
-threads sequences ;
+vectors ;
 
 ! The world gadget is the top level gadget that all (visible)
 ! gadgets are contained in. The current world is stored in the
@@ -30,22 +30,26 @@ C: world ( -- world )
 : add-layer ( gadget -- )
     world get add-gadget ;
 
-: show-glass ( gadget -- )
-    <empty-gadget> dup
-    world get 2dup add-gadget set-world-glass
-    add-gadget ;
-
 : hide-glass ( -- )
     world get world-glass unparent f
     world get set-world-glass ;
 
+: show-glass ( gadget -- )
+    hide-glass
+    <empty-gadget> dup
+    world get 2dup add-gadget set-world-glass
+    dupd add-gadget prefer ;
+
 M: world inside? ( point world -- ? ) 2drop t ;
 
 : hand world get world-hand ;
 
 : draw-world ( world -- )
     [
-        dup 0 0 width get height get <rectangle> clip set-paint-prop
+        dup
+        { 0 0 0 }
+        width get height get 0 3vector <rectangle>
+        clip set-paint-prop
         draw-gadget
     ] with-surface ;