Merge branch 'master' of git://github.com/slavapestov/factor

basis/io/servers/servers.factor

@@ -86,7 +86,9 @@ M: f >insecure ;
     [ dup secure? [ <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> >>secure-context
     ] when ;
 

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 ;
 
 : <arrow> ( 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 ;

core/math/integers/integers-tests.factor

@@ -216,8 +216,8 @@ unit-test
 
 : random-integer ( -- n )
     32 random-bits
-    1 random zero? [ neg ] when
+    { t f } random [ neg ] when
-    1 random zero? [ >bignum ] 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

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

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
 
-{ <astar> <bfs> } related-words
+{ <astar> <bfs> <dijkstra> } related-words
 
 HELP: astar
 { $description "This tuple must be subclassed and its method " { $link cost } ", "
@@ -45,7 +45,7 @@ HELP: <astar>
   { "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: <astar>
 
 HELP: <bfs>
 { $values
-  { "neighbours" "an assoc" }
+  { "neighbours" assoc }
-  { "astar" "a astar tuple" }
+  { "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: <dijkstra>
+{ $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 "

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 <bfs> find-path ] unit-test
 [ "DC" ] [ "DC" first2 routes <bfs> 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 <dijkstra> [ 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

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>
 
 : <bfs> ( neighbours -- astar )
     [ bfs new ] dip >>neighbours ;
+
+: <dijkstra> ( costs -- astar )
+    [ dijkstra new ] dip >>costs ;