project-euler.common: cleanup.
parent
388dc83efd
commit
6db0ae3087
|
@ -1,11 +1,11 @@
|
||||||
! Copyright (c) 2007-2010 Aaron Schaefer.
|
! Copyright (c) 2007-2010 Aaron Schaefer.
|
||||||
! The contents of this file are licensed under the Simplified BSD License
|
! The contents of this file are licensed under the Simplified BSD License
|
||||||
! A copy of the license is available at http://factorcode.org/license.txt
|
! A copy of the license is available at http://factorcode.org/license.txt
|
||||||
USING: accessors arrays byte-arrays fry hints kernel lists make math
|
USING: accessors arrays byte-arrays fry hints kernel lists make
|
||||||
math.functions math.matrices math.order math.parser math.primes.factors
|
math math.functions math.matrices math.order math.parser
|
||||||
math.primes.lists math.primes.miller-rabin math.ranges math.ratios
|
math.primes.factors math.primes.lists math.ranges math.ratios
|
||||||
math.vectors namespaces parser prettyprint quotations sequences sorting
|
math.vectors parser prettyprint sequences sorting strings
|
||||||
strings unicode vocabs vocabs.parser words ;
|
unicode vocabs.parser words ;
|
||||||
IN: project-euler.common
|
IN: project-euler.common
|
||||||
|
|
||||||
! A collection of words used by more than one Project Euler solution
|
! A collection of words used by more than one Project Euler solution
|
||||||
|
@ -38,39 +38,19 @@ IN: project-euler.common
|
||||||
: perfect-square? ( n -- ? )
|
: perfect-square? ( n -- ? )
|
||||||
dup sqrt mod zero? ;
|
dup sqrt mod zero? ;
|
||||||
|
|
||||||
<PRIVATE
|
|
||||||
|
|
||||||
: count-digits ( n -- byte-array )
|
|
||||||
10 <byte-array> [
|
|
||||||
'[ 10 /mod _ [ 1 + ] change-nth dup 0 > ] loop drop
|
|
||||||
] keep ;
|
|
||||||
|
|
||||||
HINTS: count-digits fixnum ;
|
|
||||||
|
|
||||||
: max-children ( seq -- seq )
|
|
||||||
[ dup length 1 - <iota> [ nth-pair max , ] with each ] { } make ;
|
|
||||||
|
|
||||||
! Propagate one row into the upper one
|
|
||||||
: propagate ( bottom top -- newtop )
|
|
||||||
[ over rest rot first2 max rot + ] map nip ;
|
|
||||||
|
|
||||||
: (sum-divisors) ( n -- sum )
|
|
||||||
dup sqrt >integer [1,b] [
|
|
||||||
[ 2dup divisor? [ 2dup / + , ] [ drop ] if ] each
|
|
||||||
dup perfect-square? [ sqrt >fixnum neg , ] [ drop ] if
|
|
||||||
] { } make sum ;
|
|
||||||
|
|
||||||
: transform ( triple matrix -- new-triple )
|
|
||||||
[ 1array ] dip m. first ;
|
|
||||||
|
|
||||||
PRIVATE>
|
|
||||||
|
|
||||||
: alpha-value ( str -- n )
|
: alpha-value ( str -- n )
|
||||||
>lower [ CHAR: a - 1 + ] map-sum ;
|
>lower [ CHAR: a - 1 + ] map-sum ;
|
||||||
|
|
||||||
: mediant ( a/c b/d -- (a+b)/(c+d) )
|
: mediant ( a/c b/d -- (a+b)/(c+d) )
|
||||||
2>fraction [ + ] 2bi@ / ;
|
2>fraction [ + ] 2bi@ / ;
|
||||||
|
|
||||||
|
<PRIVATE
|
||||||
|
|
||||||
|
: max-children ( seq -- seq )
|
||||||
|
[ dup length 1 - <iota> [ nth-pair max , ] with each ] { } make ;
|
||||||
|
|
||||||
|
PRIVATE>
|
||||||
|
|
||||||
: max-path ( triangle -- n )
|
: max-path ( triangle -- n )
|
||||||
dup length 1 > [
|
dup length 1 > [
|
||||||
2 cut* first2 max-children v+ suffix max-path
|
2 cut* first2 max-children v+ suffix max-path
|
||||||
|
@ -113,6 +93,14 @@ PRIVATE>
|
||||||
: penultimate ( seq -- elt )
|
: penultimate ( seq -- elt )
|
||||||
dup length 2 - swap nth ;
|
dup length 2 - swap nth ;
|
||||||
|
|
||||||
|
<PRIVATE
|
||||||
|
|
||||||
|
! Propagate one row into the upper one
|
||||||
|
: propagate ( bottom top -- newtop )
|
||||||
|
[ over rest rot first2 max rot + ] map nip ;
|
||||||
|
|
||||||
|
PRIVATE>
|
||||||
|
|
||||||
! Not strictly needed, but it is nice to be able to dump the
|
! Not strictly needed, but it is nice to be able to dump the
|
||||||
! triangle after the propagation
|
! triangle after the propagation
|
||||||
: propagate-all ( triangle -- new-triangle )
|
: propagate-all ( triangle -- new-triangle )
|
||||||
|
@ -120,9 +108,30 @@ PRIVATE>
|
||||||
[ propagate dup ] map nip
|
[ propagate dup ] map nip
|
||||||
reverse swap suffix ;
|
reverse swap suffix ;
|
||||||
|
|
||||||
|
<PRIVATE
|
||||||
|
|
||||||
|
: count-digits ( n -- byte-array )
|
||||||
|
10 <byte-array> [
|
||||||
|
'[ 10 /mod _ [ 1 + ] change-nth dup 0 > ] loop drop
|
||||||
|
] keep ;
|
||||||
|
|
||||||
|
HINTS: count-digits fixnum ;
|
||||||
|
|
||||||
|
PRIVATE>
|
||||||
|
|
||||||
: permutations? ( n m -- ? )
|
: permutations? ( n m -- ? )
|
||||||
[ count-digits ] same? ;
|
[ count-digits ] same? ;
|
||||||
|
|
||||||
|
<PRIVATE
|
||||||
|
|
||||||
|
: (sum-divisors) ( n -- sum )
|
||||||
|
dup sqrt >integer [1,b] [
|
||||||
|
[ 2dup divisor? [ 2dup / + , ] [ drop ] if ] each
|
||||||
|
dup perfect-square? [ sqrt >fixnum neg , ] [ drop ] if
|
||||||
|
] { } make sum ;
|
||||||
|
|
||||||
|
PRIVATE>
|
||||||
|
|
||||||
: sum-divisors ( n -- sum )
|
: sum-divisors ( n -- sum )
|
||||||
dup 4 < [ { 0 1 3 4 } nth ] [ (sum-divisors) ] if ;
|
dup 4 < [ { 0 1 3 4 } nth ] [ (sum-divisors) ] if ;
|
||||||
|
|
||||||
|
@ -150,6 +159,13 @@ PRIVATE>
|
||||||
dupd divisor? [ [ 2 + ] dip ] when
|
dupd divisor? [ [ 2 + ] dip ] when
|
||||||
] each drop * ;
|
] each drop * ;
|
||||||
|
|
||||||
|
<PRIVATE
|
||||||
|
|
||||||
|
: transform ( triple matrix -- new-triple )
|
||||||
|
[ 1array ] dip m. first ;
|
||||||
|
|
||||||
|
PRIVATE>
|
||||||
|
|
||||||
! These transforms are for generating primitive Pythagorean triples
|
! These transforms are for generating primitive Pythagorean triples
|
||||||
: u-transform ( triple -- new-triple )
|
: u-transform ( triple -- new-triple )
|
||||||
{ { 1 2 2 } { -2 -1 -2 } { 2 2 3 } } transform ;
|
{ { 1 2 2 } { -2 -1 -2 } { 2 2 3 } } transform ;
|
||||||
|
|
Loading…
Reference in New Issue