project-euler.common: cleanup.

clean-macosx-x86-64
John Benediktsson 2019-11-06 20:16:48 -08:00
parent 388dc83efd
commit 6db0ae3087
1 changed files with 48 additions and 32 deletions

View File

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