1. ; binary search
2.
3. (define (range . args)
4. (case (length args)
5. ((1) (range 0 (car args) (if (negative? (car args)) -1 1)))
6. ((2) (range (car args) (cadr args) (if (< (car args) (cadr args)) 1 -1)))
7. ((3) (let ((le? (if (negative? (caddr args)) >= <=)))
8. (let loop ((x(car args)) (xs '()))
9. (if (le? (cadr args) x)
10. (reverse xs)
11. (loop (+ x (caddr args)) (cons x xs))))))
12. (else (error 'range "unrecognized arguments"))))
13.
14. (define-syntax assert
15. (syntax-rules ()
16. ((assert expr result)
17. (if (not (equal? expr result))
18. (for-each display `(
19. #\newline "failed assertion:" #\newline
20. expr #\newline "expected: " ,result
21. #\newline "returned: " ,expr #\newline))))))
22.
23. (define (bsearch lt? x xs)
24. (let loop ((lo 0) (hi (- (vector-length xs) 1)))
25. (let ((mid (quotient (+ lo hi) 2)))
26. ;(display lo) (display " ") (display mid)
27. ;(display " ") (display hi) (newline)
28. (cond ((< hi lo) #f)
29. ((lt? x (vector-ref xs mid))
30. (loop lo (- mid 1)))
31. ((lt? (vector-ref xs mid) x)
32. (loop (+ mid 1) hi))
33. (else mid)))))
34.
35. (define (test-bsearch n)
36. (do ((i 0 (+ i 1))) ((= n i))
37. (let ((xs (list->vector (range 0 n 2))))
38. (do ((j -1 (+ j 1))) ((< n j))
39. (if (and (even? j) (< j n))
40. (assert (bsearch < j xs) (/ j 2))
41. (assert (bsearch < j xs) #f))))))
42.
43. (test-bsearch 25)
Success #stdin #stdout 0.2s 8896KB
stdin
Standard input is empty
stdout
Standard output is empty