From 10836ce1bc84ad1eaff53af75dd5f827725c467c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 16 Mar 2010 14:00:15 +1300 Subject: [PATCH 1/4] tools.memory, tools.dispatch: change collect-gc-events and collect-dispatch-stats combinators to output values instead of setting variables --- basis/tools/dispatch/dispatch.factor | 7 +++---- basis/tools/memory/memory.factor | 8 ++++---- basis/tools/time/time-docs.factor | 8 ++++---- basis/tools/time/time.factor | 8 +++++--- 4 files changed, 16 insertions(+), 15 deletions(-) diff --git a/basis/tools/dispatch/dispatch.factor b/basis/tools/dispatch/dispatch.factor index 7d30dac36b..7ee89a50fb 100644 --- a/basis/tools/dispatch/dispatch.factor +++ b/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-stats ) reset-dispatch-stats call - dispatch-stats dispatch-statistics memory>struct - last-dispatch-stats set ; inline + dispatch-stats dispatch-statistics memory>struct ; inline diff --git a/basis/tools/memory/memory.factor b/basis/tools/memory/memory.factor index 0c55612466..1c999d979a 100644 --- a/basis/tools/memory/memory.factor +++ b/basis/tools/memory/memory.factor @@ -90,12 +90,10 @@ PRIVATE> ] each 2drop ] tabular-output nl ; -SYMBOL: gc-events - -: collect-gc-events ( quot -- ) +: collect-gc-events ( quot -- gc-events ) 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 +SYMBOL: gc-events + : gc-event. ( event -- ) { { "Event type:" [ op>> gc-op-string ] } diff --git a/basis/tools/time/time-docs.factor b/basis/tools/time/time-docs.factor index d28202f844..ce9a621a2f 100644 --- a/basis/tools/time/time-docs.factor +++ b/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 } } -{ $description "Calls the quotation, storing an array of " { $link gc-event } " instances in the " { $link gc-events } " variable." } +{ $values { "quot" quotation } { "gc-events" "a sequence of " { $link gc-event } " instances" } } +{ $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 } } -{ $description "Calls the quotation, collecting method dispatch statistics and storing them in the " { $link last-dispatch-stats } " variable. " } +{ $values { "quot" quotation } { "dispatch-stats" dispatch-stats } } +{ $description "Calls the quotation and outputs a " { $link dispatch-stats } " instance." } { $notes "The " { $link time } " combinator automatically calls this combinator." } ; diff --git a/basis/tools/time/time.factor b/basis/tools/time/time.factor index 0bd97f563d..8355f1f20c 100644 --- a/basis/tools/time/time.factor +++ b/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 From 9b6b58b240aa01ac5e73b0bd71695755f083e0fe Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 16 Mar 2010 16:44:36 +1300 Subject: [PATCH 2/4] tools.time: fix load error in docs --- basis/tools/dispatch/dispatch.factor | 2 +- basis/tools/time/time-docs.factor | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/basis/tools/dispatch/dispatch.factor b/basis/tools/dispatch/dispatch.factor index 7ee89a50fb..72830b29b4 100644 --- a/basis/tools/dispatch/dispatch.factor +++ b/basis/tools/dispatch/dispatch.factor @@ -17,7 +17,7 @@ SYMBOL: last-dispatch-stats { "Tuple check count" [ pic-tuple-count>> ] } } object-table. ; -: collect-dispatch-stats ( quot -- dispatch-stats ) +: collect-dispatch-stats ( quot -- dispatch-statistics ) reset-dispatch-stats call dispatch-stats dispatch-statistics memory>struct ; inline diff --git a/basis/tools/time/time-docs.factor b/basis/tools/time/time-docs.factor index ce9a621a2f..cbcd38c801 100644 --- a/basis/tools/time/time-docs.factor +++ b/basis/tools/time/time-docs.factor @@ -32,6 +32,6 @@ HELP: collect-gc-events { $notes "The " { $link time } " combinator automatically calls this combinator." } ; HELP: collect-dispatch-stats -{ $values { "quot" quotation } { "dispatch-stats" dispatch-stats } } -{ $description "Calls the quotation and outputs a " { $link dispatch-stats } " instance." } +{ $values { "quot" quotation } { "dispatch-statistics" dispatch-statistics } } +{ $description "Calls the quotation and outputs a " { $link dispatch-statistics } " instance." } { $notes "The " { $link time } " combinator automatically calls this combinator." } ; From 604ccb0a3ab397a81437ca7a3d9c0095a51eef4b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 16 Mar 2010 18:35:44 +1300 Subject: [PATCH 3/4] tools.memory: fix unit test --- basis/tools/memory/memory-tests.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/tools/memory/memory-tests.factor b/basis/tools/memory/memory-tests.factor index 4711f472a3..1ea5854939 100644 --- a/basis/tools/memory/memory-tests.factor +++ b/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 From db106486f15b8798dac388e91163484439dc95c0 Mon Sep 17 00:00:00 2001 From: Samuel Tardieu Date: Tue, 16 Mar 2010 09:28:51 +0100 Subject: [PATCH 4/4] Also test the derivation variant of astar --- extra/astar/astar-tests.factor | 33 +++++++++++++++++++-------------- 1 file changed, 19 insertions(+), 14 deletions(-) diff --git a/extra/astar/astar-tests.factor b/extra/astar/astar-tests.factor index 11b2dfcaa2..6e2e2f4f1b 100644 --- a/extra/astar/astar-tests.factor +++ b/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 ) - first2 - { [ 1 + 2array ] [ 1 - 2array ] [ [ 1 + ] dip 2array ] [ [ 1 - ] dip 2array ] } 2cleave - 4array - [ reachable? ] filter ; +M: maze neighbours + drop + first2 + { [ 1 + 2array ] [ 1 - 2array ] [ [ 1 + ] dip 2array ] [ [ 1 - ] dip 2array ] } 2cleave + 4array + [ reachable? ] filter ; -: heuristic ( from to -- cost ) - v- [ abs ] [ + ] map-reduce ; +M: maze heuristic + drop v- [ abs ] [ + ] map-reduce ; -: cost ( from to -- cost ) - 2dup [ first ] bi@ = [ [ second ] bi@ > 1 5 ? ] [ 2drop 2 ] if ; +M: maze cost + drop 2dup [ first ] bi@ = [ [ second ] bi@ > 1 5 ? ] [ 2drop 2 ] if ; : test1 ( to -- path considered ) - { 1 1 } swap [ neighbours ] [ cost ] [ heuristic ] [ 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 . + : n ( pos -- neighbours ) $[ { "ABD" "BC" "C" "DCE" "ECF" } [ unclip swap 2array ] map >hashtable ] at ;