fork download
copy 
  1. ; ternary search
  2.  
  3. (define-syntax assert
  4.   (syntax-rules ()
  5.     ((assert expr result)
  6.       (if (not (equal? expr result))
  7.           (for-each display `(
  8.             #\newline "failed assertion:" #\newline
  9.             expr #\newline "expected: " ,result
  10.             #\newline "returned: " ,expr #\newline))))))
  11.  
  12. (define (bsearch lt? x xs)
  13.   (let loop ((lo 0) (hi (- (vector-length xs) 1)))
  14.     (let ((mid (+ lo (quotient (- hi lo) 2))))
  15.       (cond ((< hi lo) #f)
  16.             ((lt? x (vector-ref xs mid)) (loop lo (- mid 1)))
  17.             ((lt? (vector-ref xs mid) x) (loop (+ mid 1) hi))
  18.             (else mid)))))
  19.  
  20. (define (tsearch lt? x xs)
  21.   (let loop ((lo 0) (hi (- (vector-length xs) 1)))
  22.     (let ((lomid (+ lo (quotient (- hi lo) 3)))
  23.           (himid (- hi (quotient (- hi lo) 3))))
  24.       (cond ((< hi lo) #f)
  25.             ((lt? x (vector-ref xs lomid)) (loop lo (- lomid 1)))
  26.             ((lt? (vector-ref xs himid) x) (loop (+ himid 1) hi))
  27.             ((not (lt? (vector-ref xs lomid) x)) lomid)
  28.             ((not (lt? x (vector-ref xs himid))) himid)
  29.             (else (loop (+ lomid 1) (- himid 1)))))))
  30.  
  31. (define xs '#(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47))
  32.  
  33. (display (bsearch < 7 xs)) (newline)
  34. (display (bsearch < 14 xs)) (newline)
  35. (newline)
  36. (display (tsearch < 7 xs)) (newline)
  37. (display (tsearch < 14 xs)) (newline)
  38. (display (tsearch < 37 xs)) (newline)
  39. (display (tsearch < 45 xs)) (newline)
  40. (newline)
  41.  
  42. ; no news is good news
  43. (do ((x 1 (+ x 1))) ((= x 50) (display 'okay))
  44.   (assert (bsearch < x xs) (tsearch < x xs)))
Success #stdin #stdout 0.02s 43152KB
comments (?)
stdin
copy 
Standard input is empty
stdout
copy 
3
#f

3
#f
11
#f

okay
https://ideone.com/RnwQzb
language:
Scheme (guile 2.2.4)
created:
7 years ago
visibility:
public

Share or Embed source code

Discover > Sphere Engine API

The brand new service which powers Ideone!

Discover > IDE Widget

Widget for compiling and running the source code in a web browser!