home *** CD-ROM | disk | FTP | other *** search
/ RISC DISC 2 / RISC_DISC_2.iso / pd_share / program / language / scm / !Scm / slib / priorque < prev    next >
Encoding:
Text File  |  1993-04-02  |  3.6 KB  |  121 lines
  1. ;;;; "priorque.scm" priority queues for Scheme.
  2. ;;; Copyright (C) 1992, 1993 Aubrey Jaffer.
  3.  
  4. ;Permission to copy this software, to redistribute it, and to use it
  5. ;for any purpose is granted, subject to the following restrictions and
  6. ;understandings.
  7.  
  8. ;1.  Any copy made of this software must include this copyright notice
  9. ;in full.
  10.  
  11. ;2.  I have made no warrantee or representation that the operation of
  12. ;this software will be error-free, and I am under no obligation to
  13. ;provide any services, by way of maintenance, update, or otherwise.
  14.  
  15. ;3.  In conjunction with products arising from the use of this
  16. ;material, there shall be no use of my name in any advertising,
  17. ;promotional, or sales literature without prior written consent in
  18. ;each case.
  19.  
  20. ;;; Algorithm from:
  21. ;;; Introduction to Algorithms by T. Cormen, C. Leiserson, R. Rivest.
  22. ;;; 1989 MIT Press.
  23.  
  24. (require 'record)
  25. (define heap-rtd (make-record-type "heap" '(array size heap<?)))
  26. (define make-heap
  27.   (let ((cstr (record-constructor heap-rtd)))
  28.     (lambda (pred<?)
  29.       (cstr (make-vector 4) 0 pred<?))))
  30. (define heap-ref
  31.   (let ((ra (record-accessor heap-rtd 'array)))
  32.     (lambda (a i)
  33.       (vector-ref (ra a) (+ -1 i)))))
  34. (define heap-set!
  35.   (let ((ra (record-accessor heap-rtd 'array)))
  36.     (lambda (a i v)
  37.       (vector-set! (ra a) (+ -1 i) v))))
  38. (define heap-exchange
  39.   (let ((aa (record-accessor heap-rtd 'array)))
  40.     (lambda (a i j)
  41.       (set! i (+ -1 i))
  42.       (set! j (+ -1 j))
  43.       (let* ((ra (aa a))
  44.          (tmp (vector-ref ra i)))
  45.     (vector-set! ra i (vector-ref ra j))
  46.     (vector-set! ra j tmp)))))
  47. (define heap-size (record-accessor heap-rtd 'size))
  48. (define heap<? (record-accessor heap-rtd 'heap<?))
  49. (define heap-set-size
  50.   (let ((aa (record-accessor heap-rtd 'array))
  51.     (am (record-modifier heap-rtd 'array))
  52.     (sm (record-modifier heap-rtd 'size)))
  53.     (lambda (a s)
  54.       (let ((ra (aa a)))
  55.     (if (> s (vector-length ra))
  56.         (let ((nra (make-vector (+ s (quotient s 2)))))
  57.           (do ((i (+ -1 (vector-length ra)) (+ -1 i)))
  58.           ((negative? i) (am a nra))
  59.         (vector-set! nra i (vector-ref ra i)))))
  60.     (sm a s)))))
  61.  
  62. (define (heap-parent i) (quotient i 2))
  63. (define (heap-left i) (* 2 i))
  64. (define (heap-right i) (+ 1 (* 2 i)))
  65.  
  66. (define (heapify a i)
  67.   (define l (heap-left i))
  68.   (define r (heap-right i))
  69.   (define largest
  70.     (if (and (<= l (heap-size a))
  71.          ((heap<? a) (heap-ref a i) (heap-ref a l)))
  72.     l
  73.     i))
  74.   (if (and (<= r (heap-size a))
  75.        ((heap<? a) (heap-ref a largest) (heap-ref a r)))
  76.       (set! largest r))
  77.   (if (not (= largest i))
  78.       (begin
  79.     (heap-exchange a i largest)
  80.     (heapify a largest))))
  81.  
  82. (define (heap-insert! a key)
  83.   (define i (+ 1 (heap-size a)))
  84.   (heap-set-size a i)
  85.   (do ()
  86.       ((not (and (> i 1)
  87.          ((heap<? a) (heap-ref a (heap-parent i)) key))))
  88.     (heap-set! a i (heap-ref a (heap-parent i)))
  89.     (set! i (heap-parent i)))
  90.   (heap-set! a i key))
  91.  
  92. (define (heap-extract-max a)
  93.   (if (< (heap-size a) 1)
  94.       (slib:error "heap underflow" a))
  95.   (let ((max (heap-ref a 1)))
  96.     (heap-set! a 1 (heap-ref a (heap-size a)))
  97.     (heap-set-size a (+ -1 (heap-size a)))
  98.     (heapify a 1)
  99.     max))
  100.  
  101. (define heap #f)
  102. (define (heap-test)
  103.   (set! heap (make-heap char>?))
  104.   (heap-insert! heap #\A)
  105.   (heap-insert! heap #\Z)
  106.   (heap-insert! heap #\G)
  107.   (heap-insert! heap #\B)
  108.   (heap-insert! heap #\G)
  109.   (heap-insert! heap #\Q)
  110.   (heap-insert! heap #\S)
  111.   (heap-insert! heap #\R)
  112.   (print (heap-extract-max heap))
  113.   (print (heap-extract-max heap))
  114.   (print (heap-extract-max heap))
  115.   (print (heap-extract-max heap))
  116.   (print (heap-extract-max heap))
  117.   (print (heap-extract-max heap))
  118.   (print (heap-extract-max heap))
  119.   (print (heap-extract-max heap))
  120.   )
  121.