diff --git a/basis/compiler/tree/propagation/info/info.factor b/basis/compiler/tree/propagation/info/info.factor index 7f5b9f6fcd..22ea1306d6 100644 --- a/basis/compiler/tree/propagation/info/info.factor +++ b/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<= ] [ - 2nip dup zero? [ drop f f ] [ >float t ] if - ] } + { [ pick float class<= ] [ 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 swap prefix ; + +: slots-with-length ( seq -- slots ) + [ length ] [ 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 >>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 -: ( value -- info ) +: ( length class -- info ) - object >>class - swap value-info >>length - init-value-info ; foldable + over >>class + [ (slots-with-length) ] dip swap >>slots + init-value-info ; : ( slots class -- 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 diff --git a/basis/compiler/tree/propagation/recursive/recursive.factor b/basis/compiler/tree/propagation/recursive/recursive.factor index eb4158e756..d4ab697e21 100644 --- a/basis/compiler/tree/propagation/recursive/recursive.factor +++ b/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 ] - tri + bi ] if ] if ; diff --git a/basis/compiler/tree/propagation/slots/slots.factor b/basis/compiler/tree/propagation/slots/slots.factor index 18d31985d6..2602d6d59a 100644 --- a/basis/compiler/tree/propagation/slots/slots.factor +++ b/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 -- ? ) { (byte-array) } member-eq? ; @@ -23,9 +21,9 @@ UNION: fixed-length-sequence array byte-array string ; } at ; : propagate-sequence-constructor ( #call word -- infos ) - [ in-d>> first ] - [ constructor-output-class ] - bi* value-info-intersect 1array ; + [ in-d>> first value-info ] + [ constructor-output-class ] bi* + 1array ; : fold- ( 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 ] } - { [ 2dup length-accessor? ] [ nip length>> ] } { [ dup literal?>> ] [ literal>> literal-info-slot ] } [ [ 1 - ] [ slots>> ] bi* ?nth ] } cond [ object-info ] unless* ; diff --git a/extra/astar/astar-docs.factor b/extra/astar/astar-docs.factor index b8da237ed6..b43f2aba1c 100644 --- a/extra/astar/astar-docs.factor +++ b/extra/astar/astar-docs.factor @@ -3,7 +3,40 @@ USING: help.markup help.syntax ; IN: astar -{ find-path 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 } " 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: { $values @@ -16,7 +49,8 @@ HELP: { $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 diff --git a/extra/astar/astar.factor b/extra/astar/astar.factor index 1912b6af21..45f8aaa86e 100644 --- a/extra/astar/astar.factor +++ b/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 ) + > 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 - [ [ goal>> ] [ heuristic>> call( n1 n2 -- c ) ] bi + ] 2keep + [ astar>> g>> at ] 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 >>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 ; : ( 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 ; diff --git a/extra/project-euler/265/265-tests.factor b/extra/project-euler/265/265-tests.factor new file mode 100644 index 0000000000..5e6a7f40c4 --- /dev/null +++ b/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 diff --git a/extra/project-euler/265/265.factor b/extra/project-euler/265/265.factor new file mode 100644 index 0000000000..f9ae9393fc --- /dev/null +++ b/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 diff --git a/extra/project-euler/project-euler.factor b/extra/project-euler/project-euler.factor index 4131f41b1f..77017ce578 100644 --- a/extra/project-euler/project-euler.factor +++ b/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