spacial indexing for faster pane display

diff --git a/doc/handbook.tex b/doc/handbook.tex
index f6d2c08a084e72f114917b59a03c66383ee80219..71e55c02ecf4210788dfce4a263d1aa01637611f 100644 (file)
--- a/doc/handbook.tex
+++ b/doc/handbook.tex
@@ -3329,11 +3329,11 @@ Computes both the quotient and remainder. That is, \texttt{/mod} could be define
 \end{verbatim}
 \wordtable{
 \vocabulary{math}
-\ordinaryword{gcd}{gcd ( x y -- a c )}
+\ordinaryword{gcd}{gcd ( x y -- a d )}
 }
 Applies the Euclidian algorithm to \texttt{x} and \texttt{y}. The output values satisfy the following property for some integer $b$:
-$$ax+by=c$$
-Furthermore, $c$ is the greatest integer having this property; that is, it is the greatest common divisor of $a$ and $b$.
+$$ax+by=d$$
+Furthermore, $d$ is the greatest integer having this property; that is, it is the greatest common divisor of $a$ and $b$.
 \wordtable{
 \vocabulary{math}
 \ordinaryword{mod-inv}{mod-inv ( x n -- y )}

diff --git a/library/collections/sequence-sort.factor b/library/collections/sequence-sort.factor
index 43225c709f26543019e99a5b36f3ebabad77c893..d71c97e75e93e6d8dc3a7e676b39fab9b7df51b6 100644 (file)
--- a/library/collections/sequence-sort.factor
+++ b/library/collections/sequence-sort.factor
@@ -62,7 +62,7 @@ DEFER: (nsort)
         ] ifte
     ] ifte ; inline
 
-: binsearch-slice ( seq -- slice )
+: flatten-slice ( seq -- slice )
     #! Binsearch returns an index relative to the sequence
     #! being sliced, so if we are given a slice as input,
     #! unexpected behavior will result.
@@ -84,15 +84,9 @@ IN: sequences
 
 : binsearch ( elt seq quot -- i | quot: elt elt -- -1/0/1 )
     swap dup empty?
