Converting to scheme
svn: r15261
This commit is contained in:
Jay McCarthy
parent
233359b0e6
commit
912feda115
|
|
@ -1,55 +0,0 @@
|
|||
(module base-gm mzscheme
|
||||
(require mzlib/list
|
||||
mzlib/etc)
|
||||
|
||||
(provide assert
|
||||
print-each
|
||||
make-hash
|
||||
hash-get
|
||||
hash-put!
|
||||
hash-remove!
|
||||
hash-map
|
||||
hash-for-each
|
||||
hash-mem?
|
||||
hash-fold
|
||||
hash-keys
|
||||
hash-add-all!)
|
||||
|
||||
(define-struct (exn:assert exn) ())
|
||||
|
||||
(define-syntax (assert stx)
|
||||
(syntax-case stx ()
|
||||
[(src-assert bool) #'(src-assert bool "")]
|
||||
[(src-assert bool msg ...)
|
||||
(with-syntax ([src-text (datum->syntax-object
|
||||
(syntax src-assert)
|
||||
(format "~a:~a:~a: assertion failed: "
|
||||
(syntax-source (syntax bool))
|
||||
(syntax-line (syntax bool))
|
||||
(syntax-column (syntax bool))))])
|
||||
#'(unless bool
|
||||
(raise (make-exn:assert (format-each src-text msg ...)))))]))
|
||||
|
||||
(define (format-each . args)
|
||||
(apply string-append (map (lambda (s) (format "~a " s)) args)))
|
||||
|
||||
(define (print-each . args)
|
||||
(printf "~a~n" (apply format-each args)))
|
||||
|
||||
|
||||
(define make-hash make-hash-table)
|
||||
(define hash-get hash-table-get)
|
||||
(define hash-put! hash-table-put!)
|
||||
(define hash-remove! hash-table-remove!)
|
||||
(define hash-map hash-table-map)
|
||||
(define hash-for-each hash-table-for-each)
|
||||
(define (hash-mem? hash item) (hash-get hash item (lambda () false)))
|
||||
(define (hash-fold hash init fn)
|
||||
(hash-for-each hash (lambda (key val) (set! init (fn key val init)))) init)
|
||||
(define (hash-keys hash)
|
||||
(hash-fold hash empty (lambda (key val acc) (cons key acc))))
|
||||
(define (hash-add-all! to-hash from-hash) ;; // memcpy-style argument order
|
||||
(hash-for-each from-hash
|
||||
(lambda (key val) (hash-put! to-hash key val))))
|
||||
|
||||
)
|
||||
|
|
@ -1,100 +1,54 @@
|
|||
; -*- Scheme -*-
|
||||
#lang scheme
|
||||
|
||||
; Shriram Krishnamurthi (shriram@cs.rice.edu)
|
||||
; Tue Jul 25 23:20:45 EDT 1995
|
||||
(define-struct dv (real used vec) #:mutable #:transparent)
|
||||
|
||||
; (define-structure (dv:vector length size contents))
|
||||
(define (dv:make size)
|
||||
(make-dv size 0 (make-vector size)))
|
||||
|
||||
(module dv mzscheme
|
||||
(define (dv:length dv) (dv-used dv))
|
||||
|
||||
(provide dv:make dv:make-w/-init dv:length dv:contents dv:append
|
||||
dv:remove-last dv:legitimate-index dv:ref dv:set!)
|
||||
(define (dv:remove-last a-dv)
|
||||
(match a-dv
|
||||
[(struct dv (_ used vec))
|
||||
(set-dv-used! a-dv (sub1 used))
|
||||
(vector-set! vec (sub1 used) 0)]))
|
||||
|
||||
(define dv:vector?
|
||||
(lambda (obj)
|
||||
(if (vector? obj)
|
||||
(if (= (vector-length obj) 4)
|
||||
(eq? (vector-ref obj 0) 'dv:vector)
|
||||
#f)
|
||||
#f)))
|
||||
(define dv:vector-length
|
||||
(lambda (obj) (vector-ref obj 1)))
|
||||
(define dv:vector-size
|
||||
(lambda (obj) (vector-ref obj 2)))
|
||||
(define dv:vector-contents
|
||||
(lambda (obj) (vector-ref obj 3)))
|
||||
(define dv:set-vector-length!
|
||||
(lambda (obj newval) (vector-set! obj 1 newval)))
|
||||
(define dv:set-vector-size!
|
||||
(lambda (obj newval) (vector-set! obj 2 newval)))
|
||||
(define dv:set-vector-contents!
|
||||
(lambda (obj newval) (vector-set! obj 3 newval)))
|
||||
(define dv:make-vector
|
||||
(lambda (length size contents)
|
||||
((lambda () (vector 'dv:vector length size contents)))))
|
||||
(define (dv:ref a-dv pos)
|
||||
(match a-dv
|
||||
[(struct dv (_ _ vec))
|
||||
(vector-ref vec pos)]))
|
||||
|
||||
(define dv:make
|
||||
(let* ((default-initial-size 8)
|
||||
(default-initial-vector (make-vector default-initial-size)))
|
||||
(lambda arg
|
||||
(cond
|
||||
((null? arg)
|
||||
(dv:make-vector 0 default-initial-size default-initial-vector))
|
||||
((= 1 (length arg))
|
||||
(let ((l (car arg)))
|
||||
(dv:make-vector 0 l (make-vector l))))
|
||||
(else
|
||||
(error 'dv:make "wrong number of arguments"))))))
|
||||
(define (dv:set! a-dv pos new-val)
|
||||
(match a-dv
|
||||
[(struct dv (_ _ vec))
|
||||
(vector-set! vec pos new-val)]))
|
||||
|
||||
(define dv:make-w/-init
|
||||
(lambda values
|
||||
(let ((l (length values)))
|
||||
(dv:make-vector l l (list->vector values)))))
|
||||
|
||||
(define dv:append
|
||||
(lambda (dv item)
|
||||
(let ((length (dv:vector-length dv))
|
||||
(size (dv:vector-size dv))
|
||||
(contents (dv:vector-contents dv)))
|
||||
(if (< length size)
|
||||
(begin
|
||||
(vector-set! contents length item)
|
||||
(dv:set-vector-length! dv (+ length 1)))
|
||||
(begin
|
||||
(let ((new-vector (make-vector (* size 2))))
|
||||
(let loop
|
||||
((i 0))
|
||||
(when (< i size)
|
||||
(vector-set! new-vector i (vector-ref contents i))
|
||||
(loop (+ i 1))))
|
||||
(dv:set-vector-contents! dv new-vector)
|
||||
(dv:set-vector-size! dv (* size 2))
|
||||
(dv:append dv item)))))))
|
||||
|
||||
(define dv:remove-last
|
||||
(lambda (dv)
|
||||
(dv:set-vector-length! dv (- (dv:vector-length dv) 1))
|
||||
(vector-set! (dv:vector-contents dv) (dv:vector-length dv) 0)))
|
||||
|
||||
|
||||
(define dv:legitimate-index
|
||||
(lambda (dv index)
|
||||
(< index (dv:vector-length dv))))
|
||||
|
||||
(define dv:ref
|
||||
(lambda (dv index)
|
||||
(if (dv:legitimate-index dv index)
|
||||
(vector-ref (dv:vector-contents dv) index)
|
||||
(error 'dv:ref "index too large"))))
|
||||
|
||||
(define dv:set!
|
||||
(lambda (dv index value)
|
||||
(if (dv:legitimate-index dv index)
|
||||
(vector-set! (dv:vector-contents dv) index value)
|
||||
(error 'dv:set! "index too large"))))
|
||||
|
||||
(define dv:contents dv:vector-contents)
|
||||
|
||||
(define dv:length dv:vector-length)
|
||||
)
|
||||
(define (dv:append a-dv item)
|
||||
(match a-dv
|
||||
[(struct dv (real used vec))
|
||||
(if (used . < . real)
|
||||
(begin (set-dv-used! a-dv (add1 used))
|
||||
(vector-set! vec used item))
|
||||
(let ([new-vec
|
||||
(build-vector
|
||||
(* 2 real)
|
||||
(lambda (i)
|
||||
(if (i . < . used)
|
||||
(vector-ref vec i)
|
||||
0)))])
|
||||
(set-dv-vec! a-dv new-vec)
|
||||
(set-dv-real! a-dv (* 2 real))
|
||||
(set-dv-used! a-dv (add1 used))
|
||||
(vector-set! new-vec used item)))]))
|
||||
|
||||
(provide/contract
|
||||
[dv:make (exact-nonnegative-integer? . -> . dv?)]
|
||||
[dv:length (dv? . -> . exact-nonnegative-integer?)]
|
||||
[dv:remove-last (dv? . -> . void)]
|
||||
[dv:ref (->d ([dv dv?] [pos exact-nonnegative-integer?]) ()
|
||||
#:pre-cond (pos . < . (dv:length dv))
|
||||
[r any/c])]
|
||||
[dv:set! (->d ([dv dv?] [pos exact-nonnegative-integer?] [val any/c]) ()
|
||||
#:pre-cond (pos . < . (dv:length dv))
|
||||
[r void])]
|
||||
[dv:append (dv? any/c . -> . void)])
|
||||
|
|
@ -1,158 +1,113 @@
|
|||
(module heap mzscheme
|
||||
#lang scheme
|
||||
(require "dv.ss")
|
||||
|
||||
(require mzlib/etc
|
||||
"base-gm.ss"
|
||||
mzlib/list
|
||||
"dv.ss")
|
||||
(define-struct t (sorter equality data) #:transparent)
|
||||
|
||||
|
||||
(provide make-heap heap-empty? heap-size heap-insert heap-pop
|
||||
heap-peak heap-remove heap-find
|
||||
heap-contains heap-resort heap->list)
|
||||
|
||||
|
||||
|
||||
|
||||
(define-struct t (sorter equality data))
|
||||
|
||||
;; sorter: elements which have the most trueness according to
|
||||
;; the sorter pop out first
|
||||
(define (make-heap sorter equality)
|
||||
(let ((data (dv:make 5)))
|
||||
;; sorter: elements which have the most trueness according to
|
||||
;; the sorter pop out first
|
||||
(define (make-heap sorter equality)
|
||||
(define data (dv:make 5))
|
||||
(dv:append data 0)
|
||||
(make-t sorter equality data)))
|
||||
(make-t sorter equality data))
|
||||
|
||||
(define (heap-size heap)
|
||||
(- (dv:length (t-data heap)) 1))
|
||||
(define (heap-size heap) (- (dv:length (t-data heap)) 1))
|
||||
(define (heap-empty? heap) (= (heap-size heap) 0))
|
||||
(define (heap-last heap) (- (dv:length (t-data heap)) 1))
|
||||
(define (heap-parent i) (floor (/ i 2)))
|
||||
(define (heap-left i) (* i 2))
|
||||
(define (heap-right i) (+ 1 (* i 2)))
|
||||
(define (heap-has-right heap i) (<= (heap-right i) (heap-last heap)))
|
||||
(define (heap-has-left heap i) (<= (heap-left i) (heap-last heap)))
|
||||
|
||||
(define (heap-empty? heap)
|
||||
(= (heap-size heap) 0))
|
||||
|
||||
(define (heap-last heap)
|
||||
(- (dv:length (t-data heap)) 1))
|
||||
|
||||
(define (heap-parent i)
|
||||
(floor (/ i 2)))
|
||||
|
||||
(define (heap-left i) (* i 2))
|
||||
|
||||
(define (heap-right i) (+ 1 (* i 2)))
|
||||
|
||||
(define (heap-has-right heap i)
|
||||
(<= (heap-right i) (heap-last heap)))
|
||||
|
||||
(define (heap-has-left heap i)
|
||||
(<= (heap-left i) (heap-last heap)))
|
||||
|
||||
(define (heap-insert heap item)
|
||||
(let* ((sorter (t-sorter heap))
|
||||
(data (t-data heap)))
|
||||
(define (heap-insert heap item)
|
||||
(match heap
|
||||
[(struct t (sorter _ data))
|
||||
(dv:append data item)
|
||||
(let ((d (let loop ((prev (heap-last heap))
|
||||
(current (heap-parent (heap-last heap))))
|
||||
(let ([d (let loop ([prev (heap-last heap)]
|
||||
[current (heap-parent (heap-last heap))])
|
||||
|
||||
(cond ((= current 0) prev)
|
||||
((sorter item (dv:ref data current))
|
||||
(cond [(= current 0) prev]
|
||||
[(sorter item (dv:ref data current))
|
||||
(dv:set! data prev (dv:ref data current))
|
||||
(loop current (heap-parent current)))
|
||||
(#t prev)))))
|
||||
(dv:set! data d item))))
|
||||
(loop current (heap-parent current))]
|
||||
[else prev]))])
|
||||
(dv:set! data d item))]))
|
||||
|
||||
(define (heap-peak heap)
|
||||
(if (= (heap-size heap) 0) (error "heap-peak: empty")
|
||||
(dv:ref (t-data heap) 1)))
|
||||
(define (heap-peak heap)
|
||||
(dv:ref (t-data heap) 1))
|
||||
|
||||
(define (heap-pop heap)
|
||||
(if (= (heap-size heap) 0) (error "heap-pop: empty")
|
||||
(define (heap-pop heap)
|
||||
(begin0 (dv:ref (t-data heap) 1)
|
||||
(heap-remove-pos heap 1))))
|
||||
(heap-remove-pos heap 1)))
|
||||
|
||||
(define (heap-remove-pos heap pos)
|
||||
(let* ((data (t-data heap))
|
||||
(sorter (t-sorter heap)))
|
||||
|
||||
(cond ((= 0 (heap-size heap)) (error "heap: removing from empty"))
|
||||
((= pos (heap-last heap)) (dv:remove-last data))
|
||||
(#t (let ((item (dv:ref data (heap-last heap))))
|
||||
(define (heap-remove-pos heap pos)
|
||||
(match heap
|
||||
[(struct t (sorter _ data))
|
||||
(cond [(= pos (heap-last heap)) (dv:remove-last data)]
|
||||
[else
|
||||
(let ((item (dv:ref data (heap-last heap))))
|
||||
(dv:remove-last data)
|
||||
(let loop ((current pos))
|
||||
(let loop ([current pos])
|
||||
|
||||
(dv:set! data current item)
|
||||
(let* ((left (heap-left current))
|
||||
(right (heap-right current))
|
||||
(best-1 (if (and (heap-has-left heap current)
|
||||
(let* ([left (heap-left current)]
|
||||
[right (heap-right current)]
|
||||
[best-1 (if (and (heap-has-left heap current)
|
||||
(sorter (dv:ref data left) item))
|
||||
left current))
|
||||
|
||||
(best-2 (if (and (heap-has-right heap current)
|
||||
left current)]
|
||||
[best-2 (if (and (heap-has-right heap current)
|
||||
(sorter (dv:ref data right)
|
||||
(dv:ref data best-1)))
|
||||
right best-1)))
|
||||
right best-1)])
|
||||
(unless (= best-2 current)
|
||||
(dv:set! data current (dv:ref data best-2))
|
||||
(loop best-2)))))])]))
|
||||
|
||||
(if (not (= best-2 current))
|
||||
(begin (dv:set! data current (dv:ref data best-2))
|
||||
(loop best-2))))))))))
|
||||
|
||||
;; return false if the object is not found
|
||||
(define (heap-remove heap item)
|
||||
(let ((pos (heap-find heap item)))
|
||||
;; return false if the object is not found
|
||||
(define (heap-remove heap item)
|
||||
(let ([pos (heap-find heap item)])
|
||||
(if (not pos) false
|
||||
; There is something present, so it must not be empty
|
||||
(begin (heap-remove-pos heap pos) true))))
|
||||
|
||||
(define (heap-contains heap item)
|
||||
(define (heap-contains heap item)
|
||||
(if (heap-find heap item) true false))
|
||||
|
||||
(define (heap-find heap item)
|
||||
(let ((data (t-data heap))
|
||||
(equality (t-equality heap))
|
||||
(sorter (t-sorter heap)))
|
||||
(let loop ((current 1))
|
||||
(let ((current-item (dv:ref data current)))
|
||||
(cond ((equality item current-item) current)
|
||||
((sorter item current-item) #f)
|
||||
(#t (or (and (heap-has-left heap current)
|
||||
(define (heap-find heap item)
|
||||
(match heap
|
||||
[(struct t (sorter equality data))
|
||||
(let loop ([current 1])
|
||||
(let ([current-item (dv:ref data current)])
|
||||
(cond [(equality item current-item) current]
|
||||
[(sorter item current-item) #f]
|
||||
[else (or (and (heap-has-left heap current)
|
||||
(not (sorter item (dv:ref data (heap-left current))))
|
||||
(loop (heap-left current)))
|
||||
(and (heap-has-right heap current)
|
||||
(not (sorter item (dv:ref data (heap-right current))))
|
||||
(loop (heap-right current))))))))))
|
||||
(loop (heap-right current))))])))]))
|
||||
|
||||
(define (heap-resort heap item)
|
||||
(define (heap-resort heap item)
|
||||
(heap-remove heap item)
|
||||
(heap-insert heap item))
|
||||
|
||||
(define (heap->list heap)
|
||||
(vector->list (t-data heap)))
|
||||
|
||||
(define (test)
|
||||
(define f (make-heap > eq?))
|
||||
(define d (t-data f))
|
||||
(heap-insert f 99)
|
||||
(print-each "A " d)
|
||||
(heap-remove-pos f 1)
|
||||
(print-each "B " d)
|
||||
(for-each (lambda (x) (heap-insert f x)) '(1 2 3 4 5 6 7 8 9 10 11 12 13 14))
|
||||
(print-each "C " d)
|
||||
(heap-remove f 10) (print-each " " d)
|
||||
(heap-remove f 5) (print-each " " d)
|
||||
(heap-remove f 8) (print-each " " d)
|
||||
(heap-remove f 13) (print-each " " d)
|
||||
(print-each (heap-contains f 11))
|
||||
(print-each (heap-contains f 123))
|
||||
(heap-pop f)
|
||||
(heap-pop f)
|
||||
(heap-pop f)
|
||||
(heap-pop f) (print-each " " d)
|
||||
(print-each (heap-contains f 11))
|
||||
(print-each (heap-contains f 4))
|
||||
(print-each (heap->list f))
|
||||
(heap-remove f 2)
|
||||
(print-each (heap->list f))
|
||||
(heap-remove f 3)
|
||||
(print-each (heap->list f))
|
||||
)
|
||||
|
||||
;(test)
|
||||
|
||||
)
|
||||
(define sorter/c
|
||||
(-> any/c any/c boolean?))
|
||||
(define equality/c
|
||||
(-> any/c any/c boolean?))
|
||||
(define heap? t?)
|
||||
(define (non-empty-heap? heap)
|
||||
(and (heap? heap)
|
||||
(not (= (heap-size heap) 0))))
|
||||
|
||||
(provide/contract
|
||||
[heap? (any/c . -> . boolean?)]
|
||||
[non-empty-heap? (any/c . -> . boolean?)]
|
||||
[make-heap (sorter/c equality/c . -> . heap?)]
|
||||
[heap-empty? (heap? . -> . boolean?)]
|
||||
[heap-insert (heap? any/c . -> . void)]
|
||||
[heap-pop (non-empty-heap? . -> . void)]
|
||||
[heap-peak (non-empty-heap? . -> . any/c)]
|
||||
[heap-remove-pos (non-empty-heap? exact-nonnegative-integer? . -> . void)]
|
||||
[heap-remove (heap? any/c . -> . void)]
|
||||
[heap-contains (heap? any/c . -> . boolean?)])
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user