Project Euler Problem 16 - 20

	#lang racket
	(require srfi/1
	(except-in srfi/13
	string-hash)
	(except-in srfi/69
	string-hash)
	srfi/19
	srfi/41
	math/number-theory)
	;;;2^15 = 32768 であり, これの数字和 ( 各桁の和 ) は 3 + 2 + 7 + 6 + 8 = 26 となる.
	;;;
	;;;同様にして, 21000 の数字和を求めよ.
	(define (problem16 n)
	(fold + 0
	(map (lambda (x)
	(apply - (map char->integer `(,x #\0))))
	(string->list (number->string (expt 2 n))))))
	(problem16 1000)
	;;;1 から 5 までの数字を英単語で書けば one, two, three, four, five であり,
	;;;全部で 3 + 3 + 5 + 4 + 4 = 19 の文字が使われている.
	;;;
	;;;では 1 から 1000 (one thousand) までの数字をすべて英単語で書けば, 全部で何文字になるか.
	;;;
	;;;注: 空白文字やハイフンを数えないこと.
	;;;例えば, 342 (three hundred and forty-two) は 23 文字,
	;;;115 (one hundred and fifteen) は20文字と数える. なお, "and" を使用するのは英国の慣習.
	(define (problem17 n)
	(let ((to-19 #("zero" "one" "two" "three" "four" "five" "six"
	"seven" "eight" "nine" "ten" "eleven" "twelve" "thirteen"
	"fourteen" "fifteen" "sixteen" "seventeen" "eighteen" "nineteen"))
	(tens #(""
	""
	"twenty" "thirty" "forty" "fifty" "sixty" "seventy" "eighty" "ninety"))
	(denoms (alist->hash-table
	'((3 . "thousand")
	(6 . "million")
	(9 . "billion")
	(12 . "trillion")
	(15 . "quadrillion")
	(18 . "quintillion")
	(21 . "sextillion")
	(24 . "septillion")
	(27 . "octillion")
	(30 . "nonillion")
	(33 . "decillion")
	(36 . "undecillion")
	(39 . "duodecillion")
	(42 . "tredecillion")
	(45 . "quattuordecillion")
	(48 . "quindecillion")
	(51 . "sexdecillion")
	(54 . "septendecillion")
	(57 . "octodecillion")
	(60 . "novemdecillion")
	(63 . "vigintillion"))
	eqv?)))
	(define (convert-nn val)
	(if (< val 20)
	(vector-ref to-19 val)
	(let ((dcap (vector-ref tens (quotient val 10)))
	(dval (modulo val 10)))
	(if (zero? dval)
	dcap
	(string-append dcap "-" (vector-ref to-19 dval))))))
	(define (convert-nnn val . arg)
	(let ((rem (quotient val 100)) (mod (modulo val 100)))
	(if (zero? rem)
	(convert-nn mod)
	(string-append (vector-ref to-19 rem)
	" hundred"
	(if (zero? mod)
	""
	(string-append (if (null? arg)
	" "
	" and ")
	(convert-nn mod)))))))
	(define (number->english val . arg)
	(cond ((< val (expt 10 3))
	(string-append
	(if (null? arg)
	""
	(car arg))
	(if (< val (expt 10 2))
	(convert-nn val)
	(convert-nnn val 'British))))
	((< val (expt 10 66))
	(let loop ((val val) (v (reverse (hash-table-keys denoms))) (ret ""))
	(if (null? v)
	(if (positive? val)
	(number->english val (string-append ret " "))
	ret)
	(let ((didx (car v)))
	(let ((dval (expt 10 didx)))
	(if (> dval val)
	(loop val (cdr v) ret)
	(let ((l (quotient val dval))
	(r (modulo val dval)))
	(loop r (cdr v) (string-append
	(if (string-null? ret)
	ret
	(string-append ret
	" "))
	(convert-nnn l)
	" "
	(hash-table-ref denoms didx))))))))))
	(else (error "number too large to print in English: " val))))
	(let ((str (map number->english (iota n 1))))
	(for-each (lambda (x)
	(display x)
	(newline)) str)
	(string-length (string-filter (lambda (x)
	(not (or (char=? x #\space) (char=? x #\-))))
	(string-concatenate str))))))
	(problem17 1000)
	;;;以下の三角形の頂点から下まで移動するとき, その数値の和の最大値は23になる.
	;;;3
	;;;7 4
	;;;2 4 6
	;;;8 5 9 3
	;;;
	;;;この例では 3 + 7 + 4 + 9 = 23.
	;;;
	;;;以下の三角形を頂点から下まで移動するとき, その最大の和を求めよ.
	;;;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
	;;;
	;;;注: ここではたかだか 16384 通りのルートしかないので, すべてのパターンを試すこともできる.
	;;;Problem 67 は同じ問題だが100行あるので, 総当りでは解けない. もっと賢い方法が必要である.
	(define (problem18 ls)
	(define (triangle? ls)
	(let ((str (stream-from 1))
	(l (length ls)))
	(let loop ((n 0))
	(let ((sum (apply + (stream->list (stream-take n str)))))
	(cond ((> sum l) #f)
	((< sum l) (loop (+ n 1)))
	(else #t))))))
	(define (make-triangle ls)
	(when (triangle? ls)
	(let loop ((n 1) (ls0 ls) (ls1 '()))
	(if (null? ls0)
	(list->vector (map list->vector (reverse ls1)))
	(let-values (((a b) (split-at ls0 n)))
	(loop (+ n 1) b (cons a ls1)))))))
	(define (aref arr i j)
	(vector-ref (vector-ref arr i) j))
	(define (minimum-solver arr i j)
	(+ (aref arr i j) (max (aref arr (+ i 1) j) (aref arr (+ i 1) (+ j 1)))))
	(define (scan-solver arr i)
	(let ((n (vector-length (vector-ref arr i))))
	(let loop ((m 0) (acc '()))
	(if (= m n)
	(list->vector (reverse acc))
	(loop (+ m 1) (cons (minimum-solver arr i m) acc))))))
	(define (solver arr)
	(let loop ((k (- (vector-length arr) 1)) (arr arr))
	(if (zero? k)
	(aref arr 0 0)
	(let ((obj (scan-solver arr (- k 1)))
	(arr (vector-copy arr 0 k)))
	(vector-set! arr (- k 1) obj)
	(loop (- k 1) arr)))))
	(solver (make-triangle ls)))
	(problem18 '(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))
	;;;次の情報が与えられている.
	;;;
	;;; 1900年1月1日は月曜日である.
	;;; 9月, 4月, 6月, 11月は30日まであり, 2月を除く他の月は31日まである.
	;;; 2月は28日まであるが, うるう年のときは29日である.
	;;; うるう年は西暦が4で割り切れる年に起こる.
	;;; しかし, 西暦が400で割り切れず100で割り切れる年はうるう年でない.
	;;;
	;;;20世紀(1901年1月1日から2000年12月31日)中に月の初めが日曜日になるのは何回あるか?
	(define (problem19)
	(let loop ((year 1901) (month 1) (count 0))
	(if (= year 2001)
	count
	(let ((date (make-date 0 0 0 0 1 month year time-utc)))
	(loop (if (> (+ month 1) 12)
	(+ year 1)
	year)
	(if (> (+ month 1) 12)
	1
	(+ month 1))
	(if (zero? (date-week-day date))
	(+ count 1)
	count))))))
	(problem19)
	;;;n × (n - 1) × ... × 3 × 2 × 1 を n! と表す.
	;;;
	;;;例えば, 10! = 10 × 9 × ... × 3 × 2 × 1 = 3628800 となる.
	;;;この数の各桁の合計は 3 + 6 + 2 + 8 + 8 + 0 + 0 = 27 である.
	;;;
	;;;では, 100! の各位の数字の和を求めよ.
	;;;
	;;;注: Problem 16 も各位の数字の和に関する問題です。解いていない方は解いてみてください。
	(define (problem20 n)
	(fold + 0
	(map (lambda (x)
	(- (char->integer x) (char->integer #\0)))
	(string->list (number->string (factorial n))))))
	(problem20 100)

view raw projectEuler16-20.rkt hosted with ❤ by GitHub