renaming rectangle tuple to rect and a few shape- words to rect-; working on spacial...

diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt
index d9d77cc8b9063c5bf5a4a90485085249c2d1f073..a5ddefcf95fbd37c2518331d49f3f28a55b6207b 100644 (file)
--- a/TODO.FACTOR.txt
+++ b/TODO.FACTOR.txt
@@ -1,8 +1,11 @@
 - reader syntax for arrays, byte arrays, displaced aliens\r
 - fix infer hang\r
+- out of memory error when printing global namespace\r
+- HTML formatting\r
 \r
 + ui:\r
 \r
+- adding/removing timers automatically for animated gadgets\r
 - fix listener prompt display after presentation commands invoked\r
 - theme abstraction in ui\r
 - menu dragging\r
@@ -76,6 +79,8 @@
 \r
 + kernel:\r
 \r
+- merge timers with sleeping tasks\r
+- what about tasks and timers between image restarts\r
 - split: return vectors\r
 - specialized arrays\r
 - there is a problem with hashcodes of words and bootstrapping\r

diff --git a/library/collections/sequence-sort.factor b/library/collections/sequence-sort.factor
index 6555bdd31f910ee43afae87fa51b92d683d84ccf..adc77ef4bb1ec577a956fe243a2ebe69a7d25da6 100644 (file)
--- a/library/collections/sequence-sort.factor
+++ b/library/collections/sequence-sort.factor
@@ -82,6 +82,13 @@ IN: sequences
     swap dup empty?
     [ 3drop -1 ] [ binsearch-slice (binsearch) ] ifte ;
     inline
-    
+
+: binsearch* ( elt seq quot -- elt | quot: elt elt -- -1/0/1 )
+    over >r binsearch dup -1 = [ r> 2drop f ] [ r> nth ] ifte ;
+    inline
+
 : binsearch-range ( from to seq quot -- from to )
-    [ binsearch ] 2keep rot >r binsearch r> ;
+    [ binsearch 0 max ] 2keep rot >r binsearch 1 + r> ; inline
+
+: binsearch-slice ( from to seq quot -- slice )
+    over >r binsearch-range r> <slice> ; inline

diff --git a/library/syntax/prettyprint.factor b/library/syntax/prettyprint.factor
index f568030ae996337b60361efa10499724a0fdd846..6ea15585d294642c39a8bccf141347a36820e12d 100644 (file)
--- a/library/syntax/prettyprint.factor
+++ b/library/syntax/prettyprint.factor
@@ -4,10 +4,6 @@ IN: prettyprint
 USING: alien generic hashtables io kernel lists math namespaces
 parser sequences strings styles vectors words ;
 
-! TODO:
-! - out of memory when printing global namespace
-! - formatting HTML code
-
 ! State
 SYMBOL: column
 SYMBOL: indent
@@ -110,11 +106,8 @@ C: block ( -- block )
     [ section-end fresh-line ] [ drop ] ifte ;
 
 : advance ( section -- )
-    section-start last-newline get = [
-        last-newline inc
-    ] [
-        " " write
-    ] ifte ;
+    section-start last-newline get =
+    [ last-newline inc ] [ " " write ] ifte ;
 
 : pprint-section ( section -- )
     last-newline? get [
@@ -198,7 +191,7 @@ M: complex pprint* ( num -- )
     \ }# pprint-word ;
 
 : ch>ascii-escape ( ch -- esc )
-    [
+    {{
         [[ CHAR: \e "\\e"  ]]
         [[ CHAR: \n "\\n"  ]]
         [[ CHAR: \r "\\r"  ]]
@@ -206,7 +199,7 @@ M: complex pprint* ( num -- )
         [[ CHAR: \0 "\\0"  ]]
         [[ CHAR: \\ "\\\\" ]]
         [[ CHAR: \" "\\\"" ]]
-    ] assoc ;
+    }} hash ;
 
 : ch>unicode-escape ( ch -- esc )
     >hex 4 CHAR: 0 pad-left "\\u" swap append ;
@@ -290,7 +283,11 @@ M: tuple pprint* ( tuple -- )
     [ <mirror> \ << \ >> pprint-sequence ] check-recursion ;
 
 M: alien pprint* ( alien -- )
