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 parser accessors vocabs.parser
   6     namespaces vocabs words quotations prettyprint ;
   7 IN: project-euler.common
   8
   9 ! A collection of words used by more than one Project Euler solution
  10 ! and/or related words that could be useful for future problems.
  11
  12 ! Problems using each public word
  13 ! -------------------------------
  14 ! alpha-value - #22, #42
  15 ! cartesian-product - #4, #27, #29, #32, #33, #43, #44, #56
  16 ! log10 - #25, #134
  17 ! max-path - #18, #67
  18 ! mediant - #71, #73
  19 ! nth-triangle - #12, #42
  20 ! number>digits - #16, #20, #30, #34, #35, #38, #43, #52, #55, #56, #92
  21 ! palindrome? - #4, #36, #55
  22 ! pandigital? - #32, #38
  23 ! pentagonal? - #44, #45
  24 ! propagate-all - #18, #67
  25 ! sum-proper-divisors - #21
  26 ! tau* - #12
  27 ! [uad]-transform - #39, #75
  28
  29
  30 : nth-pair ( seq n -- nth next )
  31     tail-slice first2 ;
  32
  33 : perfect-square? ( n -- ? )
  34     dup sqrt mod zero? ;
  35
  36 <PRIVATE
  37
  38 : max-children ( seq -- seq )
  39     [ dup length 1- [ nth-pair max , ] with each ] { } make ;
  40
  41 ! Propagate one row into the upper one
  42 : propagate ( bottom top -- newtop )
  43     [ over rest rot first2 max rot + ] map nip ;
  44
  45 : (sum-divisors) ( n -- sum )
  46     dup sqrt >integer [1,b] [
  47         [ 2dup mod 0 = [ 2dup / + , ] [ drop ] if ] each
  48         dup perfect-square? [ sqrt >fixnum neg , ] [ drop ] if
  49     ] { } make sum ;
  50
  51 : transform ( triple matrix -- new-triple )
  52     [ 1array ] dip m. first ;
  53
  54 PRIVATE>
  55
  56 : alpha-value ( str -- n )
  57     >lower [ CHAR: a - 1+ ] sigma ;
  58
  59 : cartesian-product ( seq1 seq2 -- seq1xseq2 )
  60     [ [ 2array ] with map ] curry map concat ;
  61
  62 : log10 ( m -- n )
  63     log 10 log / ;
  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-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 ;
  92
  93 ! Not strictly needed, but it is nice to be able to dump the triangle after the
  94 ! propagation
  95 : propagate-all ( triangle -- new-triangle )
  96     reverse [ first dup ] [ rest ] bi
  97     [ propagate dup ] map nip reverse swap suffix ;
  98
  99 : sum-divisors ( n -- sum )
 100     dup 4 < [ { 0 1 3 4 } nth ] [ (sum-divisors) ] if ;
 101
 102 : sum-proper-divisors ( n -- sum )
 103     dup sum-divisors swap - ;
 104
 105 : abundant? ( n -- ? )
 106     dup sum-proper-divisors < ;
 107
 108 : deficient? ( n -- ? )
 109     dup sum-proper-divisors > ;
 110
 111 : perfect? ( n -- ? )
 112     dup sum-proper-divisors = ;
 113
 114 ! The divisor function, counts the number of divisors
 115 : tau ( m -- n )
 116     group-factors flip second 1 [ 1+ * ] reduce ;
 117
 118 ! Optimized brute-force, is often faster than prime factorization
 119 : tau* ( m -- n )
 120     factor-2s dup [ 1+ ]
 121     [ perfect-square? -1 0 ? ]
 122     [ dup sqrt >fixnum [1,b] ] tri* [
 123         dupd mod 0 = [ [ 2 + ] dip ] when
 124     ] each drop * ;
 125
 126 ! These transforms are for generating primitive Pythagorean triples
 127 : u-transform ( triple -- new-triple )
 128     { { 1 2 2 } { -2 -1 -2 } { 2 2 3 } } transform ;
 129 : a-transform ( triple -- new-triple )
 130     { { 1 2 2 } { 2 1 2 } { 2 2 3 } } transform ;
 131 : d-transform ( triple -- new-triple )
 132     { { -1 -2 -2 } { 2 1 2 } { 2 2 3 } } transform ;
 133
 134 SYNTAX: SOLUTION:
 135     scan-word
 136     [ name>> "-main" append create-in ] keep
 137     [ drop in get vocab (>>main) ]
 138     [ [ . ] swap prefix (( -- )) define-declared ]
 139     2bi ;
 140