extra/project-euler/common/common.factor

   1 ! Copyright (c) 2007-2010 Aaron Schaefer.
   2 ! The contents of this file are licensed under the Simplified BSD License
   3 ! A copy of the license is available at http://factorcode.org/license.txt
   4 USING: accessors arrays byte-arrays hints kernel lists make
   5 math math.functions math.matrices math.order math.parser
   6 math.primes.factors math.primes.lists ranges math.ratios
   7 math.vectors parser prettyprint sequences sorting strings
   8 unicode vocabs.parser words ;
   9 IN: project-euler.common
  10
  11 ! A collection of words used by more than one Project Euler solution
  12 ! and/or related words that could be useful for future problems.
  13
  14 ! Problems using each public word
  15 ! -------------------------------
  16 ! alpha-value - #22, #42
  17 ! cartesian-product - #4, #27, #29, #32, #33, #43, #44, #56
  18 ! log10 - #25, #134
  19 ! max-path - #18, #67
  20 ! mediant - #71, #73
  21 ! nth-prime - #7, #69
  22 ! nth-triangle - #12, #42
  23 ! number>digits - #16, #20, #30, #34, #35, #38, #43, #52, #55, #56, #92, #206
  24 ! palindrome? - #4, #36, #55
  25 ! pandigital? - #32, #38
  26 ! pentagonal? - #44, #45
  27 ! penultimate - #69, #71
  28 ! propagate-all - #18, #67
  29 ! permutations? - #49, #70
  30 ! sum-proper-divisors - #21
  31 ! tau* - #12
  32 ! [uad]-transform - #39, #75
  33
  34
  35 : nth-pair ( seq n -- nth next )
  36     tail-slice first2 ;
  37
  38 : perfect-square? ( n -- ? )
  39     dup sqrt mod zero? ;
  40
  41 : alpha-value ( str -- n )
  42     >lower [ CHAR: a - 1 + ] map-sum ;
  43
  44 : mediant ( a/c b/d -- (a+b)/(c+d) )
  45     2>fraction [ + ] 2bi@ / ;
  46
  47 <PRIVATE
  48
  49 : max-children ( seq -- seq )
  50     [ dup length 1 - <iota> [ nth-pair max , ] with each ] { } make ;
  51
  52 PRIVATE>
  53
  54 : max-path ( triangle -- n )
  55     dup length 1 > [
  56         2 cut* first2 max-children v+ suffix max-path
  57     ] [
  58         first first
  59     ] if ;
  60
  61 : number>digits ( n -- seq )
  62     [ dup 0 = not ] [ 10 /mod ] produce reverse! nip ;
  63
  64 : digits>number ( seq -- n )
  65     0 [ [ 10 * ] [ + ] bi* ] reduce ;
  66
  67 : number-length ( n -- m )
  68     abs [
  69         1
  70     ] [
  71         1 0 [ 2over >= ]
  72         [ [ 10 * ] [ 1 + ] bi* ] while 2nip
  73     ] if-zero ;
  74
  75 : nth-place ( x n -- y )
  76     10^ [ * round >integer ] keep /f ;
  77
  78 : nth-prime ( n -- n )
  79     1 - lprimes lnth ;
  80
  81 : nth-triangle ( n -- n )
  82     dup 1 + * 2 / ;
  83
  84 : palindrome? ( n -- ? )
  85     number>string dup reverse = ;
  86
  87 : pandigital? ( n -- ? )
  88     number>string natural-sort >string "123456789" = ;
  89
  90 : pentagonal? ( n -- ? )
  91     dup 0 > [ 24 * 1 + sqrt 1 + 6 / 1 mod zero? ] [ drop f ] if ; inline
  92
  93 : penultimate ( seq -- elt )
  94     dup length 2 - swap nth ;
  95
  96 <PRIVATE
  97
  98 ! Propagate one row into the upper one
  99 : propagate ( bottom top -- newtop )
 100     [ over rest rot first2 max rot + ] map nip ;
 101
 102 PRIVATE>
 103
 104 ! Not strictly needed, but it is nice to be able to dump the
 105 ! triangle after the propagation
 106 : propagate-all ( triangle -- new-triangle )
 107     reverse unclip dup rot
 108     [ propagate dup ] map nip
 109     reverse swap suffix ;
 110
 111 <PRIVATE
 112
 113 : count-digits ( n -- byte-array )
 114     10 <byte-array> [
 115         '[ 10 /mod _ [ 1 + ] change-nth dup 0 > ] loop drop
 116     ] keep ;
 117
 118 HINTS: count-digits fixnum ;
 119
 120 PRIVATE>
 121
 122 : permutations? ( n m -- ? )
 123     [ count-digits ] same? ;
 124
 125 <PRIVATE
 126
 127 : (sum-divisors) ( n -- sum )
 128     dup sqrt >integer [1..b] [
 129         [ 2dup divisor? [ 2dup / + , ] [ drop ] if ] each
 130         dup perfect-square? [ sqrt >fixnum neg , ] [ drop ] if
 131     ] { } make sum ;
 132
 133 PRIVATE>
 134
 135 : sum-divisors ( n -- sum )
 136     dup 4 < [ { 0 1 3 4 } nth ] [ (sum-divisors) ] if ;
 137
 138 : sum-proper-divisors ( n -- sum )
 139     [ sum-divisors ] keep - ;
 140
 141 : abundant? ( n -- ? )
 142     dup sum-proper-divisors < ;
 143
 144 : deficient? ( n -- ? )
 145     dup sum-proper-divisors > ;
 146
 147 : perfect? ( n -- ? )
 148     dup sum-proper-divisors = ;
 149
 150 ! The divisor function, counts the number of divisors
 151 : tau ( m -- n )
 152     group-factors flip second 1 [ 1 + * ] reduce ;
 153
 154 ! Optimized brute-force, is often faster than prime factorization
 155 : tau* ( m -- n )
 156     factor-2s dup [ 1 + ]
 157     [ perfect-square? -1 0 ? ]
 158     [ dup sqrt >fixnum [1..b] ] tri* [
 159         dupd divisor? [ [ 2 + ] dip ] when
 160     ] each drop * ;
 161
 162 <PRIVATE
 163
 164 : transform ( triple matrix -- new-triple )
 165     [ 1array ] dip mdot first ;
 166
 167 PRIVATE>
 168
 169 ! These transforms are for generating primitive Pythagorean triples
 170 : u-transform ( triple -- new-triple )
 171     { { 1 2 2 } { -2 -1 -2 } { 2 2 3 } } transform ;
 172 : a-transform ( triple -- new-triple )
 173     { { 1 2 2 } { 2 1 2 } { 2 2 3 } } transform ;
 174 : d-transform ( triple -- new-triple )
 175     { { -1 -2 -2 } { 2 1 2 } { 2 2 3 } } transform ;
 176
 177 SYNTAX: SOLUTION:
 178     scan-word
 179     [ name>> "-main" append create-word-in ] keep
 180     [ drop current-vocab main<< ]
 181     [ [ . ] swap prefix ( -- ) define-declared ]
 182     2bi ;