extra/project-euler/common/common.factor

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