« Project Euler --- Problem 4 | トップページ | 困ったものです --- バグの混入 »

2009年3月29日 (日)

自作の手続きたち

Project Euler の問題を解くために自作の手続きを作っていたら、結構な数になったので、ここでまとめてグロブに載せておきます。(最新版を改めてこちらにまとめました : 2009/10/31)

ちなみに、処理系は Chez Scheme です。Gauche とは違った独自の拡張がされているので、多くの Gauche 使いの人は「ちょっと試しに使ってみる」というわけにもいかないかもしれませんが、少しでも Scheme を使っている人たちの役にたってくれればいいなあ……。

まず、今回紹介した手続きの中に含まれる、Chez 独自の拡張について簡単に紹介しておきます。詳しくは Chez Scheme のホームページにある『Chez Scheme Version 7 User's Guide (CSUG)』を見てください。

  • (isqrt n) : n の平方根の整数部分のみを返します。R5RSの手続きで定義するなら"(define isqrt (lambda (x) (inexact->exact (truncate (sqrt x)))))"でよいと思います。
  • (remv i lst) : lst から数値 i を取り除いたリストを返します。SRFI-1 の "delete" で代用できると思います。

続いて自作の手続きたちです。「参考になった」とか、「もっといい方法がある」といったご意見お待ちしてます。


注意1:最初に投稿したバージョンでは、「sequence が3個の引数を取る場合」に、ちょっとしたバグが紛れこんでいました。この記事は既に訂正されています。

注意2:人様のホームページからコピペさせてもらった手続きが紛れ込んでいました。出典は書いてありましたが、作者の方に無断で記事に書くのも気が引けるので、削除させていただきました。


