extra/project-euler/common/common.factor

   1 USING: arrays kernel math math.functions math.miller-rabin math.matrices
   2     math.order math.parser math.primes.factors math.ranges namespaces
   3     sequences sequences.lib sorting unicode.case ;
   4 IN: project-euler.common
   5
   6 ! A collection of words used by more than one Project Euler solution
   7 ! and/or related words that could be useful for future problems.
   8
   9 ! Problems using each public word
  10 ! -------------------------------
  11 ! alpha-value - #22, #42
  12 ! cartesian-product - #4, #27, #29, #32, #33, #43, #44, #56
  13 ! collect-consecutive - #8, #11
  14 ! log10 - #25, #134
  15 ! max-path - #18, #67
  16 ! nth-triangle - #12, #42
  17 ! number>digits - #16, #20, #30, #34, #35, #38, #43, #52, #55, #56
  18 ! palindrome? - #4, #36, #55
  19 ! pandigital? - #32, #38
  20 ! pentagonal? - #44, #45
  21 ! propagate-all - #18, #67
  22 ! sum-proper-divisors - #21
  23 ! tau* - #12
  24 ! [uad]-transform - #39, #75
  25
  26
  27 : nth-pair ( n seq -- nth next )
  28     over 1+ over nth >r nth r> ;
  29
  30 : perfect-square? ( n -- ? )
  31     dup sqrt mod zero? ;
  32
  33 <PRIVATE
  34
  35 : count-shifts ( seq width -- n )
  36     >r length 1+ r> - ;
  37
  38 : max-children ( seq -- seq )
  39     [ dup length 1- [ over nth-pair max , ] each ] { } make nip ;
  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 : shift-3rd ( seq obj obj -- seq obj obj )
  46     rot rest -rot ;
  47
  48 : (sum-divisors) ( n -- sum )
  49     dup sqrt >fixnum [1,b] [
  50         [ 2dup mod zero? [ 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     swap [ swap [ 2array ] map-with ] map-with concat ;
  64
  65 : collect-consecutive ( seq width -- seq )
  66     [
  67         2dup count-shifts [ 2dup head shift-3rd , ] times
  68     ] { } make 2nip ;
  69
  70 : log10 ( m -- n )
  71     log 10 log / ;
  72
  73 : max-path ( triangle -- n )
  74     dup length 1 > [
  75         2 cut* first2 max-children [ + ] 2map suffix max-path
  76     ] [
  77         first first
  78     ] if ;
  79
  80 : number>digits ( n -- seq )
  81     [ dup zero? not ] [ 10 /mod ] [ ] produce reverse nip ;
  82
  83 : nth-triangle ( n -- n )
  84     dup 1+ * 2 / ;
  85
  86 : palindrome? ( n -- ? )
  87     number>string dup reverse = ;
  88
  89 : pandigital? ( n -- ? )
  90     number>string natural-sort "123456789" = ;
  91
  92 : pentagonal? ( n -- ? )
  93     dup 0 > [ 24 * 1+ sqrt 1+ 6 / 1 mod zero? ] [ drop f ] if ;
  94
  95 ! Not strictly needed, but it is nice to be able to dump the triangle after the
  96 ! propagation
  97 : propagate-all ( triangle -- newtriangle )
  98     reverse [ first dup ] keep rest [ propagate dup ] map nip reverse swap suffix ;
  99
 100 : sum-divisors ( n -- sum )
 101     dup 4 < [ { 0 1 3 4 } nth ] [ (sum-divisors) ] if ;
 102
 103 : sum-proper-divisors ( n -- sum )
 104     dup sum-divisors swap - ;
 105
 106 : abundant? ( n -- ? )
 107     dup sum-proper-divisors < ;
 108
 109 : deficient? ( n -- ? )
 110     dup sum-proper-divisors > ;
 111
 112 : perfect? ( n -- ? )
 113     dup sum-proper-divisors = ;
 114
 115 ! The divisor function, counts the number of divisors
 116 : tau ( m -- n )
 117     group-factors flip second 1 [ 1+ * ] reduce ;
 118
 119 ! Optimized brute-force, is often faster than prime factorization
 120 : tau* ( m -- n )
 121     factor-2s [ 1+ ] dip [ perfect-square? -1 0 ? ] keep
 122     dup sqrt >fixnum [1,b] [
 123         dupd mod zero? [ [ 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