fix bug in pick-up

TODO.FACTOR.txt

@@ -33,7 +33,6 @@
 - faster layout
 - faster repaint
 - ui browser
-- auto-updating inspector, mirrors abstraction
 - mouse enter onto overlapping with interior, but not child, gadget
 - rollovers broken in inspector
 - menu dragging
@@ -74,17 +73,12 @@
 
 + sequences
 
-- generic skip
 - dipping 2nmap, 2each
 - array sort
-- 2map slow with lists
 - nappend: instead of using push, enlarge the sequence with set-length
   then add set the elements with set-nth
 - faster sequence operations
-- generic some? all? memq? fiber?
-- index and index* are very slow with lists
 - specialized arrays
-- list map, subset: not tail recursive
 - phase out sbuf-append
 
 + kernel:

library/bootstrap/boot-stage3.factor

@@ -30,6 +30,8 @@ init-assembler
 
 : compile? "compile" get supported-cpu? and ;
 
+"library/inference/branches.factor" run-file
+
 compile? [
     \ car compile
     \ * compile

library/collections/lists.factor

@@ -71,13 +71,10 @@ M: general-list find* ( start list quot -- i elt )
     #! list.
     2dup member? [ nip ] [ cons ] ifte ;
 
-M: general-list reverse ( list -- list )
+M: general-list reversed ( list -- list )
     [ ] [ swons ] reduce ;
 
-M: f map ( list quot -- list ) drop ;
-
-M: cons map ( list quot -- list | quot: elt -- elt )
-    (each) rot >r map r> swons ;
+M: general-list reverse reversed ;
 
 IN: sequences
 DEFER: <range>

library/collections/sequences-epilogue.factor

@@ -37,8 +37,14 @@ M: object each ( seq quot -- )
     #! Destructive on seq.
     0 swap (nmap) ; inline
 
-M: object map ( seq quot -- seq | quot: elt -- elt )
-    swap [ swap nmap ] immutable ;
+: map ( seq quot -- seq | quot: elt -- elt )
+    swap [ swap nmap ] immutable ; inline
+
+: map-with ( obj list quot -- list | quot: obj elt -- elt )
+    swap [ with rot ] map 2nip ; inline
+
+: accumulate ( list identity quot -- values | quot: x y -- z )
+    rot [ pick >r swap call r> ] map-with nip ; inline
 
 : (2nmap) ( seq1 seq2 i quot -- elt3 )
     pick pick >r >r >r 2nth r> call r> r> swap set-nth ; inline
@@ -183,25 +189,25 @@ M: object peek ( sequence -- element )
 
 : >pop> ( stack -- stack ) dup pop drop ;
 
+M: object reversed ( seq -- seq ) <reversed> ;
+
 M: object reverse ( seq -- seq ) [ <reversed> ] keep like ;
 
 ! Set theoretic operations
-: seq-intersect ( seq seq -- seq )
-    #! Make a list of elements that occur in both lists.
+: seq-intersect ( seq1 seq2 -- seq1/\seq2 )
     [ swap member? ] subset-with ;
 
-: seq-diff ( list1 list2 -- list )
-    #! Make a list of elements that occur in list2 but not
-    #! list1.
+: seq-diff ( seq1 seq2 -- seq2-seq1 )
     [ swap member? not ] subset-with ;
 
-: seq-diffq ( list1 list2 -- list )
-    #! Make a list of elements that occur in list2 but not
-    #! list1.
+: seq-diffq ( seq1 seq2 -- seq2-seq1 )
     [ swap memq? not ] subset-with ;
 
-: contained? ( list1 list2 -- ? )
-    #! Is every element of list1 in list2?
+: seq-union ( seq1 seq2 -- seq1\/seq2 )
+    append prune ;
+
+: contained? ( seq1 seq2 -- ? )
+    #! Is every element of seq1 in seq2
     swap [ swap member? ] all-with? ;
 
 IN: kernel

library/collections/sequences.factor

@@ -19,12 +19,16 @@ GENERIC: set-nth ( value n sequence -- obj )
 GENERIC: thaw ( seq -- mutable-seq )
 GENERIC: like ( seq seq -- seq )
 GENERIC: reverse ( seq -- seq )
+GENERIC: reversed ( seq -- seq )
 GENERIC: peek ( seq -- elt )
 GENERIC: head ( n seq -- seq )
 GENERIC: tail ( n seq -- seq )
 GENERIC: concat ( seq -- seq )
 GENERIC: resize ( n seq -- seq )
 
+: immutable ( seq quot -- seq | quot: seq -- )
+    swap [ thaw ] keep >r dup >r swap call r> r> like ; inline
+
 G: each ( seq quot -- | quot: elt -- )
     [ over ] [ type ] ; inline
 
@@ -34,15 +38,6 @@ G: each ( seq quot -- | quot: elt -- )
 : reduce ( list identity quot -- value | quot: x y -- z )
     swapd each ; inline
 
-G: map ( seq quot -- seq | quot: elt -- elt )
-    [ over ] [ type ] ; inline
-
-: map-with ( obj list quot -- list | quot: obj elt -- elt )
-    swap [ with rot ] map 2nip ; inline
-
-: accumulate ( list identity quot -- values | quot: x y -- z )
-    rot [ pick >r swap call r> ] map-with nip ; inline
-
 G: 2map ( seq seq quot -- seq | quot: elt elt -- elt )
     [ over ] [ type ] ; inline
 
@@ -56,9 +51,6 @@ G: find* [ over ] [ type ] ; inline
 : find-with* ( obj i seq quot -- i elt )
     -rot [ with rot ] find* 2swap 2drop ; inline
 
-: immutable ( seq quot -- seq | quot: seq -- )
-    swap [ thaw ] keep >r dup >r swap call r> r> like ; inline
-
 : first 0 swap nth ; inline
 : second 1 swap nth ; inline
 : third 2 swap nth ; inline

library/generic/generic.factor

@@ -161,9 +161,6 @@ SYMBOL: typemap
 
 SYMBOL: object
 
-: type-union ( list list -- list )
-    append prune ;
-
 : lookup-union ( typelist -- class )
     [ > ] sort typemap get hash [ object ] unless* ;
 
@@ -171,7 +168,7 @@ SYMBOL: object
     #! Return a class that both classes are subclasses of.
     swap builtin-supertypes
     swap builtin-supertypes
-    type-union lookup-union ;
+    seq-union lookup-union ;
 
 : class-or-list ( list -- class )
     #! Return a class that every class in the list is a

library/inference/branches.factor

@@ -8,7 +8,7 @@ sequences strings vectors words hashtables prettyprint ;
     [ length ] map 0 [ max ] reduce ;
 
 : computed-value-vector ( n -- vector )
-    empty-vector [ object <computed> ] map ;
+    empty-vector [ drop object <computed> ] map ;
 
 : add-inputs ( count stack -- stack )
     #! Add this many inputs to the given stack.

library/ui/hand.factor

@@ -4,10 +4,8 @@ IN: gadgets
 USING: alien generic io kernel lists math matrices namespaces
 prettyprint sdl sequences vectors ;
 
-DEFER: pick-up
-
 : (pick-up) ( point gadget -- gadget )
-    gadget-children <reversed> [ pick-up ] find nip ;
+    gadget-children reversed [ inside? ] find-with nip ;
 
 : pick-up ( point gadget -- gadget )
     #! The logic is thus. If the point is definately outside the
@@ -15,7 +13,8 @@ DEFER: pick-up
     #! in any subgadget. If not, see if it is contained in the
     #! box delegate.
     2dup inside? [
-        [ [ translate ] keep (pick-up) dup ] keep ?
+        [ translate ] keep 2dup
+        (pick-up) [ pick-up ] [ nip ] ?ifte
     ] [
         2drop f
     ] ifte ;

library/ui/hierarchy.factor

@@ -2,7 +2,7 @@
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: gadgets
 USING: generic hashtables kernel lists math matrices namespaces
-sequences ;
+sequences vectors ;
 
 : remove-gadget ( gadget parent -- )
     [ 2dup gadget-children remq swap set-gadget-children ] keep
@@ -20,7 +20,7 @@ sequences ;
     0 over gadget-children set-length relayout ;
 
 : ?push ( elt seq/f -- seq )
-    [ push ] [ 1vector ] ifte* ;
+    [ [ push ] keep ] [ 1vector ] ifte* ;
 
 : (add-gadget) ( gadget box -- )
     over unparent

library/ui/layouts.factor

@@ -20,7 +20,7 @@ namespaces sdl sequences ;
 TUPLE: pack align fill vector ;
 
 : pref-dims ( gadget -- list )
-    gadget-children [ pref-dim ] map ;
+    gadget-children [ pref-dim ] map >list ;
 
 : orient ( gadget list1 list2 -- list )
     zip >r pack-vector r> [ uncons rot set-axis ] map-with ;