|
Last change
on this file since 31138 was
31138,
checked in by felix winkelmann, 6 years ago
|
|
added preliminary eggs for extraction from core libraries
|
|
File size:
763 bytes
|
| Line | |
|---|
| 1 | ;;; Binary search |
|---|
| 2 | |
|---|
| 3 | |
|---|
| 4 | (module binary-search (binary-search) |
|---|
| 5 | |
|---|
| 6 | (import scheme chicken) |
|---|
| 7 | |
|---|
| 8 | (define (binary-search seq proc) |
|---|
| 9 | (let-values (((seq len) |
|---|
| 10 | (cond ((pair? seq) |
|---|
| 11 | (let ((seq (list->vector seq))) |
|---|
| 12 | (values seq (vector-length seq)))) |
|---|
| 13 | ((vector? seq) |
|---|
| 14 | (values seq (vector-length seq))) |
|---|
| 15 | ((fixnum? seq) (values #f seq)) |
|---|
| 16 | (else (error 'binary-search "invalid sequence" seq))))) |
|---|
| 17 | (and (fx> len 0) |
|---|
| 18 | (let loop ((ps 0) |
|---|
| 19 | (pe len) ) |
|---|
| 20 | (let ((p (fx+ ps (##core#inline "C_fixnum_shift_right" (fx- pe ps) 1)))) |
|---|
| 21 | (let* ((x (if seq (##sys#slot seq p) p)) |
|---|
| 22 | (r (proc x)) ) |
|---|
| 23 | (cond ((fx= r 0) p) |
|---|
| 24 | ((fx< r 0) (and (not (fx= pe p)) (loop ps p))) |
|---|
| 25 | (else (and (not (fx= ps p)) (loop p pe))) ) ) ) ) ) ) ) |
|---|
| 26 | |
|---|
| 27 | ) |
|---|
Note: See
TracBrowser
for help on using the repository browser.