-    [ 3drop -1 ] [ binsearch-slice (binsearch) ] ifte ;
+    [ 3drop -1 ] [ flatten-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 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/help/tutorial.factor b/library/help/tutorial.factor
index d96d49ee33f1a364d473856a7663a2eb6354fbb7..75c9a8b7e82b28a8e9f2d1426da05ea88d1fd411 100644 (file)
--- a/library/help/tutorial.factor
+++ b/library/help/tutorial.factor
@@ -136,7 +136,7 @@ M: general-list tutorial-line
             "The squared word"\r
             "Try entering the following word definition:"\r
             ""\r
-            [ ": squared ( n -- n*n ) dup * ;" ]\r
+            [ ": square ( n -- n*n ) dup * ;" ]\r
             ""\r
             "Shuffle words solve the problem where we need to compose"\r
             "two words, but their stack effects do not ``fit''."\r
@@ -166,13 +166,13 @@ M: general-list tutorial-line
             "you will now have several new colon definitions:"\r
             ""\r
             "  twice"\r
-            "  squared"\r
-            "  negated"\r
+            "  square"\r
+            "  negate"\r
             ""\r
             "You can look at previously-entered word definitions using 'see'."\r
             "Try the following:"\r
             ""\r
-            [ "\\ negated see" ]\r
+            [ "\\ negate see" ]\r
             ""\r
             "Prefixing a word with \\ pushes it on the stack, instead of"\r
             "executing it. So the see word has stack effect ( word -- )."\r
@@ -191,7 +191,7 @@ M: general-list tutorial-line
             "absolute value of a number; that is, if it is less than 0,"\r
             "the number will be negated to yield a positive result."\r
             ""\r
-            [ ": absolute ( x -- |x| ) dup 0 < [ negated ] when ;" ]\r
+            [ ": absolute ( x -- |x| ) dup 0 < [ negate ] when ;" ]\r
             ""\r
             "It duplicates the top of the stack, since negative? pops it."\r
             "Then if the top of the stack was found to be negative,"\r

diff --git a/library/math/integer.factor b/library/math/integer.factor
index e89514e0b2383f5d872bb7e35aff63dbfcdc15c2..40f2bba04fcec8872ac183a328efa09908b08099 100644 (file)
--- a/library/math/integer.factor
+++ b/library/math/integer.factor
@@ -17,6 +17,10 @@ UNION: integer fixnum bignum ;
     #! such that a*x=d mod y.
     swap 0 1 2swap (gcd) abs ; foldable
 
+: lcm ( a b -- c )
+    #! Smallest integer such that c/a and c/b are both integers.
+    2dup gcd nip >r * r> /i ;
+
 : mod-inv ( x n -- y )
     #! Compute the multiplicative inverse of x mod n.
     gcd 1 = [ "Non-trivial divisor found" throw ] unless ; foldable

diff --git a/library/syntax/prettyprint.factor b/library/syntax/prettyprint.factor
index 6ea15585d294642c39a8bccf141347a36820e12d..4c8b49c81872f0cdfffb264bae5b7941751dc496 100644 (file)
--- a/library/syntax/prettyprint.factor
+++ b/library/syntax/prettyprint.factor
@@ -242,10 +242,10 @@ M: dll pprint* ( obj -- str ) dll-path "DLL\" " pprint-string ;
 : check-recursion ( obj quot -- indent )
     #! We detect circular structure.
     nesting-limit? [
-        2drop "&" f text
+        2drop "#" f text
     ] [
         over recursion-check get memq? [
-            2drop "#" f text
+            2drop "&" f text
         ] [
             over recursion-check [ cons ] change
             call
@@ -318,7 +318,7 @@ M: wrapper pprint* ( wrapper -- )
 
 : unparse-short ( object -- str ) [ pprint-short ] string-out ;
 
-: unparse-short. ( object -- )
+: short. ( object -- )
     dup unparse-short swap write-object terpri ;
 
 : [.] ( sequence -- ) [ unparse-short. ] each ;

diff --git a/library/test/gadgets/rectangles.factor b/library/test/gadgets/rectangles.factor
index 5ff78d0e8327de26611abd7297ce4a8d265f6c7c..6f9b20e953738d19fa85edd92584817aaeb112cb 100644 (file)
--- a/library/test/gadgets/rectangles.factor
+++ b/library/test/gadgets/rectangles.factor
@@ -1,54 +1,32 @@
 USING: gadgets kernel namespaces test ;
-[ t ] [
-    [
-        { 2000  2000 0 } origin set
-        { 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 } <rect> inside?
-    ] with-scope
-] unit-test
-
-[ t ] [
-    [
-        { -10 -20 0 } origin set
-        { 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 } <rect> inside?
-    ] with-scope
-] unit-test
-
-[ << rectangle f { 10 10 0 } { 20 20 0 } >> ]
+[ << rect f { 10 10 0 } { 20 20 0 } >> ]
 [
-    << rectangle f { 10 10 0 } { 50 50 0 } >>
-    << rectangle f { -10 -10 0 } { 40 40 0 } >>
+    << rect f { 10 10 0 } { 50 50 0 } >>
+    << rect f { -10 -10 0 } { 40 40 0 } >>
     intersect
 ] unit-test
 
-[ << rectangle f { 200 200 0 } { 0 0 0 } >> ]
+[ << rect f { 200 200 0 } { 0 0 0 } >> ]
 [
-    << rectangle f { 100 100 0 } { 50 50 0 } >>
-    << rectangle f { 200 200 0 } { 40 40 0 } >>
+    << rect f { 100 100 0 } { 50 50 0 } >>
+    << rect 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 } >>
+    << rect f { 100 100 0 } { 50 50 0 } >>
+    << rect 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 } >>
+    << rect f { 100 100 0 } { 50 50 0 } >>
+    << rect f { 120 120 0 } { 40 40 0 } >>
+    intersects?
+] unit-test
+
+[ f ] [
+    << rect f { 1000 100 0 } { 50 50 0 } >>
+    << rect f { 120 120 0 } { 40 40 0 } >>
     intersects?
 ] unit-test

diff --git a/library/tools/debugger.factor b/library/tools/debugger.factor
index 0e5642b541455316c29fc9ceef8c14de0b5be2be..de0cc9432cc7b07aaa0569a2712e26ed46069303 100644 (file)
--- a/library/tools/debugger.factor
+++ b/library/tools/debugger.factor
@@ -15,7 +15,7 @@ parser prettyprint sequences io strings vectors words ;
 
 : type-check-error. ( list -- )
     "Type check error" print
-    uncons car dup "Object: " write .
+    uncons car dup "Object: " write short.
     "Object type: " write class .
     "Expected type: " write type>class . ;
 
@@ -63,13 +63,13 @@ M: kernel-error error. ( error -- )
 M: no-method error. ( error -- )
     "No suitable method." print
     "Generic word: " write dup no-method-generic .
-    "Object: " write no-method-object . ;
+    "Object: " write no-method-object short. ;
 
 M: no-math-method error. ( error -- )
     "No suitable arithmetic method." print
     "Generic word: " write dup no-math-method-generic .
-    "Left operand: " write dup no-math-method-left .
-    "Right operand: " write no-math-method-right . ;
+    "Left operand: " write dup no-math-method-left short.
+    "Right operand: " write no-math-method-right short. ;
 
 : parse-dump ( error -- )
     "Parsing " write
@@ -86,7 +86,7 @@ M: parse-error error. ( error -- )
 
 M: bounds-error error. ( error -- )
     "Sequence index out of bounds" print
-    "Sequence: " write dup bounds-error-seq .
+    "Sequence: " write dup bounds-error-seq short.
     "Minimum: 0" print
     "Maximum: " write dup bounds-error-seq length .
     "Requested: " write bounds-error-index . ;

diff --git a/library/ui/gadgets.factor b/library/ui/gadgets.factor
index d7fdb1980655f6a4b729570c9e0e9b18ea988e77..44f9dc255c276c82542bd07b6c4eb52e531ddf89 100644 (file)
--- a/library/ui/gadgets.factor
+++ b/library/ui/gadgets.factor
@@ -10,28 +10,24 @@ global [ { 0 0 0 } origin set ] bind
 
 TUPLE: rect loc dim ;
 
-GENERIC: inside? ( loc rect -- ? )
+M: vector rect-loc ;
 
-: rect-bounds ( rect -- loc dim )
-    dup rect-loc swap rect-dim ;
+M: vector rect-dim drop { 0 0 0 } ;
 
-: rect-extent ( rect -- loc dim )
-    dup rect-loc dup rot rect-dim v+ ;
+: rect-bounds ( rect -- loc dim ) dup rect-loc swap rect-dim ;
 
-: >absolute ( rect -- rect )
-    dup rect-loc origin get v+ dup rot rect-dim v+ <rect> ;
+: rect-extent ( rect -- loc dim ) rect-bounds over v+ ;
 
-M: rect inside? ( loc rect -- ? )
-    >absolute rect-bounds { 1 1 1 } v- { 0 0 0 } vmax
-    >r v- { 0 0 0 } r> vbetween? conjunction ;
+: >absolute ( rect -- rect )
+    rect-bounds >r origin get v+ r> <rect> ;
 
 : 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 -- ? )
