Project EulerをSchemeで(26-30)

1ヶ月ほどご無沙汰してたけど、Kyoto.lispにも行ってきたことだし、もっとLisp勉強しよう。
今度参加するときはLT出来るようにネタを作っときたいな。

今回からGaucheのver.が0.9.2->0.9.3になりました。
iotaがコアに入って楽、という程度の使いこなしなんですがね…

(use srfi-1)

(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 (integer->list i)
  (letrec ((i->rl (^(i) (cons (modulo i 10)
			      (if (< i 10)
				  '()
				  (i->rl (quotient i 10)))))))
    (reverse (i->rl i))))

問26.

d < 1000 なる 1/d の中で循環節が最も長くなるような d を求める問題

; 小数部の循環 <=> 余りの循環 なので同じ余りが出るまで計算すればよい
; また, p / q の余りは0 ~ q-1の範囲なので, 循環節の長さは最大でq
; よって大きいnから調べ, それまでの最大値よりもnが小さくなれば計算を終了できる
(define (e26)
  (define (recurring-length n)
  (let1 v (make-vector n #f)
    (vector-set! v 1 0)
    (let loop ((p 1) (c 0))
      (if (< p n)
	  (loop (* p 10) (+ c 1))
	  (let1 r (remainder p n)
	    (if (zero? r)
		0
		(if (vector-ref v r)
		    (- c (vector-ref v r))
		    (begin (vector-set! v r c)
			   (loop (* r 10) (+ c 1))))))))))
  (let loop ((n 999) (ans '(0 0)))
    (if (< n (cadr ans))
	(car ans)
	(loop (- n 1) (let1 len (recurring-length n)
			(if (< (cadr ans) len)
			    (list n len)
			    ans))))))

問27.

n^2 + an + b のnに連続した整数を与えて素数を生成するとき、その長さが最大となるようなa, bを求める問題

; f(n) = n^2 + an + b とすると
; f(0) = b, f(1) = a + b + 1
; ∴ b: 素数, a + b + 1: 素数 と考えて良い
; また, b = 2 のときを考えると
; f(2) = 2^2 + 2a + 2 となり,
; これは明らかに2以上の偶数なので, bは3以上の素数と考えて良い
; またこのとき, aは奇数となる
(define (e27)
  (let ((v (make-vector 1000000 #f))
	(ps_1000 (primes 1000)))
    (for-each (cut vector-set! v <> #t) (primes 1000000))
    ((^(ans) (* (car ans) (cadr ans)))
     (fold
      (^(val prev) (if (> (caddr val) (caddr prev)) val prev))
      '(0 0 0)
      (append-map
       (^(a)
	 (map (^(b)
		(list a b (length
			   (take-while
			    (^(n) (let1 y (+ (* n n) (* a n) b)
				    (and (positive? y) (vector-ref v y))))
			    (iota b)))))
	      ps_1000))
       (iota 1000 -999 2))))))

問28.

ルールに従って作成した1001×1001の升目の、対角線上の数字の合計を求める問題

; 1周毎の四隅の合計を足し続ける
(define (e28)
  (let loop ((sides 1) (pos 1) (ans 1) (d 2))
    (if (= sides 1001)
	ans
	(loop (+ sides 2)
	      (+ pos (* 4 d))
	      (+ ans (* 4 pos) (* 10 d))
	      (+ d 2)))))

問29.

a^bを 2<=a<=100, 2<=b<=100 で動かしたときに何種類の数字が生成されるか求める問題

; 力押し
(define (e29)
  (length (delete-duplicates
	   (append-map
	    (^(a)
	      (map (^(b)
		     (expt a b))
		   (iota 99 2)))
	    (iota 99 2)))))

問30.

各桁を5乗した数の和が元の数と一致するような数の総和を求める問題

; そのまんま
(define (e30)
  (let1 max-e (* 5 (expt 9 5))
    (apply + (filter-map
	      (^(n) (and (= n (apply + (map (cut expt <> 5)
					    (integer->list n))))
			 n))
	      (iota (- max-e 1) 2)))))