-! Copyright (c) 2007-2009 Aaron Schaefer.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays kernel lists make math math.functions math.matrices
- math.primes.miller-rabin math.order math.parser math.primes.factors
- math.primes.lists math.ranges math.ratios namespaces parser prettyprint
- quotations sequences sorting strings unicode.case vocabs vocabs.parser
- words ;
+! Copyright (c) 2007-2010 Aaron Schaefer.
+! 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
+USING: accessors arrays byte-arrays hints kernel lists make
+math math.functions math.matrices math.order math.parser
+math.primes.factors math.primes.lists ranges math.ratios
+math.vectors parser prettyprint sequences sorting strings
+unicode vocabs.parser words ;
IN: project-euler.common
! A collection of words used by more than one Project Euler solution
! mediant - #71, #73
! nth-prime - #7, #69
! nth-triangle - #12, #42
-! number>digits - #16, #20, #30, #34, #35, #38, #43, #52, #55, #56, #92
+! number>digits - #16, #20, #30, #34, #35, #38, #43, #52, #55, #56, #92, #206
! palindrome? - #4, #36, #55
! pandigital? - #32, #38
! pentagonal? - #44, #45
! penultimate - #69, #71
! propagate-all - #18, #67
+! permutations? - #49, #70
! sum-proper-divisors - #21
! tau* - #12
! [uad]-transform - #39, #75
: perfect-square? ( n -- ? )
dup sqrt mod zero? ;
-<PRIVATE
-
-: max-children ( seq -- seq )
- [ dup length 1 - [ nth-pair max , ] with each ] { } make ;
+: alpha-value ( str -- n )
+ >lower [ CHAR: a - 1 + ] map-sum ;
-! Propagate one row into the upper one
-: propagate ( bottom top -- newtop )
- [ over rest rot first2 max rot + ] map nip ;
+: mediant ( a/c b/d -- (a+b)/(c+d) )
+ 2>fraction [ + ] 2bi@ / ;
-: (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
-: transform ( triple matrix -- new-triple )
- [ 1array ] dip m. first ;
+: max-children ( seq -- seq )
+ [ dup length 1 - <iota> [ nth-pair max , ] with each ] { } make ;
PRIVATE>
-: alpha-value ( str -- n )
- >lower [ CHAR: a - 1 + ] sigma ;
-
-: cartesian-product ( seq1 seq2 -- seq1xseq2 )
- [ [ 2array ] with map ] curry map concat ;
-
-: mediant ( a/c b/d -- (a+b)/(c+d) )
- 2>fraction [ + ] 2bi@ / ;
-
: max-path ( triangle -- n )
dup length 1 > [
- 2 cut* first2 max-children [ + ] 2map suffix max-path
+ 2 cut* first2 max-children v+ suffix max-path
] [
first first
] if ;
: number>digits ( n -- seq )
- [ dup 0 = not ] [ 10 /mod ] produce reverse nip ;
+ [ dup 0 = not ] [ 10 /mod ] produce reverse! nip ;
+
+: digits>number ( seq -- n )
+ 0 [ [ 10 * ] [ + ] bi* ] reduce ;
: number-length ( n -- m )
- log10 floor 1 + >integer ;
+ abs [
+ 1
+ ] [
+ 1 0 [ 2over >= ]
+ [ [ 10 * ] [ 1 + ] bi* ] while 2nip
+ ] if-zero ;
+
+: nth-place ( x n -- y )
+ 10^ [ * round >integer ] keep /f ;
: nth-prime ( n -- n )
1 - lprimes lnth ;
: penultimate ( seq -- elt )
dup length 2 - swap nth ;
-! Not strictly needed, but it is nice to be able to dump the triangle after the
-! propagation
+<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
+! triangle after the propagation
: propagate-all ( triangle -- new-triangle )
- reverse [ first dup ] [ rest ] bi
- [ propagate dup ] map nip reverse swap suffix ;
+ reverse unclip dup rot
+ [ propagate dup ] map nip
+ 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 -- ? )
+ [ 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 )
dup 4 < [ { 0 1 3 4 } nth ] [ (sum-divisors) ] if ;
: sum-proper-divisors ( n -- sum )
- dup sum-divisors swap - ;
+ [ sum-divisors ] keep - ;
: abundant? ( n -- ? )
dup sum-proper-divisors < ;
: tau* ( m -- n )
factor-2s dup [ 1 + ]
[ perfect-square? -1 0 ? ]
- [ dup sqrt >fixnum [1,b] ] tri* [
+ [ dup sqrt >fixnum [1..b] ] tri* [
dupd divisor? [ [ 2 + ] dip ] when
] each drop * ;
+<PRIVATE
+
+: transform ( triple matrix -- new-triple )
+ [ 1array ] dip mdot first ;
+
+PRIVATE>
+
! These transforms are for generating primitive Pythagorean triples
: u-transform ( triple -- new-triple )
{ { 1 2 2 } { -2 -1 -2 } { 2 2 3 } } transform ;
SYNTAX: SOLUTION:
scan-word
- [ name>> "-main" append create-in ] keep
- [ drop current-vocab (>>main) ]
- [ [ . ] swap prefix (( -- )) define-declared ]
+ [ name>> "-main" append create-word-in ] keep
+ [ drop current-vocab main<< ]
+ [ [ . ] swap prefix ( -- ) define-declared ]
2bi ;
projects / factor.git / blobdiff