From 0c840a796560f3e9b78a46afc8853e8e1eb088e0 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 13 Nov 2010 16:02:12 -0800 Subject: [PATCH 1/6] math.integers: bignum/f rounding was wrong (reported by Joe Groff) --- core/math/integers/integers-tests.factor | 10 ++++++++-- core/math/integers/integers.factor | 7 ++++++- 2 files changed, 14 insertions(+), 3 deletions(-) diff --git a/core/math/integers/integers-tests.factor b/core/math/integers/integers-tests.factor index 6f57b06658..85cd63463c 100644 --- a/core/math/integers/integers-tests.factor +++ b/core/math/integers/integers-tests.factor @@ -216,8 +216,8 @@ unit-test : random-integer ( -- n ) 32 random-bits - 1 random zero? [ neg ] when - 1 random zero? [ >bignum ] when ; + { t f } random [ neg ] when + { t f } random [ >bignum ] when ; [ t ] [ 10000 [ @@ -232,5 +232,11 @@ unit-test [ HEX: 1.758bec11492f9p-54 ] [ 1 12345678901234567 /f ] unit-test [ HEX: -1.758bec11492f9p-54 ] [ 1 -12345678901234567 /f ] unit-test +! Ensure that /f rounds to nearest and not to zero +[ HEX: 1.0p55 ] [ HEX: 7f,ffff,ffff,ffff >bignum 1 /f ] unit-test +[ HEX: 1.0p55 ] [ HEX: -7f,ffff,ffff,ffff >bignum -1 /f ] unit-test +[ HEX: -1.0p55 ] [ HEX: -7f,ffff,ffff,ffff >bignum 1 /f ] unit-test +[ HEX: -1.0p55 ] [ HEX: 7f,ffff,ffff,ffff >bignum -1 /f ] unit-test + [ 17 ] [ 17 >bignum 5 max ] unit-test [ 5 ] [ 17 >bignum 5 min ] unit-test diff --git a/core/math/integers/integers.factor b/core/math/integers/integers.factor index a3be60ed35..22fe01f1ab 100644 --- a/core/math/integers/integers.factor +++ b/core/math/integers/integers.factor @@ -140,13 +140,18 @@ M: bignum (log2) bignum-log2 ; inline [ 2/ ] dip over log2 52 > [ [ 2/ ] [ 1 + ] bi* ] when [ unscaled-float ] dip scale-float ; inline +: round-to-nearest ( fraction-and-guard rem -- fraction-and-guard' ) + over odd? + [ zero? [ dup zero? [ 1 + ] unless ] [ 1 + ] if ] [ drop ] if ; + inline + ! Main word : /f-abs ( m n -- f ) over zero? [ nip zero? 0/0. 0.0 ? ] [ [ drop 1/0. ] [ pre-scale /f-loop - [ over odd? [ zero? [ 1 + ] unless ] [ drop ] if ] dip + [ round-to-nearest ] dip post-scale ] if-zero ] if ; inline From c4a83d2d0b3cc6f2f1b22cb3b345617fa1d6a09b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 13 Nov 2010 18:31:29 -0600 Subject: [PATCH 2/6] io.servers: don't try to open SSL sockets if they're not supported on the current platform (ie, Windows) --- basis/io/servers/servers.factor | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) mode change 100644 => 100755 basis/io/servers/servers.factor diff --git a/basis/io/servers/servers.factor b/basis/io/servers/servers.factor old mode 100644 new mode 100755 index 0ef461697b..5eee753db2 --- a/basis/io/servers/servers.factor +++ b/basis/io/servers/servers.factor @@ -86,7 +86,9 @@ M: f >insecure ; [ dup secure? [ ] unless ] map ; : listen-on ( threaded-server -- addrspecs ) - [ secure>> >secure ] [ insecure>> >insecure ] bi append + [ secure>> ssl-supported? [ >secure ] [ drop { } ] if ] + [ insecure>> >insecure ] + bi append [ resolve-host ] map concat ; : accepted-connection ( remote local -- ) @@ -141,7 +143,7 @@ M: threaded-server handle-client* handler>> call( -- ) ; \ start-accept-loop NOTICE add-error-logging : create-secure-context ( threaded-server -- threaded-server ) - dup secure>> [ + dup secure>> ssl-supported? and [ dup secure-config>> >>secure-context ] when ; From 6994e6c8eedf48b56ac22b78a296ba33a40d92e2 Mon Sep 17 00:00:00 2001 From: Samuel Tardieu Date: Thu, 11 Nov 2010 10:59:05 +0100 Subject: [PATCH 3/6] path-finding: add Dijkstra algorithm Dijkstra algorithm is a particular case of the A* algorithm with the heuristic being set to 0. --- extra/path-finding/path-finding-docs.factor | 13 ++++++++++++- extra/path-finding/path-finding-tests.factor | 18 ++++++++++++++++++ extra/path-finding/path-finding.factor | 8 ++++++++ 3 files changed, 38 insertions(+), 1 deletion(-) diff --git a/extra/path-finding/path-finding-docs.factor b/extra/path-finding/path-finding-docs.factor index 46f1048ba7..a41959db69 100644 --- a/extra/path-finding/path-finding-docs.factor +++ b/extra/path-finding/path-finding-docs.factor @@ -3,7 +3,7 @@ USING: help.markup help.syntax ; IN: path-finding -{ } related-words +{ } related-words HELP: astar { $description "This tuple must be subclassed and its method " { $link cost } ", " @@ -65,6 +65,17 @@ HELP: "path finding algorithm which is a particular case of the general A* algorithm." } ; +HELP: +{ $values + { "costs" "an assoc" } +} +{ $description "Build an astar object from the " { $snippet "costs" } " assoc. " + "The assoc keys are edges of the graph, while the corresponding values are assocs whose keys are " + "the edges that can be reached and whose values are the costs to reach those edges. When used with " + { $link find-path } ", this astar tuple will use the Dijkstra path finding algorithm which is " + "a particular case of the general A* algorithm." +} ; + HELP: find-path { $values { "start" "a node" } diff --git a/extra/path-finding/path-finding-tests.factor b/extra/path-finding/path-finding-tests.factor index 11a047cb89..0e9b5289b1 100644 --- a/extra/path-finding/path-finding-tests.factor +++ b/extra/path-finding/path-finding-tests.factor @@ -120,3 +120,21 @@ MEMO: routes ( -- hash ) $[ { "ABD" "BC" "C" "DCE" "ECF" } [ unclip swap 2array [ f ] [ "FA" first2 routes find-path ] unit-test [ "DC" ] [ "DC" first2 routes find-path >string ] unit-test + +<< + +! Build the costs as expected by the dijkstra word. + +MEMO: costs ( -- costs ) + routes keys [ dup dup n [ dup [ c ] dip swap 2array ] with { } map-as >hashtable 2array ] map >hashtable ; + +: test3 ( fromto -- path considered ) + first2 costs [ find-path ] [ considered natural-sort >string ] bi ; + +>> + +! Check path from A to C -- all nodes but F must have been examined +[ "ADC" "ABCDE" ] [ "AC" test3 [ >string ] dip ] unit-test + +! No path from D to B -- all nodes reachable from D must have been examined +[ f "CDEF" ] [ "DB" test3 ] unit-test diff --git a/extra/path-finding/path-finding.factor b/extra/path-finding/path-finding.factor index cd63a5c8d5..4b11616c20 100644 --- a/extra/path-finding/path-finding.factor +++ b/extra/path-finding/path-finding.factor @@ -74,6 +74,11 @@ M: bfs cost 3drop 1 ; M: bfs heuristic 3drop 0 ; M: bfs neighbours neighbours>> at ; +TUPLE: dijkstra < astar costs ; +M: dijkstra cost costs>> swapd at at ; +M: dijkstra heuristic 3drop 0 ; +M: dijkstra neighbours costs>> at keys ; + PRIVATE> : find-path ( start target astar -- path/f ) @@ -87,3 +92,6 @@ PRIVATE> : ( neighbours -- astar ) [ bfs new ] dip >>neighbours ; + +: ( costs -- astar ) + [ dijkstra new ] dip >>costs ; From b207482d38be17c72f551c04700b06f37d452599 Mon Sep 17 00:00:00 2001 From: Jon Harper Date: Sun, 14 Nov 2010 17:20:19 +0100 Subject: [PATCH 4/6] Remove unecessary slot from arrow models --- basis/models/arrow/arrow.factor | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/basis/models/arrow/arrow.factor b/basis/models/arrow/arrow.factor index e0cf73c7f1..17107999ca 100644 --- a/basis/models/arrow/arrow.factor +++ b/basis/models/arrow/arrow.factor @@ -1,18 +1,17 @@ ! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors models kernel ; +USING: accessors models kernel sequences ; IN: models.arrow -TUPLE: arrow < model model quot ; +TUPLE: arrow < model quot ; : ( model quot -- arrow ) f arrow new-model swap >>quot - over >>model [ add-dependency ] keep ; M: arrow model-changed [ [ value>> ] [ quot>> ] bi* call( old -- new ) ] [ nip ] 2bi set-model ; -M: arrow model-activated [ model>> ] keep model-changed ; +M: arrow model-activated [ dependencies>> ] keep [ model-changed ] curry each ; From 97a8e889c3118bc48bda6846fc20277da369dc51 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 14 Nov 2010 15:30:32 -0800 Subject: [PATCH 5/6] models.arrow: fix formatting --- basis/models/arrow/arrow.factor | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/basis/models/arrow/arrow.factor b/basis/models/arrow/arrow.factor index 17107999ca..a1654ccc34 100644 --- a/basis/models/arrow/arrow.factor +++ b/basis/models/arrow/arrow.factor @@ -14,4 +14,5 @@ M: arrow model-changed [ [ value>> ] [ quot>> ] bi* call( old -- new ) ] [ nip ] 2bi set-model ; -M: arrow model-activated [ dependencies>> ] keep [ model-changed ] curry each ; +M: arrow model-activated + [ dependencies>> ] keep [ model-changed ] curry each ; From c412237dc44921704a01e80c2a5d84cd629622ad Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 14 Nov 2010 19:29:37 -0800 Subject: [PATCH 6/6] path-finding: fix help lint --- extra/path-finding/path-finding-docs.factor | 15 ++++++++------- 1 file changed, 8 insertions(+), 7 deletions(-) diff --git a/extra/path-finding/path-finding-docs.factor b/extra/path-finding/path-finding-docs.factor index a41959db69..c282aa1dc0 100644 --- a/extra/path-finding/path-finding-docs.factor +++ b/extra/path-finding/path-finding-docs.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2010 Samuel Tardieu. ! See http://factorcode.org/license.txt for BSD license. -USING: help.markup help.syntax ; +USING: help.markup help.syntax assocs ; IN: path-finding { } related-words @@ -45,7 +45,7 @@ HELP: { "neighbours" "a quotation with stack effect ( node -- seq )" } { "cost" "a quotation with stack effect ( from to -- cost )" } { "heuristic" "a quotation with stack effect ( pos target -- cost )" } - { "astar" "a astar tuple" } + { "astar" astar } } { $description "Build an astar object from the given quotations. The " { $snippet "neighbours" } " one builds the list of neighbours. The " @@ -57,8 +57,8 @@ HELP: HELP: { $values - { "neighbours" "an assoc" } - { "astar" "a astar tuple" } + { "neighbours" assoc } + { "astar" astar } } { $description "Build an astar object from the " { $snippet "neighbours" } " assoc. " "When used with " { $link find-path } ", this astar tuple will use the breadth-first search (BFS) " @@ -67,7 +67,8 @@ HELP: HELP: { $values - { "costs" "an assoc" } + { "costs" assoc } + { "astar" astar } } { $description "Build an astar object from the " { $snippet "costs" } " assoc. " "The assoc keys are edges of the graph, while the corresponding values are assocs whose keys are " @@ -80,7 +81,7 @@ HELP: find-path { $values { "start" "a node" } { "target" "a node" } - { "astar" "a astar tuple" } + { "astar" astar } { "path/f" "an optimal path from " { $snippet "start" } " to " { $snippet "target" } ", or f if no such path exists" } } @@ -90,7 +91,7 @@ HELP: find-path HELP: considered { $values - { "astar" "a astar tuple" } + { "astar" astar } { "considered" "a sequence" } } { $description "When called after a call to " { $link find-path } ", return a list of nodes "