今回はベクタを操作するときに便利な関数を取り上げます。なお、ベクタの操作は Scheme のライブラリ SRFI-133 に用意されています。SRFI-133 は RSR7-large のライブラリ (scheme vector) に採り入れられました。もちろん、Gauche でも利用することができますが、Scheme のお勉強ということで、あえてプログラムを作ってみましょう。
まず最初に、ベクタを生成する関数 vector-iota と vector-tabulate を作ります。
リストを生成する関数 iota と tabulate のベクタ版です。vector-tabulate はライブラリ (scheme vector) に用意されていますが、start と step は指定できないことに注意してください。プログラムは次のようになります。
リスト : ベクタの生成
(define vector-iota
(case-lambda
((n)
(vector-iota n 0 1))
((n s)
(vector-iota n s 1))
((n s i)
(let ((vec (make-vector n)))
(do ((j 0 (+ j 1))
(s s (+ s i)))
((>= j n) vec)
(vector-set! vec j s))))))
(define vector-tabulate
(case-lambda
((n proc)
(vector-tabulate n proc 0 1))
((n proc s)
(vector-tabulate n proc s 1))
((n proc s i)
(let ((vec (make-vector n)))
(do ((j 0 (+ j 1))
(s s (+ s i)))
((>= j n) vec)
(vector-set! vec j (proc s)))))))
make-vector で大きさ n のベクタ vec を生成し、do ループで vec に値をセットしていくだけです。簡単な実行例を示します。
gosh[r7rs.user]> (vector-iota 10) #(0 1 2 3 4 5 6 7 8 9) gosh[r7rs.user]> (vector-iota 10 1) #(1 2 3 4 5 6 7 8 9 10) gosh[r7rs.user]> (vector-iota 10 1 2) #(1 3 5 7 9 11 13 15 17 19) gosh[r7rs.user]> (vector-iota 10 1 -2) #(1 -1 -3 -5 -7 -9 -11 -13 -15 -17)
gosh[r7rs.user]> (vector-tabulate 10 (lambda (x) x)) #(0 1 2 3 4 5 6 7 8 9) gosh[r7rs.user]> (vector-tabulate 10 (lambda (x) (* x x)) 1) #(1 4 9 16 25 36 49 64 81 100) gosh[r7rs.user]> (vector-tabulate 10 (lambda (x) (* x x)) 1 2) #(1 9 25 49 81 121 169 225 289 361)
vector-sawp! はベクタ vec の i 番目と j 番目の要素を交換します。vector-reverse! はベクタ vec を破壊的に反転します。
リスト : 要素の交換とベクタの反転
(define (vector-swap! vec i j)
(let ((tmp (vector-ref vec i)))
(vector-set! vec i (vector-ref vec j))
(vector-set! vec j tmp)))
(define (vector-reverse! vec)
(do ((i 0 (+ i 1))
(j (- (vector-length vec) 1) (- j 1)))
((>= i j) vec)
(vector-swap! vec i j)))
vector-swap! は簡単ですね。vector-reverse! は前方と後方から要素を交換していくだけです。簡単な実行例を示します。
gosh[r7rs.user]> (define a (vector 1 2 3 4 5)) a gosh[r7rs.user]> a #(1 2 3 4 5) gosh[r7rs.user]> (vector-swap! a 0 4) #<undef> gosh[r7rs.user]> a #(5 2 3 4 1) gosh[r7rs.user]> (vector-swap! a 3 1) #<undef> gosh[r7rs.user]> a #(5 4 3 2 1) gosh[r7rs.user]> (vector-reverse! a) #(1 2 3 4 5) gosh[r7rs.user]> a #(1 2 3 4 5) gosh[r7rs.user]> (vector-reverse! #(1 2 3 4 5 6)) #(6 5 4 3 2 1)
vector-partition! は述語 pred の返り値 (真偽値) を基準にしてベクタ vec を二分割します。pred が真を返す要素を前半に、偽を返す要素を後半に集めます。返り値は整数 x で、start から x - 1 が前半部分、x から end までが後半部分になります。なお、ライブラリ (scheme vector) には非破壊的な操作を行う vector-partition が用意されています。
リスト : ベクタの分割 (破壊的修正)
(define vector-partition!
(case-lambda
((pred vec)
(vector-partition! pred vec 0 (- (vector-length vec) 1)))
((pred vec s)
(vector-partition! pred vec s (- (vector-length vec) 1)))
((pred vec s e)
(let loop ((i s) (j e))
(do () ((or (< e i) (not (pred (vector-ref vec i))))) (set! i (+ i 1)))
(do () ((or (> s j) (pred (vector-ref vec j)))) (set! j (- j 1)))
(cond
((>= i j) i)
(else
(vector-swap! vec i j)
(loop (+ i 1) (- j 1))))))))
case-lambda の 3 番目の節が本体です。name-let の中の最初の do ループで、前方から pred を満たさない要素を探します。次の do ループで、後方から pred を満たす要素を探します。i と j が交差すれば分割終了です。そうでなければ、i 番目と j 番目の要素を交換して、ベクタの分割処理を続行します。簡単な実行例を示します。
gosh[r7rs.user]> (define a #(5 6 4 7 3 8 2 9 1 0)) a gosh[r7rs.user]> (vector-partition! (lambda (x) (< x 5)) a) 5 gosh[r7rs.user]> a #(0 1 4 2 3 8 7 9 6 5) gosh[r7rs.user]> (define a #(5 6 4 7 3 8 2 9 1 0)) a gosh[r7rs.user]> (vector-partition! (lambda (x) (> x 5)) a) 4 gosh[r7rs.user]> a #(9 6 8 7 3 4 2 5 1 0) gosh[r7rs.user]> (define a #(2 4 6 8 10)) a gosh[r7rs.user]> (vector-partition! odd? a) 0 gosh[r7rs.user]> a #(2 4 6 8 10) gosh[r7rs.user]> (vector-partition! even? a) 5 gosh[r7rs.user]> a #(2 4 6 8 10)
vector-map! は vector-map の破壊的操作バージョンです。関数 proc の返り値はベクタ vec1 にセットされます。R7RS-large のライブラリ (scheme vector) とは異なり、渡すことができるベクタは 2 つまでに限定しています。
リスト : マッピング (破壊的操作)
(define vector-map!
(case-lambda
((proc vec)
(let ((len (vector-length vec)))
(do ((i 0 (+ i 1)))
((>= i len) vec)
(vector-set! vec i (proc (vector-ref vec i))))))
((proc vec1 vec2)
(let ((len (min (vector-length vec1) (vector-length vec2))))
(do ((i 0 (+ i 1)))
((>= i len) vec1)
(vector-set! vec1 i (proc (vector-ref vec1 i) (vector-ref vec2 i))))))))
case-lambda を使って引数の個数で場合分けします。一番短いベクタの長さを求めて変数 len にセットします。あとは do ループで 0 から len - 1 番目の要素を取り出して関数 proc に渡して評価し、その結果を最初のベクタに格納します。簡単な実行例を示します。
gosh[r7rs.user]> (define a #(1 2 3 4 5 6 7 8)) a gosh[r7rs.user]> (vector-map! (lambda (x) (* x x)) a) #(1 4 9 16 25 36 49 64) gosh[r7rs.user]> a #(1 4 9 16 25 36 49 64) gosh[r7rs.user]> (define a #(1 2 3 4 5 6 7 8)) a gosh[r7rs.user]> (define b #(2 4 6 8 10 12)) b gosh[r7rs.user]> (vector-map! + a b) #(3 6 9 12 15 18 7 8) gosh[r7rs.user]> a #(3 6 9 12 15 18 7 8) gosh[r7rs.user]> (define a #(1 2 3 4 5 6 7 8)) a gosh[r7rs.user]> (define b #(2 4 6 8 10 12)) b gosh[r7rs.user]> (vector-map! + b a) #(3 6 9 12 15 18) gosh[r7rs.user]> a #(1 2 3 4 5 6 7 8) gosh[r7rs.user]> b #(3 6 9 12 15 18)
添字付きのマップ関数です。関数 proc の第 1 引数に添字が渡されます。R7RS-large のライブラリ (scheme vector) とは異なり、渡すことができるベクタは 2 つまでに限定しています。プログラムと実行例を示します。
リスト : 添字付きマップ関数
(define vector-map-with-index
(case-lambda
((proc vec)
(let* ((len (vector-length vec))
(dst (make-vector len)))
(do ((i 0 (+ i 1)))
((>= i len) dst)
(vector-set! dst i (proc i (vector-ref vec i))))))
((proc vec1 vec2)
(let* ((len (min (vector-length vec1) (vector-length vec2)))
(dst (make-vector len)))
(do ((i 0 (+ i 1)))
((>= i len) dst)
(vector-set! dst i (proc i (vector-ref vec1 i) (vector-ref vec2 i))))))))
gosh[r7rs.user]> (vector-map-with-index (lambda (i x) (list i x)) #(1 2 3 4 5)) #((0 1) (1 2) (2 3) (3 4) (4 5)) gosh[r7rs.user]> (vector-map-with-index (lambda (i x y) (list i x y)) #(1 2 3 4 5) #(a b c d)) #((0 1 a) (1 2 b) (2 3 c) (3 4 d)) gosh[r7rs.user]> (vector-map-with-index (lambda (i x y) (list i x y)) #(1 2 3) #(a b c d)) #((0 1 a) (1 2 b) (2 3 c)) gosh[r7rs.user]> (vector-map-with-index (lambda (i x y) (list i x y)) #(1 2 3 4) #(a b c d)) #((0 1 a) (1 2 b) (2 3 c) (3 4 d))
ベクタ用の畳み込み関数です。関数 proc の第 1 引数に累積変数の値が渡されます。R7RS-large のライブラリ (scheme vector) とは異なり、渡すことができるベクタは 2 つまでに限定しています。プログラムと実行例を示します。
リスト : ベクタの畳み込み
(define vector-foldl
(case-lambda
((proc a vec)
(let ((len (vector-length vec)))
(do ((i 0 (+ i 1)))
((>= i len) a)
(set! a (proc a (vector-ref vec i))))))
((proc a vec1 vec2)
(let ((len (min (vector-length vec1) (vector-length vec2))))
(do ((i 0 (+ i 1)))
((>= i len) a)
(set! a (proc a (vector-ref vec1 i) (vector-ref vec2 i))))))))
(define vector-foldr
(case-lambda
((proc a vec)
(let ((len (vector-length vec)))
(do ((i (- len 1) (- i 1)))
((negative? i) a)
(set! a (proc a (vector-ref vec i))))))
((proc a vec1 vec2)
(let ((len (min (vector-length vec1) (vector-length vec2))))
(do ((i (- len 1) (- i 1)))
((negative? i) a)
(set! a (proc a (vector-ref vec1 i) (vector-ref vec2 i))))))))
gosh[r7rs.user]> (vector-foldl + 0 #(1 2 3 4 5)) 15 gosh[r7rs.user]> (vector-foldr + 0 #(1 2 3 4 5)) 15 gosh[r7rs.user]> (define (xcons d a) (cons a d)) xcons gosh[r7rs.user]> (vector-foldl xcons '() #(1 2 3 4 5)) (5 4 3 2 1) gosh[r7rs.user]> (vector-foldr xcons '() #(1 2 3 4 5)) (1 2 3 4 5) gosh[r7rs.user]> (vector-foldl (lambda (a x y) (cons (list x y) a)) '() #(1 2 3 4 5) #(a b c d)) ((4 d) (3 c) (2 b) (1 a)) gosh[r7rs.user]> (vector-foldr (lambda (a x y) (cons (list x y) a)) '() #(1 2 3 4 5) #(a b c d)) ((1 a) (2 b) (3 c) (4 d)) gosh[r7rs.user]> (vector-foldl (lambda (a x y) (cons (list x y) a)) '() #(1 2 3) #(a b c d)) ((3 c) (2 b) (1 a)) gosh[r7rs.user]> (vector-foldr (lambda (a x y) (cons (list x y) a)) '() #(1 2 3) #(a b c d)) ((1 a) (2 b) (3 c))
添字付きの vector-for-each です。添字は関数 porc の第 1 引数に渡されます。R7RS-large のライブラリ (scheme vector) とは異なり、渡すことができるベクタは 2 つまでに限定しています。プログラムと実行例を示します。
リスト : 添字付き vector-for-each
(define vector-for-each-with-index
(case-lambda
((proc vec)
(let ((len (vector-length vec)))
(do ((i 0 (+ i 1)))
((>= i len))
(proc i (vector-ref vec i)))))
((proc vec1 vec2)
(let ((len (min (vector-length vec1) (vector-length vec2))))
(do ((i 0 (+ i 1)))
((>= i len))
(proc i (vector-ref vec1 i) (vector-ref vec2 i)))))))
gosh[r7rs.user]> (vector-for-each-with-index (lambda (i x) (display (list i x)) (newline)) #(a b c d e)) (0 a) (1 b) (2 c) (3 d) (4 e) #t gosh[r7rs.user]> (vector-for-each-with-index (lambda (i x y) (display (list i x y)) (newline)) #(a b c d e) #(2 4 6 8)) (0 a 2) (1 b 4) (2 c 6) (3 d 8) #t
any と every のベクタ版です。R7RS-large のライブラリ (scheme vector) とは異なり、渡すことができるベクタは 2 つまでに限定しています。プログラムと実行例を示します。
リスト : ベクタ用の any と every
(define vector-any
(case-lambda
((pred vec)
(let ((len (vector-length vec)))
(let loop ((i 0))
(if (>= i len)
#f
(or (pred (vector-ref vec i))
(loop (+ i 1)))))))
((pred vec1 vec2)
(let ((len (min (vector-length vec1) (vector-length vec2))))
(let loop ((i 0))
(if (>= i len)
#f
(or (pred (vector-ref vec1 i) (vector-ref vec2 i))
(loop (+ i 1)))))))))
(define vector-every
(case-lambda
((pred vec)
(let ((len (vector-length vec)))
(if (zero? len)
#t
(let loop ((i 0))
(let ((val (pred (vector-ref vec i))))
(if (or (not val) (= (- len 1) i))
val
(loop (+ i 1))))))))
((pred vec1 vec2)
(let ((len (min (vector-length vec1) (vector-length vec2))))
(if (zero? len)
#t
(let loop ((i 0))
(let ((val (pred (vector-ref vec1 i) (vector-ref vec2 i))))
(if (or (not val) (= (- len 1) i))
val
(loop (+ i 1))))))))))
gosh[r7rs.user]> (vector-any (lambda (x) x) #(#f #f #f #f #f)) #f gosh[r7rs.user]> (vector-any (lambda (x) x) #(#f #f 3 #f #f)) 3 gosh[r7rs.user]> (vector-any (lambda (x) x) #()) #f gosh[r7rs.user]> (vector-every (lambda (x) x) #(1 2 3 4 5)) 5 gosh[r7rs.user]> (vector-every (lambda (x) x) #(1 2 #f 4 5)) #f gosh[r7rs.user]> (vector-every (lambda (x) x) #()) #t gosh[r7rs.user]> (vector-any < #(1 3 5 7) #(0 0 2 0)) #f gosh[r7rs.user]> (vector-any < #(1 3 5 7) #(0 0 6 0)) #t gosh[r7rs.user]> (vector-every < #(1 3 5 7) #(2 4 6 8)) #t gosh[r7rs.user]> (vector-every < #(1 3 5 7) #(2 4 0 8)) #f
find, find-if, position, position-if, count, count-if のベクタ版です。引数 test? が省略された場合、述語 eqv? を使うことにします。プログラムと実行例を示します。
リスト : ベクタの探索
(define (vector-find-if pred vec)
(let loop ((i 0))
(cond
((>= i (vector-length vec)) #f)
((pred (vector-ref vec i))
(vector-ref vec i))
(else (loop (+ i 1))))))
(define vector-find
(case-lambda
((x vec)
(vector-find-if (lambda (y) (eqv? x y)) vec))
((x vec pred)
(vector-find-if (lambda (y) (pred x y)) vec))))
(define (vector-position-if pred vec)
(let loop ((i 0))
(cond
((>= i (vector-length vec)) #f)
((pred (vector-ref vec i)) i)
(else (loop (+ i 1))))))
(define vector-position
(case-lambda
((x vec)
(vector-position-if (lambda (y) (eqv? x y)) vec))
((x vec pred)
(vector-position-if (lambda (y) (pred x y)) vec))))
(define (vector-count-if pred vec)
(do ((c 0)
(i 0 (+ i 1)))
((>= i (vector-length vec)) c)
(when
(pred (vector-ref vec i))
(set! c (+ c 1)))))
(define vector-count
(case-lambda
((x vec)
(vector-count-if (lambda (y) (eqv? x y)) vec))
((x vec pred)
(vector-count-if (lambda (y) (pred x y)) vec))))
gosh[r7rs.user]> (vector-find 5 #(1 2 3 4 5 6 7 8)) 5 gosh[r7rs.user]> (vector-find 10 #(1 2 3 4 5 6 7 8)) #f gosh[r7rs.user]> (vector-find '(7 8) #((1 2) (3 4) (5 6) (7 8)) equal?) (7 8) gosh[r7rs.user]> (vector-find '(7 8) #(#(1 2) #(3 4) #(5 6) #(7 8)) equalp?) #f gosh[r7rs.user]> (vector-find #(7 8) #(#(1 2) #(3 4) #(5 6) #(7 8)) equalp?) #(7 8) gosh[r7rs.user]> (vector-find-if even? #(1 2 3 4 5 6 7 8)) 2 gosh[r7rs.user]> (vector-find-if (lambda (x) (> x 6)) #(1 2 3 4 5 6 7 8)) 7 gosh[r7rs.user]> (vector-find-if (lambda (x) (> x 10)) #(1 2 3 4 5 6 7 8)) #f
gosh[r7rs.user]> (vector-position 5 #(1 2 3 4 5 6 7 8)) 4 gosh[r7rs.user]> (vector-position 10 #(1 2 3 4 5 6 7 8)) #f gosh[r7rs.user]> (vector-position #(7 8) #(#(1 2) #(3 4) #(5 6) #(7 8)) equalp?) 3 gosh[r7rs.user]> (vector-position #(7 9) #(#(1 2) #(3 4) #(5 6) #(7 8)) equalp?) #f gosh[r7rs.user]> (vector-position 5 #(1 2 3 4 5 6 7 8)) 4 gosh[r7rs.user]> (vector-position 10 #(1 2 3 4 5 6 7 8)) #f gosh[r7rs.user]> (vector-position #(7 8) #(#(1 2) #(3 4) #(5 6) #(7 8)) equalp?) 3 gosh[r7rs.user]> (vector-position #(7 9) #(#(1 2) #(3 4) #(5 6) #(7 8)) equalp?) #f gosh[r7rs.user]> (vector-position-if even? #(1 2 3 4 5 6 7 8)) 1 gosh[r7rs.user]> (vector-position-if (lambda (x) (< 6 x)) #(1 2 3 4 5 6 7 8)) 6 gosh[r7rs.user]> (vector-position-if (lambda (x) (< 10 x)) #(1 2 3 4 5 6 7 8)) #f
gosh[r7rs.user]> (vector-count 1 #(1 2 3 4 1 2 3 1 2 1)) 4 gosh[r7rs.user]> (vector-count 5 #(1 2 3 4 1 2 3 1 2 1)) 0 gosh[r7rs.user]> (vector-count #(1 2) #(#(1 2) #(3 4) #(1 2) #(5 6)) equalp?) 2 gosh[r7rs.user]> (vector-count #(1 3) #(#(1 2) #(3 4) #(1 2) #(5 6)) equalp?) 0 gosh[r7rs.user]> (vector-count-if even? #(1 2 3 4 5 6 7 8)) 4 gosh[r7rs.user]> (vector-count-if (lambda (x) (< 5 x)) #(1 2 3 4 5 6 7 8)) 3 gosh[r7rs.user]> (vector-count-if (lambda (x) (< 10 x)) #(1 2 3 4 5 6 7 8)) 0
関数 vector-binary-search はベクタ vec から x を二分探索します。見つけた場合は位置を返し、見つからない場合は #f を返します。要素の比較は関数 cmp で行います。(cmp x y) は x < ならば負の値を、x = y ならば 0 を、x > y ならば正の値を返すものとします。プログラムと実行例を示します。
リスト : 二分探索
(define (vector-binary-search vec value cmp)
(let loop ((low 0) (high (- (vector-length vec) 1)))
(if (> low high)
#f
(let* ((mid (quotient (+ low high) 2))
(r (cmp value (vector-ref vec mid))))
(cond
((zero? r) mid)
((negative? r)
(loop low (- mid 1)))
(else
(loop (+ mid 1) high)))))))
gosh[r7rs.user]> (define a (vector-iota 16 10 10)) a gosh[r7rs.user]> a #(10 20 30 40 50 60 70 80 90 100 110 120 130 140 150 160) gosh[r7rs.user]> (vector-binary-search a 100 (lambda (x y) (- x y))) 9 gosh[r7rs.user]> (vector-binary-search a 10 (lambda (x y) (- x y))) 0 gosh[r7rs.user]> (vector-binary-search a 160 (lambda (x y) (- x y))) 15 gosh[r7rs.user]> (vector-binary-search a 0 (lambda (x y) (- x y))) #f gosh[r7rs.user]> (vector-binary-search a 170 (lambda (x y) (- x y))) #f gosh[r7rs.user]> (vector-binary-search a 95 (lambda (x y) (- x y))) #f
関数 vector-insert-sort! はベクタ vec を単純挿入ソートでソートします。要素の比較は関数 cmp で行います。(cmp x y) は x < ならば負の値を、x = y ならば 0 を、x > y ならば正の値を返すものとします。関数 vector-sort! はベクタ vec をクイックソートでソートします。どちらの関数もベクタ vec を破壊的に修正します。
単純挿入ソートのプログラムと実行例を示します。
リスト : 単純挿入ソート
(define (vector-insert-sort! vec cmp)
(do ((i 1 (+ i 1)))
((>= i (vector-length vec)) vec)
(do ((tmp (vector-ref vec i))
(j (- i 1) (- j 1)))
((or (negative? j)
(>= (cmp tmp (vector-ref vec j)) 0))
(vector-set! vec (+ j 1) tmp))
(vector-set! vec (+ j 1) (vector-ref vec j)))))
gosh[r7rs.user]> (vector-insert-sort! #(5 6 4 7 3 8 2 9 1 0) (lambda (x y) (- x y))) #(0 1 2 3 4 5 6 7 8 9) gosh[r7rs.user]> (vector-insert-sort! #(0 1 2 3 4 5 6 7 8 9) (lambda (x y) (- x y))) #(0 1 2 3 4 5 6 7 8 9) gosh[r7rs.user]> (vector-insert-sort! #(9 8 7 6 5 4 3 2 1 0) (lambda (x y) (- x y))) #(0 1 2 3 4 5 6 7 8 9)
次は vector-sort! のプログラムを示します。クイックソートのアルゴリズムは、拙作のページ Algorithms with Python 整列 [1] をお読みください。
リスト : クイックソート
(define (vector-sort! vec cmp)
;; 3 つの中の中央値を選ぶ
(define (median3 a b c)
(if (positive? (cmp a b)) ; a > b
(cond
((positive? (cmp b c)) b) ; b > c
((negative? (cmp a c)) a) ; a < c
(else c))
(cond ; a < b
((negative? (cmp b c)) b) ; b < c
((negative? (cmp a c)) c) ; a < c
(else a))))
;; 9 つの中から中央値を選ぶ
(define (median9 low high)
(let* ((m2 (quotient (- high low) 2))
(m4 (quotient m2 2))
(m8 (quotient m4 2))
(a (vector-ref vec low))
(b (vector-ref vec (+ low m8)))
(c (vector-ref vec (+ low m4)))
(d (vector-ref vec (+ low (- m2 m8))))
(e (vector-ref vec (+ low m2)))
(f (vector-ref vec (+ low m2 m8)))
(g (vector-ref vec (- high m4)))
(h (vector-ref vec (- high m8)))
(i (vector-ref vec high)))
(median3 (median3 a b c) (median3 d e f) (median3 g h i))))
(define (qsort! low high)
(when
(>= (- high low) 16)
(let ((p (median9 low high)))
(let loop ((i low) (j high))
(do () ((<= (cmp p (vector-ref vec i)) 0)) (set! i (+ i 1)))
(do () ((>= (cmp p (vector-ref vec j)) 0)) (set! j (- j 1)))
(cond
((< i j)
(vector-swap! vec i j)
(loop (+ i 1) (- j 1)))
(else
(cond
((< (- i low) (- high j))
(qsort! low (- i 1))
(qsort! (+ j 1) high))
(else
(qsort! (+ j 1) high)
(qsort! low (- i 1))))))))))
;;
(qsort! 0 (- (vector-length vec) 1))
(vector-insert-sort! vec cmp))
今回は枢軸の選択に median-of-9 という方法を使っています。実際に 9 つの要素の中央値を求めているわけではありませんが、3 つの要素の中央値を求める方法 (median-of-3) よりも最悪のケースに遭遇する確率は低くなると思います。
関数 median3 は引数 a, b, c の中で中央値となるものを返します。関数 median9 は区間 (low, high) から 9 つの要素を選びます。区間を (0, 1) とすると、0, 1/8, 1/4, 3/8, 1/2, 5/8, 3/4, 7/8, 1 の位置にある要素を選びます。次に、9 つの要素を 3 つのグループ (0, 1/8, 1/4), (3/18, 1/2, 5/8), (3/4, 7/8, 1) に分けて、おのおののグループの中央値を median3 で求めます。さらに、その 3 つから中央値を median3 で求め、その値が枢軸となります。
median-of-9 の詳細は拙作のページ Memorandum 2013 年 5 月 18 日 をお読みください。
リスト : 簡単なテスト
(import (scheme base) (scheme write) (scheme time)
(mylib random) ; 線形合同法による簡単な乱数生成
(mylib vector))
(define (make-random-data n)
(let ((a (make-vector n)))
(do ((i 0 (+ i 1)))
((>= i n) a)
(vector-set! a i (irand)))))
(define (sorted? a cmp)
(let loop ((i 0))
(cond
((>= i (- (vector-length a) 1)) #t)
((positive? (cmp (vector-ref a i) (vector-ref a (+ i 1)))) #f)
(else (loop (+ i 1))))))
;;; テスト
(define (test fn n)
(let ((buff (make-random-data n))
(s (current-jiffy)))
(fn buff -)
(display (inexact (/ (- (current-jiffy) s) (jiffies-per-second))))
(newline)
(unless (sorted? buff -) (error "not sorted!"))))
gosh[r7rs.user]> (test vector-insert-sort! 1000) 0.0418165 #<undef> gosh[r7rs.user]> (test vector-insert-sort! 2000) 0.1802637 #<undef> gosh[r7rs.user]> (test vector-insert-sort! 4000) 0.5397235 #<undef> gosh[r7rs.user]> (test vector-sort! 10000) 0.0325998 #<undef> gosh[r7rs.user]> (test vector-sort! 20000) 0.0608123 #<undef> gosh[r7rs.user]> (test vector-sort! 40000) 0.1191062 #<undef> gosh[r7rs.user]> (test vector-sort! 80000) 0.241267 #<undef>
;;;
;;; vector.scm : ちょっと便利なベクタ操作関数
;;;
;;; Copyright (C) 2020 Makoto Hiroi
;;;
(define-library (mylib vector)
(import (scheme base) (scheme case-lambda))
(export vector-iota vector-tabulate vector-swap! vector-reverse! vector-map!
vector-partition! vector-map-with-index vector-for-each-with-index
vector-foldl vector-foldr vector-any vector-every vector-find
vector-find-if vector-position vector-position-if vector-count vector-count-if
vector-insert-sort! vector-sort! vector-binary-search
)
(begin
;; ベクタの生成
(define vector-iota
(case-lambda
((n)
(vector-iota n 0 1))
((n s)
(vector-iota n s 1))
((n s i)
(let ((vec (make-vector n)))
(do ((j 0 (+ j 1))
(s s (+ s i)))
((>= j n) vec)
(vector-set! vec j s))))))
(define vector-tabulate
(case-lambda
((n proc)
(vector-tabulate n proc 0 1))
((n proc s)
(vector-tabulate n proc s 1))
((n proc s i)
(let ((vec (make-vector n)))
(do ((j 0 (+ j 1))
(s s (+ s i)))
((>= j n) vec)
(vector-set! vec j (proc s)))))))
;; 要素の交換
(define (vector-swap! vec i j)
(let ((tmp (vector-ref vec i)))
(vector-set! vec i (vector-ref vec j))
(vector-set! vec j tmp)))
;; ベクタの反転
(define (vector-reverse! vec)
(do ((i 0 (+ i 1))
(j (- (vector-length vec) 1) (- j 1)))
((>= i j) vec)
(vector-swap! vec i j)))
;; ベクタの分割
(define vector-partition!
(case-lambda
((pred vec)
(vector-partition! pred vec 0 (- (vector-length vec) 1)))
((pred vec s)
(vector-partition! pred vec s (- (vector-length vec) 1)))
((pred vec s e)
(let loop ((i s) (j e))
(do () ((or (< e i) (not (pred (vector-ref vec i))))) (set! i (+ i 1)))
(do () ((or (> s j) (pred (vector-ref vec j)))) (set! j (- j 1)))
(cond
((>= i j) i)
(else
(vector-swap! vec i j)
(loop (+ i 1) (- j 1))))))))
;; マッピング
(define vector-map!
(case-lambda
((proc vec)
(let ((len (vector-length vec)))
(do ((i 0 (+ i 1)))
((>= i len) vec)
(vector-set! vec i (proc (vector-ref vec i))))))
((proc vec1 vec2)
(let ((len (min (vector-length vec1) (vector-length vec2))))
(do ((i 0 (+ i 1)))
((>= i len) vec1)
(vector-set! vec1 i (proc (vector-ref vec1 i) (vector-ref vec2 i))))))))
(define vector-map-with-index
(case-lambda
((proc vec)
(let* ((len (vector-length vec))
(dst (make-vector len)))
(do ((i 0 (+ i 1)))
((>= i len) dst)
(vector-set! dst i (proc i (vector-ref vec i))))))
((proc vec1 vec2)
(let* ((len (min (vector-length vec1) (vector-length vec2)))
(dst (make-vector len)))
(do ((i 0 (+ i 1)))
((>= i len) dst)
(vector-set! dst i (proc i (vector-ref vec1 i) (vector-ref vec2 i))))))))
;; 畳み込み
(define vector-foldl
(case-lambda
((proc a vec)
(let ((len (vector-length vec)))
(do ((i 0 (+ i 1)))
((>= i len) a)
(set! a (proc a (vector-ref vec i))))))
((proc a vec1 vec2)
(let ((len (min (vector-length vec1) (vector-length vec2))))
(do ((i 0 (+ i 1)))
((>= i len) a)
(set! a (proc a (vector-ref vec1 i) (vector-ref vec2 i))))))))
(define vector-foldr
(case-lambda
((proc a vec)
(let ((len (vector-length vec)))
(do ((i (- len 1) (- i 1)))
((negative? i) a)
(set! a (proc a (vector-ref vec i))))))
((proc a vec1 vec2)
(let ((len (min (vector-length vec1) (vector-length vec2))))
(do ((i (- len 1) (- i 1)))
((negative? i) a)
(set! a (proc a (vector-ref vec1 i) (vector-ref vec2 i))))))))
;; 巡回
(define vector-for-each-with-index
(case-lambda
((proc vec)
(let ((len (vector-length vec)))
(do ((i 0 (+ i 1)))
((>= i len))
(proc i (vector-ref vec i)))))
((proc vec1 vec2)
(let ((len (min (vector-length vec1) (vector-length vec2))))
(do ((i 0 (+ i 1)))
((>= i len))
(proc i (vector-ref vec1 i) (vector-ref vec2 i)))))))
;; 述語
(define vector-any
(case-lambda
((pred vec)
(let ((len (vector-length vec)))
(let loop ((i 0))
(if (>= i len)
#f
(or (pred (vector-ref vec i))
(loop (+ i 1)))))))
((pred vec1 vec2)
(let ((len (min (vector-length vec1) (vector-length vec2))))
(let loop ((i 0))
(if (>= i len)
#f
(or (pred (vector-ref vec1 i) (vector-ref vec2 i))
(loop (+ i 1)))))))))
(define vector-every
(case-lambda
((pred vec)
(let ((len (vector-length vec)))
(if (zero? len)
#t
(let loop ((i 0))
(let ((val (pred (vector-ref vec i))))
(if (or (not val) (= (- len 1) i))
val
(loop (+ i 1))))))))
((pred vec1 vec2)
(let ((len (min (vector-length vec1) (vector-length vec2))))
(if (zero? len)
#t
(let loop ((i 0))
(let ((val (pred (vector-ref vec1 i) (vector-ref vec2 i))))
(if (or (not val) (= (- len 1) i))
val
(loop (+ i 1))))))))))
;; 探索
(define (vector-find-if pred vec)
(let loop ((i 0))
(cond
((>= i (vector-length vec)) #f)
((pred (vector-ref vec i))
(vector-ref vec i))
(else (loop (+ i 1))))))
(define vector-find
(case-lambda
((x vec)
(vector-find-if (lambda (y) (eqv? x y)) vec))
((x vec pred)
(vector-find-if (lambda (y) (pred x y)) vec))))
(define (vector-position-if pred vec)
(let loop ((i 0))
(cond
((>= i (vector-length vec)) #f)
((pred (vector-ref vec i)) i)
(else (loop (+ i 1))))))
(define vector-position
(case-lambda
((x vec)
(vector-position-if (lambda (y) (eqv? x y)) vec))
((x vec pred)
(vector-position-if (lambda (y) (pred x y)) vec))))
(define (vector-count-if pred vec)
(do ((c 0)
(i 0 (+ i 1)))
((>= i (vector-length vec)) c)
(when
(pred (vector-ref vec i))
(set! c (+ c 1)))))
(define vector-count
(case-lambda
((x vec)
(vector-count-if (lambda (y) (eqv? x y)) vec))
((x vec pred)
(vector-count-if (lambda (y) (pred x y)) vec))))
;;
;; ソート
;;
;; 単純挿入ソート
(define (vector-insert-sort! vec cmp)
(do ((i 1 (+ i 1)))
((>= i (vector-length vec)) vec)
(do ((tmp (vector-ref vec i))
(j (- i 1) (- j 1)))
((or (negative? j)
(>= (cmp tmp (vector-ref vec j)) 0))
(vector-set! vec (+ j 1) tmp))
(vector-set! vec (+ j 1) (vector-ref vec j)))))
;; クイックソート
(define (vector-sort! vec cmp)
;; 3 つの中の中央値を選ぶ
(define (median3 a b c)
(if (positive? (cmp a b)) ; a > b
(cond
((positive? (cmp b c)) b) ; b > c
((negative? (cmp a c)) a) ; a < c
(else c))
(cond ; a < b
((negative? (cmp b c)) b) ; b < c
((negative? (cmp a c)) c) ; a < c
(else a))))
;; 9 つの中から中央値を選ぶ
(define (median9 low high)
(let* ((m2 (quotient (- high low) 2))
(m4 (quotient m2 2))
(m8 (quotient m4 2))
(a (vector-ref vec low))
(b (vector-ref vec (+ low m8)))
(c (vector-ref vec (+ low m4)))
(d (vector-ref vec (+ low (- m2 m8))))
(e (vector-ref vec (+ low m2)))
(f (vector-ref vec (+ low m2 m8)))
(g (vector-ref vec (- high m4)))
(h (vector-ref vec (- high m8)))
(i (vector-ref vec high)))
(median3 (median3 a b c) (median3 d e f) (median3 g h i))))
(define (qsort! low high)
(when
(>= (- high low) 16)
(let ((p (median9 low high)))
(let loop ((i low) (j high))
(do () ((<= (cmp p (vector-ref vec i)) 0)) (set! i (+ i 1)))
(do () ((>= (cmp p (vector-ref vec j)) 0)) (set! j (- j 1)))
(cond
((< i j)
(vector-swap! vec i j)
(loop (+ i 1) (- j 1)))
(else
(cond
((< (- i low) (- high j))
(qsort! low (- i 1))
(qsort! (+ j 1) high))
(else
(qsort! (+ j 1) high)
(qsort! low (- i 1))))))))))
;;
(qsort! 0 (- (vector-length vec) 1))
(vector-insert-sort! vec cmp))
;; 二分探索
(define (vector-binary-search vec value cmp)
(let loop ((low 0) (high (- (vector-length vec) 1)))
(if (> low high)
#f
(let* ((mid (quotient (+ low high) 2))
(r (cmp value (vector-ref vec mid))))
(cond
((zero? r) mid)
((negative? r)
(loop low (- mid 1)))
(else
(loop (+ mid 1) high)))))))
))
;;;
;;; random.scm : 乱数 (線形合同法)
;;;
;;; Copyright (C) 2020 Makoto Hiroi
;;;
(define-library (mylib random)
(import (scheme base))
(export srand irand random)
(begin
;; 種 (seed)
(define *seed* 1)
;; シードの設定
(define (srand x) (set! *seed* x))
;; 整数の一様乱数
(define (irand)
(set! *seed* (modulo (+ (* 69069 *seed*) 1) #x100000000))
*seed*)
;; 実数の一様乱数
(define (random) (* (/ 1.0 #x100000000) (irand)))
))