« 九九表を作る。 | トップページ | Project Euler - Problem 1 : 今度は Scheme で…… »

2009年10月31日 (土)

自作の手続き for Project Euler

今まで Ruby で解いてきた Project Euler の問題を今度は Scheme で解いていくことにしました。

以前、いくつかの問題を Scheme で解いたものをピックアップして投稿したことがありましたが、Ruby で解いたときの経験を生かして、改めてコードを書いてみようと思っています。

基本的なアルゴリズムは、Ruby で解いたときと同じものになっていくと思うので、アルゴリズムの説明は Ruby 版の記事を読んでもらうことになると思います。


まずは、Project Euler を解くために使っていく自作の手続きをまとめて書いておきます。

以前にもほぼ同じものを投稿してあるのですが、いじっているうちに内容が少し変わってしまった手続きもあるので、今回改めて紹介しておきます。

なお、一部のコードはこちらのホームページのコード使用させていただいています。

また、Chez Scheme で独自に拡張された手続きやマクロを一部使用していますが、不明な点はこちらの "Chez Scheme Version 7 User's Guide" をご覧ください。(なお、"case-lambda" に関してはここにも情報があります)


;;;; ;;;; math.ss --- 数学関連の関数群 ;;;; ;;;; for Chez Scheme by Tsumuji ;;;; ;;; ;;; (sequence start end) ;;; (sequence start end step) ;;; ;;; * start 〜 end の範囲の等差数列のリストを返す。 ;;; * step が省略された場合、step = 1 とみなされる。 ;;; * 引数が少数の場合、計算誤差がでる場合があるので注意。 ;;; (define sequence (case-lambda ([start end] (sequence start end 1)) ([start end step] (if [or (zero? step) (< (* (- end start) step) 0)] '() (let ([op (if [> step 0] > <)]) (let loop ([val start] [result '()]) (if [op val end] (reverse result) (loop (+ val step) (cons val result))))))))) (define seq sequence) ; alias ;;; ;;; (prime? n) ;;; ;;; * n が「素数」なら #t ;;; (define prime? (lambda (n) (cond ([= n 1] #f) ([< n 4] #t) ([or (even? n) (zero? (remainder n 3))] #f) (else (let ([i-max (isqrt n)]) (let loop ([i 5] [add 2]) (cond ([> i i-max] #t) ([zero? (remainder n i)] #f) ([> i 10000] (fast-prime? n)) (else (loop (+ i add) (- 6 add)))))))))) ;;; ;;; (fast-prime? n) ;;; ;;; * n が「素数」なら #t ;;; * Miller-Rabin test によって判定している。 ;;; (define fast-prime? (lambda (n) (define miller-rabin (lambda (b s t) (if [= (expt-mod b t n) 1] #t (let ([n (- n)]) (let loop ([m (expt-mod b t n)] [i 0]) (cond ([= i s] #f) ([= m -1] #t) (else (loop (expt-mod m 2 n) (+ i 1))))))))) (cond ([< n 2] #f) ([= n 2] #t) ([even? n] #f) (else (let loop1 ([t (- n 1)] [s 0]) (if [even? t] (loop1 (/ t 2) (+ s 1)) (let loop2 ([i 5]) ; 5 回テストする。 (cond ([zero? i] #t) ([miller-rabin (+ 2 (random (- n 2))) s t] (loop2 (- i 1))) (else #f))))))))) ;;; ;;; (prime-list n) ;;; ;;; * 自然数 n 以下の素数のリストを返す。 ;;; * Ruby の"sample/sieve.rb" のアルゴリズムを改良したものを使用 ;;; している。 ;;; (define prime-list (lambda (n) (if [= n 2] '(2) ;; エラトステネスの篩 (let* ([p-vct (list->vector (cons 0 (sequence 3 n 2)))] ;; p-vct = #(3 5 7 ...) [size (vector-length p-vct)] [max (isqrt n)]) (let loop1 ([i 1]) (let ([j (vector-ref p-vct i)]) (cond ([zero? j] (loop1 (+ i 1))) ([> j max] (cons 2 (remv 0 (vector->list p-vct)))) (else (let loop2 ([k (* 2 i (+ i 1))]) (if [>= k size] (loop1 (+ i 1)) (begin (vector-set! p-vct k 0) (loop2 (+ j k))))))))))))) ;;; ;;; (factorize n) ;;; ;;; * 自然数 n を素因数分解した要素のリストを返す。 ;;; * 引数が 1 の場合、本来はエラーとすべきだが……。 ;;; ex : (factorize 12) => ((2 . 2) (3 . 1)) ;;; ex : (factorize 1) => ((1 . 0)) ;;; (define factorize (lambda (n) (define result '()) (define f-count (lambda (n i) (let loop ([n n] [c 0]) (cond ([zero? (remainder n i)] (loop (/ n i) (+ c 1))) ([> c 0] (set! result (cons (cons i c) result)) n) (else n))))) (cond ([= n 1] '((1 . 0))) (else (set! n (f-count n 2)) (set! n (f-count n 3)) (let loop ([n n] [i 5] [add 2]) (cond ([= n 1] (reverse result)) ([> (* i i) n] (reverse (cons (cons n 1) result))) (else (loop (f-count n i) (+ i add) (- 6 add))))))))) ;;; ;;; (divisor n) ;;; ;;; * 自然数 n の約数のリストを返す。 ;;; * n が大きくなると iota がエラーを出すことがある。 ;;; (define divisor (lambda (n) (let* ([a (filter (lambda (x) (zero? (remainder n x))) (cdr (iota (+ (isqrt n) 1))))] [b (reverse (map (lambda (x) (/ n x)) a))]) (if [= n (expt (car b) 2)] (append a (cdr b)) (append a b))))) ;;; ;;; (divisor2 n) ;;; ;;; * 自然数 n の約数をリストを返す。 ;;; * 素因数分解をもとに約数を探す。 ;;; (define divisor2 (lambda (n) ;; ex : (2 . 3) => (1 2 4 8) (define spread (lambda (lst) (let ([b (car lst)] [i-lst (iota (+ 1 (cdr lst)))]) (map (lambda (x) (expt b x)) i-lst)))) ;; ex : (1 2 4) (1 3) => (1 3 2 6 4 12) (define distribute (lambda (lst1 lst2) (apply append (map (lambda (x) (map (lambda (y) (* x y)) lst2)) lst1)))) (let ([lst (map spread (factorize n))]) (sort < (fold-left distribute '(1) lst))))) ;;; ;;; (count-divisor n) ;;; ;;; * 自然数 n の約数の個数を素因数分解を基にして数える。 ;;; (define count-divisor (lambda (n) (apply * (map (lambda (lst) (+ 1 (cdr lst))) (factorize n))))) ;;; ;;; (factorial n) ;;; (factorial n m) ;;; ;;; * 引数が 1 個の場合 : n! ;;; * 引数が 2 個の場合 : 下降階乗冪 ;;; (define factorial (case-lambda ([n] (factorial n n)) ([n m] (apply * (sequence (- n m -1) n))))) ;;; ;;; (perm n r) ;;; ;;; * 順列 nPr ;;; (define perm (lambda (n r) (factorial n r))) ;;; ;;; (permutations lst) ;;; (permutations lst size) ;;; ;;; * 順列をリストにして返す。 ;;; ex : (permutations '(1 2 3)) ;;; => ((1 2 3) (1 3 2) (2 1 3) (2 3 1) (3 1 2) (3 2 1)) ;;; ex : (permutations '(1 2 3) 2) ;;; => ((1 2) (1 3) (2 1) (2 3) (3 1) (3 2)) ;;; ;;; from 『M.Hiroi's Home Page』, modified by Tsumuji ;;; (define permutations (case-lambda ([lst] (permutations lst (length lst))) ([lst size] (define perm (lambda (lst a b size) (if [zero? size] (cons (reverse a) b) (fold-right (lambda (x y) (perm (remove x lst) (cons x a) y (- size 1))) b lst)))) (perm lst '() '() size)))) ;;; ;;; (permutations-for-each proc lst) ;;; (permutations-for-each proc lst size) ;;; ;;; * 順列を生成し、proc を適用する。 ;;; ;;; from 『M.Hiroi's Home Page』, modified by Tsumuji ;;; (define permutations-for-each (case-lambda ([proc lst] (permutations-for-each proc lst (length lst))) ([proc lst size] (define perm (lambda (lst a size) (if [zero? size] (proc (reverse a)) (for-each (lambda (n) (perm (remove n lst) (cons n a) (- size 1))) lst)))) (perm lst '() size)))) ;;; ;;; (comb n r) ;;; ;;; * 組合せ nCr ;;; (define comb (lambda (n r) (/ (factorial n r) (factorial r)))) ;;; ;;; (combinations ls n) ;;; ;;; * 組み合わせをリストにして返す。 ;;; ex : (combinations '(1 2 3 4) 2) ;;; => ((1 2) (1 3) (1 4) (2 3) (2 4) (3 4)) ;;; ;;; from 『M.Hiroi's Home Page』 ;;; (define combinations (lambda (ls n) (define comb (lambda (n ls a b) (cond ([zero? n] (cons (reverse a) b)) ([= (length ls) n] (cons (append (reverse a) ls) b)) (else (comb (- n 1) (cdr ls) (cons (car ls) a) (comb n (cdr ls) a b)))))) (if [> n (length ls)] #f (comb n ls '() '())))) ;;; ;;; (combinations-for-each proc ls n) ;;; ;;; * 組合せを生成し、proc を適応する。 ;;; ;;; from 『M.Hiroi's Home Page』 ;;; (define combinations-for-each (lambda (proc ls n) (define comb (lambda (ls n a) (cond ([zero? n] (proc (reverse a))) ([= (length ls) n] (proc (append (reverse a) ls))) (else (comb (cdr ls) (- n 1) (cons (car ls) a)) (comb (cdr ls) n a))))) (if [> n (length ls)] #f (comb ls n '())))) ;;; ;;; (real->integer n) ;;; ;;; * 実数の少数部分を切り捨てて、整数に変換する。 ;;; (define real->integer (lambda (n) (exact (truncate n)))) ;;; ;;; (triangle-number n) ;;; ;;; * n 番目の三角数 ;;; * Tn = n * (n + 1) / 2 ;;; (define triangle-number (lambda (n) (/ (+ (* n n) n) 2))) ;;; ;;; (triangle-number? n) ;;; ;;; * n が三角数なら「何番目か」を返す。 ;;; (define triangle-number? (lambda (n) (let* ([a (sqrt (+ 1 (* 8 n)))] [b (/ (+ -1 a) 2)]) (if [positive-integer? b] b #f)))) ;;; ;;; (square-number n) ;;; ;;; * n 番目の四角数(平方数) ;;; * Sn = n * n ;;; (define square-number (lambda (n) (* n n))) ;;; ;;; (square-number? n) ;;; ;;; * n が四角数(平方数)なら「何番目か」を返す。 ;;; (define square-number? (lambda (n) (let ([a (sqrt n)]) (if [positive-integer? a] a #f)))) ;;; ;;; (pentagon-number n) ;;; ;;; * n 番目の五角数 ;;; * Pn = n * (3 * n - 1) / 2 ;;; (define pentagon-number (lambda (n) (/ (- (* 3 n n) n) 2))) ;;; ;;; (pentagon-number? n) ;;; ;;; * n が五角数なら「何番目か」を返す。 ;;; (define pentagon-number? (lambda (n) (let* ([a (sqrt (+ 1 (* 24 n)))] [b (/ (+ 1 a) 6)]) (if [positive-integer? b] b #f)))) ;;; ;;; (hexagon-number n) ;;; ;;; * n 番目の六角数 ;;; * Hn = n * (2 * n - 1) ;;; (define hexagon-number (lambda (n) (- (* 2 n n) n))) ;;; ;;; (hexagon-number? n) ;;; ;;; * n が六角数なら「何番目か」を返す。 ;;; (define hexagon-number? (lambda (n) (let* ([a (sqrt (+ 1 (* 8 n)))] [b (/ (+ 1 a) 4)]) (if [positive-integer? b] b #f)))) ;;; ;;; (heptagon-number n) ;;; ;;; * n 番目の七角数 ;;; (define heptagon-number (lambda (n) (/ (- (* 5 n n) (* 3 n)) 2))) ;;; ;;; (heptagon-number? n) ;;; ;;; * n が七角数なら「何番目か」を返す。 ;;; (define heptagon-number? (lambda (n) (let* ([a (sqrt (+ 9 (* 40 n)))] [b (/ (+ 3 a) 10)]) (if [positive-integer? b] b #f)))) ;;; ;;; (octagon-number n) ;;; ;;; * n 番目の八画数 ;;; (define octagon-number (lambda (n) (- (* 3 n n) (* 2 n)))) ;;; ;;; (octagon-number? n) ;;; ;;; * n が八角数なら「何番目か」を返す。 (define octagon-number? (lambda (n) (let* ([a (sqrt (+ 4 (* 12 n)))] [b (/ (+ 2 a) 6)]) (if [positive-integer? b] b #f)))) ;;; ;;; (sum-of-divisors n) ;;; ;;; * 「真の約数の和」を求める。(約数に n 自身は含まれない) ;;; * n < 1 の場合エラーになる。 ;;; * 詳しくは『数学ガール』参照。 ;;; (define sum-of-divisors (lambda (n) (let ([lst (map (lambda (ls) (let ([f (car ls)] [i (cdr ls)]) (/ (- (expt f (+ i 1)) 1) (- f 1)))) (factorize n))]) (- (apply * lst) n)))) ;;; ;;; (perfect-number? n) ;;; ;;; * n が「完全数」なら #t ;;; (define perfect-number? (lambda (n) (= n (sum-of-divisors n)))) ;;; ;;; (deficient-number? n) ;;; ;;; * n が「不足数」なら #t ;;; (define deficient-number? (lambda (n) (> n (sum-of-divisors n)))) ;;; ;;; (abundant-number? n) ;;; ;;; * n が「過剰数」なら #t ;;; (define abundant-number? (lambda (n) (< n (sum-of-divisors n)))) ;;; ;;; (amicable-pair n) ;;; ;;; * n が「友愛数」の場合、ペアとなる数を返す。 ;;; * n が「友愛数でない場合は、#f を返す。 ;;; (define amicable-pair (lambda (n) (let ([sum (sum-of-divisors n)]) (cond ([= n sum] #f) ([= n (sum-of-divisors sum)] sum) (else #f))))) ;;; ;;; (pythagorean-triples n) ;;; (pythagorean-triples n flag) ;;; ;;; * a² + b² = c² かつ a + b + c = n (a < b < c) を満たす ;;; a, b, c の組み合わせを返す。 ;;; * flag が #f 以外の場合は、既約であるものだけを返す。 ;;; ex : (pythagoras-triples 120) ;;; => ((20 48 52) (24 45 51) (30 40 50)) ;;; ex : (pythagoras-triples 120 #t) => () ;;; (define pythagorean-triples (case-lambda ([n] (pythagorean-triples n #f)) ([n flag] (define check-b (lambda (a) (let ([b (- n (/ (* n n) (- n a) 2))]) (if [and (integer? b) (< a b)] (list a b (- n a b)) #f)))) (if [odd? n] '() (let* ([lst-a (sequence 1 (real->integer (/ n 3)))] [lst-b (remq #f (map check-b lst-a))]) (if flag (filter (lambda (lst) (= 1 (apply gcd lst))) lst-b) lst-b))))))

