ui.gadgets: make fast-children-on more flexible and take a quotation instead of always calling loc>> on elements of the children array. This enables a bug fix for M\ grid children-on, discovered from UI mis-rendering of '\ blend-mode help'

basis/ui/gadgets/gadgets.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2005, 2009 Slava Pestov.
+! Copyright (C) 2005, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays hashtables kernel math namespaces
 make sequences quotations math.vectors combinators sorting
@@ -62,18 +62,19 @@ M: gadget children-on nip children>> ;
 
 <PRIVATE
 
-: ((fast-children-on)) ( gadget dim axis -- <=> )
+:: (fast-children-on) ( point axis children quot -- i )
-    [ swap loc>> v- ] dip v. 0 <=> ;
+    children [
-
+        [ point ] dip
-:: (fast-children-on) ( dim axis children -- i )
+        quot call( value -- loc ) v-
-    children [ dim axis ((fast-children-on)) ] search drop ;
+        axis v. 0 <=>
+    ] search drop ; inline
 
 PRIVATE>
 
-: fast-children-on ( rect axis children -- from to )
+:: fast-children-on ( rect axis children quot -- slice )
-    [ [ loc>> ] 2dip (fast-children-on) 0 or ]
+    rect loc>> axis children quot (fast-children-on) 0 or
-    [ [ rect-bounds v+ ] 2dip (fast-children-on) ?1+ ]
+    rect rect-bounds v+ axis children quot (fast-children-on) ?1+
-    3bi ;
+    children <slice> ; inline
 
 M: gadget contains-rect? ( bounds gadget -- ? )
     dup visible?>> [ call-next-method ] [ 2drop f ] if ;

basis/ui/gadgets/grids/grids-tests.factor

@@ -1,12 +1,14 @@
 USING: ui.gadgets ui.gadgets.grids tools.test kernel arrays
 namespaces math.rectangles accessors ui.gadgets.grids.private
-ui.gadgets.debug sequences ;
+ui.gadgets.debug sequences classes ;
 IN: ui.gadgets.grids.tests
 
 [ { 0 0 } ] [ { } <grid> pref-dim ] unit-test
 
 : 100x100 ( -- gadget ) <gadget> { 100 100 } >>dim ;
 
+: 200x200 ( -- gadget ) <gadget> { 200 200 } >>dim ;
+
 [ { 100 100 } ] [
     100x100
     1array 1array <grid> pref-dim
@@ -81,4 +83,22 @@ IN: ui.gadgets.grids.tests
     "g" get
     dup layout
     children>> [ loc>> ] map
-] unit-test
+] unit-test
+
+! children-on logic was insufficient
+[ ] [
+    100x100 dup "a" set 200x200 2array
+    100x100 dup "b" set 200x200 2array 2array <grid> f >>fill? "g" set
+] unit-test
+
+[ ] [ "g" get prefer ] unit-test
+[ ] [ "g" get layout ] unit-test
+
+[ { 0 50 } ] [ "a" get loc>> ] unit-test
+[ { 0 250 } ] [ "b" get loc>> ] unit-test
+
+[ gadget { 200 200 } ]
+[ { 120 20 } "g" get pick-up [ class ] [ dim>> ] bi ] unit-test
+
+[ gadget { 200 200 } ]
+[ { 120 220 } "g" get pick-up [ class ] [ dim>> ] bi ] unit-test

basis/ui/gadgets/grids/grids.factor

@@ -1,7 +1,8 @@
-! Copyright (C) 2006, 2009 Slava Pestov.
+! Copyright (C) 2006, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays kernel math math.order math.matrices namespaces make sequences words io
+USING: arrays kernel math math.order math.matrices namespaces
-math.vectors ui.gadgets ui.baseline-alignment columns accessors strings.tables
+make sequences words io math.vectors ui.gadgets
+ui.baseline-alignment columns accessors strings.tables
 math.rectangles fry ;
 IN: ui.gadgets.grids
 
@@ -115,8 +116,10 @@ M: grid layout* [ grid>> ] [ <grid-layout> ] bi grid-layout ;
 
 M: grid children-on ( rect gadget -- seq )
     dup children>> empty? [ 2drop f ] [
-        [ { 0 1 } ] dip grid>>
+        [ { 0 1 } ] dip
-        [ 0 <column> fast-children-on ] [ <slice> concat ] bi
+        [ grid>> ] [ dim>> ] bi
+        '[ _ [ loc>> vmin ] reduce ] fast-children-on
+        concat
     ] if ;
 
 M: grid gadget-text*

basis/ui/gadgets/packs/packs.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2005, 2009 Slava Pestov.
+! Copyright (C) 2005, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: sequences ui.gadgets ui.baseline-alignment
 ui.baseline-alignment.private kernel math math.functions math.vectors
@@ -100,5 +100,4 @@ M: pack layout*
     dup children>> pref-dims pack-layout ;
 
 M: pack children-on ( rect gadget -- seq )
-    [ orientation>> ] [ children>> ] bi
+    [ orientation>> ] [ children>> ] bi [ loc>> ] fast-children-on ;
-    [ fast-children-on ] keep <slice> ;

basis/ui/gadgets/panes/panes.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2005, 2009 Slava Pestov.
+! Copyright (C) 2005, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays hashtables io kernel namespaces sequences
 strings quotations math opengl combinators memoize math.vectors
@@ -352,7 +352,8 @@ M: paragraph stream-format
 GENERIC: sloppy-pick-up* ( loc gadget -- n )
 
 M: pack sloppy-pick-up* ( loc gadget -- n )
-    [ orientation>> ] [ children>> ] bi (fast-children-on) ;
+    [ orientation>> ] [ children>> ] bi
+    [ loc>> ] (fast-children-on) ;
 
 M: gadget sloppy-pick-up*
     children>> [ contains-point? ] with find-last drop ;