1 ! Copyright (c) 2007-2009 Aaron Schaefer.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays kernel lists make math math.functions math.matrices
4 math.primes.miller-rabin math.order math.parser math.primes.factors
5 math.primes.lists math.ranges math.ratios namespaces parser prettyprint
6 quotations sequences sorting strings unicode.case vocabs vocabs.parser
8 IN: project-euler.common
10 ! A collection of words used by more than one Project Euler solution
11 ! and/or related words that could be useful for future problems.
13 ! Problems using each public word
14 ! -------------------------------
15 ! alpha-value - #22, #42
16 ! cartesian-product - #4, #27, #29, #32, #33, #43, #44, #56
21 ! nth-triangle - #12, #42
22 ! number>digits - #16, #20, #30, #34, #35, #38, #43, #52, #55, #56, #92
23 ! palindrome? - #4, #36, #55
24 ! pandigital? - #32, #38
25 ! pentagonal? - #44, #45
26 ! penultimate - #69, #71
27 ! propagate-all - #18, #67
28 ! sum-proper-divisors - #21
30 ! [uad]-transform - #39, #75
33 : nth-pair ( seq n -- nth next )
36 : perfect-square? ( n -- ? )
41 : max-children ( seq -- seq )
42 [ dup length 1- [ nth-pair max , ] with each ] { } make ;
44 ! Propagate one row into the upper one
45 : propagate ( bottom top -- newtop )
46 [ over rest rot first2 max rot + ] map nip ;
48 : (sum-divisors) ( n -- sum )
49 dup sqrt >integer [1,b] [
50 [ 2dup divisor? [ 2dup / + , ] [ drop ] if ] each
51 dup perfect-square? [ sqrt >fixnum neg , ] [ drop ] if
54 : transform ( triple matrix -- new-triple )
55 [ 1array ] dip m. first ;
59 : alpha-value ( str -- n )
60 >lower [ CHAR: a - 1+ ] sigma ;
62 : cartesian-product ( seq1 seq2 -- seq1xseq2 )
63 [ [ 2array ] with map ] curry map concat ;
68 : mediant ( a/c b/d -- (a+b)/(c+d) )
69 2>fraction [ + ] 2bi@ / ;
71 : max-path ( triangle -- n )
73 2 cut* first2 max-children [ + ] 2map suffix max-path
78 : number>digits ( n -- seq )
79 [ dup 0 = not ] [ 10 /mod ] produce reverse nip ;
81 : number-length ( n -- m )
82 log10 floor 1+ >integer ;
84 : nth-prime ( n -- n )
87 : nth-triangle ( n -- n )
90 : palindrome? ( n -- ? )
91 number>string dup reverse = ;
93 : pandigital? ( n -- ? )
94 number>string natural-sort >string "123456789" = ;
96 : pentagonal? ( n -- ? )
97 dup 0 > [ 24 * 1+ sqrt 1+ 6 / 1 mod zero? ] [ drop f ] if ;
99 : penultimate ( seq -- elt )
100 dup length 2 - swap nth ;
102 ! Not strictly needed, but it is nice to be able to dump the triangle after the
104 : propagate-all ( triangle -- new-triangle )
105 reverse [ first dup ] [ rest ] bi
106 [ propagate dup ] map nip reverse swap suffix ;
108 : sum-divisors ( n -- sum )
109 dup 4 < [ { 0 1 3 4 } nth ] [ (sum-divisors) ] if ;
111 : sum-proper-divisors ( n -- sum )
112 dup sum-divisors swap - ;
114 : abundant? ( n -- ? )
115 dup sum-proper-divisors < ;
117 : deficient? ( n -- ? )
118 dup sum-proper-divisors > ;
120 : perfect? ( n -- ? )
121 dup sum-proper-divisors = ;
123 ! The divisor function, counts the number of divisors
125 group-factors flip second 1 [ 1+ * ] reduce ;
127 ! Optimized brute-force, is often faster than prime factorization
130 [ perfect-square? -1 0 ? ]
131 [ dup sqrt >fixnum [1,b] ] tri* [
132 dupd divisor? [ [ 2 + ] dip ] when
135 ! These transforms are for generating primitive Pythagorean triples
136 : u-transform ( triple -- new-triple )
137 { { 1 2 2 } { -2 -1 -2 } { 2 2 3 } } transform ;
138 : a-transform ( triple -- new-triple )
139 { { 1 2 2 } { 2 1 2 } { 2 2 3 } } transform ;
140 : d-transform ( triple -- new-triple )
141 { { -1 -2 -2 } { 2 1 2 } { 2 2 3 } } transform ;
145 [ name>> "-main" append create-in ] keep
146 [ drop in get vocab (>>main) ]
147 [ [ . ] swap prefix (( -- )) define-declared ]