Project EulerをSchemeで(41-45)

一週間ほどプログラムから離れてたら、括弧が恋しくなってきちゃって。

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

(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 (make-polygonal-test solver)
  (let1 ht (make-hash-table)
    (^(y) (if (hash-table-get ht y #f)
	      #t
	      (let1 x (solver y)
		(if (= x (floor->exact x))
		    (begin (hash-table-put! ht y #t)
			   #t)
		    #f))))))

問41.

n桁Pandigitalな素数の中で最大の数を求める問題。

; 各桁の和が3の倍数になる数は3の倍数なので
; (apply + (iota 4 1)) = 10
; (apply + (iota 5 1)) = 15
; (apply + (iota 6 1)) = 21
; (apply + (iota 7 1)) = 28
; (apply + (iota 8 1)) = 36
; (apply + (iota 9 1)) = 45
; より, 7桁と4桁のときのみを調べればよい
(define (e41)
  (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)))))))))
  (define (seek digit)
    (let1 l (reverse (sort (map list->integer
				(permutations (iota digit 1)))))
      (let loop ((l l))
	(cond ((null? l) #f)
	      ((prime? (car l)) (car l))
	      (else (loop (cdr l)))))))
  (or (seek 7) (seek 4)))

問42.

指定のファイル中に三角語はいくつあるかを求める問題。

; words.txtに含まれる単語の最大長は15なので, 1000(> 15*26)以下の三角数を判定出来れば十分
(define (e42)
  (define (word-value w)
    (apply + (map (^(c) (- (char->integer c) 64))
		  (string->list w))))
  (define triangle?
    (let1 v (make-vector 1000 #f)
      (let loop ((n 1) (val 1))
	(when (< val 1000)
	  (vector-set! v val #t)
	  (loop (+ n 1) (* (/ n 2) (+ n 1)))))
      (^(n) (vector-ref v n))))
  (let1 ans 0
    (for-each (^(w) (when (triangle? (word-value w))
		      (set! ans (+ 1 ans))))
	      (map (^(s) (substring s 1 (- (string-length s) 1)))
		   (string-split (call-with-input-file "./words.txt" read-line) ",")))
    ans))

問43.

指定の性質をもつ0から9のPandigital数の総和を求める問題。

; 後ろからチェックしていく
(define (e43)
  (define (make-pandigital-test d)
    (^(l) (= d (length (delete-duplicates l)))))
  (define (add-digit l)
    (map (^(d) (cons d l)) (iota 10)))
  (let loop ((l (map integer->list (iota 90 10)))
	     (ps '(17 13 11 7 5 3 2))
	     (d 3))
    (if (null? ps)
	(apply + (map list->integer (filter (make-pandigital-test d)
					    (append-map add-digit l))))
	(let1 next (filter (make-pandigital-test d)
			   (filter (^(k) (zero? (modulo (list->integer (list (car k) (cadr k) (caddr k)))
							(car ps))))
				   (append-map add-digit l)))
	  (loop next (cdr ps) (+ d 1))))))

問44.

差と和が五角数になる五角数のペアについて差の最小値を求める問題。

; 五角数に対して, それ以下の五角数全てとの和, 差をチェックする
(define (e44)
  (define pentagonal? (make-polygonal-test (^(y) (/ (+ 1 (sqrt (+ 1 (* 24 y)))) 6))))
  (let loop ((n 2) (l '(1)))
    (let1 p (/ (* n (- (* 3 n) 1)) 2)
      (let loop2 ((pl l))
	(cond ((null? pl) (loop (+ n 1) (cons p l)))
	      ((and (pentagonal? (+ p (car pl)))
		    (pentagonal? (- p (car pl))))
	       (- p (car pl)))
	      (else (loop2 (cdr pl))))))))

問45.

40755の次の三角数かつ五角数かつ六角数な数を求める問題。

; 六角数をチェックしていくだけ
(define (e45)
  (define triangle? (make-polygonal-test (^(y) (/ (- (sqrt (+ 1 (* 8 y))) 1) 2))))
  (define pentagonal? (make-polygonal-test (^(y) (/ (+ 1 (sqrt (+ 1 (* 24 y)))) 6))))
  (let loop ((n 144) (v 41328))
    (if (and (triangle? v) (pentagonal? v))
	v
	(loop (+ n 1) (* (+ n 1) (+ (* 2 n) 1))))))