Project EulerをSchemeで(36-40)

Schemeらしい書き方も勉強しなきゃ。

(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))))))))

問36.

100万未満で10進でも2進でも回文数になるような数の総和を求める問題。

; そのまんま
(define (e36)
  (define (palindrome? i)
    (= i (list->integer (reverse (integer->list i)))))
  (let1 ans 0
    (for-each (^(n) (when (and (palindrome? n)
			       (palindrome? (string->number (number->string n 2))))
		      (set! ans (+ ans n))))
	      (iota 1000000 1))
    ans))

問37.

右から切り詰めても左から切り詰めても素数になるような素数の総和を求める問題。

; 偶数と5が含まれていると, それらが1の位に来たときに割り切れる
; 9, 1が先頭や末尾にあると, 1桁のときに素数でなくなってしまう
; 39が先頭や末尾にあると, 2桁のときに素数でなくなってしまう
; 他に11, 33, 77, 99が含まれていてもダメだが, 面倒なので省略
(define (e37)
  (let ((ps (primes 1000000))
	(ht (make-hash-table)))
    (for-each (^(p) (hash-table-put! ht p #t)) ps)
    (let1 truncatable?
	   (^(p)
	     (let* ((prime? (^(p) (hash-table-get ht p #f)))
		    (l (integer->list p)))
	       (and (< 10 p)
		    (or (< p 100)
			(not (any (^(n) (or (even? n) (= 5 n))) l))) ; !/[024568]/
		    (not (or (= 9 (car l)) (= 1 (car l))             ; !/^[91]/
			     (= 9 (last l)) (= 1 (last l))           ; !/[91]$/
			     (and (= 3 (car l)) (= 9 (cadr l)))      ; !/^39/
			     (and (= 3 (car (reverse l)))            ; !/39$/
				  (= 9 (cadr (reverse l))))))
		    (let l-loop ((l (cdr l)))
		      (cond ((null? l) #t)
			    ((not (prime? (list->integer l))) #f)
			    (else (l-loop (cdr l)))))
		    (let r-loop ((p (quotient p 10)))
		      (cond ((zero? p) #t)
			    ((not (prime? p)) #f)
			    (else (r-loop (quotient p 10))))))))
      (let loop ((ps ps)
		 (ans '()))
	(if (null? ps)
	    (apply + ans)
	    (loop (cdr ps) (if (truncatable? (car ps))
			       (cons (car ps) ans)
			       ans)))))))

問38.

整数と(1,2,...,n) (n > 1) との連結積として得られる9桁のPandigital数の中で最大のものを求める問題。

; (連結数) -> (許容される整数の範囲) とすると
; 9 -> 1
; 8 -> 無
; 7 -> 無
; 6 -> 3
; 5 -> 5 - 9
; 4 -> 25 - 33
; 3 -> 100 - 333
; 2 -> 5000 - 9999
; よって, 9182 - 9999 の範囲を調べればよい.
(define (e38)
  (define (pandigital? i)
    (= 123456789 (list->integer (sort (integer->list i)))))
  (fold (^(n p) (let1 i (+ (* n 100000) (* n 2))
		  (if (and (pandigital? i) (< p i))
		      i p)))
	918273645
	(iota 818 9182)))

問39.

直角三角形の周囲の長さをpとして、p<=1000の範囲でもっとも多くの直角三角形を持つpを求める問題。

; 直角三角形の各辺の長さをa, b, cとする(c: 斜辺)と,
; a^2 + b^2 = c^2 と
; a + b + c = p より
; p(p - 2a) = 2b(p - a) が成り立つので
; aは, mod p(p - 2a) 2(p - a) = 0 を満たす
(define (e39)
  (define (solutions p)
    (let1 ans 0
      (for-each (^(a) (when (zero? (modulo (* p (- p (* 2 a)))
					   (* 2 (- p a))))
			(set! ans (+ ans 1))))
		(iota (- (quotient p 3) 1) 1))
      ans))
  (cadr (fold (^(n p) (let1 s (solutions n)
			(if (< (car p) s)
			    (list s n) p)))
	      '(0 0)
	      (iota 499 4 2))))

問40.

1234567891011...と無限に続く数列のなかで、特定の項の積を求める問題。

; 1000000 < 1*10 + 2*90 + 3*900 + 4*9000 + 5*90000 + 6* 100000
; なので200000までで十分
(define (e40)
  (let loop ((cnt 0) (next 1) (ans 1) (l (iota 200000)))
    (if (< 1000000 cnt)
	ans
	(let* ((il (integer->list (car l)))
	       (hit? (< next (+ cnt (length il)))))
	  (loop (+ cnt (length il))
		(* next (if hit? 10 1))
		(* ans (if hit? (list-ref il (- next cnt)) 1))
		(cdr l))))))