extra/project-euler/049/049.factor

   1 ! Copyright (c) 2009 Aaron Schaefer.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: arrays byte-arrays fry kernel math math.combinatorics math.functions
   4     math.parser math.primes project-euler.common sequences sets ;
   5 IN: project-euler.049
   6
   7 ! http://projecteuler.net/index.php?section=problems&id=49
   8
   9 ! DESCRIPTION
  10 ! -----------
  11
  12 ! The arithmetic sequence, 1487, 4817, 8147, in which each of the terms
  13 ! increases by 3330, is unusual in two ways: (i) each of the three terms are
  14 ! prime, and, (ii) each of the 4-digit numbers are permutations of one another.
  15
  16 ! There are no arithmetic sequences made up of three 1-, 2-, or 3-digit primes,
  17 ! exhibiting this property, but there is one other 4-digit increasing sequence.
  18
  19 ! What 12-digit number do you form by concatenating the three terms in this
  20 ! sequence?
  21
  22
  23 ! SOLUTION
  24 ! --------
  25
  26 <PRIVATE
  27
  28 : collect-permutations ( seq -- seq )
  29     [ V{ } clone ] [ dup ] bi* [
  30         dupd '[ _ permutations? ] filter
  31         [ diff ] keep pick push
  32     ] each drop ;
  33
  34 : potential-sequences ( -- seq )
  35     1000 9999 primes-between
  36     collect-permutations [ length 3 >= ] filter ;
  37
  38 : arithmetic-terms ( m n -- seq )
  39     2dup [ swap - ] keep + 3array ;
  40
  41 : (find-unusual-terms) ( n seq -- seq/f )
  42     [ [ arithmetic-terms ] with map ] keep
  43     '[ _ [ last ] dip member? ] find nip ;
  44
  45 : find-unusual-terms ( seq -- seq/? )
  46     unclip-slice over (find-unusual-terms) [
  47         nip
  48     ] [
  49         dup length 3 >= [ find-unusual-terms ] [ drop f ] if
  50     ] if* ;
  51
  52 : 4digit-concat ( seq -- str )
  53     0 [ [ 10000 * ] dip + ] reduce ;
  54
  55 PRIVATE>
  56
  57 : euler049 ( -- answer )
  58     potential-sequences [ find-unusual-terms ] map sift
  59     [ { 1487 4817 8147 } = not ] find nip 4digit-concat ;
  60
  61 ! [ euler049 ] 100 ave-time
  62 ! 206 ms ave run time - 10.25 SD (100 trials)
  63
  64 SOLUTION: euler049