[ create a new paste ] login | about

Link: http://codepad.org/ae17jWwR    [ raw code | fork ]

programmingpraxis - Scheme, pasted on Jul 31:
; ordered hash tables

(define (range . args)
  (case (length args)
    ((1) (range 0 (car args) (if (negative? (car args)) -1 1)))
    ((2) (range (car args) (cadr args) (if (< (car args) (cadr args)) 1 -1)))
    ((3) (let ((le? (if (negative? (caddr args)) >= <=)))
           (let loop ((x(car args)) (xs '()))
             (if (le? (cadr args) x)
                 (reverse xs)
                 (loop (+ x (caddr args)) (cons x xs))))))
    (else (error 'range "unrecognized arguments"))))

(define rand #f)
(define randint #f)
(let ((two31 #x80000000) (a (make-vector 56 -1)) (fptr #f))
  (define (mod-diff x y) (modulo (- x y) two31)) ; generic version
  ; (define (mod-diff x y) (logand (- x y) #x7FFFFFFF)) ; fast version
  (define (flip-cycle)
    (do ((ii 1 (+ ii 1)) (jj 32 (+ jj 1))) ((< 55 jj))
      (vector-set! a ii (mod-diff (vector-ref a ii) (vector-ref a jj))))
    (do ((ii 25 (+ ii 1)) (jj 1 (+ jj 1))) ((< 55 ii))
      (vector-set! a ii (mod-diff (vector-ref a ii) (vector-ref a jj))))
    (set! fptr 54) (vector-ref a 55))
  (define (init-rand seed)
    (let* ((seed (mod-diff seed 0)) (prev seed) (next 1))
      (vector-set! a 55 prev)
      (do ((i 21 (modulo (+ i 21) 55))) ((zero? i))
        (vector-set! a i next) (set! next (mod-diff prev next))
        (set! seed (+ (quotient seed 2) (if (odd? seed) #x40000000 0)))
        (set! next (mod-diff next seed)) (set! prev (vector-ref a i)))
      (flip-cycle) (flip-cycle) (flip-cycle) (flip-cycle) (flip-cycle)))
  (define (next-rand)
    (if (negative? (vector-ref a fptr)) (flip-cycle)
      (let ((next (vector-ref a fptr))) (set! fptr (- fptr 1)) next)))
  (define (unif-rand m)
    (let ((t (- two31 (modulo two31 m))))
      (let loop ((r (next-rand)))
        (if (<= t r) (loop (next-rand)) (modulo r m)))))
  (init-rand 19380110) ; happy birthday donald e knuth
  (set! rand (lambda seed
    (cond ((null? seed) (/ (next-rand) two31))
          ((eq? (car seed) 'get) (cons fptr (vector->list a)))
          ((eq? (car seed) 'set) (set! fptr (caadr seed))
                                 (set! a (list->vector (cdadr seed))))
          (else (/ (init-rand (modulo (numerator
                  (inexact->exact (car seed))) two31)) two31)))))
  (set! randint (lambda args
    (cond ((null? (cdr args))
            (if (< (car args) two31) (unif-rand (car args))
              (floor (* (next-rand) (car args)))))
          ((< (car args) (cadr args))
            (let ((span (- (cadr args) (car args))))
              (+ (car args)
                 (if (< span two31) (unif-rand span)
                   (floor (* (next-rand) span))))))
          (else (let ((span (- (car args) (cadr args))))
                  (- (car args)
                     (if (< span two31) (unif-rand span)
                       (floor (* (next-rand) span))))))))))

(define (shuffle x)
  (do ((v (list->vector x)) (n (length x) (- n 1)))
      ((zero? n) (vector->list v))
    (let* ((r (randint n)) (t (vector-ref v r)))
      (vector-set! v r (vector-ref v (- n 1)))
      (vector-set! v (- n 1) t))))

(define-syntax assert
  (syntax-rules ()
    ((assert expr result)
      (if (not (equal? expr result))
          (for-each display `(
            #\newline "failed assertion:" #\newline
            expr #\newline "expected: " ,result
            #\newline "returned: " ,expr #\newline))))))

(define (hash k) k)

(define (lt? k1 k2) (< k1 k2))

(define len 5)

(define ht (make-vector len (list)))

(define (lookup k)
  (let* ((index (modulo (hash k) len))
         (bucket (vector-ref ht index)))
    (let loop ((bucket bucket))
      (cond ((null? bucket) (list))
            ((lt? k (caar bucket)) (list))
            ((lt? (caar bucket) k) (loop (cdr bucket)))
            (else (car bucket))))))

(define (insert k v)
  (let* ((index (modulo (hash k) len))
         (bucket (vector-ref ht index)))
    (let loop ((bucket bucket) (xs (list)))
      (cond ((null? bucket)
              (vector-set! ht index
                (append (reverse xs) (list (cons k v)))))
            ((lt? k (caar bucket))
              (vector-set! ht index
                (append (reverse xs) (list (cons k v)) bucket)))
            ((lt? (caar bucket) k)
              (loop (cdr bucket) (cons (car bucket) xs)))
            (else (vector-set! ht index
              (append (reverse xs) (list (cons k v)) (cdr bucket))))))))

(define (delete k)
  (let* ((index (modulo (hash k) len))
         (bucket (vector-ref ht index)))
    (let loop ((bucket bucket) (xs (list)))
      (cond ((null? bucket))
            ((lt? k (caar bucket)))
            ((lt? (caar bucket) k)
              (loop (cdr bucket) (cons (car bucket) xs)))
            (else (vector-set! ht index
              (append (reverse xs) (cdr bucket))))))))

(define (enlist)
  (let ((xs (list)))
    (do ((i 0 (+ i 1))) ((= i len) xs)
      (set! xs (append (vector-ref ht i) xs)))))

(define alphabet '(alpha bravo charlie delta echo foxtrot golf
  hotel india juliet kilo lima mike november oscar papa quebec
  romeo sierra tango uniform victor whiskey xray yankee zulu))

(define (test)
  (let ((xs (shuffle (map cons (range 1 27) alphabet))))
    (do ((xs xs (cdr xs))) ((null? xs))
      (insert (caar xs) (cdar xs))))
  (assert (length (enlist)) 26)
  (assert (cdr (lookup 3)) 'charlie)
  (assert (cdr (lookup 17)) 'quebec)
  (assert (lookup 43) '())
  (let ((xs (shuffle (range 27))))
    (do ((xs xs (cdr xs))) ((null? xs))
      (delete (car xs))))
  (assert (length (enlist)) 0)
  (assert (lookup 3) '())
  (assert (lookup 17) '())
  (assert (lookup 43) '()))

(test)


Output:
No errors or program output.


Create a new paste based on this one


Comments: