steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge branch 'master' into row-polymorphism

db4
Joe Groff 2010-03-10 11:48:41 -08:00
parent 6bf709429b 7744559a46
commit f24a74f66c
8 changed files with 145 additions and 52 deletions

38
basis/compiler/tree/propagation/info/info.factor
View File

@ -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

3
basis/compiler/tree/propagation/recursive/recursive.factor
View File

@ -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
basis/compiler/tree/propagation/slots/slots.factor
View File

@ -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* ;

38
extra/astar/astar-docs.factor
View File

@ -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

39
extra/astar/astar.factor
View File

@ -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 ;

5
extra/project-euler/265/265-tests.factor Normal file
View File

@ -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

63
extra/project-euler/265/265.factor Normal file
View File

@ -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

2
extra/project-euler/project-euler.factor
View File

@ -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