[ create a new paste ] login | about

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

programmingpraxis - Scheme, pasted on Oct 2:
; calculating statistics

(define (make-dict lt?)

  (define-syntax define-generator
    (lambda (x)
      (syntax-case x (lambda)
        ((stx name (lambda formals e0 e1 ...))
           (with-syntax ((yield (datum->syntax-object (syntax stx) 'yield)))
             (syntax (define name
               (lambda formals
                 (let ((resume #f) (return #f))
                   (define yield
                     (lambda args
                       (call-with-current-continuation
                        (lambda (cont)
                          (set! resume cont)
                          (apply return args)))))
                   (lambda ()
                     (call-with-current-continuation
                      (lambda (cont)
                        (set! return cont)
                        (cond (resume (resume))
                        (else (let () e0 e1 ...)
                              (error 'name "unexpected return"))))))))))))
          ((stx (name . formals) e0 e1 ...)
            (syntax (stx name (lambda formals e0 e1 ...)))))))

  (define (tree k v l r)
    (vector k v l r (+ (max (ht l) (ht r)) 1)
                    (+ (size l) (size r) 1)))
  (define (key t) (vector-ref t 0))
  (define (val t) (vector-ref t 1))
  (define (lkid t) (vector-ref t 2))
  (define (rkid t) (vector-ref t 3))
  (define (ht t) (vector-ref t 4))
  (define (size t) (vector-ref t 5))
  (define (bal t) (- (ht (lkid t)) (ht (rkid t))))
  (define nil (vector 'nil 'nil 'nil 'nil 0 0))
  (define (nil? t) (eq? t nil))

  (define (rot-left t)
    (if (nil? t) t
      (tree (key (rkid t))
            (val (rkid t))
            (tree (key t) (val t) (lkid t) (lkid (rkid t)))
            (rkid (rkid t)))))

  (define (rot-right t)
    (if (nil? t) t
      (tree (key (lkid t))
            (val (lkid t))
            (lkid (lkid t))
            (tree (key t) (val t) (rkid (lkid t)) (rkid t)))))

  (define (balance t)
    (let ((b (bal t)))
      (cond ((< (abs b) 2) t)
            ((positive? b)
              (if (< -1 (bal (lkid t))) (rot-right t)
                (rot-right (tree (key t) (val t)
                  (rot-left (lkid t)) (rkid t)))))
            ((negative? b)
              (if (< (bal (rkid t)) 1) (rot-left t)
                (rot-left (tree (key t) (val t)
                  (lkid t) (rot-right (rkid t)))))))))

  (define (lookup t k)
    (cond ((nil? t) #f)
          ((lt? k (key t)) (lookup (lkid t) k))
          ((lt? (key t) k) (lookup (rkid t) k))
          (else (cons k (val t)))))

  (define (insert t k v)
    (cond ((nil? t) (tree k v nil nil))
          ((lt? k (key t))
            (balance (tree (key t) (val t)
              (insert (lkid t) k v) (rkid t))))
          ((lt? (key t) k)
            (balance (tree (key t) (val t)
              (lkid t) (insert (rkid t) k v))))
          (else (tree k v (lkid t) (rkid t)))))

  (define (update t f k v)
    (cond ((nil? t) (tree k v nil nil))
          ((lt? k (key t))
            (balance (tree (key t) (val t)
              (update (lkid t) f k v) (rkid t))))
          ((lt? (key t) k)
            (balance (tree (key t) (val t)
              (lkid t) (update (rkid t) f k v))))
          (else (tree k (f k (val t)) (lkid t) (rkid t)))))

  (define (delete-successor t)
    (if (nil? (lkid t)) (values (rkid t) (key t) (val t))
      (call-with-values
        (lambda () (delete-successor (lkid t)))
        (lambda (l k v)
          (values (balance (tree (key t) (val t) l (rkid t))) k v)))))

  (define (delete t k)
    (cond ((nil? t) nil)
          ((lt? k (key t))
            (balance (tree (key t) (val t)
              (delete (lkid t) k) (rkid t))))
          ((lt? (key t) k)
            (balance (tree (key t) (val t)
              (lkid t) (delete (rkid t) k))))
          ((nil? (lkid t)) (rkid t))
          ((nil? (rkid t)) (lkid t))
          (else (call-with-values
                  (lambda () (delete-successor (rkid t)))
                  (lambda (r k v) (balance (tree k v (lkid t) r)))))))

  (define (nth t n)
    (if (negative? n) (error 'nth "must be non-negative")
      (let ((s (size (lkid t))))
        (cond ((< n s) (nth (lkid t) n))
              ((< s n) (nth (rkid t) (- n s 1)))
              ((nil? t) #f)
              (else (cons (key t) (val t)))))))

  (define (rank t k)
    (let loop ((t t) (s (size (lkid t))))
      (cond ((nil? t) #f)
            ((lt? k (key t))
              (loop (lkid t) (size (lkid (lkid t)))))
            ((lt? (key t) k)
              (loop (rkid t) (+ s (size (lkid (rkid t))) 1)))
            (else s))))

  (define (avl-map proc t) ; (proc key value)
    (if (nil? t) nil
      (tree (key t) (proc (key t) (val t))
            (avl-map proc (lkid t))
            (avl-map proc (rkid t)))))

  (define (avl-fold proc base t) ; (proc key value base)
    (if (nil? t) base
      (avl-fold proc
                (proc (key t) (val t)
                      (avl-fold proc base (lkid t)))
                (rkid t))))

  (define (avl-for-each proc t) ; (proc key value)
    (unless (nil? t)
      (avl-for-each proc (lkid t))
      (proc (key t) (val t))
      (avl-for-each proc (rkid t))))

  (define (to-list t)
    (cond ((nil? t) (list))
          ((and (nil? (lkid t)) (nil? (rkid t)))
            (list (cons (key t) (val t))))
          (else (append (to-list (lkid t))
                        (list (cons (key t) (val t)))
                        (to-list (rkid t))))))

  (define (from-list t xs)
    (let loop ((xs xs) (t t))
      (if (null? xs) t
        (loop (cdr xs) (insert t (caar xs) (cdar xs))))))

  (define-generator (make-gen t)
    (avl-for-each (lambda (k v) (yield (cons k v))) t)
    (do () (#f) (yield #f)))

  (define (new dict)
    (lambda (message . args) (dispatch dict message args)))

  (define (dispatch dict message args)
    (define (arity n)
      (if (not (= (length args) n)) (error 'dict "incorrect arity")))
    (case message
      ((empty? nil?) (arity 0) (nil? dict))
      ((lookup fetch get) (arity 1) (apply lookup dict args))
      ((insert store put) (arity 2) (new (apply insert dict args)))
      ((update) (arity 3) (new (apply update dict args)))
      ((delete remove) (arity 1) (new (apply delete dict args)))
      ((size count length) (arity 0) (size dict))
      ((nth) (arity 1) (apply nth dict args))
      ((rank) (arity 1) (apply rank dict args))
      ((map) (arity 1) (new (avl-map (car args) dict)))
      ((fold) (arity 2) (avl-fold (car args) (cadr args) dict))
      ((for-each) (arity 1) (avl-for-each (car args) dict))
      ((to-list enlist) (arity 0) (to-list dict))
      ((from-list) (arity 1) (new (apply from-list dict args)))
      ((make-gen gen) (arity 0) (make-gen dict))
      (else (error 'dict "invalid message"))))

  (vector-set! nil 2 nil) (vector-set! nil 3 nil) (new nil))

(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 (read-file file-name)
  (with-input-from-file file-name
    (lambda ()
      (let ((t (make-dict <)))
        (do ((x (read) (read))) ((eof-object? x) t)
          (set! t (t 'update (lambda (k v) (+ v 1)) x 1)))))))

(define (count t) (t 'fold (lambda (k v b) (+ v b)) 0))

(define (sum t) (t 'fold (lambda (k v b) (+ (* k v) b)) 0))

(define (mean t) (/ (sum t) (count t)))

(define (median t)
  (let ((m (car (t 'nth 0))) (med (/ (count t) 2)))
    (t 'fold (lambda (k v b) (when (< (+ v b) med) (set! m k)) (+ v b)) 0)
    m))

(define (mode t)
  (let* ((x (t 'nth 0)) (m-key (car x)) (m-val (cdr x)))
    (t 'for-each (lambda (k v)
      (when (< m-val v) (set! m-key k) (set! m-val v))))
    m-key))

(define (minimum t) (car (t 'nth 0)))

(define (maximum t) (car (t 'nth (- (t 'size) 1))))


Output:
No errors or program output.


Create a new paste based on this one


Comments: