Merge branch 'master' into row-polymorphism
commit
f24a74f66c
|
@ -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 <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
|
||||
swap value-info >>length
|
||||
init-value-info ; foldable
|
||||
over >>class
|
||||
[ (slots-with-length) ] dip swap >>slots
|
||||
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
|
||||
|
|
|
@ -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 ;
|
||||
|
||||
|
|
|
@ -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> ]
|
||||
[ constructor-output-class <class-info> ]
|
||||
bi* value-info-intersect 1array ;
|
||||
[ in-d>> first value-info ]
|
||||
[ constructor-output-class ] bi*
|
||||
<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* ;
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
goal g origin in-open-set in-closed-set open-set ;
|
||||
TUPLE: (astar) astar goal origin in-open-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
|
||||
[ [ 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
|
||||
<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 ;
|
||||
|
|
|
@ -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
|
|
@ -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
|
|
@ -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
|
||||
|
|
Loading…
Reference in New Issue