;;; ;;; (sequence start end) ;;; (sequence start end step) ;;; ;;; * start 以上 end 以下の範囲の等差数列のリストを返す。 ;;; * step が省略された場合、step = 1 とみなされる。 ;;; * step が少数の場合、計算誤差がでる場合があるので注意。 ;;; * Chez Scheme の iota は開始する数やステップを指定できない ;;; (その代わりとても高速)ので、この手続きを作った。 ;;; (define sequence (case-lambda ([start end] (let ([size (- end start -1)]) (cond ([nonpositive? size] '()) ([= start 0] (iota size)) ([= start 1] (cdr (iota (+ size 1)))) (else (map (lambda (x) (+ x start)) (iota size)))))) ([start end step] (let* ([range (- end start)] [size (+ 1 (real->integer (/ (- end start) step)))]) (cond ([negative? (* range step)] '()) ([= start 0] (map (lambda (x) (* x step)) (iota size))) (else (map (lambda (x) (+ (* x step) start)) (iota size)))))))) ;;; ;;; (pred-list pred? n) ;;; (pred-list pred? n start) ;;; ;;; * pred? が真になる整数の n 番目までのリストを返す。 ;;; * start が指定されなれば "1" から探し始める。 ;;; (define pred-list (case-lambda ([pred? n] (pred-list pred? n 1)) ([pred? n start] (let loop ([count n] [i start]) (cond ([zero? count] '()) ([pred? i] (cons i (loop (- count 1) (+ i 1)))) (else (loop count (+ i 1)))))))) ;;; ;;; (prime? n) ;;; ;;; * n が「素数」なら #t ;;; (define prime?* (lambda (n) (cond ([not (integer? n)] #f) ([< n 2] #f) ([= n 2] #t) ([even? n] #f) (else (let ([i-max (isqrt n)]) (let loop ([i 3]) (cond ([> i i-max] #t) ([zero? (remainder n i)] #f) (else (loop (+ i 2)))))))))) ;;; ;;; (prime-list n) ;;; ;;; * 自然数 n 以下の素数のリストを返す。 ;;; * Ruby の"sample/sieve.rb" のアルゴリズムを改良して使用。 ;;; (define prime-list (lambda (n) (cond ([< n 2] '()) ([= n 2] '(2)) (else ;; エラトステネスの篩 (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)))))))))))))) ;;; ;;; (prime-list* n) ;;; ;;; * n 以下の素数のリストを返す。 ;;; * prime-list よりかなり遅い。 ;;; (define prime-list* (lambda (n) (cond ([< n 2] '()) ([= n 2] '(2)) (else (let ([n-max (isqrt n)]) (let loop ([lst (sequence 3 n 2)] [result '()]) (let ([a (car lst)]) (if [> a n-max] (cons 2 (append (reverse result) lst)) (loop (filter (lambda (x) (> (remainder x a) 0)) (cdr lst)) (cons a result)))))))))) ;;; ;;; (factorize n) ;;; ;;; * 自然数 n を素因数分解した要素のリストを返す。 ;;; ex : (factorize 12) => ((2 . 2) (3 . 1)) ;;; ex : (map (lambda (lst) ;;; (make-list (cdr lst) (car lst))) ;;; (factorize 12)) ;;; => ((2 2) (3)) ;;; (define factorize (lambda (n) (define result '()) (define check (lambda (n i) (let loop ([n n] [c 0]) (if [zero? (remainder n i)] (loop (/ n i) (+ c 1)) (begin (if [> c 0] (set! result (cons (cons i c) result))) n))))) (let loop ([n (check n 2)] [i 3]) (cond ([= n 1] (reverse result)) ([> (* i i) n] (reverse (cons (cons n 1) result))) (else (loop (check n i) (+ i 2))))))) ;;; ;;; (divisor n) ;;; ;;; * 自然数 n の約数のリストを返す。 ;;; (define divisor (lambda (n) (let* ([a (filter (lambda (x) (zero? (remainder n x))) (sequence 1 (isqrt n)))] [b (map (lambda (x) (/ n x)) a)]) (if (integer? (sqrt n)) (append a (cdr (reverse b))) (append a (reverse 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) => (3 6 12 1 2 4) (define distribute (lambda (lst1 lst2) (do ([ls lst2 (cdr ls)] [result '() (cons (map (lambda (x) (* x (car ls))) lst1) result)]) ([null? ls] (apply append result))))) (if [= n 1] '(1) (let ([lst (map spread (factorize n))]) (sort < (fold-left distribute (car lst) (cdr lst))))))) ;;; ;;; (factorial n) ;;; (factorial n m) ;;; ;;; * 引数が 1 個の場合 : n! ;;; * 引数が 2 個の場合 : 下降階乗冪 ;;; (define factorial (case-lambda ([n] (factorial n n)) ([m n] (apply * (sequence (- n m -1) n))))) ;;; ;;; (permutation n r) ;;; ;;; * 順列 nPr ;;; (define permutation (lambda (n r) (factorial n r))) ;;; ;;; (combination n r) ;;; ;;; * 組合せ nCr ;;; (define combination (lambda (n r) (/ (factorial n r) (factorial r)))) ;;; ;;; (real->integer n) ;;; ;;; * 実数の少数部分を切り捨てて、整数に変換する。 ;;; (define real->integer (lambda (n) (exact (truncate n)))) ;;; ;;; (sum-of-divisors n) ;;; ;;; * 真の約数の和を求める。(約数に n 自身は含まれない) ;;; (define sum-of-divisors (lambda (n) (- (apply + (divisor n)) n))) ;;; ;;; (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 は正の整数またはリスト。 ;;; * m 桁の数が Pandigital であるとは, 1 から m までの数を各桁に ;;; 1 つずつもつことである。 ;;; (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))))))))

« Project Euler --- Problem 4 | トップページ | 困ったものです --- バグの混入 »

Project Euler」カテゴリの記事

Scheme」カテゴリの記事

コメント

コメントを書く

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

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

トラックバック

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

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

« Project Euler --- Problem 4 | トップページ | 困ったものです --- バグの混入 »

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            
フォト

最近のトラックバック

無料ブログはココログ