-    \ ALIEN: pprint-word bl alien-address number>string f text ;
+    dup expired? [
+        drop "( alien expired )"
+    ] [
+        \ ALIEN: pprint-word bl alien-address number>string
+    ] ifte f text ;
 
 M: wrapper pprint* ( wrapper -- )
     dup wrapped word? [

diff --git a/library/test/gadgets/rectangles.factor b/library/test/gadgets/rectangles.factor
index c41cad04d7262ae62bc9fb6c7acd1d26c34069a2..5ff78d0e8327de26611abd7297ce4a8d265f6c7c 100644 (file)
--- a/library/test/gadgets/rectangles.factor
+++ b/library/test/gadgets/rectangles.factor
@@ -2,28 +2,28 @@ USING: gadgets kernel namespaces test ;
 [ t ] [
     [
         { 2000  2000 0 } origin set
-        { 2030 2040 0 } { 10 20 0 } { 300 400 0 } <rectangle> inside?
+        { 2030 2040 0 } { 10 20 0 } { 300 400 0 } <rect> inside?
     ] with-scope
 ] unit-test
 
 [ f ] [
     [
         { 2000  2000 0 } origin set
-        { 2500 2040 0 } { 10 20 0 } { 300 400 0 } <rectangle> inside?
+        { 2500 2040 0 } { 10 20 0 } { 300 400 0 } <rect> inside?
     ] with-scope
 ] unit-test
 
 [ t ] [
     [
         { -10 -20 0 } origin set
-        { 0 0 0 } { 10 20 0 } { 300 400 0 } <rectangle> inside?
+        { 0 0 0 } { 10 20 0 } { 300 400 0 } <rect> inside?
     ] with-scope
 ] unit-test
 
 [ f ] [
     [
         { 0 0 0 } origin set
-        { 10 10 0 } { 0 0 0 } { 10 10 0 } <rectangle> inside?
+        { 10 10 0 } { 0 0 0 } { 10 10 0 } <rect> inside?
     ] with-scope
 ] unit-test
 
@@ -40,3 +40,15 @@ USING: gadgets kernel namespaces test ;
     << rectangle f { 200 200 0 } { 40 40 0 } >>
     intersect
 ] unit-test
+
+[ f ] [
+    << rectangle f { 100 100 0 } { 50 50 0 } >>
+    << rectangle f { 200 200 0 } { 40 40 0 } >>
+    intersects?
+] unit-test
+
+[ t ] [
+    << rectangle f { 100 100 0 } { 50 50 0 } >>
+    << rectangle f { 120 120 0 } { 40 40 0 } >>
+    intersects?
+] unit-test

diff --git a/library/threads.factor b/library/threads.factor
index 8fc21eb7e7caba4b33e4ceb1640de7561eb56062..ba23d2ccabea4b34b5cabdff22c21a53260f2340 100644 (file)
--- a/library/threads.factor
+++ b/library/threads.factor
@@ -63,7 +63,7 @@ GENERIC: tick ( ms object -- )
 : timers ( -- hash ) \ timers global hash ;
 
 : add-timer ( object delay -- )
-    [ <timer> ] keep timers set-hash ;
+    over >r <timer> r> timers set-hash ;
 
 : remove-timer ( object -- ) timers remove-hash ;
 

diff --git a/library/ui/books.factor b/library/ui/books.factor
index eade0aef97ac65d1fa189e6fb1331a4772a4f088..c8f7d9c3a1f4d855bceaa7bbb433c021cbea025a 100644 (file)
--- a/library/ui/books.factor
+++ b/library/ui/books.factor
@@ -14,9 +14,9 @@ M: book pref-dim ( book -- dim )
     gadget-children { 0 0 0 } [ pref-dim vmax ] reduce ;
 
 M: book layout* ( book -- )
