[funds-cvs] r59 - in trunk/funds/src: . stack trees trees/heap
abaine at common-lisp.net
abaine at common-lisp.net
Sun Jul 8 02:52:18 UTC 2007
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))
More information about the Funds-cvs
mailing list