Merge branch 'master' of git://factorcode.org/git/factor

basis/tools/dispatch/dispatch.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2009 Slava Pestov.
+! Copyright (C) 2009, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors kernel namespaces prettyprint classes.struct
 vm tools.dispatch.private ;
@@ -17,8 +17,7 @@ SYMBOL: last-dispatch-stats
         { "Tuple check count" [ pic-tuple-count>> ] }
     } object-table. ;
 
-: collect-dispatch-stats ( quot -- )
+: collect-dispatch-stats ( quot -- dispatch-statistics )
     reset-dispatch-stats
     call
-    dispatch-stats dispatch-statistics memory>struct
+    dispatch-stats dispatch-statistics memory>struct ; inline
-    last-dispatch-stats set ; inline

basis/tools/memory/memory-tests.factor

@@ -1,9 +1,9 @@
-USING: tools.test tools.memory memory ;
+USING: tools.test tools.memory memory arrays ;
 IN: tools.memory.tests
 
 [ ] [ room. ] unit-test
 [ ] [ heap-stats. ] unit-test
-[ ] [ [ gc gc ] collect-gc-events ] unit-test
+[ t ] [ [ gc gc ] collect-gc-events array? ] unit-test
 [ ] [ gc-events. ] unit-test
 [ ] [ gc-stats. ] unit-test
 [ ] [ gc-summary. ] unit-test

basis/tools/memory/memory.factor

@@ -90,12 +90,10 @@ PRIVATE>
         ] each 2drop
     ] tabular-output nl ;
 
-SYMBOL: gc-events
+: collect-gc-events ( quot -- gc-events )
-
-: collect-gc-events ( quot -- )
     enable-gc-events
     [ ] [ disable-gc-events drop ] cleanup
-    disable-gc-events [ gc-event memory>struct ] map gc-events set ; inline
+    disable-gc-events [ gc-event memory>struct ] map ; inline
 
 <PRIVATE
 
@@ -164,6 +162,8 @@ TUPLE: gc-stats collections times ;
 
 PRIVATE>
 
+SYMBOL: gc-events
+
 : gc-event. ( event -- )
     {
         { "Event type:" [ op>> gc-op-string ] }

basis/tools/time/time-docs.factor

@@ -27,11 +27,11 @@ HELP: time
 { benchmark system-micros time } related-words
 
 HELP: collect-gc-events
-{ $values { "quot" quotation } }
+{ $values { "quot" quotation } { "gc-events" "a sequence of " { $link gc-event } " instances" } }
-{ $description "Calls the quotation, storing an array of " { $link gc-event } " instances in the " { $link gc-events } " variable." }
+{ $description "Calls the quotation and outputs a sequence of " { $link gc-event } " instances." }
 { $notes "The " { $link time } " combinator automatically calls this combinator." } ;
 
 HELP: collect-dispatch-stats
-{ $values { "quot" quotation } }
+{ $values { "quot" quotation } { "dispatch-statistics" dispatch-statistics } }
-{ $description "Calls the quotation, collecting method dispatch statistics and storing them in the " { $link last-dispatch-stats } " variable. " }
+{ $description "Calls the quotation and outputs a " { $link dispatch-statistics } " instance." }
 { $notes "The " { $link time } " combinator automatically calls this combinator." } ;

basis/tools/time/time.factor

@@ -1,6 +1,6 @@
-! Copyright (C) 2003, 2009 Slava Pestov.
+! Copyright (C) 2003, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: system kernel math io prettyprint tools.memory
+USING: system kernel math namespaces io prettyprint tools.memory
 tools.dispatch ;
 IN: tools.time
 
@@ -18,5 +18,7 @@ IN: tools.time
     "gc-summary.      - Print aggregate garbage collection statistics" print ;
 
 : time ( quot -- )
-    [ [ benchmark ] collect-dispatch-stats ] collect-gc-events
+    [
+        [ benchmark ] collect-dispatch-stats last-dispatch-stats set
+    ] collect-gc-events gc-events set
     time. nl time-banner. ; inline

extra/astar/astar-tests.factor

@@ -4,8 +4,6 @@ USING: arrays assocs astar combinators hashtables kernel literals math math.func
 math.vectors sequences sorting splitting strings tools.test ;
 IN: astar.tests
 
-<<
-
 ! Use a 10x9 maze (see below) to try to go from s to e, f or g.
 ! X means that a position is unreachable.
 ! The costs model is:
@@ -13,6 +11,10 @@ IN: astar.tests
 !   - going down costs 1 point
 !   - going left or right costs 2 points
 
+<<
+
+TUPLE: maze < astar ;
+
 : reachable? ( pos -- ? )
     first2 [ 2 * 5 + ] [ 2 + ] bi* $[
 "    0 1 2 3 4 5 6 7 8 9
@@ -28,20 +30,21 @@ IN: astar.tests
   8  X X X X X X X X X X"
         "\n" split ] nth nth CHAR: X = not ;
 
-: neighbours ( pos -- neighbours )
+M: maze neighbours
-     first2
+    drop
-     { [ 1 + 2array ] [ 1 - 2array ] [ [ 1 + ] dip 2array ] [ [ 1 - ] dip 2array ] } 2cleave
+    first2
-     4array
+    { [ 1 + 2array ] [ 1 - 2array ] [ [ 1 + ] dip 2array ] [ [ 1 - ] dip 2array ] } 2cleave
-     [ reachable? ] filter ;
+    4array
+    [ reachable? ] filter ;
 
-: heuristic ( from to -- cost )
+M: maze heuristic
-    v- [ abs ] [ + ] map-reduce ;
+    drop v- [ abs ] [ + ] map-reduce ;
 
-: cost ( from to -- cost )
+M: maze cost
-    2dup [ first ] bi@ = [ [ second ] bi@ > 1 5 ? ] [ 2drop 2 ] if ;
+    drop 2dup [ first ] bi@ = [ [ second ] bi@ > 1 5 ? ] [ 2drop 2 ] if ;
 
 : test1 ( to -- path considered )
-    { 1 1 } swap [ neighbours ] [ cost ] [ heuristic ] <astar> [ find-path ] [ considered ] bi ;
+    { 1 1 } swap maze new [ find-path ] [ considered ] bi ;
 >>
 
 ! Existing path from s to f
@@ -73,8 +76,6 @@ IN: astar.tests
 ! Non-existing path from s to g -- all positions must have been considered
 [ f 26 ] [ { 1 7 } test1 length ] unit-test
 
-<<
-
 ! Look for a path between A and C. The best path is A --> D --> C. C will be placed
 ! in the open set early because B will be examined first. This checks that the evaluation
 ! of C is correctly replaced in the open set.
@@ -92,6 +93,10 @@ IN: astar.tests
 !     A ---> D ---------> E ---> F
 !       (2)       (1)       (1)
 
+<<
+
+! In this version, we will use the quotations-aware version through <astar>.
+
 : n ( pos -- neighbours )
     $[ { "ABD" "BC" "C" "DCE" "ECF" } [ unclip swap 2array ] map >hashtable ] at ;