-    dup rectangle-dim over gadget-children [
+    dup rect-dim over gadget-children [
         f over set-gadget-visible?
-        { 0 0 0 } over set-rectangle-loc
+        { 0 0 0 } over set-rect-loc
         set-gadget-dim
     ] each-with
     dup book-page swap gadget-children nth

diff --git a/library/ui/borders.factor b/library/ui/borders.factor
index 8df8922dd02dbc5f74b3b10e8e0a74952ccdca61..90eec1b71f417a94a05053743135f939c10c7033 100644 (file)
--- a/library/ui/borders.factor
+++ b/library/ui/borders.factor
@@ -21,10 +21,10 @@ C: border ( child delegate size -- border )
     <bevel-gadget> { 5 5 0 } <border> ;
 
 : layout-border-loc ( border -- )
-    dup border-size swap gadget-child set-rectangle-loc ;
+    dup border-size swap gadget-child set-rect-loc ;
 
 : layout-border-dim ( border -- )
-    dup rectangle-dim over border-size 2 v*n v-
+    dup rect-dim over border-size 2 v*n v-
     swap gadget-child set-gadget-dim ;
 
 M: border pref-dim ( border -- dim )

diff --git a/library/ui/editors.factor b/library/ui/editors.factor
index eccf25bd09846cd42cae29bd75512837375f4fa0..91ea21a438dbb8ae20571ea7308fefb681870999 100644 (file)
--- a/library/ui/editors.factor
+++ b/library/ui/editors.factor
@@ -17,10 +17,10 @@ C: caret ( -- caret )
 
 M: caret tick* ( ms caret -- ) nip toggle-visible ;
 
-: caret-block 500 ;
+: caret-blink 500 ;
 
 : add-caret ( caret parent -- )
-    dupd add-gadget caret-block add-timer ;
+    dupd add-gadget caret-blink add-timer ;
 
 : unparent-caret ( caret -- )
     dup remove-timer unparent ;
@@ -100,7 +100,7 @@ C: editor ( text -- )
     0 0 3vector ;
 
 : caret-dim ( editor -- w h )
-    rectangle-dim { 0 1 1 } v* { 1 0 0 } v+ ;
+    rect-dim { 0 1 1 } v* { 1 0 0 } v+ ;
 
 M: editor user-input* ( ch editor -- ? )
     [ insert-char ] with-editor  t ;
@@ -110,7 +110,7 @@ M: editor pref-dim ( editor -- dim )
 
 M: editor layout* ( editor -- )
     dup editor-caret over caret-dim swap set-gadget-dim
-    dup editor-caret swap caret-loc swap set-rectangle-loc ;
+    dup editor-caret swap caret-loc swap set-rect-loc ;
 
 M: editor draw-gadget* ( editor -- )
     dup delegate draw-gadget*

diff --git a/library/ui/frames.factor b/library/ui/frames.factor
index 194187b1b234f2c2341f3f0d62969eb55146417d..e276b3bcf920655ad057bca3938634be2457087e 100644 (file)
--- a/library/ui/frames.factor
+++ b/library/ui/frames.factor
@@ -72,11 +72,11 @@ SYMBOL: frame-bottom-run
 : var-frame-top \ frame-top var-frame-y ;
 : var-frame-right
     dup \ frame-right var-frame-x
-    swap rectangle-dim first \ frame-right [ - ] change
+    swap rect-dim first \ frame-right [ - ] change
     \ frame-right get \ frame-left get - frame-right-run set ;
 : var-frame-bottom
     dup \ frame-bottom var-frame-y
-    swap rectangle-dim second \ frame-bottom [ - ] change
+    swap rect-dim second \ frame-bottom [ - ] change
     \ frame-bottom get \ frame-top get - frame-bottom-run set ;
 
 : setup-frame ( frame -- )
@@ -86,7 +86,7 @@ SYMBOL: frame-bottom-run
     var-frame-bottom ;
 
 : move-gadget ( x y gadget -- )
-    >r 0 3vector r> set-rectangle-loc ;
+    >r 0 3vector r> set-rect-loc ;
 
 : reshape-gadget ( x y w h gadget -- )
     [ >r 0 3vector r> set-gadget-dim ] keep move-gadget ;

diff --git a/library/ui/gadgets.factor b/library/ui/gadgets.factor
index 9a9f063303dd038d01195dd8671c66ec32a8e8c8..6eab81b9c6a18d763c9c31490728c1e24f80d252 100644 (file)
--- a/library/ui/gadgets.factor
+++ b/library/ui/gadgets.factor
@@ -8,27 +8,33 @@ SYMBOL: origin
 
 global [ { 0 0 0 } origin set ] bind
 
-TUPLE: rectangle loc dim ;
+TUPLE: rect loc dim ;
 
-GENERIC: inside? ( loc shape -- ? )
+GENERIC: inside? ( loc rect -- ? )
 
-: shape-bounds ( shape -- loc dim )
-    dup rectangle-loc swap rectangle-dim ;
+: rect-bounds ( rect -- loc dim )
+    dup rect-loc swap rect-dim ;
 
-: shape-extent ( shape -- loc dim )
-    dup rectangle-loc dup rot rectangle-dim v+ ;
+: rect-extent ( rect -- loc dim )
+    dup rect-loc dup rot rect-dim v+ ;
 
-: screen-bounds ( shape -- rect )
-    shape-bounds >r origin get v+ r> <rectangle> ;
+: screen-loc ( rect -- loc )
+    rect-loc origin get v+ ;
+
+: screen-bounds ( rect -- rect )
+    dup screen-loc swap rect-dim <rect> ;
 
 M: rectangle inside? ( loc rect -- ? )
-    screen-bounds shape-bounds { 1 1 1 } v- { 0 0 0 } vmax
+    screen-bounds rect-bounds { 1 1 1 } v- { 0 0 0 } vmax
     >r v- { 0 0 0 } r> vbetween? conjunction ;
 
-: intersect ( shape shape -- rect )
-    >r shape-extent r> shape-extent
-    swapd vmin >r vmax dup r> swap v- { 0 0 0 } vmax
-    <rectangle> ;
+: intersect ( rect rect -- rect )
+    >r rect-extent r> rect-extent swapd vmin >r vmax dup r>
+    swap v- { 0 0 0 } vmax <rect> ;
+
+: intersects? ( rect rect -- ? )
+    >r rect-extent r> rect-extent swapd vmin >r vmax r> v-
+    [ 0 < ] contains? ;
 
 ! A gadget is a rectangle, a paint, a mapping of gestures to
 ! actions, and a reference to the gadget's parent.
@@ -39,7 +45,7 @@ TUPLE: gadget
 : gadget-child gadget-children first ;
 
 C: gadget ( -- gadget )
-    { 0 0 0 } dup <rectangle> over set-delegate
+    { 0 0 0 } dup <rect> over set-delegate
     t over set-gadget-visible? ;
 
 DEFER: add-invalid
@@ -67,12 +73,12 @@ DEFER: add-invalid
     dup add-invalid (relayout-down) ;
 
 : set-gadget-dim ( dim gadget -- )
-    2dup rectangle-dim =
-    [ 2drop ] [ [ set-rectangle-dim ] keep relayout-down ] ifte ;
+    2dup rect-dim =
+    [ 2drop ] [ [ set-rect-dim ] keep relayout-down ] ifte ;
 
 GENERIC: pref-dim ( gadget -- dim )
 
-M: gadget pref-dim rectangle-dim ;
+M: gadget pref-dim rect-dim ;
 
 GENERIC: layout* ( gadget -- )
 
@@ -91,3 +97,25 @@ M: gadget focusable-child* drop t ;
 : focusable-child ( gadget -- gadget )
     dup focusable-child*
     dup t = [ drop ] [ nip focusable-child ] ifte ;
+
+GENERIC: pick-up* ( point gadget -- gadget )
+
+: pick-up-list ( point gadgets -- gadget )
+    [
+        dup gadget-visible? [ inside? ] [ 2drop f ] ifte
+    ] find-with nip ;
+
+M: gadget pick-up* ( point gadget -- gadget )
+    gadget-children pick-up-list ;
+
+: pick-up ( point gadget -- gadget )
+    #! The logic is thus. If the point is definately outside the
+    #! box, return f. Otherwise, see if the point is contained
+    #! in any subgadget. If not, see if it is contained in the
+    #! box delegate.
+    dup gadget-visible? >r 2dup inside? r> drop [
+        [ rect-loc v- ] keep 2dup
+        pick-up* [ pick-up ] [ nip ] ?ifte
+    ] [
+        2drop f
+    ] ifte ;

diff --git a/library/ui/hand.factor b/library/ui/hand.factor
index 5ae0926f8d8e29778f8c5914a43c534f01e7f00f..7921a601aa8aca46cfb00bd4280c8cd147a5fa27 100644 (file)
--- a/library/ui/hand.factor
+++ b/library/ui/hand.factor
@@ -4,23 +4,6 @@ IN: gadgets
 USING: alien generic io kernel lists math matrices namespaces
 prettyprint sdl sequences vectors ;
 
-: (pick-up) ( point gadget -- gadget )
-    gadget-children reverse-slice [
-        dup gadget-visible? [ inside? ] [ 2drop f ] ifte
-    ] find-with nip ;
-
-: pick-up ( point gadget -- gadget )
-    #! The logic is thus. If the point is definately outside the
-    #! box, return f. Otherwise, see if the point is contained
-    #! in any subgadget. If not, see if it is contained in the
-    #! box delegate.
-    dup gadget-visible? >r 2dup inside? r> drop [
-        [ rectangle-loc v- ] keep 2dup
-        (pick-up) [ pick-up ] [ nip ] ?ifte
-    ] [
-        2drop f
-    ] ifte ;
-
 ! The hand is a special gadget that holds mouse position and
 ! mouse button click state. The hand's parent is the world, but
 ! it is special in that the world does not list it as part of
@@ -72,13 +55,13 @@ C: hand ( world -- hand )
 
 : move-hand ( loc hand -- )
     dup hand-gadget parents-down >r
-    2dup set-rectangle-loc
+    2dup set-rect-loc
     [ >r world get pick-up r> set-hand-gadget ] keep
     dup hand-gadget parents-down r> hand-gestures ;
 
 : update-hand ( hand -- )
     #! Called when a gadget is removed or added.
-    dup rectangle-loc swap move-hand ;
+    dup rect-loc swap move-hand ;
 
 : focus-gestures ( new old -- )
     drop-prefix

diff --git a/library/ui/hierarchy.factor b/library/ui/hierarchy.factor
index 776d4169dec8f6b4c6f2d1b89ed5da0274d1f3df..cd48563562896f75488e3667c3104115fff7269e 100644 (file)
--- a/library/ui/hierarchy.factor
+++ b/library/ui/hierarchy.factor
@@ -55,7 +55,7 @@ sequences vectors ;
 
 : screen-loc ( gadget -- point )
     #! The position of the gadget on the screen.
-    parents-up { 0 0 0 } [ rectangle-loc v+ ] reduce ;
+    parents-up { 0 0 0 } [ rect-loc v+ ] reduce ;
 
 : relative ( g1 g2 -- g2-g1 )
     screen-loc swap screen-loc v- ;

diff --git a/library/ui/incremental.factor b/library/ui/incremental.factor
index 038ded5bc8783a45f5bac88c0dc95d46ec715d69..b1711ef8149297c427d1fcfbdfacf4c6536ad136 100644 (file)
--- a/library/ui/incremental.factor
+++ b/library/ui/incremental.factor
@@ -24,7 +24,7 @@ M: incremental layout* drop ;
 
 : next-cursor ( gadget incremental -- cursor )
     [
-        swap rectangle-dim swap incremental-cursor
+        swap rect-dim swap incremental-cursor
         2dup v+ >r vmax r>
     ] keep  pack-vector set-axis ;
 
@@ -33,10 +33,10 @@ M: incremental layout* drop ;
 
 : incremental-loc ( gadget incremental -- )
     dup incremental-cursor swap pack-vector v*
-    swap set-rectangle-loc ;
+    swap set-rect-loc ;
 
 : prefer-incremental ( gadget -- )
-    dup pref-dim over set-rectangle-dim layout ;
+    dup pref-dim over set-rect-dim layout ;
 
 : add-incremental ( gadget incremental -- )
     2dup (add-gadget)

diff --git a/library/ui/layouts.factor b/library/ui/layouts.factor
index f1cbf27f3f0b713a8edba1fbc79efed6016e646b..2035c2559269b3d6db5dfdbf2f3da1e249ec93a4 100644 (file)
--- a/library/ui/layouts.factor
+++ b/library/ui/layouts.factor
@@ -27,7 +27,7 @@ TUPLE: pack align fill vector ;
 
 : packed-dim-2 ( gadget sizes -- list )
     [
-        over rectangle-dim { 1 1 1 } vmax over v-
+        over rect-dim { 1 1 1 } vmax over v-
         rot pack-fill v*n v+
     ] map-with ;
 
@@ -42,9 +42,9 @@ TUPLE: pack align fill vector ;
     { 0 0 0 } [ v+ ] accumulate ;
 
 : packed-loc-2 ( gadget sizes -- seq )
-    >r dup rectangle-dim { 1 1 1 } vmax over r>
+    >r dup rect-dim { 1 1 1 } vmax over r>
     packed-dim-2 [ v- ] map-with
-    >r dup pack-align swap rectangle-dim { 1 1 1 } vmax r>
+    >r dup pack-align swap rect-dim { 1 1 1 } vmax r>
     [ >r 2dup r> v- n*v ] map 2nip ;
 
 : (packed-locs) ( gadget sizes -- seq )
@@ -52,7 +52,7 @@ TUPLE: pack align fill vector ;
 
 : packed-locs ( gadget sizes -- )
     over gadget-children >r (packed-locs) r>
-    [ set-rectangle-loc ] 2each ;
+    [ set-rect-loc ] 2each ;
 
 : packed-layout ( gadget sizes -- )
     2dup packed-locs packed-dims ;
@@ -83,6 +83,24 @@ M: pack pref-dim ( pack -- dim )
 
 M: pack layout* ( pack -- ) dup pref-dims packed-layout ;
 
-: <stack> ( list -- gadget )
+: pick-up-fast ( axis point gadgets -- gadget )
+    [ rect-loc v- over v. ] binsearch* nip ;
+
+M: pack pick-up* ( point pack -- gadget )
+    dup pack-vector pick rot gadget-children
+    pick-up-fast tuck inside? [ drop f ] unless ;
+
+! M: pack visible-children* ( rect gadget -- list )
+!     gadget-children [ rect-loc origin get v+ intersects? ] subset-with ;
+
+TUPLE: stack ;
+
+C: stack ( -- gadget )
     #! A stack lays out all its children on top of each other.
-    0 1 { 0 0 1 } <pack>  swap [ over add-gadget ] each ;
+    0 1 { 0 0 1 } <pack> over set-delegate ;
+
+M: stack pick-up* ( point stack -- gadget )
+    gadget-children reverse-slice pick-up-list ;
+
+M: stack visible-children* ( rect gadget -- list )
+    nip gadget-children ;

diff --git a/library/ui/load.factor b/library/ui/load.factor
index 706d38a22fd966f4dff7692b0ec8c907cb927a22..b996162deb62f2f349ed0f53dd571cd0c95bbe7a 100644 (file)
--- a/library/ui/load.factor
+++ b/library/ui/load.factor
@@ -10,7 +10,6 @@ USING: kernel parser sequences io ;
     "/library/ui/borders.factor"
     "/library/ui/frames.factor"
     "/library/ui/world.factor"
-    "/library/ui/timer.factor"
     "/library/ui/hand.factor"
     "/library/ui/labels.factor"
     "/library/ui/buttons.factor"

diff --git a/library/ui/menus.factor b/library/ui/menus.factor
index 6eeb2a5c5624cb9b7857cdcb2dfafdfe62c67b1f..5529c802d1326b429a7aee26f69dbbae1d9f6377 100644 (file)
--- a/library/ui/menus.factor
+++ b/library/ui/menus.factor
@@ -4,7 +4,7 @@ IN: gadgets
 USING: generic kernel lists math namespaces sequences ;
 
 : show-menu ( menu -- )
-    hand screen-loc over set-rectangle-loc show-glass ;
+    hand screen-loc over set-rect-loc show-glass ;
 
 : menu-item-border ( child -- border )
     <plain-gadget> { 1 1 0 } <border> ;

diff --git a/library/ui/paint.factor b/library/ui/paint.factor
index 4ec8663e516ce45c334ed0cc7b7f9c98094289e2..d0bc992ab1461002621dc9f83dd3398e40252879 100644 (file)
--- a/library/ui/paint.factor
+++ b/library/ui/paint.factor
@@ -7,32 +7,35 @@ namespaces sdl sequences strings styles vectors ;
 SYMBOL: clip
 
 : >sdl-rect ( rectangle -- sdlrect )
-    [ rectangle-loc 2unseq ] keep rectangle-dim 2unseq make-rect ;
+    [ rect-loc 2unseq ] keep rect-dim 2unseq make-rect ;
 
-: set-clip ( 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 f if the clip region
-    #! is an empty region.
-    surface get swap >sdl-rect SDL_SetClipRect ;
-
-: with-clip ( shape quot -- )
-    #! All drawing done inside the quotation is clipped to the
-    #! shape's bounds.
-    [
-        >r screen-bounds clip [ intersect dup ] change set-clip
-        [ r> call ] [ r> 2drop ] ifte
-    ] with-scope ; inline
+    #! intersected clip rectangle.
+    surface get swap >sdl-rect SDL_SetClipRect drop ;
+
+GENERIC: visible-children* ( rect gadget -- list )
+
+M: gadget visible-children* ( rect gadget -- list )
+    gadget-children [ screen-bounds intersects? ] subset-with ;
+
+: visible-children ( gadget -- list )
+    clip get swap visible-children* ;
 
 GENERIC: draw-gadget* ( gadget -- )
 
+: translate&clip ( gadget -- )
+    screen-bounds dup rect-loc origin set
+    clip [ intersect dup ] change ( set-clip ) drop ;
+
 : draw-gadget ( gadget -- )
     dup gadget-visible? [
         dup [
-            dup rectangle-loc origin [ v+ ] change
+            translate&clip
             dup draw-gadget*
-            gadget-children [ draw-gadget ] each
-        ] with-clip
+            visible-children [ draw-gadget ] each
+        ] with-scope
     ] [ drop ] ifte ;
 
 : paint-prop* ( gadget key -- value )
@@ -73,14 +76,15 @@ M: f draw-boundary 2drop ;
 TUPLE: solid ;
 
 : rect>screen ( shape -- x1 y1 x2 y2 )
-    >r origin get dup r> rectangle-dim v+ >r 2unseq r> 2unseq ;
+    >r origin get dup r> rect-dim v+
+    >r 2unseq r> 2unseq >r 1 - r> 1 - ;
 
 ! Solid pen
 M: solid draw-interior
     drop >r surface get r> [ rect>screen ] keep bg rgb boxColor ;
 
 M: solid draw-boundary
-    drop >r surface get r> [ rect>screen >r 1 - r> 1 - ] keep
+    drop >r surface get r> [ rect>screen ] keep
     fg rgb rectangleColor ;
 
 ! Gradient pen
@@ -113,7 +117,7 @@ TUPLE: gradient vector from to ;
     dup first [ 3dup gradient-y ] repeat 2drop ;
 
 M: gradient draw-interior ( gadget gradient -- )
-    swap rectangle-dim { 1 1 1 } vmax
+    swap rect-dim { 1 1 1 } vmax
     over gradient-vector { 1 0 0 } =
     [ horiz-gradient ] [ vert-gradient ] ifte ;
 
@@ -144,7 +148,7 @@ SYMBOL: bevel-2
 M: bevel draw-boundary ( gadget boundary -- )
     #! Ugly code.
     bevel-width [
-        >r origin get over rectangle-dim over v+ r>
+        >r origin get over rect-dim over v+ r>
         { 1 1 0 } n*v tuck v- { 1 1 0 } v- >r v+ r>
         rot draw-bevel
     ] each-with ;

diff --git a/library/ui/scrolling.factor b/library/ui/scrolling.factor
index c2c64d205f241d04ff761969ac06c561d5d000e4..9ddec29cb9ffb722bdc85db545593640dbe1cf1b 100644 (file)
--- a/library/ui/scrolling.factor
+++ b/library/ui/scrolling.factor
@@ -16,7 +16,7 @@ TUPLE: scroller viewport x y ;
 : viewport-dim gadget-child pref-dim ;
 
 : fix-scroll ( origin viewport -- origin )
-    dup rectangle-dim swap viewport-dim v- vmax { 0 0 0 } vmin ;
+    dup rect-dim swap viewport-dim v- vmax { 0 0 0 } vmin ;
 
 : scroll-viewport ( origin viewport -- )
     [ fix-scroll ] keep [ set-viewport-origin ] keep relayout ;
@@ -41,13 +41,13 @@ M: viewport pref-dim gadget-child pref-dim ;
 M: viewport layout* ( viewport -- )
     dup gadget-child dup prefer
     >r dup viewport-origin* swap fix-scroll r>
-    set-rectangle-loc ;
+    set-rect-loc ;
 
 M: viewport focusable-child* ( viewport -- gadget )
     gadget-child ;
 
 : visible-portion ( viewport -- vector )
-    dup rectangle-dim { 1 1 1 } vmax
+    dup rect-dim { 1 1 1 } vmax
     swap viewport-dim { 1 1 1 } vmax
     v/ { 1 1 1 } vmin ;
 
@@ -117,13 +117,13 @@ C: slider ( vector -- slider )
 : slider-dim { 12 12 12 } ;
 
 : thumb-dim ( slider -- h )
-    [ rectangle-dim dup ] keep >thumb slider-dim vmax vmin ;
+    [ rect-dim dup ] keep >thumb slider-dim vmax vmin ;
 
 M: slider pref-dim drop slider-dim ;
 
 M: slider layout* ( slider -- )
     dup thumb-loc over slider-vector v*
-    over slider-thumb set-rectangle-loc
+    over slider-thumb set-rect-loc
     dup thumb-dim over slider-vector v* slider-dim vmax
     swap slider-thumb set-gadget-dim ;
 

diff --git a/library/ui/splitters.factor b/library/ui/splitters.factor
index 9cbcb22e845f6c5da974d957495136a0a4a8dfad..46aa1d062ac5db7bda600623935e2788091e4af7 100644 (file)
--- a/library/ui/splitters.factor
+++ b/library/ui/splitters.factor
@@ -17,7 +17,7 @@ TUPLE: splitter split ;
 
 : divider-motion ( splitter -- )
     dup hand>split
-    over rectangle-dim { 1 1 1 } vmax v/ over pack-vector v.
+    over rect-dim { 1 1 1 } vmax v/ over pack-vector v.
     0 max 1 min over set-splitter-split relayout ;
 
 : divider-actions ( thumb -- )
@@ -45,14 +45,14 @@ C: splitter ( first second split vector -- splitter )
     { 1 0 0 } <splitter> ;
 
 : splitter-part ( splitter -- vec )
-    dup splitter-split swap rectangle-dim
+    dup splitter-split swap rect-dim
     n*v divider-size 1/2 v*n v- ;
 
 : splitter-layout ( splitter -- { a b c } )
     [
         dup splitter-part ,
         divider-size ,
-        dup rectangle-dim divider-size v- swap splitter-part v- ,
+        dup rect-dim divider-size v- swap splitter-part v- ,
     ] make-vector ;
 
 M: splitter layout* ( splitter -- )

diff --git a/library/ui/ui.factor b/library/ui/ui.factor
index de03cc068da19735a0eb5fb46147677330ce3479..8cb3974ed2c65270e9bbd36de660163e6e371641 100644 (file)
--- a/library/ui/ui.factor
+++ b/library/ui/ui.factor
@@ -61,7 +61,7 @@ IN: shells
     #! dimensions.
     ttf-init
     ?init-world
-    world get rectangle-dim 2unseq 0 SDL_RESIZABLE [
+    world get rect-dim 2unseq 0 SDL_RESIZABLE [
         [
             "Factor " version append dup SDL_WM_SetCaption
             start-world

diff --git a/library/ui/world.factor b/library/ui/world.factor
index 2cfb9dbe7507772ddcf0b9fb06524c41fc942666..265d10520f5e9391ad3a71daecb4897005209ad9 100644 (file)
--- a/library/ui/world.factor
+++ b/library/ui/world.factor
@@ -16,7 +16,7 @@ DEFER: update-hand
 DEFER: do-timers
 
 C: world ( -- world )
-    f <stack> over set-delegate
+    <stack> over set-delegate
     t over set-gadget-root?
     dup <hand> over set-world-hand ;
 
@@ -47,7 +47,7 @@ M: world inside? ( point world -- ? ) 2drop t ;
 
 : draw-world ( world -- )
     [
-        { 0 0 0 } width get height get 0 3vector <rectangle> clip set
+        { 0 0 0 } width get height get 0 3vector <rect> clip set
         draw-gadget
     ] with-surface ;