Merge branch 'master' into row-polymorphism

basis/compiler/tree/propagation/info/info.factor

@@ -31,7 +31,6 @@ class
 interval
 literal
 literal?
-length
 slots ;
 
 CONSTANT: null-info T{ value-info f null empty-interval }
@@ -48,9 +47,7 @@ CONSTANT: object-info T{ value-info f object full-interval }
             { [ over interval-length 0 > ] [ 3drop f f ] }
             { [ pick bignum class<= ] [ 2nip >bignum t ] }
             { [ pick integer class<= ] [ 2nip >fixnum t ] }
-            { [ pick float class<= ] [
+            { [ pick float class<= ] [ 2nip dup zero? [ drop f f ] [ >float t ] if ] }
-                2nip dup zero? [ drop f f ] [ >float t ] if
-            ] }
             [ 3drop f f ]
         } cond
     ] if ;
@@ -74,13 +71,19 @@ UNION: fixed-length array byte-array string ;
         ] unless
     ] unless ;
 
+: (slots-with-length) ( length class -- slots )
+    "slots" word-prop length 1 - f <array> swap prefix ;
+
+: slots-with-length ( seq -- slots )
+    [ length <literal-info> ] [ class ] bi (slots-with-length) ;
+
 : init-literal-info ( info -- info )
     empty-interval >>interval
     dup literal>> literal-class >>class
     dup literal>> {
         { [ dup real? ] [ [a,a] >>interval ] }
         { [ dup tuple? ] [ tuple-slot-infos >>slots ] }
-        { [ dup fixed-length? ] [ length <literal-info> >>length ] }
+        { [ dup fixed-length? ] [ slots-with-length >>slots ] }
         [ drop ]
     } cond ; inline
 
@@ -158,11 +161,11 @@ UNION: fixed-length array byte-array string ;
         t >>literal?
     init-value-info ; foldable
 
-: <sequence-info> ( value -- info )
+: <sequence-info> ( length class -- info )
     <value-info>
-        object >>class
+        over >>class
-        swap value-info >>length
+        [ (slots-with-length) ] dip swap >>slots
-    init-value-info ; foldable
+    init-value-info ;
 
 : <tuple-info> ( slots class -- info )
     <value-info>
@@ -185,13 +188,6 @@ DEFER: value-info-intersect
 
 DEFER: (value-info-intersect)
 
-: intersect-lengths ( info1 info2 -- length )
-    [ length>> ] bi@ {
-        { [ dup not ] [ drop ] }
-        { [ over not ] [ nip ] }
-        [ value-info-intersect ]
-    } cond ;
-
 : intersect-slot ( info1 info2 -- info )
     {
         { [ dup not ] [ nip ] }
@@ -215,7 +211,6 @@ DEFER: (value-info-intersect)
         [ [ class>> ] bi@ class-and >>class ]
         [ [ interval>> ] bi@ interval-intersect >>interval ]
         [ intersect-literals [ >>literal ] [ >>literal? ] bi* ]
-        [ intersect-lengths >>length ]
         [ intersect-slots >>slots ]
     } 2cleave
     init-value-info ;
@@ -236,13 +231,6 @@ DEFER: value-info-union
 
 DEFER: (value-info-union)
 
-: union-lengths ( info1 info2 -- length )
-    [ length>> ] bi@ {
-        { [ dup not ] [ nip ] }
-        { [ over not ] [ drop ] }
-        [ value-info-union ]
-    } cond ;
-
 : union-slot ( info1 info2 -- info )
     {
         { [ dup not ] [ nip ] }
@@ -261,7 +249,6 @@ DEFER: (value-info-union)
         [ [ class>> ] bi@ class-or >>class ]
         [ [ interval>> ] bi@ interval-union >>interval ]
         [ union-literals [ >>literal ] [ >>literal? ] bi* ]
-        [ union-lengths >>length ]
         [ union-slots >>slots ]
     } 2cleave
     init-value-info ;
@@ -293,7 +280,6 @@ DEFER: (value-info-union)
                 { [ 2dup [ class>> ] bi@ class<= not ] [ f ] }
                 { [ 2dup [ interval>> ] bi@ interval-subset? not ] [ f ] }
                 { [ 2dup literals<= not ] [ f ] }
