Author: abaine Date: Sat Jul 7 22:52:17 2007 New Revision: 59 Added: trunk/funds/src/funds-clos.asd trunk/funds/src/queue.lisp trunk/funds/src/stack/ trunk/funds/src/stack.lisp trunk/funds/src/trees/avl.lisp trunk/funds/src/trees/bt.lisp trunk/funds/src/trees/classes.lisp trunk/funds/src/trees/constructors.lisp trunk/funds/src/trees/heap/ trunk/funds/src/trees/heap/heap-empty-p.lisp trunk/funds/src/trees/heap/heap-first.lisp trunk/funds/src/trees/heap/heap-insert.lisp trunk/funds/src/trees/heap/heap-remove.lisp trunk/funds/src/trees/tree-as-alist.lisp trunk/funds/src/trees/tree-empty-p.lisp trunk/funds/src/trees/tree-find.lisp trunk/funds/src/trees/tree-height.lisp trunk/funds/src/trees/tree-insert.lisp trunk/funds/src/trees/tree-remove.lisp trunk/funds/src/trees/tree-weight.lisp Removed: trunk/funds/src/trees/avl-tree.lisp trunk/funds/src/trees/binary-tree.lisp trunk/funds/src/trees/package.lisp Modified: trunk/funds/src/package.lisp Log: Total rewrite using CLOS. Added: trunk/funds/src/funds-clos.asd ============================================================================== --- (empty file) +++ trunk/funds/src/funds-clos.asd Sat Jul 7 22:52:17 2007 @@ -0,0 +1,35 @@ + +; -*- Lisp -*- + +(in-package :cl-user) +(defpackage #:funds-clos-asd + (:use :cl :asdf)) + +(in-package :funds-clos-asd) + +(defsystem funds-clos + :serial t + :components ((:file "package") + (:file "stack") + (:module trees + :serial t + :components ((:file "classes") + (:file "constructors") + (:file "bt") + (:file "avl") + (:file "tree-as-alist") + (:file "tree-empty-p") + (:file "tree-insert") + (:file "tree-remove") + (:file "tree-find") + (:file "tree-weight") + (:file "tree-height") + (:module heap + :serial t + :components ((:file "heap-empty-p") + (:file "heap-insert") + (:file "heap-remove") + (:file "heap-first"))))) + (:file "queue"))) + + Modified: trunk/funds/src/package.lisp ============================================================================== --- trunk/funds/src/package.lisp (original) +++ trunk/funds/src/package.lisp Sat Jul 7 22:52:17 2007 @@ -1,21 +1,35 @@ (in-package :cl-user) -(defpackage :funds - (:use :common-lisp) - (:export :make-stack - :stack-length - :stack-push - :stack-pop +(defpackage :funds-clos + (:use :cl) + (:export :make-avl-tree + :make-binary-tree + + :tree-insert + :tree-remove + :tree-find + :tree-empty-p + :tree-height + :tree-weight + + :make-heap + :heap-empty-p + :heap-first + :heap-insert + :heap-remove + + :make-queue + :queue-empty-p + :queue-enqueue + :queue-dequeue + :queue-first + :queue-size + + :make-stack :stack-empty-p + :stack-push + :stack-top + :stack-size)) + - :empty-avl-tree - :avl-empty-p - :avl-insert - :avl-remove - :avl-find-value - :avl-key - :avl-value - :avl-height - :avl-left - :avl-right)) Added: trunk/funds/src/queue.lisp ============================================================================== --- (empty file) +++ trunk/funds/src/queue.lisp Sat Jul 7 22:52:17 2007 @@ -0,0 +1,25 @@ + +(in-package :funds-clos) + +(defstruct queue + (next-priority 0) + (heap (make-heap))) + +(defun queue-first (q) + (heap-first (queue-heap q))) + +(defun queue-enqueue (q item) + (make-queue :next-priority (1+ (queue-next-priority q)) + :heap (heap-insert (queue-heap q) item (queue-next-priority q)))) + +(defun queue-dequeue (q) + (if (queue-empty-p q) + q + (make-queue :next-priority (1- (queue-next-priority q)) + :heap (heap-remove (queue-heap q))))) + +(defun queue-size (q) + (tree-weight (queue-heap q))) + +(defun queue-empty-p (q) + (tree-empty-p (queue-heap q))) Added: trunk/funds/src/stack.lisp ============================================================================== --- (empty file) +++ trunk/funds/src/stack.lisp Sat Jul 7 22:52:17 2007 @@ -0,0 +1,30 @@ + +(in-package :funds-clos) + +(defun make-stack () + "An empty stack." + nil) + +(defun stack-push (stack item) + "The stack that results when the given item is pushed onto the given stack." + (cons item stack)) + +(defun stack-pop (stack) + "The stack that results when the top item is popped off the given stack." + (cdr stack)) + +(defun stack-top (stack) + "The top item on the given stack." + (car stack)) + +(defun stack-empty-p (stack) + "Whether the given stack is empty." + (null stack)) + +(defun stack-size (stack) + "The number of items on this stack; note that this is an O(n) operation." + (labels ((f (stack accum) + (if (stack-empty-p stack) + accum + (f (stack-pop stack) (1+ accum))))) + (f stack 0))) Added: trunk/funds/src/trees/avl.lisp ============================================================================== --- (empty file) +++ trunk/funds/src/trees/avl.lisp Sat Jul 7 22:52:17 2007 @@ -0,0 +1,31 @@ + +(in-package :funds-clos) + +(defun balance (inside root outside &key heavy-side) + (let ((other-side (other-side heavy-side))) + (if (balanced-p inside outside) + (make-avl-tree :key (bt-key root) + :value (bt-value root) + heavy-side outside + other-side inside) + (rotate inside root + (if (heavier-p outside :side other-side) + (rotate (tree-child outside :side heavy-side) + outside + (tree-child outside :side other-side) + :side heavy-side) + outside) + :side other-side)))) + +(defun rotate (inside root outside &key side) + (let* ((t1 (tree-child outside :side side)) + (new-inside (make-avl-tree :key (bt-key root) + :value (bt-value root) + side inside + (other-side side) t1)) + (new-outside (tree-child outside :side (other-side side)))) + (make-avl-tree + :key (bt-key outside) + :value (bt-key outside) + side new-inside + (other-side side) new-outside))) Added: trunk/funds/src/trees/bt.lisp ============================================================================== --- (empty file) +++ trunk/funds/src/trees/bt.lisp Sat Jul 7 22:52:17 2007 @@ -0,0 +1,36 @@ + +(in-package :funds-clos) + +(defun left-p (side) + (eq side :left)) + +(defun other-side (side) + (if (left-p side) :right :left)) + +(defun tree-child (tree &key side) + (funcall (if (left-p side) #'bt-left #'bt-right) tree)) + +(defun next-in-order (tree) + (labels ((f (tree) + (if (tree-empty-p (bt-left tree)) + tree + (f (bt-left tree))))) + (f (bt-right tree)))) + +(defun parent-height (t1 t2) + (let ((h1 (tree-height t1)) + (h2 (tree-height t2))) + (1+ (if (> h1 h2) h1 h2)))) + +(defun balanced-p (t1 t2) + (< -2 (height-difference t1 t2) 2)) + +(defun height-difference (t1 t2) + (- (tree-height t1) (tree-height t2))) + +(defun heavier-p (tree &key side) + (funcall (if (left-p side) #'plusp #'minusp) + (height-difference (bt-left tree) + (bt-right tree)))) + + Added: trunk/funds/src/trees/classes.lisp ============================================================================== --- (empty file) +++ trunk/funds/src/trees/classes.lisp Sat Jul 7 22:52:17 2007 @@ -0,0 +1,45 @@ + +(in-package :funds-clos) + +(defclass tree () + () + (:documentation "The foundation of all trees.")) + +(defclass leaf (tree) + () + (:documentation "A leaf with no data or children.")) + +(defclass avl-leaf (leaf) + () + (:documentation "A leaf node of an AVL tree.")) + +(defclass bt-leaf (leaf) + () + (:documentation "A leaf node of an AVL tree.")) + +(defclass binary-tree (tree) + ((key :initarg :key :reader bt-key) + (value :initarg :value :reader bt-value) + (left :initarg :left :reader bt-left :initform (make-binary-tree)) + (right :initarg :right :reader bt-right :initform (make-binary-tree))) + (:documentation "A binary tree that holds a key-value pair in its root.")) + +(defclass avl-tree (binary-tree) + ((height :initarg :height :reader avl-height) + (left :initform (make-avl-tree)) + (right :initform (make-avl-tree))) + (:documentation "A height-balanced binary tree.")) + +(defclass heap-leaf (leaf) + () + (:documentation "A leaf node of a heap.")) + +(defclass heap (binary-tree) + ((key :initarg :priority :reader heap-priority) + (left :initform (make-heap)) + (right :initform (make-heap)) + (weight :initarg :weight :initform 1 :reader heap-weight))) + + + + Added: trunk/funds/src/trees/constructors.lisp ============================================================================== --- (empty file) +++ trunk/funds/src/trees/constructors.lisp Sat Jul 7 22:52:17 2007 @@ -0,0 +1,36 @@ + +(in-package :funds-clos) + +(defun make-bt-leaf () + (make-instance 'bt-leaf)) + +(defun make-avl-leaf () + (make-instance 'avl-leaf)) + +(defun make-binary-tree () + (make-bt-leaf)) + +(defun make-avl-tree (&key (key nil k-p) (value nil) + (left (make-avl-leaf)) (right (make-avl-leaf))) + (if k-p + (make-instance 'avl-tree + :key key + :value value + :left left + :right right + :height (parent-height left right)) + (make-avl-leaf))) + +(defun make-heap-leaf () + (make-instance 'heap-leaf)) + +(defun make-heap (&key (priority 0 p-p) value + (left (make-heap-leaf)) (right (make-heap-leaf))) + (if p-p + (make-instance 'heap + :priority priority + :value value + :left left + :right right + :weight (+ 1 (tree-weight left) (tree-weight right))) + (make-heap-leaf))) Added: trunk/funds/src/trees/heap/heap-empty-p.lisp ============================================================================== --- (empty file) +++ trunk/funds/src/trees/heap/heap-empty-p.lisp Sat Jul 7 22:52:17 2007 @@ -0,0 +1,5 @@ + +(in-package :funds-clos) + +(defun heap-empty-p (heap) + (tree-empty-p heap)) \ No newline at end of file Added: trunk/funds/src/trees/heap/heap-first.lisp ============================================================================== --- (empty file) +++ trunk/funds/src/trees/heap/heap-first.lisp Sat Jul 7 22:52:17 2007 @@ -0,0 +1,5 @@ + +(in-package :funds-clos) + +(defun heap-first (heap) + (bt-value heap)) Added: trunk/funds/src/trees/heap/heap-insert.lisp ============================================================================== --- (empty file) +++ trunk/funds/src/trees/heap/heap-insert.lisp Sat Jul 7 22:52:17 2007 @@ -0,0 +1,42 @@ + +(in-package :funds-clos) + +(defgeneric heap-insert (heap value priority &key order)) + +(defmethod heap-insert ((heap heap-leaf) value priority &key order) + (declare (ignore order)) + (make-heap :priority priority + :value value)) + +(defmethod heap-insert (heap value priority &key (order #'<)) + (let* ((side (next-direction heap)) + (other-side (other-side side)) + (h1 (heap-insert (tree-child heap :side side) value priority + :order order)) + (h2 (tree-child heap :side other-side))) + (if (funcall order (bt-key h1) (bt-key heap)) ; if we need to bubble up + (make-heap :priority (heap-priority h1) + :value (bt-value h1) + side (make-heap :priority (heap-priority heap) + + :value (bt-value heap) + :left (bt-left h1) + :right (bt-right h1)) + other-side h2) + (make-heap :priority (heap-priority heap) + :value (bt-value heap) + side h1 + other-side h2)))) + + +(defun next-direction (heap) + (path-direction (1+ (heap-weight heap)))) + +(defun last-direction (heap) + (path-direction (heap-weight heap))) + +(defun path-direction (n) + (let ((lg (floor (log n 2)))) + (if (< (- n (expt 2 lg)) (expt 2 (1- lg))) + :left + :right))) Added: trunk/funds/src/trees/heap/heap-remove.lisp ============================================================================== --- (empty file) +++ trunk/funds/src/trees/heap/heap-remove.lisp Sat Jul 7 22:52:17 2007 @@ -0,0 +1,66 @@ + +(in-package :funds-clos) + +(defmethod heap-remove ((heap heap-leaf) &key order) + (declare (ignore order)) + heap) + +(defmethod heap-remove (heap &key (order #'<)) + (let ((last-node (last-node heap))) + (if (eq last-node heap) + (make-heap) + (let* ((side (last-direction heap)) + (other-side (other-side side))) + (bubble-down last-node + side (clip-last (tree-child heap :side side)) + other-side (tree-child heap :side other-side) + :order order))))) + +(defun bubble-down (root &key left right order) + (cond ((and (not (heap-empty-p left)) + (in-order-p left root :order order) + (or (heap-empty-p right) + (in-order-p left right :order order))) + (attach-heap left + (bubble-down root + :left (bt-left left) + :right (bt-right left) + :order order) + right)) + ((and (not (heap-empty-p right)) + (in-order-p right root :order order)) + (attach-heap right + left + (bubble-down root + :left (bt-left right) + :right (bt-right right) + :order order))) + (t (attach-heap root left right)))) + +(defun attach-heap (root left right) + (make-heap :priority (heap-priority root) + :value (bt-value root) + :left left + :right right)) + +(defun in-order-p (h1 h2 &key order) + (funcall order (heap-priority h1) (heap-priority h2))) + +(defun clip-last (heap) + "The heap that results when the last node is removed." + (if (no-children-p heap) + (make-heap) + (let ((side (last-direction heap))) + (make-heap side (clip-last (tree-child heap :side side)) + (other-side side) (tree-child heap :side (other-side side)) + :priority (heap-priority heap) + :value (bt-value heap))))) + +(defun no-children-p (heap) + (and (heap-empty-p (bt-left heap)) + (heap-empty-p (bt-right heap)))) + +(defun last-node (heap) + (if (no-children-p heap) + heap + (last-node (tree-child heap :side (last-direction heap))))) Added: trunk/funds/src/trees/tree-as-alist.lisp ============================================================================== --- (empty file) +++ trunk/funds/src/trees/tree-as-alist.lisp Sat Jul 7 22:52:17 2007 @@ -0,0 +1,22 @@ + +(in-package :funds-clos) + +(defgeneric tree-as-alist (tree) + (:documentation + "An association list containing the key-value pairs in the given tree.")) + +(defmethod tree-as-alist ((tree leaf)) + nil) + +(defmethod tree-as-alist ((tree binary-tree)) + (append (tree-as-alist (bt-left tree)) + (cons (cons (bt-key tree) (bt-value tree)) + (tree-as-alist (bt-right tree))))) + +(defmethod tree-as-pre-order-alist ((tree leaf)) + nil) + +(defmethod tree-as-pre-order-alist ((tree binary-tree)) + (cons (cons (bt-key tree) (bt-value tree)) + (append (tree-as-pre-order-alist (bt-left tree)) + (tree-as-pre-order-alist (bt-right tree))))) Added: trunk/funds/src/trees/tree-empty-p.lisp ============================================================================== --- (empty file) +++ trunk/funds/src/trees/tree-empty-p.lisp Sat Jul 7 22:52:17 2007 @@ -0,0 +1,12 @@ + +(in-package :funds-clos) + +(defgeneric tree-empty-p (tree) + (:documentation +"Whether this tree has any key-value pairs.")) + +(defmethod tree-empty-p ((tree t)) + nil) + +(defmethod tree-empty-p ((tree leaf)) + t) \ No newline at end of file Added: trunk/funds/src/trees/tree-find.lisp ============================================================================== --- (empty file) +++ trunk/funds/src/trees/tree-find.lisp Sat Jul 7 22:52:17 2007 @@ -0,0 +1,26 @@ + +(in-package :funds-clos) + +(defgeneric tree-find (tree key &key test order) + (:documentation +"The value to which the given key is mapped, or nil if this tree contains no +such key. The second value returned indicates whether the tree contained the +key. So + + (find t k) -> nil t + +if k maps to nil. But + + (find t k) -> nil nil + +if there is no mapping for k in the tree.")) + +(defmethod tree-find ((tree leaf) key &key test order) + (declare (ignore key test order)) + (values nil nil)) + +(defmethod tree-find (tree key &key (test #'eql) (order #'<)) + (cond ((funcall test key (bt-key tree)) (values (bt-value tree) t)) + ((funcall order key (bt-key tree)) (tree-find (bt-left tree) key + :test test :order order)) + (t (tree-find (bt-left tree) key :test test :order order)))) Added: trunk/funds/src/trees/tree-height.lisp ============================================================================== --- (empty file) +++ trunk/funds/src/trees/tree-height.lisp Sat Jul 7 22:52:17 2007 @@ -0,0 +1,17 @@ + +(in-package :funds-clos) + +(defgeneric tree-height (tree) + (:documentation "The height of the given tree.")) + +(defmethod tree-height ((tree leaf)) + 0) + +(defmethod tree-height ((tree binary-tree)) + (let ((a (tree-height (bt-left tree))) + (b (tree-height (bt-right tree)))) + (1+ (if (> a b) a b)))) + +(defmethod tree-height ((tree avl-tree)) + (avl-height tree)) + Added: trunk/funds/src/trees/tree-insert.lisp ============================================================================== --- (empty file) +++ trunk/funds/src/trees/tree-insert.lisp Sat Jul 7 22:52:17 2007 @@ -0,0 +1,52 @@ + +(in-package :funds-clos) + +(defgeneric tree-insert (tree key value &key test order) + (:documentation +"A new tree similar to the given tree except that the given key and value +are now associated with one another. If the given key is already contained +in the tree, according to the test function, then the old value is replaced +by the specified value. The order function specifies whether the given +key-value pair should be inserted to the left or right of the given tree.")) + +(defmethod tree-insert ((tree bt-leaf) key value &key test order) + (declare (ignore test order)) + (make-instance 'binary-tree + :key key + :value value)) + +(defmethod tree-insert ((tree avl-leaf) key value &key test order) + (declare (ignore test order)) + (make-avl-tree :key key + :value value)) + +(defmethod tree-insert ((tree binary-tree) key value + &key (test #'eql) (order #'<)) + (cond ((funcall test key (bt-key tree)) + (make-instance 'binary-tree + :key key + :value value + :left (bt-left tree) + :right (bt-right tree))) + ((funcall order key (bt-key tree)) + (insert tree key value + :test test :order order :side :left)) + (t (insert tree key value + :test test :order order :side :right)))) + +(defmethod insert ((tree binary-tree) key value &key test order side) + (make-instance 'binary-tree + :key (bt-key tree) + :value (bt-value tree) + side (tree-insert (tree-child tree :side side) + key value + :test test + :order order) + (other-side side) (tree-child tree :side (other-side side)))) + +(defmethod insert ((tree avl-tree) key value &key test order side) + (declare (ignore test order)) + (let* ((temp (call-next-method)) ; the temp object will be a bt, not an avl tree. + (outside (tree-child temp :side side)) + (inside (tree-child temp :side (other-side side)))) + (balance inside temp outside :heavy-side side))) Added: trunk/funds/src/trees/tree-remove.lisp ============================================================================== --- (empty file) +++ trunk/funds/src/trees/tree-remove.lisp Sat Jul 7 22:52:17 2007 @@ -0,0 +1,61 @@ + +(in-package :funds-clos) + +(defgeneric tree-remove (tree key &key test order) + (:documentation +"A new tree with the given key removed. The test function is used to compare +the tree's key to the given key. The order function is used to determine +whether the key can be found to the left or right if it is not found at the +root.")) + +(defmethod tree-remove ((tree leaf) key &key test order) + (declare (ignore test order key)) + tree) + +(defmethod tree-remove ((tree binary-tree) key &key (test #'eql) (order #'<)) + (cond ((funcall test key (bt-key tree)) + (remove-root tree :order order :test test)) + ((funcall order key (bt-key tree)) + (remove-side tree key :test test :order order :side :left)) + (t (remove-side tree key :test test :order order :side :right)))) + +(defmethod tree-remove ((tree avl-tree) key &key (test #'eql) (order #'<)) + (let* ((temp (call-next-method)) + (heavy-side (if (heavier-p temp :side :left) + :left + :right)) + (inside (tree-child temp :side (other-side heavy-side))) + (outside (tree-child temp :side heavy-side))) + (balance inside temp outside :heavy-side heavy-side))) + + +(defmethod remove-root ((tree binary-tree) &key test order) + (cond ((tree-empty-p (bt-left tree)) (bt-right tree)) + ((tree-empty-p (bt-right tree)) (bt-left tree)) + (t (remove-root-with-children tree :test test :order order)))) + +(defmethod remove-side ((tree binary-tree) key &key test order side) + (make-instance 'binary-tree + :key (bt-key tree) + :value (bt-value tree) + side (tree-remove (tree-child tree :side side) key + :test test :order order) + (other-side side) (tree-child tree :side (other-side side)))) + +(defmethod remove-root-with-children ((tree binary-tree) &key test order) + (let* ((next (next-in-order tree)) + (k (bt-key next))) + (make-instance 'binary-tree + :key k + :value (bt-value next) + :left (bt-left tree) + :right (tree-remove (bt-right tree) k :test test :order order)))) + +(defmethod remove-root-with-children ((tree avl-tree) &key test order) + (let* ((next (next-in-order tree)) + (k (bt-key next))) + (make-avl-tree :key k + :value (bt-value next) + :left (bt-left tree) + :right (tree-remove (bt-right tree) k :test test :order order)))) + Added: trunk/funds/src/trees/tree-weight.lisp ============================================================================== --- (empty file) +++ trunk/funds/src/trees/tree-weight.lisp Sat Jul 7 22:52:17 2007 @@ -0,0 +1,16 @@ + +(in-package :funds-clos) + +(defgeneric tree-weight (tree) + (:documentation +"The number of nodes in the given tree.")) + +(defmethod tree-weight ((tree leaf)) + 0) + +(defmethod tree-weight ((tree binary-tree)) + (+ 1 (tree-weight (bt-left tree)) + (tree-weight (bt-right tree)))) + +(defmethod tree-weight ((tree heap)) + (heap-weight tree))