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 ; diff --git a/basis/models/arrow/arrow.factor b/basis/models/arrow/arrow.factor index e0cf73c7f1..a1654ccc34 100644 --- a/basis/models/arrow/arrow.factor +++ b/basis/models/arrow/arrow.factor @@ -1,18 +1,18 @@ ! 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 ; 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 diff --git a/extra/path-finding/path-finding-docs.factor b/extra/path-finding/path-finding-docs.factor index 46f1048ba7..c282aa1dc0 100644 --- a/extra/path-finding/path-finding-docs.factor +++ b/extra/path-finding/path-finding-docs.factor @@ -1,9 +1,9 @@ ! 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 +{ } related-words HELP: astar { $description "This tuple must be subclassed and its method " { $link cost } ", " @@ -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,19 +57,31 @@ 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) " "path finding algorithm which is a particular case of the general A* algorithm." } ; +HELP: +{ $values + { "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 " + "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" } { "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" } } @@ -79,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 " 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 ;