+: intersects? ( rect/point rect -- ? )
     >r rect-extent r> rect-extent swapd vmin >r vmax r> v-
-    [ 0 < ] contains? ;
+    [ 0 <= ] all? ;
 
 ! A gadget is a rectangle, a paint, a mapping of gestures to
 ! actions, and a reference to the gadget's parent.
@@ -86,32 +82,3 @@ M: gadget layout* drop ;
 GENERIC: user-input* ( ch gadget -- ? )
 
 M: gadget user-input* 2drop t ;
-
-GENERIC: focusable-child* ( gadget -- gadget/t )
-
-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 [
-        pick-up* [ pick-up ] [ nip ] ?ifte
-    ] [
-        2drop f
-    ] ifte ;

diff --git a/library/ui/hierarchy.factor b/library/ui/hierarchy.factor
index cd48563562896f75488e3667c3104115fff7269e..538ee754ee3a337528a114755c4007ce828d9839 100644 (file)
--- a/library/ui/hierarchy.factor
+++ b/library/ui/hierarchy.factor
@@ -57,8 +57,37 @@ sequences vectors ;
     #! The position of the gadget on the screen.
     parents-up { 0 0 0 } [ rect-loc v+ ] reduce ;
 
-: relative ( g1 g2 -- g2-g1 )
-    screen-loc swap screen-loc v- ;
+: relative ( g1 g2 -- g2-g1 ) screen-loc swap screen-loc v- ;
 
-: child? ( parent child -- ? )
-    parents-down memq? ;
+: child? ( parent child -- ? ) parents-down memq? ;
+
+GENERIC: focusable-child* ( gadget -- gadget/t )
+
+M: gadget focusable-child* drop t ;
+
+: focusable-child ( gadget -- gadget )
+    dup focusable-child*
+    dup t = [ drop ] [ nip focusable-child ] ifte ;
+
+GENERIC: children-on ( rect/point gadget -- list )
+
+M: gadget children-on ( rect/point gadget -- list )
+    nip gadget-children ;
+
+: inside? ( bounds gadget -- ? )
+    dup gadget-visible?
+    [ >absolute intersects? ] [ 2drop f ] ifte ;
+
+: pick-up-list ( rect/point gadget -- gadget/f )
+    dupd children-on reverse-slice [ inside? ] find-with nip ;
+
+: translate ( rect/point -- )
+    rect-loc origin [ v+ ] change ;
+
+: pick-up ( rect/point gadget -- gadget )
+    2dup inside? [
+        [
+            dup translate 2dup pick-up-list dup
+            [ nip pick-up ] [ rot 2drop ] ifte
+        ] with-scope
+    ] [ 2drop f ] ifte ;