;;;; ;;;; euler.ss --- Project Euler のための関数群 ;;;; ;;;; for Chez Scheme by Tsumuji ;;;; ;;; ;;; (integer->list n) ;;; (integer->list n radix) ;;; ;;; * 整数の各桁を要素とするリストを返す。 ;;; * radix を指定すると、radix を基数にしたリストを返す。 ;;; ex : (integer->list 123) => (1 2 3) ;;; ex : (integer->list 123 2) => (1 1 1 1 0 1 1) ;;; (define integer->list (case-lambda ([n] (integer->list n 10)) ([n radix] (do ([n n (quotient n radix)] [result '() (cons (remainder n radix) result)]) ([< n radix] (cons n result)))))) ;;; ;;; (list->integer lst) ;;; (list->integer lst radix) ;;; ;;; * リストの要素を各桁とする整数を返す。 ;;; * radix を指定すると、radix を基数とした整数を返す。 ;;; ex : (list->integer '(1 2 3)) => 123 ;;; ex : (list->integer '(1 1 1 1 0 1 1) 2) => 123 ;;; (define list->integer (case-lambda ([lst] (list->integer lst 10)) ([lst radix] (fold-left (lambda (a b) (+ b (* radix a))) 0 lst)))) ;;; ;;; (sum-of-digits n) ;;; ;;; * 整数の各桁の合計を求める。 ;;; ex : (sum-of-digits 123) => 6 ;;; (define sum-of-digits (lambda (n) (apply + (integer->list n)))) ;;; ;;; (unique lst) ;;; ;;; * lst の重複する要素を取り除く。 ;;; ex : (unique '(a b a b c)) => (a b c) ;;; (define unique (lambda (lst) (if [null? lst] '() (let ([a (car lst)]) (cons a (unique (remove a (cdr lst)))))))) ;;; ;;; (pandigital? obj) ;;; ;;; * obj が 「Pandigital」ならば #t ;;; * obj は正の整数またはリスト。 ;;; (define pandigital? (lambda (obj) (cond ([positive-integer? obj] (pandigital? (integer->list obj))) ([list? obj] (let* ([lst-a (list-head '(1 2 3 4 5 6 7 8 9) (length obj))] [lst-b (sort < obj)]) (equal? lst-a lst-b))) (else #f)))) ;;; ;;; (all-different? lst) ;;; ;;; * lst の要素がすべて異なれば #t ;;; (define all-different? (lambda (lst) (cond ([null? lst] #t) ([member (car lst) (cdr lst)] #f) (else (all-different? (cdr lst)))))) ;;; ;;; (palindromic? obj) ;;; ;;; * obj が「回文」なら #t ;;; * obj は正の整数またはリスト。 ;;; (define palindromic? (lambda (obj) (cond ([positive-integer? obj] (palindromic? (integer->list obj))) ([list? obj] (equal? obj (reverse obj))) (else #f)))) ;;; ;;; (make-palindromic-number n) ;;; (make-palindromic-number n #t) ;;; ;;; * 第 1 引数 n を上位の桁とする回文数を作る。 ;;; * 第 2 引数がない場合は奇数桁の回文数を作る。 ;;; * 第 2 引数が #t の場合、偶数桁の回文数を作る。 ;;; ex : (make-palindromic-number 123) => 12321 ;;; ex : (make-palindromic-number 123 #t) => 123321 ;;; (define make-palindromic-number (case-lambda ([n] (make-palindromic-number n #f)) ([n flag] (let* ([a (integer->list n)] [b (reverse a)]) (list->integer (append a (if flag b (cdr b)))))))) ;;; ;;; (partial-list lst start length) ;;; ;;; * lst の start の位置から、長さ length の部分リストを返す。 ;;; (define partial-list (lambda (lst start length) (list-head (list-tail lst start) length)))

« 九九表を作る。 | トップページ | Project Euler - Problem 1 : 今度は Scheme で…… »

Project Euler」カテゴリの記事

Scheme」カテゴリの記事

コメント

コメントを書く

コメントは記事投稿者が公開するまで表示されません。

(ウェブ上には掲載しません)

トラックバック

この記事のトラックバックURL:
http://app.cocolog-nifty.com/t/trackback/112020/46632552

この記事へのトラックバック一覧です: 自作の手続き for Project Euler:

« 九九表を作る。 | トップページ | Project Euler - Problem 1 : 今度は Scheme で…… »

2016年7月
          1 2
3 4 5 6 7 8 9
10 11 12 13 14 15 16
17 18 19 20 21 22 23
24 25 26 27 28 29 30
31            
フォト

最近のトラックバック

無料ブログはココログ