384 lines
14 KiB
Scheme
384 lines
14 KiB
Scheme
|
(cond-expand
|
|||
|
|
(r7rs)
|
|||
|
|
(chicken (import r7rs)))
|
|||
|
|
|
|||
|
|
(define-library (avl-trees)
|
|||
|
|
|
|||
|
|
;;
|
|||
|
|
;; This library implements ‘persistent’ (that is, ‘immutable’) AVL
|
|||
|
|
;; trees for R7RS Scheme.
|
|||
|
|
;;
|
|||
|
|
;; References:
|
|||
|
|
;;
|
|||
|
|
;; * Niklaus Wirth, 1976. Algorithms + Data Structures =
|
|||
|
|
;; Programs. Prentice-Hall, Englewood Cliffs, New Jersey.
|
|||
|
|
;;
|
|||
|
|
;; * Niklaus Wirth, 2004. Algorithms and Data Structures. Updated
|
|||
|
|
;; by Fyodor Tkachov, 2014.
|
|||
|
|
;;
|
|||
|
|
;; THIS IS A TRIMMED-DOWN VERSION OF MY SOLUTION TO THE AVL TREES
|
|||
|
|
;; TASK: https://rosettacode.org/wiki/AVL_tree#Scheme
|
|||
|
|
;;
|
|||
|
|
|
|||
|
|
(export avl)
|
|||
|
|
(export avl?)
|
|||
|
|
(export avl-empty?)
|
|||
|
|
(export avl-insert)
|
|||
|
|
(export avl-search-values)
|
|||
|
|
(export avl-check-usage)
|
|||
|
|
|
|||
|
|
(import (scheme base))
|
|||
|
|
(import (scheme case-lambda))
|
|||
|
|
(import (scheme process-context))
|
|||
|
|
(import (scheme write))
|
|||
|
|
|
|||
|
|
(begin
|
|||
|
|
|
|||
|
|
(define-syntax avl-check-usage
|
|||
|
|
(syntax-rules ()
|
|||
|
|
((_ pred msg)
|
|||
|
|
(or pred (usage-error msg)))))
|
|||
|
|
|
|||
|
|
(define-record-type <avl>
|
|||
|
|
(%avl key data bal left right)
|
|||
|
|
avl?
|
|||
|
|
(key %key)
|
|||
|
|
(data %data)
|
|||
|
|
(bal %bal)
|
|||
|
|
(left %left)
|
|||
|
|
(right %right))
|
|||
|
|
|
|||
|
|
(define (avl)
|
|||
|
|
(%avl #f #f #f #f #f))
|
|||
|
|
|
|||
|
|
(define (avl-empty? tree)
|
|||
|
|
(avl-check-usage
|
|||
|
|
(avl? tree)
|
|||
|
|
"avl-empty? expects an AVL tree as argument")
|
|||
|
|
(not (%bal tree)))
|
|||
|
|
|
|||
|
|
(define (avl-search-values pred<? tree key)
|
|||
|
|
;; Return two values: the data matching the key, or #f is the
|
|||
|
|
;; key is not found; and a second value that is either #f or #t,
|
|||
|
|
;; depending on whether the key is found.
|
|||
|
|
(define (search p)
|
|||
|
|
(if (not p)
|
|||
|
|
(values #f #f)
|
|||
|
|
(let ((k (%key p)))
|
|||
|
|
(cond ((pred<? key k) (search (%left p)))
|
|||
|
|
((pred<? k key) (search (%right p)))
|
|||
|
|
(else (values (%data p) #t))))))
|
|||
|
|
(avl-check-usage
|
|||
|
|
(procedure? pred<?)
|
|||
|
|
"avl-search-values expects a procedure as first argument")
|
|||
|
|
(if (avl-empty? tree)
|
|||
|
|
(values #f #f)
|
|||
|
|
(search tree)))
|
|||
|
|
|
|||
|
|
(define (avl-insert pred<? tree key data)
|
|||
|
|
|
|||
|
|
(define (search p fix-balance?)
|
|||
|
|
(cond
|
|||
|
|
((not p)
|
|||
|
|
;; The key was not found. Make a new node and set
|
|||
|
|
;; fix-balance?
|
|||
|
|
(values (%avl key data 0 #f #f) #t))
|
|||
|
|
|
|||
|
|
((pred<? key (%key p))
|
|||
|
|
;; Continue searching.
|
|||
|
|
(let-values (((p1 fix-balance?)
|
|||
|
|
(search (%left p) fix-balance?)))
|
|||
|
|
(cond
|
|||
|
|
((not fix-balance?)
|
|||
|
|
(let ((p^ (%avl (%key p) (%data p) (%bal p)
|
|||
|
|
p1 (%right p))))
|
|||
|
|
(values p^ #f)))
|
|||
|
|
(else
|
|||
|
|
;; A new node has been inserted on the left side.
|
|||
|
|
(case (%bal p)
|
|||
|
|
((1)
|
|||
|
|
(let ((p^ (%avl (%key p) (%data p) 0
|
|||
|
|
p1 (%right p))))
|
|||
|
|
(values p^ #f)))
|
|||
|
|
((0)
|
|||
|
|
(let ((p^ (%avl (%key p) (%data p) -1
|
|||
|
|
p1 (%right p))))
|
|||
|
|
(values p^ fix-balance?)))
|
|||
|
|
((-1)
|
|||
|
|
;; Rebalance.
|
|||
|
|
(case (%bal p1)
|
|||
|
|
((-1)
|
|||
|
|
;; A single LL rotation.
|
|||
|
|
(let* ((p^ (%avl (%key p) (%data p) 0
|
|||
|
|
(%right p1) (%right p)))
|
|||
|
|
(p1^ (%avl (%key p1) (%data p1) 0
|
|||
|
|
(%left p1) p^)))
|
|||
|
|
(values p1^ #f)))
|
|||
|
|
((0 1)
|
|||
|
|
;; A double LR rotation.
|
|||
|
|
(let* ((p2 (%right p1))
|
|||
|
|
(bal2 (%bal p2))
|
|||
|
|
(p^ (%avl (%key p) (%data p)
|
|||
|
|
(- (min bal2 0))
|
|||
|
|
(%right p2) (%right p)))
|
|||
|
|
(p1^ (%avl (%key p1) (%data p1)
|
|||
|
|
(- (max bal2 0))
|
|||
|
|
(%left p1) (%left p2)))
|
|||
|
|
(p2^ (%avl (%key p2) (%data p2) 0
|
|||
|
|
p1^ p^)))
|
|||
|
|
(values p2^ #f)))
|
|||
|
|
(else (internal-error))))
|
|||
|
|
(else (internal-error)))))))
|
|||
|
|
|
|||
|
|
((pred<? (%key p) key)
|
|||
|
|
;; Continue searching.
|
|||
|
|
(let-values (((p1 fix-balance?)
|
|||
|
|
(search (%right p) fix-balance?)))
|
|||
|
|
(cond
|
|||
|
|
((not fix-balance?)
|
|||
|
|
(let ((p^ (%avl (%key p) (%data p) (%bal p)
|
|||
|
|
(%left p) p1)))
|
|||
|
|
(values p^ #f)))
|
|||
|
|
(else
|
|||
|
|
;; A new node has been inserted on the right side.
|
|||
|
|
(case (%bal p)
|
|||
|
|
((-1)
|
|||
|
|
(let ((p^ (%avl (%key p) (%data p) 0
|
|||
|
|
(%left p) p1)))
|
|||
|
|
(values p^ #f)))
|
|||
|
|
((0)
|
|||
|
|
(let ((p^ (%avl (%key p) (%data p) 1
|
|||
|
|
(%left p) p1)))
|
|||
|
|
(values p^ fix-balance?)))
|
|||
|
|
((1)
|
|||
|
|
;; Rebalance.
|
|||
|
|
(case (%bal p1)
|
|||
|
|
((1)
|
|||
|
|
;; A single RR rotation.
|
|||
|
|
(let* ((p^ (%avl (%key p) (%data p) 0
|
|||
|
|
(%left p) (%left p1)))
|
|||
|
|
(p1^ (%avl (%key p1) (%data p1) 0
|
|||
|
|
p^ (%right p1))))
|
|||
|
|
(values p1^ #f)))
|
|||
|
|
((-1 0)
|
|||
|
|
;; A double RL rotation.
|
|||
|
|
(let* ((p2 (%left p1))
|
|||
|
|
(bal2 (%bal p2))
|
|||
|
|
(p^ (%avl (%key p) (%data p)
|
|||
|
|
(- (max bal2 0))
|
|||
|
|
(%left p) (%left p2)))
|
|||
|
|
(p1^ (%avl (%key p1) (%data p1)
|
|||
|
|
(- (min bal2 0))
|
|||
|
|
(%right p2) (%right p1)))
|
|||
|
|
(p2^ (%avl (%key p2) (%data p2) 0
|
|||
|
|
p^ p1^)))
|
|||
|
|
(values p2^ #f)))
|
|||
|
|
(else (internal-error))))
|
|||
|
|
(else (internal-error)))))))
|
|||
|
|
|
|||
|
|
(else
|
|||
|
|
;; The key was found; p is an existing node.
|
|||
|
|
(values (%avl key data (%bal p) (%left p) (%right p))
|
|||
|
|
#f))))
|
|||
|
|
|
|||
|
|
(avl-check-usage
|
|||
|
|
(procedure? pred<?)
|
|||
|
|
"avl-insert expects a procedure as first argument")
|
|||
|
|
(if (avl-empty? tree)
|
|||
|
|
(%avl key data 0 #f #f)
|
|||
|
|
(let-values (((p fix-balance?) (search tree #f)))
|
|||
|
|
p)))
|
|||
|
|
|
|||
|
|
(define (internal-error)
|
|||
|
|
(display "internal error\n" (current-error-port))
|
|||
|
|
(emergency-exit 123))
|
|||
|
|
|
|||
|
|
(define (usage-error msg)
|
|||
|
|
(display "Procedure usage error:\n" (current-error-port))
|
|||
|
|
(display " " (current-error-port))
|
|||
|
|
(display msg (current-error-port))
|
|||
|
|
(newline (current-error-port))
|
|||
|
|
(exit 1))
|
|||
|
|
|
|||
|
|
)) ;; end library (avl-trees)
|
|||
|
|
|
|||
|
|
|
|||
|
|
(define-library (associative-arrays)
|
|||
|
|
|
|||
|
|
;;
|
|||
|
|
;; Persistent associative arrays for R7RS Scheme.
|
|||
|
|
;;
|
|||
|
|
;; The story:
|
|||
|
|
;;
|
|||
|
|
;; An implementation of associative arrays, where keys are compared
|
|||
|
|
;; with an ‘equal to’ predicate, typically has three parts:
|
|||
|
|
;;
|
|||
|
|
;; * a hash function, which converts a key to a hash value; and
|
|||
|
|
;; the hash value either has a ‘less than’ predicate or can be
|
|||
|
|
;; put in a radix tree;
|
|||
|
|
;;
|
|||
|
|
;; * a table keyed by the hash values;
|
|||
|
|
;;
|
|||
|
|
;; * a way to resolve hash value collisions.
|
|||
|
|
;;
|
|||
|
|
;; At one extreme is the association list, which can be viewed as
|
|||
|
|
;; having a hash function that *always* collides. At a nearly
|
|||
|
|
;; opposite extreme are ideal hash trees, which never have
|
|||
|
|
;; collisions, but which, towards that end, require hash values to
|
|||
|
|
;; ‘grow’ on the fly.
|
|||
|
|
;;
|
|||
|
|
;; Perhaps the simplest form of associative array having all three
|
|||
|
|
;; parts is ‘separate chaining’: the hash function generates an
|
|||
|
|
;; integer modulo some table size; the table itself is an array of
|
|||
|
|
;; that size; and collisions are resolved by falling back to an
|
|||
|
|
;; association list.
|
|||
|
|
;;
|
|||
|
|
;; Below I use my solution to the AVL Tree task
|
|||
|
|
;; (https://rosettacode.org/wiki/AVL_tree#Scheme) to implement
|
|||
|
|
;; *persistent* (that is, ‘immutable’) associative arrays. The hash
|
|||
|
|
;; function is whatever you want, as long as it produces (what
|
|||
|
|
;; Scheme regards as) a real number. Hash value collisions are
|
|||
|
|
;; resolved by falling back to association lists.
|
|||
|
|
;;
|
|||
|
|
|
|||
|
|
(export assoc-array)
|
|||
|
|
(export assoc-array?)
|
|||
|
|
(export assoc-array-set)
|
|||
|
|
(export assoc-array-ref)
|
|||
|
|
|
|||
|
|
(import (scheme base))
|
|||
|
|
(import (scheme case-lambda))
|
|||
|
|
(import (scheme write))
|
|||
|
|
(import (avl-trees))
|
|||
|
|
|
|||
|
|
(cond-expand
|
|||
|
|
(chicken (import (only (srfi 1) alist-delete)))
|
|||
|
|
;; Insert whatever you need here for your Scheme.
|
|||
|
|
(else))
|
|||
|
|
|
|||
|
|
(begin
|
|||
|
|
|
|||
|
|
(define-record-type <assoc-array>
|
|||
|
|
(%assoc-array hashfunc pred=? default table)
|
|||
|
|
assoc-array?
|
|||
|
|
(hashfunc %hashfunc)
|
|||
|
|
(pred=? %pred=?)
|
|||
|
|
(default %default)
|
|||
|
|
(table %table))
|
|||
|
|
|
|||
|
|
(define assoc-array
|
|||
|
|
;; Create an associative array.
|
|||
|
|
(case-lambda
|
|||
|
|
((hashfunc)
|
|||
|
|
(let ((pred=? equal?)
|
|||
|
|
(default #f))
|
|||
|
|
(assoc-array hashfunc pred=? default)))
|
|||
|
|
((hashfunc pred=?)
|
|||
|
|
(let ((default #f))
|
|||
|
|
(assoc-array hashfunc pred=? default)))
|
|||
|
|
((hashfunc pred=? default)
|
|||
|
|
(%assoc-array hashfunc pred=? default (avl)))))
|
|||
|
|
|
|||
|
|
(define (assoc-array-set array key data)
|
|||
|
|
;; Produce a new associative array that is the same as the input
|
|||
|
|
;; array except for the given key-data association. The input
|
|||
|
|
;; array is left unchanged (which is why the procedure is called
|
|||
|
|
;; ‘assoc-array-set’ rather than ‘assoc-array-set!’).
|
|||
|
|
(let ((hashfunc (%hashfunc array))
|
|||
|
|
(pred=? (%pred=? array))
|
|||
|
|
(default (%default array))
|
|||
|
|
(table (%table array)))
|
|||
|
|
(let ((hash-value (hashfunc key)))
|
|||
|
|
;; The following could be made more efficient by combining
|
|||
|
|
;; the ‘search’ and ‘insert’ operations for the AVL tree.
|
|||
|
|
(let*-values
|
|||
|
|
(((alst found?) (avl-search-values < table hash-value)))
|
|||
|
|
(cond
|
|||
|
|
(found?
|
|||
|
|
;; Add a new entry to the association list. Removal of
|
|||
|
|
;; any old associations with the key is not strictly
|
|||
|
|
;; necessary, but without it the associative array will
|
|||
|
|
;; grow every time you replace an
|
|||
|
|
;; association. (Alternatively, you could occasionally
|
|||
|
|
;; clean the associative array of shadowed key
|
|||
|
|
;; associations.)
|
|||
|
|
(let* ((alst (alist-delete key alst pred=?))
|
|||
|
|
(alst `((,key . ,data) . ,alst))
|
|||
|
|
(table (avl-insert < table hash-value alst)))
|
|||
|
|
(%assoc-array hashfunc pred=? default table)))
|
|||
|
|
(else
|
|||
|
|
;; Start a new association list.
|
|||
|
|
(let* ((alst `((,key . ,data)))
|
|||
|
|
(table (avl-insert < table hash-value alst)))
|
|||
|
|
(%assoc-array hashfunc pred=? default table))))))))
|
|||
|
|
|
|||
|
|
(define (assoc-array-ref array key)
|
|||
|
|
;; Return the data associated with the key. If the key is not in
|
|||
|
|
;; the table, return the associative array’s default data.
|
|||
|
|
(let* ((hashfunc (%hashfunc array))
|
|||
|
|
(hash-value (hashfunc key)))
|
|||
|
|
(let*-values
|
|||
|
|
(((alst found?)
|
|||
|
|
(avl-search-values < (%table array) hash-value)))
|
|||
|
|
(if found?
|
|||
|
|
(let ((pair (assoc key alst (%pred=? array))))
|
|||
|
|
(if pair
|
|||
|
|
(cdr pair)
|
|||
|
|
(%default array)))
|
|||
|
|
(%default array)))))
|
|||
|
|
|
|||
|
|
)) ;; end library (associative-arrays)
|
|||
|
|
|
|||
|
|
|
|||
|
|
(cond-expand
|
|||
|
|
(DEMONSTRATION
|
|||
|
|
(begin
|
|||
|
|
(import (scheme base))
|
|||
|
|
(import (scheme write))
|
|||
|
|
(import (srfi 151))
|
|||
|
|
(import (associative-arrays))
|
|||
|
|
|
|||
|
|
;; I like SpookyHash, but for this demonstration I shall use the
|
|||
|
|
;; simpler ‘ElfHash’ and define it only for strings. See
|
|||
|
|
;; https://en.wikipedia.org/w/index.php?title=PJW_hash_function&oldid=997863283
|
|||
|
|
(define (hashfunc s)
|
|||
|
|
(let ((n (string-length s))
|
|||
|
|
(h 0))
|
|||
|
|
(do ((i 0 (+ i 1)))
|
|||
|
|
((= i n))
|
|||
|
|
(let* ((ch
|
|||
|
|
;; If the character is outside the 8-bit range,
|
|||
|
|
;; probably I should break it into four bytes, each
|
|||
|
|
;; incorporated separately into the hash. For this
|
|||
|
|
;; demonstration, I shall simply discard the higher
|
|||
|
|
;; bits.
|
|||
|
|
(bitwise-and (char->integer (string-ref s i))
|
|||
|
|
#xFF))
|
|||
|
|
(h^ (+ (arithmetic-shift h 4) ch))
|
|||
|
|
(high^ (bitwise-and h^ #xF0000000)))
|
|||
|
|
(unless (zero? high^)
|
|||
|
|
(set! h^
|
|||
|
|
(bitwise-xor h^ (arithmetic-shift high^ -24))))
|
|||
|
|
(set! h (bitwise-and h^ (bitwise-not high^)))))
|
|||
|
|
h))
|
|||
|
|
|
|||
|
|
(let* ((a1 (assoc-array hashfunc))
|
|||
|
|
(a2 (assoc-array-set a1 "A" #\A))
|
|||
|
|
(a3 (assoc-array-set a2 "B" #x42)) ; ASCII ‘B’.
|
|||
|
|
(a4 (assoc-array-set a3 "C" "C")))
|
|||
|
|
(write (assoc-array-ref a1 "A")) (newline)
|
|||
|
|
(write (assoc-array-ref a1 "B")) (newline)
|
|||
|
|
(write (assoc-array-ref a1 "C")) (newline)
|
|||
|
|
(write (assoc-array-ref a2 "A")) (newline)
|
|||
|
|
(write (assoc-array-ref a2 "B")) (newline)
|
|||
|
|
(write (assoc-array-ref a2 "C")) (newline)
|
|||
|
|
(write (assoc-array-ref a3 "A")) (newline)
|
|||
|
|
(write (assoc-array-ref a3 "B")) (newline)
|
|||
|
|
(write (assoc-array-ref a3 "C")) (newline)
|
|||
|
|
(write (assoc-array-ref a4 "A")) (newline)
|
|||
|
|
(write (assoc-array-ref a4 "B")) (newline)
|
|||
|
|
(write (assoc-array-ref a4 "C")) (newline))
|
|||
|
|
|
|||
|
|
))
|
|||
|
|
(else))
|