fork download
  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