source: project/release/4/binary-search/binary-search.scm @ 31138

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.