extra/project-euler/common/common.factor

   1 ! Copyright (c) 2007-2010 Aaron Schaefer.
   2 ! The contents of this file are licensed under the Simplified BSD License
   3 ! A copy of the license is available at http://factorcode.org/license.txt
   4 USING: accessors arrays byte-arrays fry hints kernel lists make math
   5     math.functions math.matrices math.order math.parser math.primes.factors
   6     math.primes.lists math.primes.miller-rabin math.ranges math.ratios
   7     math.vectors namespaces parser prettyprint quotations sequences sorting
   8     strings unicode vocabs vocabs.parser words ;
   9 IN: project-euler.common
  10
  11 ! A collection of words used by more than one Project Euler solution
  12 ! and/or related words that could be useful for future problems.
  13
  14 ! Problems using each public word
  15 ! -------------------------------
  16 ! alpha-value - #22, #42
  17 ! cartesian-product - #4, #27, #29, #32, #33, #43, #44, #56
  18 ! log10 - #25, #134
  19 ! max-path - #18, #67
  20 ! mediant - #71, #73
  21 ! nth-prime - #7, #69
  22 ! nth-triangle - #12, #42
  23 ! number>digits - #16, #20, #30, #34, #35, #38, #43, #52, #55, #56, #92, #206
  24 ! palindrome? - #4, #36, #55
  25 ! pandigital? - #32, #38
  26 ! pentagonal? - #44, #45
  27 ! penultimate - #69, #71
  28 ! propagate-all - #18, #67
  29 ! permutations? - #49, #70
  30 ! sum-proper-divisors - #21
  31 ! tau* - #12
  32 ! [uad]-transform - #39, #75
  33
  34
  35 : nth-pair ( seq n -- nth next )
  36     tail-slice first2 ;
  37
  38 : perfect-square? ( n -- ? )
  39     dup sqrt mod zero? ;
  40
  41 <PRIVATE
  42
  43 : count-digits ( n -- byte-array )
  44     10 <byte-array> [
  45         '[ 10 /mod _ [ 1 + ] change-nth dup 0 > ] loop drop
  46     ] keep ;
  47
  48 HINTS: count-digits fixnum ;
  49
  50 : max-children ( seq -- seq )
  51     [ dup length 1 - iota [ nth-pair max , ] with each ] { } make ;
  52
  53 ! Propagate one row into the upper one
  54 : propagate ( bottom top -- newtop )
  55     [ over rest rot first2 max rot + ] map nip ;
  56
  57 : (sum-divisors) ( n -- sum )
  58     dup sqrt >integer [1,b] [
  59         [ 2dup divisor? [ 2dup / + , ] [ drop ] if ] each
  60         dup perfect-square? [ sqrt >fixnum neg , ] [ drop ] if
  61     ] { } make sum ;
  62
  63 : transform ( triple matrix -- new-triple )
  64     [ 1array ] dip m. first ;
  65
  66 PRIVATE>
  67
  68 : alpha-value ( str -- n )
  69     >lower [ CHAR: a - 1 + ] map-sum ;
  70
  71 : mediant ( a/c b/d -- (a+b)/(c+d) )
  72     2>fraction [ + ] 2bi@ / ;
  73
  74 : max-path ( triangle -- n )
  75     dup length 1 > [
  76         2 cut* first2 max-children v+ suffix max-path
  77     ] [
  78         first first
  79     ] if ;
  80
  81 : number>digits ( n -- seq )
  82     [ dup 0 = not ] [ 10 /mod ] produce reverse! nip ;
  83
  84 : digits>number ( seq -- n )
  85     0 [ [ 10 * ] [ + ] bi* ] reduce ;
  86
  87 : number-length ( n -- m )
  88     abs [
  89         1
  90     ] [
  91         1 0 [ 2over >= ]
  92         [ [ 10 * ] [ 1 + ] bi* ] while 2nip
  93     ] if-zero ;
  94
  95 : nth-place ( x n -- y )
  96     10^ [ * round >integer ] keep /f ;
  97
  98 : nth-prime ( n -- n )
  99     1 - lprimes lnth ;
 100
 101 : nth-triangle ( n -- n )
 102     dup 1 + * 2 / ;
 103
 104 : palindrome? ( n -- ? )
 105     number>string dup reverse = ;
 106
 107 : pandigital? ( n -- ? )
 108     number>string natural-sort >string "123456789" = ;
 109
 110 : pentagonal? ( n -- ? )
 111     dup 0 > [ 24 * 1 + sqrt 1 + 6 / 1 mod zero? ] [ drop f ] if ; inline
 112
 113 : penultimate ( seq -- elt )
 114     dup length 2 - swap nth ;
 115
 116 ! Not strictly needed, but it is nice to be able to dump the
 117 ! triangle after the propagation
 118 : propagate-all ( triangle -- new-triangle )
 119     reverse unclip dup rot
 120     [ propagate dup ] map nip
 121     reverse swap suffix ;
 122
 123 : permutations? ( n m -- ? )
 124     [ count-digits ] same? ;
 125
 126 : sum-divisors ( n -- sum )
 127     dup 4 < [ { 0 1 3 4 } nth ] [ (sum-divisors) ] if ;
 128
 129 : sum-proper-divisors ( n -- sum )
 130     [ sum-divisors ] keep - ;
 131
 132 : abundant? ( n -- ? )
 133     dup sum-proper-divisors < ;
 134
 135 : deficient? ( n -- ? )
 136     dup sum-proper-divisors > ;
 137
 138 : perfect? ( n -- ? )
 139     dup sum-proper-divisors = ;
 140
 141 ! The divisor function, counts the number of divisors
 142 : tau ( m -- n )
 143     group-factors flip second 1 [ 1 + * ] reduce ;
 144
 145 ! Optimized brute-force, is often faster than prime factorization
 146 : tau* ( m -- n )
 147     factor-2s dup [ 1 + ]
 148     [ perfect-square? -1 0 ? ]
 149     [ dup sqrt >fixnum [1,b] ] tri* [
 150         dupd divisor? [ [ 2 + ] dip ] when
 151     ] each drop * ;
 152
 153 ! These transforms are for generating primitive Pythagorean triples
 154 : u-transform ( triple -- new-triple )
 155     { { 1 2 2 } { -2 -1 -2 } { 2 2 3 } } transform ;
 156 : a-transform ( triple -- new-triple )
 157     { { 1 2 2 } { 2 1 2 } { 2 2 3 } } transform ;
 158 : d-transform ( triple -- new-triple )
 159     { { -1 -2 -2 } { 2 1 2 } { 2 2 3 } } transform ;
 160
 161 SYNTAX: SOLUTION:
 162     scan-word
 163     [ name>> "-main" append create-word-in ] keep
 164     [ drop current-vocab main<< ]
 165     [ [ . ] swap prefix ( -- ) define-declared ]
 166     2bi ;