extra/project-euler/common/common.factor

   1 ! Copyright (c) 2007-2008 Aaron Schaefer.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: arrays kernel make math math.functions math.matrices math.miller-rabin
   4     math.order math.parser math.primes.factors math.ranges math.ratios
   5     sequences sorting strings unicode.case ;
   6 IN: project-euler.common
   7
   8 ! A collection of words used by more than one Project Euler solution
   9 ! and/or related words that could be useful for future problems.
  10
  11 ! Problems using each public word
  12 ! -------------------------------
  13 ! alpha-value - #22, #42
  14 ! cartesian-product - #4, #27, #29, #32, #33, #43, #44, #56
  15 ! log10 - #25, #134
  16 ! max-path - #18, #67
  17 ! mediant - #71, #73
  18 ! nth-triangle - #12, #42
  19 ! number>digits - #16, #20, #30, #34, #35, #38, #43, #52, #55, #56, #92
  20 ! palindrome? - #4, #36, #55
  21 ! pandigital? - #32, #38
  22 ! pentagonal? - #44, #45
  23 ! propagate-all - #18, #67
  24 ! sum-proper-divisors - #21
  25 ! tau* - #12
  26 ! [uad]-transform - #39, #75
  27
  28
  29 : nth-pair ( seq n -- nth next )
  30     tail-slice first2 ;
  31
  32 : perfect-square? ( n -- ? )
  33     dup sqrt mod zero? ;
  34
  35 <PRIVATE
  36
  37 : max-children ( seq -- seq )
  38     [ dup length 1- [ nth-pair max , ] with each ] { } make ;
  39
  40 ! Propagate one row into the upper one
  41 : propagate ( bottom top -- newtop )
  42     [ over rest rot first2 max rot + ] map nip ;
  43
  44 : (sum-divisors) ( n -- sum )
  45     dup sqrt >integer [1,b] [
  46         [ 2dup mod 0 = [ 2dup / + , ] [ drop ] if ] each
  47         dup perfect-square? [ sqrt >fixnum neg , ] [ drop ] if
  48     ] { } make sum ;
  49
  50 : transform ( triple matrix -- new-triple )
  51     [ 1array ] dip m. first ;
  52
  53 PRIVATE>
  54
  55 : alpha-value ( str -- n )
  56     >lower [ CHAR: a - 1+ ] sigma ;
  57
  58 : cartesian-product ( seq1 seq2 -- seq1xseq2 )
  59     swap [ swap [ 2array ] with map ] with map concat ;
  60
  61 : log10 ( m -- n )
  62     log 10 log / ;
  63
  64 : mediant ( a/c b/d -- (a+b)/(c+d) )
  65     2>fraction [ + ] 2bi@ / ;
  66
  67 : max-path ( triangle -- n )
  68     dup length 1 > [
  69         2 cut* first2 max-children [ + ] 2map suffix max-path
  70     ] [
  71         first first
  72     ] if ;
  73
  74 : number>digits ( n -- seq )
  75     [ dup 0 = not ] [ 10 /mod ] [ ] produce reverse nip ;
  76
  77 : nth-triangle ( n -- n )
  78     dup 1+ * 2 / ;
  79
  80 : palindrome? ( n -- ? )
  81     number>string dup reverse = ;
  82
  83 : pandigital? ( n -- ? )
  84     number>string natural-sort >string "123456789" = ;
  85
  86 : pentagonal? ( n -- ? )
  87     dup 0 > [ 24 * 1+ sqrt 1+ 6 / 1 mod zero? ] [ drop f ] if ;
  88
  89 ! Not strictly needed, but it is nice to be able to dump the triangle after the
  90 ! propagation
  91 : propagate-all ( triangle -- new-triangle )
  92     reverse [ first dup ] [ rest ] bi
  93     [ propagate dup ] map nip reverse swap suffix ;
  94
  95 : sum-divisors ( n -- sum )
  96     dup 4 < [ { 0 1 3 4 } nth ] [ (sum-divisors) ] if ;
  97
  98 : sum-proper-divisors ( n -- sum )
  99     dup sum-divisors swap - ;
 100
 101 : abundant? ( n -- ? )
 102     dup sum-proper-divisors < ;
 103
 104 : deficient? ( n -- ? )
 105     dup sum-proper-divisors > ;
 106
 107 : perfect? ( n -- ? )
 108     dup sum-proper-divisors = ;
 109
 110 ! The divisor function, counts the number of divisors
 111 : tau ( m -- n )
 112     group-factors flip second 1 [ 1+ * ] reduce ;
 113
 114 ! Optimized brute-force, is often faster than prime factorization
 115 : tau* ( m -- n )
 116     factor-2s dup [ 1+ ]
 117     [ perfect-square? -1 0 ? ]
 118     [ dup sqrt >fixnum [1,b] ] tri* [
 119         dupd mod 0 = [ [ 2 + ] dip ] when
 120     ] each drop * ;
 121
 122 ! These transforms are for generating primitive Pythagorean triples
 123 : u-transform ( triple -- new-triple )
 124     { { 1 2 2 } { -2 -1 -2 } { 2 2 3 } } transform ;
 125 : a-transform ( triple -- new-triple )
 126     { { 1 2 2 } { 2 1 2 } { 2 2 3 } } transform ;
 127 : d-transform ( triple -- new-triple )
 128     { { -1 -2 -2 } { 2 1 2 } { 2 2 3 } } transform ;
 129