diff --git a/library/ui/layouts.factor b/library/ui/layouts.factor
index 84f368b999fe0e1d3f7c650644bc24d80ed14f30..8d815ea02086a89b6da5a419ecfe3d0bfd576740 100644 (file)
--- a/library/ui/layouts.factor
+++ b/library/ui/layouts.factor
@@ -83,18 +83,17 @@ M: pack pref-dim ( pack -- dim )
 
 M: pack layout* ( pack -- ) dup pref-dims packed-layout ;
 
-: pack-comparator rect-loc origin get v+ v- over v. ;
-
-: pick-up-fast ( axis point gadgets -- gadget )
-    [ pack-comparator ] 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 pack -- list )
-    dup pack-vector -rot gadget-children >r rect-extent r>
-    [ pack-comparator ] binsearch-slice nip ;
+: fast-children-on ( dim axis gadgets -- i )
+    swapd [ rect-loc origin get v+ v- over v. ] binsearch nip ;
+
+M: pack children-on ( rect pack -- list )
+    dup pack-vector swap gadget-children [
+        3dup
+        >r >r dup rect-loc swap rect-dim v+ r> r> fast-children-on 1 +
+        >r
+        >r >r rect-loc r> r> fast-children-on 0 max
+        r>
+    ] keep <slice> ;
 
 TUPLE: stack ;
 
@@ -102,8 +101,5 @@ C: stack ( -- gadget )
     #! A stack lays out all its children on top of each other.
     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 )
+M: stack children-on ( point stack -- gadget )
     nip gadget-children ;

diff --git a/library/ui/menus.factor b/library/ui/menus.factor
index 5529c802d1326b429a7aee26f69dbbae1d9f6377..79ef5d0220c041e8c3022b5324a2c89abed9ee21 100644 (file)
--- a/library/ui/menus.factor
+++ b/library/ui/menus.factor
@@ -29,7 +29,3 @@ C: menu ( assoc -- gadget )
     [ f line-border swap set-delegate ] keep
     0 1 <pile> [ swap add-gadget ] 2keep
     rot assoc>menu dup menu-actions ;
-
-! While a menu is open, clicking anywhere sends the click to
-! the menu.
-M: menu inside? ( point menu -- ? ) 2drop t ;

diff --git a/library/ui/paint.factor b/library/ui/paint.factor
index 2c8ae88756786c2e01087ba2385366bb429dd2e0..39c3587a228b6ad1ab71a11712e778666caec0ff 100644 (file)
--- a/library/ui/paint.factor
+++ b/library/ui/paint.factor
@@ -15,30 +15,22 @@ SYMBOL: clip
     #! 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 [ >absolute intersects? ] subset-with ;
-
-: visible-children ( gadget -- list )
-    clip get swap visible-children* ;
+: visible-children ( gadget -- seq ) clip get swap children-on ;
 
 GENERIC: draw-gadget* ( gadget -- )
 
-: translate&clip ( gadget -- )
-    >absolute dup rect-loc origin set
-    clip [ intersect dup ] change set-clip ;
+: do-clip ( gadget -- )
+    >absolute clip [ intersect dup ] change set-clip ;
 
 : draw-gadget ( gadget -- )
-    dup gadget-visible? [
+    clip get over inside? [
         [
-            dup translate&clip dup draw-gadget*
+            dup do-clip dup translate dup draw-gadget*
             visible-children [ draw-gadget ] each
         ] with-scope
     ] [ drop ] ifte ;
 
-: paint-prop* ( gadget key -- value )
-    swap gadget-paint ?hash ;
+: paint-prop* ( gadget key -- value ) swap gadget-paint ?hash ;
 
 : paint-prop ( gadget key -- value )
     over [

diff --git a/library/ui/world.factor b/library/ui/world.factor
index 265d10520f5e9391ad3a71daecb4897005209ad9..d303b728502de8b840ea8519d68e519f3ad910ce 100644 (file)
--- a/library/ui/world.factor
+++ b/library/ui/world.factor
@@ -43,8 +43,6 @@ C: world ( -- world )
     world get 2dup add-gadget set-world-glass
     dupd add-gadget prefer ;
 
-M: world inside? ( point world -- ? ) 2drop t ;
-
 : draw-world ( world -- )
     [
         { 0 0 0 } width get height get 0 3vector <rect> clip set