extra/project-euler/common/common.factor

   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
   7     words ;
   8 IN: project-euler.common
   9
  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.
  12
  13 ! Problems using each public word
  14 ! -------------------------------
  15 ! alpha-value - #22, #42
  16 ! cartesian-product - #4, #27, #29, #32, #33, #43, #44, #56
  17 ! log10 - #25, #134
  18 ! max-path - #18, #67
  19 ! mediant - #71, #73
  20 ! nth-prime - #7, #69
  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
  29 ! tau* - #12
  30 ! [uad]-transform - #39, #75
  31
  32
  33 : nth-pair ( seq n -- nth next )
  34     tail-slice first2 ;
  35
  36 : perfect-square? ( n -- ? )
  37     dup sqrt mod zero? ;
  38
  39 <PRIVATE
  40
  41 : max-children ( seq -- seq )
  42     [ dup length 1 - [ nth-pair max , ] with each ] { } make ;
  43
  44 ! Propagate one row into the upper one
  45 : propagate ( bottom top -- newtop )
  46     [ over rest rot first2 max rot + ] map nip ;
  47
  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
  52     ] { } make sum ;
  53
  54 : transform ( triple matrix -- new-triple )
  55     [ 1array ] dip m. first ;
  56
  57 PRIVATE>
  58
  59 : alpha-value ( str -- n )
  60     >lower [ CHAR: a - 1 + ] sigma ;
  61
  62 : cartesian-product ( seq1 seq2 -- seq1xseq2 )
  63     [ [ 2array ] with map ] curry map concat ;
  64
  65 : mediant ( a/c b/d -- (a+b)/(c+d) )
  66     2>fraction [ + ] 2bi@ / ;
  67
  68 : max-path ( triangle -- n )
  69     dup length 1 > [
  70         2 cut* first2 max-children [ + ] 2map suffix max-path
  71     ] [
  72         first first
  73     ] if ;
  74
  75 : number>digits ( n -- seq )
  76     [ dup 0 = not ] [ 10 /mod ] produce reverse nip ;
  77
  78 : number-length ( n -- m )
  79     log10 floor 1 + >integer ;
  80
  81 : nth-prime ( n -- n )
  82     1 - lprimes lnth ;
  83
  84 : nth-triangle ( n -- n )
  85     dup 1 + * 2 / ;
  86
  87 : palindrome? ( n -- ? )
  88     number>string dup reverse = ;
  89
  90 : pandigital? ( n -- ? )
  91     number>string natural-sort >string "123456789" = ;
  92
  93 : pentagonal? ( n -- ? )
  94     dup 0 > [ 24 * 1 + sqrt 1 + 6 / 1 mod zero? ] [ drop f ] if ;
  95
  96 : penultimate ( seq -- elt )
  97     dup length 2 - swap nth ;
  98
  99 ! Not strictly needed, but it is nice to be able to dump the triangle after the
 100 ! propagation
 101 : propagate-all ( triangle -- new-triangle )
 102     reverse [ first dup ] [ rest ] bi
 103     [ propagate dup ] map nip reverse swap suffix ;
 104
 105 : sum-divisors ( n -- sum )
 106     dup 4 < [ { 0 1 3 4 } nth ] [ (sum-divisors) ] if ;
 107
 108 : sum-proper-divisors ( n -- sum )
 109     dup sum-divisors swap - ;
 110
 111 : abundant? ( n -- ? )
 112     dup sum-proper-divisors < ;
 113
 114 : deficient? ( n -- ? )
 115     dup sum-proper-divisors > ;
 116
 117 : perfect? ( n -- ? )
 118     dup sum-proper-divisors = ;
 119
 120 ! The divisor function, counts the number of divisors
 121 : tau ( m -- n )
 122     group-factors flip second 1 [ 1 + * ] reduce ;
 123
 124 ! Optimized brute-force, is often faster than prime factorization
 125 : tau* ( m -- n )
 126     factor-2s dup [ 1 + ]
 127     [ perfect-square? -1 0 ? ]
 128     [ dup sqrt >fixnum [1,b] ] tri* [
 129         dupd divisor? [ [ 2 + ] dip ] when
 130     ] each drop * ;
 131
 132 ! These transforms are for generating primitive Pythagorean triples
 133 : u-transform ( triple -- new-triple )
 134     { { 1 2 2 } { -2 -1 -2 } { 2 2 3 } } transform ;
 135 : a-transform ( triple -- new-triple )
 136     { { 1 2 2 } { 2 1 2 } { 2 2 3 } } transform ;
 137 : d-transform ( triple -- new-triple )
 138     { { -1 -2 -2 } { 2 1 2 } { 2 2 3 } } transform ;
 139
 140 SYNTAX: SOLUTION:
 141     scan-word
 142     [ name>> "-main" append create-in ] keep
 143     [ drop current-vocab (>>main) ]
 144     [ [ . ] swap prefix (( -- )) define-declared ]
 145     2bi ;