Project EulerをSchemeで(16-20)

今回は問16から問20の5問。処理系はGauche。
15問まとめて書いたのはちょっと長すぎたと思います。

まずはユーティリティ関数とか。前回でも使いました。

(use srfi-1)

; (integer->list 12345) => (1 2 3 4 5)
(define (integer->list i)
  (letrec ((i->rl (lambda (i)
		    (cons (modulo i 10)
			  (if (< i 10)
			      '()
			      (i->rl (quotient i 10)))))))
    (reverse (i->rl i))))

問16.

2の1000乗の各桁を足した数を求める問題。
2の1000乗が普通に計算できることにびっくり。

(define (e16)
  (apply + (integer->list (expt 2 1000))))

問17.

1から1000までを英語で書いたときの文字数の和を求める問題。
ベクタに1から1000までを英語で書きだして、最後に文字数の和を求める。

(define (e17)
  (let ((v (make-vector 1001 "")))
    (for-each (lambda (i s) (vector-set! v i s))
	      (iota 19 1) '("one" "two" "three" "four" "five" "six" "seven" "eight" "nine" "ten" "eleven" "twelve" "thirteen" "fourteen" "fifteen" "sixteen" "seventeen" "eighteen" "nineteen"))
    (for-each (lambda (i s) 
		(for-each (lambda (j) 
			    (vector-set! v (+ i j) (string-append s (vector-ref v j)))) 
			  (iota 10)))
	      (iota 9 20 10) '("twenty" "thirty" "forty" "fifty" "sixty" "seventy" "eighty" "ninety"))
    (for-each (lambda (i) 
		(for-each (lambda (j)
			    (vector-set! v
					 (+ (* i 100) j) 
					 (string-append (vector-ref v i) "hundred"
							(if (not (zero? j))
							    (string-append "and" (vector-ref v j))
							    ""))))
			  (iota 100)))
	      (iota 9 1))
    (vector-set! v 1000 "onethousand")
    (apply + (map (lambda (i) (string-length (vector-ref v i))) (iota 1000 1)))))

問18.

三角形に並んだ数字の列があって、三角形の頂点から底まで移動するときに通過した数値の和の最大値を求める問題。
最初は泥臭い実装をしていたけれど、人の解答を見てショックを受けた。
fold-rightってこういう使い方するんだ、とか(map max k (cdr k))ってめっちゃシンプルやん、とか。よって丸パクリ。

(define (e18)
  (fold-right (lambda (x m)
		(let ((k (map + x m)))
		  (if (null? (cdr k))
		      (car k)
		      (map max k (cdr k)))))
	      (iota 15 0 0)
	      '((75)
		(95 64)
		(17 47 82)
		(18 35 87 10)
		(20 04 82 47 65)
		(19 01 23 75 03 34)
		(88 02 77 73 07 63 67)
		(99 65 04 28 06 16 70 92)
		(41 41 26 56 83 40 80 70 33)
		(41 48 72 33 47 32 37 16 94 29)
		(53 71 44 65 25 43 91 52 97 51 14)
		(70 11 33 28 77 73 17 78 39 68 17 57)
		(91 71 52 38 17 14 91 43 58 50 27 29 48)
		(63 66 04 68 89 53 67 30 73 16 69 87 40 31)
		(04 62 98 27 23 09 70 98 73 93 38 53 60 04 23))))

問19.

20世紀中に月の初め(1日)が日曜日だったのは何回あったかという問題。
1世紀分の月の日数リストを作って各月が日曜日で始まっているか判定している。

(define (e19)
  (let ((sd (modulo (+ 1 365) 7)) 
	(ml (let mloop ((l '()) (yl (iota 100 1)))
	      (if (null? yl)
		  l
		  (mloop (append l (list 31 (if (zero? (modulo (car yl) 4)) 29 28) 31 30 31 30 31 31 30 31 30 31))
			 (cdr yl))))))
    (let loop ((d sd) (res (if (zero? sd) 1 0)) (ml ml))
      (if (null? ml)
	  res
	  (loop (modulo (+ d (car ml)) 7)
		(if (zero? d) (+ 1 res) res)
		(cdr ml))))))

問20.

100の階乗の各桁の和を求める問題。
まぁそのまんま。

(define (e20)
  (apply + (integer->list (apply * (iota 100 1)))))