Project EulerをSchemeで(46-50)

そろそろProject Euler用のモジュールつくったほうがいいかな。

(use util.combinations)
(use gauche.sequence)
(use srfi-1)

(define (integer->list i)
  (letrec ((i->rl (^i (cons (modulo i 10)
                            (if (< i 10)
                                '()
                                (i->rl (quotient i 10)))))))
    (reverse (i->rl i))))

(define (list->integer l)
  (define (shift-d n)
    (let loop ((d 10))
      (if (< n d) d (loop (* 10 d)))))
  (fold (^(n p) (+ (* p (shift-d n)) n)) 0 l))

(define (primes n)
  (if (<= n 2)
      '()
      (let1 u (truncate (sqrt n))
        (let loop ((ps '(2))
                   (l (unfold (cut < n <>) values (cut + 2 <>) 3)))
          (let1 m (car l)
            (if (> m u)
                (append (reverse ps) l)
                (loop (cons m ps)
                      (remove (^x (zero? (modulo x m))) l))))))))

; 試し割り
(define (prime? n)
  (cond ((= n 2) #t)
        ((or (< n 2) (zero? (modulo n 2))) #f)
        (else (let1 m (floor->exact (sqrt n))
                (let loop ((i 3))
                  (cond ((< m i) #t)
                        ((zero? (modulo n i)) #f)
                        (else (loop (+ i 2)))))))))

問46.

平方数の2倍と素数の和で表せない最小の奇合成数を求める問題。

; 総当り
(define (e46)
  (let* ((ps (primes 10000))
         (prime? ((^h (dolist (p ps)
                        (hash-table-put! h p #t))
                      (^n (hash-table-get h n #f)))
                  (make-hash-table)))
         (twice-a-square? ((^h (dolist (n (iota 100 1))
                                 (hash-table-put! h (* 2 n n) #t))
                               (^n (hash-table-get h n #f)))
                           (make-hash-table))))
    (let loop ((n 3))
      (if (prime? n)
          (loop (+ n 2))
          (let loop2 ((ps ps))
            (cond ((null? ps) n)
                  ((twice-a-square? (- n (car ps)))
                   (loop (+ n 2)))
                  (else (loop2 (cdr ps)))))))))

問47.

連続する4つの数がそれぞれ4つの異なる素因数を持つ場合を考え, 連続する数の中で最小のものを求める問題。

; 連続する4数で素因数の個数が全て4となっているものを探す
; 遅い
(define (e47)
  (define (factor-count n ps)
    (let loop ((ans 0) (n n) (ps ps))
      (cond ((or (< n (car ps)) (null? ps)) ans)
            ((zero? (modulo n (car ps)))
             (loop (+ ans 1) (/ n (car ps)) (cdr ps)))
            (else (loop ans n (cdr ps))))))
  (let1 ps (primes 200000)
    (let loop ((i 210) (fc '()))
      (cond ((< i 214) (loop (+ i 1)
                             (cons (factor-count i ps) fc)))
            ((= 4 (car fc) (cadr fc) (caddr fc) (cadddr fc)) (- i 4))
            (else (loop (+ i 1)
                        (cons (factor-count i ps) fc)))))))

問48.

1^1 + 2^2 + 3^3 + ... + 1000^1000 の最後の10桁を求める問題。

; 全て足して下10桁のみ取り出す
(define (e48)
  (mod (apply + (map (^n (expt n n))
                     (iota 1000 1)))
       (expt 10 10)))

問49.

それぞれ素数で各項は他の項の置換で表せ、等差数列となるような3数を求める問題。

; 1000<p<10000 なる素数pと同じ数字の組み合わせで作られる数iが
; 素数かつ p<i で
; さらにp i j が等差数列となるようにjをとったとき
; jが素数かつpと同じ数の組み合わせで作られていれば
; そのp i jが求める答えになる
(define (e49)
  (call/cc (^(return)
             (for-each
              (^p (for-each
                   (^i (when (and (< p i) (prime? i))
                         (let1 j (+ i (- i p))
                           (when (and (< j 10000)
                                      (prime? j)
                                      (= (list->integer (sort (integer->list p)))
                                         (list->integer (sort (integer->list j)))))
                             (return (list->integer (list p i j)))))))
                   (map list->integer (permutations* (integer->list p)))))
              ($ delete 1487 $ filter (cut < 1000 <>) $ primes 10000)))))

問50.

連続する素数の和で表したときに最長になる100万未満の素数を求める問題。

; 最長は2以降の素数を100万を超えないように順番に足していったときの長さなので
; そこから素数が見つかるまで長さを縮めていく
(define (e50)
  (let* ((ps (primes 5000))
         (v (make-vector (+ (length ps) 1) 0)))
    (for-each-with-index
     (^(i p) (vector-set! v (+ i 1) (+ p (vector-ref v i))))
     ps)
    (let1 max-len (let loop ((i 0))
                    (if (< 1000000 (vector-ref v (+ i 1)))
                        i (loop (+ i 1))))
      (call/cc (^(return)
                 (for-each
                  (^l (call/cc (^(break)
                                 (for-each
                                  (^i (let1 s (- (vector-ref v (+ i l))
                                                 (vector-ref v i))
                                        (cond ((< 1000000 s) (break))
                                              ((prime? s) (return s)))))
                                  (iota (- (+ max-len 1) l) 1)))))
                  (iota max-len max-len -1)))))))