-                { [ 2dup [ length>> ] bi@ value-info<= not ] [ f ] }
                 { [ 2dup [ slots>> ] bi@ [ value-info<= ] 2all? not ] [ f ] }
                 [ t ]
             } cond 2nip

basis/compiler/tree/propagation/recursive/recursive.factor

@@ -45,8 +45,7 @@ IN: compiler.tree.propagation.recursive
             [ clone ] dip
             [ [ drop ] [ [ [ interval>> ] bi@ ] [ drop class>> ] 2bi generalize-counter-interval ] 2bi >>interval ]
             [ [ drop ] [ [ slots>> ] bi@ [ generalize-counter ] 2map ] 2bi >>slots ]
-            [ [ drop ] [ [ length>> ] bi@ generalize-counter ] 2bi >>length ]
+            bi
-            tri
         ] if
     ] if ;
 

basis/compiler/tree/propagation/slots/slots.factor

@@ -9,8 +9,6 @@ IN: compiler.tree.propagation.slots
 
 ! Propagation of immutable slots and array lengths
 
-UNION: fixed-length-sequence array byte-array string ;
-
 : sequence-constructor? ( word -- ? )
     { <array> <byte-array> (byte-array) <string> } member-eq? ;
 
@@ -23,9 +21,9 @@ UNION: fixed-length-sequence array byte-array string ;
     } at ;
 
 : propagate-sequence-constructor ( #call word -- infos )
-    [ in-d>> first <sequence-info> ]
+    [ in-d>> first value-info ]
-    [ constructor-output-class <class-info> ]
+    [ constructor-output-class ] bi*
-    bi* value-info-intersect 1array ;
+    <sequence-info> 1array ;
 
 : fold-<tuple-boa> ( values class -- info )
     [ [ literal>> ] map ] dip prefix >tuple
@@ -72,7 +70,6 @@ UNION: fixed-length-sequence array byte-array string ;
 : value-info-slot ( slot info -- info' )
     {
         { [ over 0 = ] [ 2drop fixnum <class-info> ] }
-        { [ 2dup length-accessor? ] [ nip length>> ] }
         { [ dup literal?>> ] [ literal>> literal-info-slot ] }
         [ [ 1 - ] [ slots>> ] bi* ?nth ]
     } cond [ object-info ] unless* ;

extra/astar/astar-docs.factor

@@ -3,7 +3,40 @@
 USING: help.markup help.syntax ;
 IN: astar
 
-{ find-path <astar> considered } related-words
+HELP: astar
+{ $description "This tuple must be subclassed and its method " { $link cost } ", "
+  { $link heuristic } ", and " { $link neighbours } " must be implemented. "
+  "Alternatively, the " { $link <astar> } " word can be used to build a non-specialized version." } ;
+
+HELP: cost
+{ $values
+  { "from" "a node" }
+  { "to" "a node" }
+  { "astar" "an instance of a subclassed " { $link astar } " tuple" }
+  { "n" "a number" }
+}
+{ $description "Return the cost to go from " { $snippet "from" } " to " { $snippet "to" } ". "
+  { $snippet "to" } " is necessarily a neighbour of " { $snippet "from" } "."
+} ;
+
+HELP: heuristic
+{ $values
+  { "from" "a node" }
+  { "to" "a node" }
+  { "astar" "an instance of a subclassed " { $link astar } " tuple" }
+  { "n" "a number" }
+}
+{ $description "Return the estimated (undervalued) cost to go from " { $snippet "from" } " to " { $snippet "to" } ". "
+  { $snippet "from" } " and " { $snippet "to" } " are not necessarily neighbours."
+} ;
+
+HELP: neighbours
+{ $values
+  { "node" "a node" }
+  { "astar" "an instance of a subclassed " { $link astar } " tuple" }
+  { "seq" "a sequence of nodes" }
+}
+{ $description "Return the list of nodes reachable from " { $snippet "node" } "." } ;
 
 HELP: <astar>
 { $values
@@ -16,7 +49,8 @@ HELP: <astar>
   { $snippet "neighbours" } " one builds the list of neighbours. The "
   { $snippet "cost" } " and " { $snippet "heuristic" } " ones represent "
   "respectively the cost for transitioning from a node to one of its neighbour, "
-  "and the underestimated cost for going from a node to the target."
+  "and the underestimated cost for going from a node to the target. This solution "
+  "may not be as efficient as subclassing the " { $link astar } " tuple."
 } ;
 
 HELP: find-path

extra/astar/astar.factor

@@ -5,44 +5,48 @@ IN: astar
 
 ! This implements the A* algorithm. See http://en.wikipedia.org/wiki/A*
 
+TUPLE: astar g in-closed-set ;
+GENERIC: cost ( from to astar -- n )
+GENERIC: heuristic ( from to astar -- n )
+GENERIC: neighbours ( node astar -- seq )
+
 <PRIVATE
 
-TUPLE: astar neighbours heuristic cost
+TUPLE: (astar) astar goal origin in-open-set open-set ;
-    goal g origin in-open-set in-closed-set open-set ;
 
 : (add-to-open-set) ( h node astar -- )
     2dup in-open-set>> at* [ over open-set>> heap-delete ] [ drop ] if
     [ swapd open-set>> heap-push* ] [ in-open-set>> set-at ] 2bi ;
 
 : add-to-open-set ( node astar -- )
-    [ g>> at ] 2keep
+    [ astar>> g>> at ] 2keep
-    [ [ goal>> ] [ heuristic>> call( n1 n2 -- c ) ] bi + ] 2keep
+    [ [ goal>> ] [ astar>> heuristic ] bi + ] 2keep
     (add-to-open-set) ;
 
 : ?add-to-open-set ( node astar -- )
-    2dup in-closed-set>> key? [ 2drop ] [ add-to-open-set ] if ;
+    2dup astar>> in-closed-set>> key? [ 2drop ] [ add-to-open-set ] if ;
 
 : move-to-closed-set ( node astar -- )
-    [ in-closed-set>> conjoin ] [ in-open-set>> delete-at ] 2bi ;
+    [ astar>> in-closed-set>> conjoin ] [ in-open-set>> delete-at ] 2bi ;
 
 : get-first ( astar -- node )
     [ open-set>> heap-pop drop dup ] [ move-to-closed-set ] bi ;
 
 : set-g ( origin g node astar -- )
-    [ [ origin>> set-at ] [ g>> set-at ] bi-curry bi-curry bi* ] [ ?add-to-open-set ] 2bi ;
+    [ [ origin>> set-at ] [ astar>> g>> set-at ] bi-curry bi-curry bi* ] [ ?add-to-open-set ] 2bi ;
 
 : cost-through ( origin node astar -- cost )
-    [ cost>> call( n1 n2 -- c ) ] [ nip g>> at ] 3bi + ;
+    [ astar>> cost ] [ nip astar>> g>> at ] 3bi + ;
 
 : ?set-g ( origin node astar -- )
     [ cost-through ] 3keep [ swap ] 2dip
-    3dup g>> at [ 1/0. ] unless* > [ 4drop ] [ set-g ] if ;
+    3dup astar>> g>> at [ 1/0. ] unless* > [ 4drop ] [ set-g ] if ;
 
 : build-path ( target astar -- path )
     [ over ] [ over [ [ origin>> at ] keep ] dip ] produce 2nip reverse ;
 
 : handle ( node astar -- )
-    dupd [ neighbours>> call( node -- neighbours ) ] keep [ ?set-g ] curry with each ;
+    dupd [ astar>> neighbours ] keep [ ?set-g ] curry with each ;
 
 : (find-path) ( astar -- path/f )
     dup open-set>> heap-empty? [
@@ -53,20 +57,25 @@ TUPLE: astar neighbours heuristic cost
 
 : (init) ( from to astar -- )
     swap >>goal
-    H{ } clone >>g
+    H{ } clone over astar>> (>>g)
+    H{ } clone over astar>> (>>in-closed-set)
     H{ } clone >>origin
     H{ } clone >>in-open-set
-    H{ } clone >>in-closed-set
     <min-heap> >>open-set
-    [ 0 ] 2dip [ (add-to-open-set) ] [ g>> set-at ] 3bi ;
+    [ 0 ] 2dip [ (add-to-open-set) ] [ astar>> g>> set-at ] 3bi ;
+
+TUPLE: astar-simple < astar cost heuristic neighbours ;
+M: astar-simple cost cost>> call( n1 n2 -- c ) ;
+M: astar-simple heuristic heuristic>> call( n1 n2 -- c ) ;
+M: astar-simple neighbours neighbours>> call( n -- neighbours ) ;
 
 PRIVATE>
 
 : find-path ( start target astar -- path/f )
-    [ (init) ] [ (find-path) ] bi ;
+    (astar) new [ (>>astar) ] keep [ (init) ] [ (find-path) ] bi ;
 
 : <astar> ( neighbours cost heuristic -- astar )
-    astar new swap >>heuristic swap >>cost swap >>neighbours ;
+    astar-simple new swap >>heuristic swap >>cost swap >>neighbours ;
 
 : considered ( astar -- considered )
     in-closed-set>> keys ;

extra/project-euler/265/265-tests.factor

@@ -0,0 +1,5 @@
+! Copyright (c) 2010 Samuel Tardieu.
+! See http://factorcode.org/license.txt for BSD license.
+USING: project-euler.265 tools.test ;
+
+[ 209110240768 ] [ euler265 ] unit-test

extra/project-euler/265/265.factor

@@ -0,0 +1,63 @@
+! Copyright (c) 2010 Samuel Tardieu.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel math math.functions project-euler.common sequences sets ;
+IN: project-euler.265
+
+! http://projecteuler.net/index.php?section=problems&id=265
+
+! 2^(N) binary digits can be placed in a circle so that all the N-digit
+! clockwise subsequences are distinct.
+
+! For N=3, two such circular arrangements are possible, ignoring rotations.
+
+! For the first arrangement, the 3-digit subsequences, in clockwise order, are:
+! 000, 001, 010, 101, 011, 111, 110 and 100.
+
+! Each circular arrangement can be encoded as a number by concatenating
+! the binary digits starting with the subsequence of all zeros as the most
+! significant bits and proceeding clockwise. The two arrangements for N=3 are
+! thus represented as 23 and 29:
+! 00010111 _(2) = 23
+! 00011101 _(2) = 29
+
+! Calling S(N) the sum of the unique numeric representations, we can see that S(3) = 23 + 29 = 52.
+
+! Find S(5).
+
+CONSTANT: N 5
+
+: decompose ( n -- seq )
+    N iota [ drop [ 2/ ] [ 1 bitand ] bi ] map nip reverse ;
+
+: bits ( seq -- n )
+    0 [ [ 2 * ] [ + ] bi* ] reduce ;
+
+: complete ( seq -- seq' )
+    unclip decompose append [ 1 bitand ] map ;
+
+: rotate-bits ( seq -- seq' )
+    dup length iota [ cut prepend bits ] with map ;
+
+: ?register ( acc seq -- )
+    complete rotate-bits
+    dup [ 2 N ^ mod ] map all-unique? [ infimum swap push ] [ 2drop ] if ;
+
+: add-bit ( seen bit -- seen' t/f )
+    over last 2 * + 2 N ^ mod
+    2dup swap member? [ drop f ] [ suffix t ] if ;
+
+: iterate ( acc left seen -- )
+    over 0 = [
+        nip ?register
+    ] [
+        [ 1 - ] dip
+        { 0 1 } [ add-bit [ iterate ] [ 3drop ] if ] with with with each
+    ] if ;
+
+: euler265 ( -- answer )
+    V{ } clone [ 2 N ^ N - { 0 } iterate ] [ sum ] bi ;
+
+! [ euler265 ] time
+! Running time: 0.376389019 seconds
+
+SOLUTION: euler265

extra/project-euler/project-euler.factor

@@ -26,7 +26,7 @@ USING: definitions io io.files io.pathnames kernel math math.parser
     project-euler.134 project-euler.148 project-euler.150 project-euler.151
     project-euler.164 project-euler.169 project-euler.173 project-euler.175
     project-euler.186 project-euler.188 project-euler.190 project-euler.203
-    project-euler.206 project-euler.215 project-euler.255 ;
+    project-euler.206 project-euler.215 project-euler.255 project-euler.265 ;
 IN: project-euler
 
 <PRIVATE