Funds

As of June 6, 2007, the project sources have not yet been moved -to the common-lisp.net servers. Once they are, in mid-June, you will -be able to -browse our CVS repository or download the current development tree -via anonymous cvs, as described here

Introduction

The goal of the Funds project is to provide portable, purely + functional, efficient data structures written in Common Lisp. Funds + is open source software released under the + + MIT License + .

Mailing Lists

Download

This project has not released any files. It is under active + development as a + Google Summer of Code Project, and a release is planned for + July 6, 2007. + +

Project members

CVS

From abaine at common-lisp.net Fri Jun 8 14:49:48 2007 From: abaine at common-lisp.net (abaine at common-lisp.net) Date: Fri, 8 Jun 2007 10:49:48 -0400 (EDT) Subject: [funds-cvs] r3 - trunk/funds/src/trees Message-ID: <20070608144948.6450A2F00A@common-lisp.net> Author: abaine Date: Fri Jun 8 10:49:48 2007 New Revision: 3 Added: trunk/funds/src/trees/ Log: Added trees directory. From abaine at common-lisp.net Fri Jun 8 14:50:38 2007 From: abaine at common-lisp.net (abaine at common-lisp.net) Date: Fri, 8 Jun 2007 10:50:38 -0400 (EDT) Subject: [funds-cvs] r4 - trunk/funds/src/trees Message-ID: <20070608145038.DD1BD36139@common-lisp.net> Author: abaine Date: Fri Jun 8 10:50:38 2007 New Revision: 4 Added: trunk/funds/src/trees/avl-tree.lisp Log: Added avl-tree.lisp Added: trunk/funds/src/trees/avl-tree.lisp ============================================================================== From abaine at common-lisp.net Mon Jun 11 03:10:18 2007 From: abaine at common-lisp.net (abaine at common-lisp.net) Date: Sun, 10 Jun 2007 23:10:18 -0400 (EDT) Subject: [funds-cvs] r5 - trunk/funds/src Message-ID: <20070611031018.4925C55352@common-lisp.net> Author: abaine Date: Sun Jun 10 23:10:17 2007 New Revision: 5 Modified: trunk/funds/src/funds.asd Log: Added defsystem form Modified: trunk/funds/src/funds.asd ============================================================================== --- trunk/funds/src/funds.asd (original) +++ trunk/funds/src/funds.asd Sun Jun 10 23:10:17 2007 @@ -0,0 +1,13 @@ + +;;;; -*- Lisp -*- + +(defpackage #:funds-asd + (:use :cl :asdf)) + +(in-package :funds-asd) + +(defsystem funds + :components ((:file "package") + (:module trees + :components ((:file "avl-tree")) + :depends-on ("package")))) From abaine at common-lisp.net Mon Jun 11 21:58:22 2007 From: abaine at common-lisp.net (abaine at common-lisp.net) Date: Mon, 11 Jun 2007 17:58:22 -0400 (EDT) Subject: [funds-cvs] r6 - trunk/funds/src/trees Message-ID: <20070611215822.23FD983049@common-lisp.net> Author: abaine Date: Mon Jun 11 17:58:22 2007 New Revision: 6 Modified: trunk/funds/src/trees/avl-tree.lisp Log: Initial version of avl-tree.lisp Modified: trunk/funds/src/trees/avl-tree.lisp ============================================================================== --- trunk/funds/src/trees/avl-tree.lisp (original) +++ trunk/funds/src/trees/avl-tree.lisp Mon Jun 11 17:58:22 2007 @@ -0,0 +1,85 @@ + +(in-package :funds) + +(defstruct avl + height + key + value + left + right) + +(defun make-avl () + nil) + +(defun avl-insert (tree key value) + (cond ((null tree) (make-avl :height 1 + :key key + :value value + :left nil + :right nil)) + ((< key (avl-key tree)) (left-insert tree)) + (t (right-insert tree)))) + +(defun left-insert (tree key value) + (let* ((left (avl-insert (avl-left tree))) + (right (avl-right tree))) + (if (imbalanced left right) + (if (left-heavy left) + (right-rotate left tree right) + (right-rotate (left-rotate left (avl-left left) ) + tree + right) + ()) + (make-avl :height (parent-height left right) + :key (avl-key tree) + :value (avl-value tree) + :left left + :right right)))) + +(defun right-rotate (b c t3) + (let ((a (avl-left b)) + (new-c (make-avl :height (avl-height c); not sure if this needs to be recalculated + :key (avl-key c) + :value (avl-value c) + :left (avl-right b) + :right t3))) + (make-avl :height (parent-height a new-c) + :key (avl-key b) + :value (avl-value b) + :left a + :right new-c))) + +(defun left-rotate (t0 a b) + (let ((c (avl-right b)) + (new-a (make-avl :height (avl-height a) + :key (avl-key a) + :value (avl-value a) + :left t0 + :right (avl-left b)))) + (make-avl :height (parent-height (new-a) c) + :key (avl-key b) + :value (avl-value b) + :left new-a + :right c))) + +(defun imbalanced (left right) + (> (abs (- (height right) (height left))) + 1)) + +(defun left-heavy (tree) + (< (balance-factor tree) 0)) + +(defun right-heavy (tree) + (> (balance-factor tree) 0)) + +(defun right-insert (tree key value) + ()) + +(defun balance-factor (tree) + (- (height (avl-right tree)) + (height (avl-left tree)))) + +(defun height (tree) + (if (null tree) + 0 + (avl-height tree))) From abaine at common-lisp.net Tue Jun 12 14:11:16 2007 From: abaine at common-lisp.net (abaine at common-lisp.net) Date: Tue, 12 Jun 2007 10:11:16 -0400 (EDT) Subject: [funds-cvs] r7 - trunk/funds/src/trees Message-ID: <20070612141116.381441008@common-lisp.net> Author: abaine Date: Tue Jun 12 10:11:16 2007 New Revision: 7 Modified: trunk/funds/src/trees/avl-tree.lisp Log: avl insertion now seems to work. Modified: trunk/funds/src/trees/avl-tree.lisp ============================================================================== --- trunk/funds/src/trees/avl-tree.lisp (original) +++ trunk/funds/src/trees/avl-tree.lisp Tue Jun 12 10:11:16 2007 @@ -8,60 +8,79 @@ left right) -(defun make-avl () +(defun make-avl-tree () nil) (defun avl-insert (tree key value) - (cond ((null tree) (make-avl :height 1 - :key key - :value value - :left nil - :right nil)) - ((< key (avl-key tree)) (left-insert tree)) - (t (right-insert tree)))) + (cond ((avl-empty tree) (make-avl :height 1 + :key key + :value value + :left nil + :right nil)) + ((< key (avl-key tree)) (left-insert tree key value)) + (t (right-insert tree key value)))) + +(defun avl-empty (tree) + (null tree)) (defun left-insert (tree key value) - (let* ((left (avl-insert (avl-left tree))) - (right (avl-right tree))) + (let ((left (avl-insert (avl-left tree) key value)) + (right (avl-right tree))) (if (imbalanced left right) (if (left-heavy left) (right-rotate left tree right) - (right-rotate (left-rotate left (avl-left left) ) + (right-rotate (left-rotate (avl-left left) + left + (avl-right left)) tree - right) - ()) + right)) (make-avl :height (parent-height left right) :key (avl-key tree) :value (avl-value tree) :left left :right right)))) -(defun right-rotate (b c t3) - (let ((a (avl-left b)) - (new-c (make-avl :height (avl-height c); not sure if this needs to be recalculated - :key (avl-key c) - :value (avl-value c) - :left (avl-right b) - :right t3))) - (make-avl :height (parent-height a new-c) - :key (avl-key b) - :value (avl-value b) - :left a - :right new-c))) +(defun right-insert (tree key value) + (let ((right (avl-insert (avl-right tree) key value)) + (left (avl-left tree))) + (if (imbalanced left right) + (if (right-heavy right) + (left-rotate left tree right) + (left-rotate (right-rotate (avl-right right) + right + (avl-left right)))) + (make-avl :height (parent-height left right) + :key (avl-key tree) + :value (avl-value tree) + :left left + :right right)))) (defun left-rotate (t0 a b) (let ((c (avl-right b)) - (new-a (make-avl :height (avl-height a) + (new-a (make-avl :height (1- (avl-height a)) ; re-calculate? :key (avl-key a) :value (avl-value a) :left t0 :right (avl-left b)))) - (make-avl :height (parent-height (new-a) c) + (make-avl :height (1+ (avl-height new-a)) :key (avl-key b) :value (avl-value b) :left new-a :right c))) +(defun right-rotate (b c t3) + (let ((a (avl-left b)) + (new-c (make-avl :height (1- (avl-height c)); re-calculate? + :key (avl-key c) + :value (avl-value c) + :left (avl-right b) + :right t3))) + (make-avl :height (1+ (avl-height new-c)) ; re-calculate? + :key (avl-key b) + :value (avl-value b) + :left a + :right new-c))) + (defun imbalanced (left right) (> (abs (- (height right) (height left))) 1)) @@ -72,9 +91,6 @@ (defun right-heavy (tree) (> (balance-factor tree) 0)) -(defun right-insert (tree key value) - ()) - (defun balance-factor (tree) (- (height (avl-right tree)) (height (avl-left tree)))) @@ -83,3 +99,8 @@ (if (null tree) 0 (avl-height tree))) + +(defun parent-height (left right) + (let ((a (height left)) + (b (height right))) + (1+ (if (> a b) a b)))) From abaine at common-lisp.net Wed Jun 13 23:12:13 2007 From: abaine at common-lisp.net (abaine at common-lisp.net) Date: Wed, 13 Jun 2007 19:12:13 -0400 (EDT) Subject: [funds-cvs] r8 - trunk/funds/src/trees Message-ID: <20070613231213.2876149051@common-lisp.net> Author: abaine Date: Wed Jun 13 19:12:10 2007 New Revision: 8 Added: trunk/funds/src/trees/package.lisp Log: funds-trees package Added: trunk/funds/src/trees/package.lisp ============================================================================== --- (empty file) +++ trunk/funds/src/trees/package.lisp Wed Jun 13 19:12:10 2007 @@ -0,0 +1,16 @@ + +(in-package :cl-user) + +(defpackage :funds-trees + (:use :cl) + (:export ; AVL Tree public interface + :empty-avl-tree + :avl-empty-p + :avl-insert + :avl-remove + + :avl-key + :avl-value + :avl-height + :avl-left + :avl-right)) From abaine at common-lisp.net Thu Jun 14 02:04:25 2007 From: abaine at common-lisp.net (abaine at common-lisp.net) Date: Wed, 13 Jun 2007 22:04:25 -0400 (EDT) Subject: [funds-cvs] r9 - trunk/funds/src Message-ID: <20070614020425.7C86D4B02D@common-lisp.net> Author: abaine Date: Wed Jun 13 22:04:25 2007 New Revision: 9 Modified: trunk/funds/src/package.lisp Log: formatting changes Modified: trunk/funds/src/package.lisp ============================================================================== --- trunk/funds/src/package.lisp (original) +++ trunk/funds/src/package.lisp Wed Jun 13 22:04:25 2007 @@ -1,3 +1,5 @@ +(in-package :cl-user) + (defpackage :funds - (:use :common-lisp)) \ No newline at end of file + (:use :common-lisp)) From abaine at common-lisp.net Thu Jun 14 02:07:48 2007 From: abaine at common-lisp.net (abaine at common-lisp.net) Date: Wed, 13 Jun 2007 22:07:48 -0400 (EDT) Subject: [funds-cvs] r10 - trunk/funds/src/trees Message-ID: <20070614020748.A3BB81D0DD@common-lisp.net> Author: abaine Date: Wed Jun 13 22:07:48 2007 New Revision: 10 Modified: trunk/funds/src/trees/avl-tree.lisp Log: Added comments and fixed problem with right-rotate. Modified: trunk/funds/src/trees/avl-tree.lisp ============================================================================== --- trunk/funds/src/trees/avl-tree.lisp (original) +++ trunk/funds/src/trees/avl-tree.lisp Wed Jun 13 22:07:48 2007 @@ -1,29 +1,35 @@ -(in-package :funds) +(in-package :funds-trees) (defstruct avl - height + ht key value left right) -(defun make-avl-tree () +(defun empty-avl-tree () + "An empty AVL Tree." nil) +(defun avl-empty-p (tree) + "Whether the given AVL Tree is empty: +t if it is empty; nil else." + (null tree)) + (defun avl-insert (tree key value) - (cond ((avl-empty tree) (make-avl :height 1 - :key key - :value value - :left nil - :right nil)) + (cond ((avl-empty-p tree) (make-avl :ht 1 + :key key + :value value + :left nil + :right nil)) ((< key (avl-key tree)) (left-insert tree key value)) (t (right-insert tree key value)))) -(defun avl-empty (tree) - (null tree)) - (defun left-insert (tree key value) + "The AVL tree that results when the given key-value pair is inserted +into left sub-tree of the given AVL tree. Only non-empty avl-trees +should be supplied as arguments." (let ((left (avl-insert (avl-left tree) key value)) (right (avl-right tree))) (if (imbalanced left right) @@ -34,22 +40,27 @@ (avl-right left)) tree right)) - (make-avl :height (parent-height left right) + (make-avl :ht (parent-height left right) :key (avl-key tree) :value (avl-value tree) :left left :right right)))) (defun right-insert (tree key value) + "The AVL tree that results when the given key-value pair is inserted +into the right sub-tree of the given AVL tree. Only non-empty avl-trees +should be supplied as the tree argument." (let ((right (avl-insert (avl-right tree) key value)) (left (avl-left tree))) (if (imbalanced left right) (if (right-heavy right) (left-rotate left tree right) - (left-rotate (right-rotate (avl-right right) + (left-rotate left + tree + (right-rotate (avl-left right) right - (avl-left right)))) - (make-avl :height (parent-height left right) + (avl-right right)))) + (make-avl :ht (parent-height left right) :key (avl-key tree) :value (avl-value tree) :left left @@ -57,12 +68,12 @@ (defun left-rotate (t0 a b) (let ((c (avl-right b)) - (new-a (make-avl :height (1- (avl-height a)) ; re-calculate? + (new-a (make-avl :ht (1- (avl-ht a)) ; re-calculate? :key (avl-key a) :value (avl-value a) :left t0 :right (avl-left b)))) - (make-avl :height (1+ (avl-height new-a)) + (make-avl :ht (1+ (avl-ht new-a)) :key (avl-key b) :value (avl-value b) :left new-a @@ -70,37 +81,50 @@ (defun right-rotate (b c t3) (let ((a (avl-left b)) - (new-c (make-avl :height (1- (avl-height c)); re-calculate? + (new-c (make-avl :ht (1- (avl-ht c)); re-calculate? :key (avl-key c) :value (avl-value c) :left (avl-right b) :right t3))) - (make-avl :height (1+ (avl-height new-c)) ; re-calculate? + (make-avl :ht (1+ (avl-ht new-c)) ; re-calculate? :key (avl-key b) :value (avl-value b) :left a :right new-c))) (defun imbalanced (left right) - (> (abs (- (height right) (height left))) - 1)) + "Whether the heights of the given sub-trees differ, +in their absolute values, by more than one." + (> (abs (height-difference left right)) 1)) + +(defun height-difference (a b) + "The difference in heights of the given sub-trees." + (- (avl-height a) (avl-height b))) + +(defun avl-height (tree) + "The height of the given AVL Tree." + (if (avl-empty-p tree) + 0 + (avl-ht tree))) (defun left-heavy (tree) + "Whether the given imbalanced AVL Tree has a left sub-tree +taller than its right sub-tree." (< (balance-factor tree) 0)) (defun right-heavy (tree) + "Whether the given imbalanced AVL Tre has a right sub-tree +taller than its left sub-tree." (> (balance-factor tree) 0)) (defun balance-factor (tree) - (- (height (avl-right tree)) - (height (avl-left tree)))) - -(defun height (tree) - (if (null tree) - 0 - (avl-height tree))) + "The difference in heights of the right sub-tree and left +sub-tree of the given AVL Tree." + (height-difference (avl-right tree) + (avl-left tree))) (defun parent-height (left right) - (let ((a (height left)) - (b (height right))) + "The height of the parent of the given sub-trees." + (let ((a (avl-height left)) + (b (avl-height right))) (1+ (if (> a b) a b)))) From abaine at common-lisp.net Thu Jun 14 02:08:32 2007 From: abaine at common-lisp.net (abaine at common-lisp.net) Date: Wed, 13 Jun 2007 22:08:32 -0400 (EDT) Subject: [funds-cvs] r11 - trunk/funds/src Message-ID: <20070614020832.A4E9131092@common-lisp.net> Author: abaine Date: Wed Jun 13 22:08:32 2007 New Revision: 11 Modified: trunk/funds/src/funds.asd Log: Added lisp-unit dependency Modified: trunk/funds/src/funds.asd ============================================================================== --- trunk/funds/src/funds.asd (original) +++ trunk/funds/src/funds.asd Wed Jun 13 22:08:32 2007 @@ -1,13 +1,21 @@ ;;;; -*- Lisp -*- +(in-package :cl-user) + (defpackage #:funds-asd (:use :cl :asdf)) (in-package :funds-asd) (defsystem funds - :components ((:file "package") - (:module trees - :components ((:file "avl-tree")) - :depends-on ("package")))) + :serial t + :components ((:module trees + :serial t + :components ((:file "package") + (:file "avl-tree") + (:module "tests" + :components ((:file "package") + (:file "avl-tree-test"))))) + (:file "package")) + :depends-on (:lisp-unit)) From abaine at common-lisp.net Thu Jun 14 02:09:33 2007 From: abaine at common-lisp.net (abaine at common-lisp.net) Date: Wed, 13 Jun 2007 22:09:33 -0400 (EDT) Subject: [funds-cvs] r12 - trunk/funds/src/trees/tests Message-ID: <20070614020933.B7A6131033@common-lisp.net> Author: abaine Date: Wed Jun 13 22:09:33 2007 New Revision: 12 Added: trunk/funds/src/trees/tests/ trunk/funds/src/trees/tests/avl-tree-test.lisp trunk/funds/src/trees/tests/package.lisp Log: Began to implement unit tests for AVL Trees Added: trunk/funds/src/trees/tests/avl-tree-test.lisp ============================================================================== --- (empty file) +++ trunk/funds/src/trees/tests/avl-tree-test.lisp Wed Jun 13 22:09:33 2007 @@ -0,0 +1,32 @@ + +(in-package :funds-trees-tests) + +(defun random-tree () + (reduce #'(lambda (tr v) + (avl-insert tr v v)) + (loop for i below 100 collect (random 10000)) + :initial-value (empty-avl-tree))) + +(define-test empty-avl-tree + (assert-true (avl-empty-p (empty-avl-tree))) + (assert-equal 0 (avl-height (empty-avl-tree)))) + + +(define-test avl-insert + (assert-true (balanced (random-tree)))) + +(defun balanced (tree) + (or (avl-empty-p tree) + (and (balanced (avl-left tree)) + (balanced (avl-right tree)) + (< -2 (- (avl-height (avl-left tree)) + (avl-height (avl-right tree))) + 2)))) + + +(defun root-height-correct (tree) + (let* ((a (avl-height (avl-left tree))) + (b (avl-height (avl-right tree))) + (c (if (> a b) a b))) + (eql (1+ c) (avl-height tree)))) + Added: trunk/funds/src/trees/tests/package.lisp ============================================================================== --- (empty file) +++ trunk/funds/src/trees/tests/package.lisp Wed Jun 13 22:09:33 2007 @@ -0,0 +1,7 @@ + +(in-package :cl-user) + +(defpackage funds-trees-tests + (:use :cl + :funds-trees + :lisp-unit)) From abaine at common-lisp.net Fri Jun 15 15:56:03 2007 From: abaine at common-lisp.net (abaine at common-lisp.net) Date: Fri, 15 Jun 2007 11:56:03 -0400 (EDT) Subject: [funds-cvs] r13 - trunk/public_html Message-ID: <20070615155603.5CE79D001@common-lisp.net> Author: abaine Date: Fri Jun 15 11:56:02 2007 New Revision: 13 Modified: trunk/public_html/index.html Log: Changed CVS header to SVN Modified: trunk/public_html/index.html ============================================================================== --- trunk/public_html/index.html (original) +++ trunk/public_html/index.html Fri Jun 15 11:56:02 2007 @@ -50,17 +50,13 @@ Andrew Baine -

CVS

Subversion

You can browse our Subversion repository or download the current development tree via anonymous SVN, as described here

- From abaine at common-lisp.net Fri Jun 15 17:57:14 2007 From: abaine at common-lisp.net (abaine at common-lisp.net) Date: Fri, 15 Jun 2007 13:57:14 -0400 (EDT) Subject: [funds-cvs] r14 - trunk/funds/src/trees/tests Message-ID: <20070615175714.073956200B@common-lisp.net> Author: abaine Date: Fri Jun 15 13:57:14 2007 New Revision: 14 Modified: trunk/funds/src/trees/tests/avl-tree-test.lisp Log: Wrote unit tests for insert and empty Modified: trunk/funds/src/trees/tests/avl-tree-test.lisp ============================================================================== --- trunk/funds/src/trees/tests/avl-tree-test.lisp (original) +++ trunk/funds/src/trees/tests/avl-tree-test.lisp Fri Jun 15 13:57:14 2007 @@ -4,29 +4,80 @@ (defun random-tree () (reduce #'(lambda (tr v) (avl-insert tr v v)) - (loop for i below 100 collect (random 10000)) + (loop for i below 20 collect (random 10)) :initial-value (empty-avl-tree))) -(define-test empty-avl-tree - (assert-true (avl-empty-p (empty-avl-tree))) - (assert-equal 0 (avl-height (empty-avl-tree)))) - +(defmacro assert-avl-valid (tree) + `(progn + (assert-true (height-correct-p ,tree) ,tree) + (assert-true (balanced-p ,tree) ,tree) + (assert-true (ordered-p ,tree) ,tree))) -(define-test avl-insert - (assert-true (balanced (random-tree)))) +(define-test test-avl-empty-p + (assert-true (avl-empty-p (empty-avl-tree))) + (assert-avl-valid (empty-avl-tree))) -(defun balanced (tree) +(define-test test-avl-insert + (let ((tree (random-tree))) + (assert-avl-valid tree))) + +(defun height-correct-p (tree) + "Whether (avl-height tree) returns the correct height of the given +AVL Tree. The height is correct if (a) the tree is empty and zero +is returned or (b) each of the following is true: + 1. the height of the left sub-tree is correct; + 2. the height of the right sub-tree is correct; + 3. the height of the given tree is 1 more than the greater + of the heights of the left and right sub-trees." + (if (avl-empty-p tree) + (zerop (avl-height tree)) + (and (height-correct-p (avl-left tree)) + (height-correct-p (avl-right tree)) + (let* ((a (avl-height (avl-left tree))) + (b (avl-height (avl-right tree))) + (c (if (> a b) a b))) + (eql (1+ c) (avl-height tree)))))) + +(defun balanced-p (tree) + "Whether the given AVL Tree is properly balanced. To be balanced, +the tree must be either (a) empty or (b) have left and right sub-trees +that differ in height by no more than 1." (or (avl-empty-p tree) - (and (balanced (avl-left tree)) - (balanced (avl-right tree)) + (and (balanced-p (avl-left tree)) + (balanced-p (avl-right tree)) (< -2 (- (avl-height (avl-left tree)) (avl-height (avl-right tree))) 2)))) - -(defun root-height-correct (tree) - (let* ((a (avl-height (avl-left tree))) - (b (avl-height (avl-right tree))) - (c (if (> a b) a b))) - (eql (1+ c) (avl-height tree)))) - +(defun ordered-p (tree &optional (less-than #'<)) + "Whether this AVL tree is properly ordered. To be ordered, +the tree must be either (a) empty or (b) satisfy each of the following +requirements: + + 1. the left sub-tree is properly ordered; + 2. the right sub-tree is properly ordered; + 3. every key in the left sub-tree is less than + the root key; and + 4. every key in the right sub-tree is not less + than the root key." + (or (avl-empty-p tree) + (and (ordered-p (avl-left tree)) + (ordered-p (avl-right tree)) + (or (avl-empty-p (avl-left tree)) + (not (funcall less-than (avl-key tree) + (greatest-key (avl-left tree))))) + (or (avl-empty-p (avl-right tree)) + (not (funcall less-than (least-key (avl-right tree)) + (avl-key tree))))))) + +(defun least-key (tree) + "The least key in a properly ordered AVL tree." + (if (avl-empty-p (avl-left tree)) + (avl-key tree) + (least-key (avl-left tree)))) + +(defun greatest-key (tree) + "The greatest key in a properly ordered AVL tree." + (if (avl-empty-p (avl-right tree)) + (avl-key tree) + (greatest-key (avl-right tree)))) From abaine at common-lisp.net Fri Jun 15 18:29:02 2007 From: abaine at common-lisp.net (abaine at common-lisp.net) Date: Fri, 15 Jun 2007 14:29:02 -0400 (EDT) Subject: [funds-cvs] r15 - trunk/funds/src/trees Message-ID: <20070615182902.5B476100A@common-lisp.net> Author: abaine Date: Fri Jun 15 14:29:02 2007 New Revision: 15 Modified: trunk/funds/src/trees/package.lisp Log: Renamed trees package to funds.trees Modified: trunk/funds/src/trees/package.lisp ============================================================================== --- trunk/funds/src/trees/package.lisp (original) +++ trunk/funds/src/trees/package.lisp Fri Jun 15 14:29:02 2007 @@ -1,7 +1,7 @@ (in-package :cl-user) -(defpackage :funds-trees +(defpackage :funds.trees (:use :cl) (:export ; AVL Tree public interface :empty-avl-tree From abaine at common-lisp.net Fri Jun 15 18:29:33 2007 From: abaine at common-lisp.net (abaine at common-lisp.net) Date: Fri, 15 Jun 2007 14:29:33 -0400 (EDT) Subject: [funds-cvs] r16 - trunk/funds/src/trees Message-ID: <20070615182933.B09FE7080@common-lisp.net> Author: abaine Date: Fri Jun 15 14:29:33 2007 New Revision: 16 Modified: trunk/funds/src/trees/avl-tree.lisp Log: Renamed trees package to funds.trees Modified: trunk/funds/src/trees/avl-tree.lisp ============================================================================== --- trunk/funds/src/trees/avl-tree.lisp (original) +++ trunk/funds/src/trees/avl-tree.lisp Fri Jun 15 14:29:33 2007 @@ -1,5 +1,5 @@ -(in-package :funds-trees) +(in-package :funds.trees) (defstruct avl ht From abaine at common-lisp.net Fri Jun 15 18:30:16 2007 From: abaine at common-lisp.net (abaine at common-lisp.net) Date: Fri, 15 Jun 2007 14:30:16 -0400 (EDT) Subject: [funds-cvs] r17 - trunk/funds/src Message-ID: <20070615183016.8C3C9A149@common-lisp.net> Author: abaine Date: Fri Jun 15 14:30:15 2007 New Revision: 17 Modified: trunk/funds/src/funds.asd Log: Rewrote defsystem form to account for changed directory structure Modified: trunk/funds/src/funds.asd ============================================================================== --- trunk/funds/src/funds.asd (original) +++ trunk/funds/src/funds.asd Fri Jun 15 14:30:15 2007 @@ -13,8 +13,12 @@ :components ((:module trees :serial t :components ((:file "package") - (:file "avl-tree") - (:module "tests" + (:file "avl-tree"))) + + (:module tests + :serial t + :components ((:module trees + :serial t :components ((:file "package") (:file "avl-tree-test"))))) (:file "package")) From abaine at common-lisp.net Fri Jun 15 18:34:07 2007 From: abaine at common-lisp.net (abaine at common-lisp.net) Date: Fri, 15 Jun 2007 14:34:07 -0400 (EDT) Subject: [funds-cvs] r18 - in trunk/funds/src: tests trees/tests Message-ID: <20070615183407.BE60513025@common-lisp.net> Author: abaine Date: Fri Jun 15 14:34:07 2007 New Revision: 18 Added: trunk/funds/src/tests/ - copied from r17, trunk/funds/src/trees/tests/ Removed: trunk/funds/src/trees/tests/ Log: Fixed directory structure. From abaine at common-lisp.net Fri Jun 15 18:38:39 2007 From: abaine at common-lisp.net (abaine at common-lisp.net) Date: Fri, 15 Jun 2007 14:38:39 -0400 (EDT) Subject: [funds-cvs] r19 - in trunk/funds/src/tests: . trees Message-ID: <20070615183839.8A8F81303B@common-lisp.net> Author: abaine Date: Fri Jun 15 14:38:39 2007 New Revision: 19 Added: trunk/funds/src/tests/trees/ trunk/funds/src/tests/trees/avl-tree-test.lisp - copied unchanged from r18, trunk/funds/src/tests/avl-tree-test.lisp trunk/funds/src/tests/trees/package.lisp - copied unchanged from r18, trunk/funds/src/tests/package.lisp Removed: trunk/funds/src/tests/avl-tree-test.lisp trunk/funds/src/tests/package.lisp Log: Now I think I've really fixed the directory structure? From abaine at common-lisp.net Fri Jun 15 18:40:49 2007 From: abaine at common-lisp.net (abaine at common-lisp.net) Date: Fri, 15 Jun 2007 14:40:49 -0400 (EDT) Subject: [funds-cvs] r20 - trunk/funds/src/tests/trees Message-ID: <20070615184049.7EA822608F@common-lisp.net> Author: abaine Date: Fri Jun 15 14:40:49 2007 New Revision: 20 Modified: trunk/funds/src/tests/trees/package.lisp Log: Fixed package name Modified: trunk/funds/src/tests/trees/package.lisp ============================================================================== --- trunk/funds/src/tests/trees/package.lisp (original) +++ trunk/funds/src/tests/trees/package.lisp Fri Jun 15 14:40:49 2007 @@ -3,5 +3,5 @@ (defpackage funds-trees-tests (:use :cl - :funds-trees + :funds.trees :lisp-unit)) From abaine at common-lisp.net Fri Jun 15 18:48:45 2007 From: abaine at common-lisp.net (abaine at common-lisp.net) Date: Fri, 15 Jun 2007 14:48:45 -0400 (EDT) Subject: [funds-cvs] r21 - trunk/funds/src/tests/trees Message-ID: <20070615184845.7DC5B3604C@common-lisp.net> Author: abaine Date: Fri Jun 15 14:48:45 2007 New Revision: 21 Modified: trunk/funds/src/tests/trees/avl-tree-test.lisp trunk/funds/src/tests/trees/package.lisp Log: Renamed funds-trees-tests to funds.tests.trees Modified: trunk/funds/src/tests/trees/avl-tree-test.lisp ============================================================================== --- trunk/funds/src/tests/trees/avl-tree-test.lisp (original) +++ trunk/funds/src/tests/trees/avl-tree-test.lisp Fri Jun 15 14:48:45 2007 @@ -1,5 +1,5 @@ -(in-package :funds-trees-tests) +(in-package :funds.tests.trees) (defun random-tree () (reduce #'(lambda (tr v) Modified: trunk/funds/src/tests/trees/package.lisp ============================================================================== --- trunk/funds/src/tests/trees/package.lisp (original) +++ trunk/funds/src/tests/trees/package.lisp Fri Jun 15 14:48:45 2007 @@ -1,7 +1,7 @@ (in-package :cl-user) -(defpackage funds-trees-tests +(defpackage funds.tests.trees (:use :cl :funds.trees :lisp-unit)) From abaine at common-lisp.net Wed Jun 20 15:45:05 2007 From: abaine at common-lisp.net (abaine at common-lisp.net) Date: Wed, 20 Jun 2007 11:45:05 -0400 (EDT) Subject: [funds-cvs] r22 - in trunk/funds/tests: . trees Message-ID: <20070620154505.88A4E4E00F@common-lisp.net> Author: abaine Date: Wed Jun 20 11:45:04 2007 New Revision: 22 Added: trunk/funds/tests/ - copied from r18, trunk/funds/src/tests/ trunk/funds/tests/trees/ - copied from r19, trunk/funds/src/tests/trees/ trunk/funds/tests/trees/avl-tree-test.lisp - copied unchanged from r21, trunk/funds/src/tests/trees/avl-tree-test.lisp trunk/funds/tests/trees/package.lisp - copied unchanged from r21, trunk/funds/src/tests/trees/package.lisp Removed: trunk/funds/tests/avl-tree-test.lisp trunk/funds/tests/package.lisp Log: Moved tests directory to project root From abaine at common-lisp.net Wed Jun 20 15:50:29 2007 From: abaine at common-lisp.net (abaine at common-lisp.net) Date: Wed, 20 Jun 2007 11:50:29 -0400 (EDT) Subject: [funds-cvs] r23 - trunk/funds/src/tests Message-ID: <20070620155029.D857E31033@common-lisp.net> Author: abaine Date: Wed Jun 20 11:50:29 2007 New Revision: 23 Removed: trunk/funds/src/tests/ Log: Deleted old tests directory. From abaine at common-lisp.net Wed Jun 20 15:56:54 2007 From: abaine at common-lisp.net (abaine at common-lisp.net) Date: Wed, 20 Jun 2007 11:56:54 -0400 (EDT) Subject: [funds-cvs] r24 - trunk/funds/src Message-ID: <20070620155654.AFE9B4E03C@common-lisp.net> Author: abaine Date: Wed Jun 20 11:56:54 2007 New Revision: 24 Modified: trunk/funds/src/funds.asd Log: Removed test modules from defsystem form. Modified: trunk/funds/src/funds.asd ============================================================================== --- trunk/funds/src/funds.asd (original) +++ trunk/funds/src/funds.asd Wed Jun 20 11:56:54 2007 @@ -13,13 +13,5 @@ :components ((:module trees :serial t :components ((:file "package") - (:file "avl-tree"))) - - (:module tests - :serial t - :components ((:module trees - :serial t - :components ((:file "package") - (:file "avl-tree-test"))))) - (:file "package")) - :depends-on (:lisp-unit)) + (:file "avl-tree"))) + (:file "package"))) From abaine at common-lisp.net Wed Jun 20 15:57:33 2007 From: abaine at common-lisp.net (abaine at common-lisp.net) Date: Wed, 20 Jun 2007 11:57:33 -0400 (EDT) Subject: [funds-cvs] r25 - trunk/funds/tests Message-ID: <20070620155733.1ED2F5201E@common-lisp.net> Author: abaine Date: Wed Jun 20 11:57:32 2007 New Revision: 25 Added: trunk/funds/tests/funds-tests.asd Log: Created new test system and added trees tests. Added: trunk/funds/tests/funds-tests.asd ============================================================================== --- (empty file) +++ trunk/funds/tests/funds-tests.asd Wed Jun 20 11:57:32 2007 @@ -0,0 +1,17 @@ + +;;;; -*- Lisp -*- + +(in-package :cl-user) + +(defpackage #:funds-tests-asd + (:use :cl :asdf)) + +(in-package #:funds-tests-asd) + +(defsystem funds-tests + :serial t + :components ((:module trees + :serial t + :components ((:file "package") + (:file "avl-tree-test")))) + :depends-on (:lisp-unit)) From abaine at common-lisp.net Wed Jun 20 16:14:34 2007 From: abaine at common-lisp.net (abaine at common-lisp.net) Date: Wed, 20 Jun 2007 12:14:34 -0400 (EDT) Subject: [funds-cvs] r26 - trunk/funds/tests Message-ID: <20070620161434.114391A0A4@common-lisp.net> Author: abaine Date: Wed Jun 20 12:14:34 2007 New Revision: 26 Modified: trunk/funds/tests/funds-tests.asd Log: Added funds dependency. Modified: trunk/funds/tests/funds-tests.asd ============================================================================== --- trunk/funds/tests/funds-tests.asd (original) +++ trunk/funds/tests/funds-tests.asd Wed Jun 20 12:14:34 2007 @@ -14,4 +14,5 @@ :serial t :components ((:file "package") (:file "avl-tree-test")))) - :depends-on (:lisp-unit)) + :depends-on (:funds + :lisp-unit)) From abaine at common-lisp.net Wed Jun 20 16:15:01 2007 From: abaine at common-lisp.net (abaine at common-lisp.net) Date: Wed, 20 Jun 2007 12:15:01 -0400 (EDT) Subject: [funds-cvs] r27 - trunk/funds/tests/trees Message-ID: <20070620161501.10F611A0A4@common-lisp.net> Author: abaine Date: Wed Jun 20 12:15:00 2007 New Revision: 27 Modified: trunk/funds/tests/trees/avl-tree-test.lisp Log: Changed a couple of comments. Modified: trunk/funds/tests/trees/avl-tree-test.lisp ============================================================================== --- trunk/funds/tests/trees/avl-tree-test.lisp (original) +++ trunk/funds/tests/trees/avl-tree-test.lisp Wed Jun 20 12:15:00 2007 @@ -29,14 +29,14 @@ 2. the height of the right sub-tree is correct; 3. the height of the given tree is 1 more than the greater of the heights of the left and right sub-trees." - (if (avl-empty-p tree) - (zerop (avl-height tree)) - (and (height-correct-p (avl-left tree)) - (height-correct-p (avl-right tree)) + (or (and (avl-empty-p tree) + (zerop (avl-height tree))) ; (a) + (and (height-correct-p (avl-left tree)) ; (1) + (height-correct-p (avl-right tree)) ; (2) (let* ((a (avl-height (avl-left tree))) (b (avl-height (avl-right tree))) (c (if (> a b) a b))) - (eql (1+ c) (avl-height tree)))))) + (eql (1+ c) (avl-height tree)))))) ; (3) (defun balanced-p (tree) "Whether the given AVL Tree is properly balanced. To be balanced, From abaine at common-lisp.net Wed Jun 20 16:27:21 2007 From: abaine at common-lisp.net (abaine at common-lisp.net) Date: Wed, 20 Jun 2007 12:27:21 -0400 (EDT) Subject: [funds-cvs] r28 - trunk/funds/src/trees Message-ID: <20070620162721.9D71E1D018@common-lisp.net> Author: abaine Date: Wed Jun 20 12:27:20 2007 New Revision: 28 Modified: trunk/funds/src/trees/avl-tree.lisp Log: Changed avl-insert signature to accept keyword arguments test and order Modified: trunk/funds/src/trees/avl-tree.lisp ============================================================================== --- trunk/funds/src/trees/avl-tree.lisp (original) +++ trunk/funds/src/trees/avl-tree.lisp Wed Jun 20 12:27:20 2007 @@ -17,13 +17,19 @@ t if it is empty; nil else." (null tree)) -(defun avl-insert (tree key value) +(defun avl-insert (tree key value &key (test #'eql) (order #'<)) (cond ((avl-empty-p tree) (make-avl :ht 1 :key key :value value - :left nil - :right nil)) - ((< key (avl-key tree)) (left-insert tree key value)) + :left (empty-avl-tree) + :right (empty-avl-tree))) + + ((funcall test key (avl-key tree)) (make-avl :ht (avl-ht tree) + :key key + :value value + :left (avl-left tree) + :right (avl-right tree))) + ((funcall order key (avl-key tree)) (left-insert tree key value)) (t (right-insert tree key value)))) (defun left-insert (tree key value) From abaine at common-lisp.net Wed Jun 20 16:37:54 2007 From: abaine at common-lisp.net (abaine at common-lisp.net) Date: Wed, 20 Jun 2007 12:37:54 -0400 (EDT) Subject: [funds-cvs] r29 - trunk/funds/src/trees Message-ID: <20070620163754.1F7485201E@common-lisp.net> Author: abaine Date: Wed Jun 20 12:37:53 2007 New Revision: 29 Modified: trunk/funds/src/trees/avl-tree.lisp Log: Changed left-insert and right-insert to provide for test and order arguments. Modified: trunk/funds/src/trees/avl-tree.lisp ============================================================================== --- trunk/funds/src/trees/avl-tree.lisp (original) +++ trunk/funds/src/trees/avl-tree.lisp Wed Jun 20 12:37:53 2007 @@ -29,14 +29,14 @@ :value value :left (avl-left tree) :right (avl-right tree))) - ((funcall order key (avl-key tree)) (left-insert tree key value)) - (t (right-insert tree key value)))) + ((funcall order key (avl-key tree)) (left-insert tree key value test order)) + (t (right-insert tree key value test order)))) -(defun left-insert (tree key value) +(defun left-insert (tree key value test order) "The AVL tree that results when the given key-value pair is inserted into left sub-tree of the given AVL tree. Only non-empty avl-trees should be supplied as arguments." - (let ((left (avl-insert (avl-left tree) key value)) + (let ((left (avl-insert (avl-left tree) key value :test test :order order)) (right (avl-right tree))) (if (imbalanced left right) (if (left-heavy left) @@ -52,11 +52,11 @@ :left left :right right)))) -(defun right-insert (tree key value) +(defun right-insert (tree key value test order) "The AVL tree that results when the given key-value pair is inserted into the right sub-tree of the given AVL tree. Only non-empty avl-trees should be supplied as the tree argument." - (let ((right (avl-insert (avl-right tree) key value)) + (let ((right (avl-insert (avl-right tree) key value :test test :order order)) (left (avl-left tree))) (if (imbalanced left right) (if (right-heavy right) From abaine at common-lisp.net Wed Jun 20 17:06:55 2007 From: abaine at common-lisp.net (abaine at common-lisp.net) Date: Wed, 20 Jun 2007 13:06:55 -0400 (EDT) Subject: [funds-cvs] r30 - trunk/funds/src/trees Message-ID: <20070620170655.1EBA45201E@common-lisp.net> Author: abaine Date: Wed Jun 20 13:06:54 2007 New Revision: 30 Modified: trunk/funds/src/trees/avl-tree.lisp Log: Minor semantic changes. Modified: trunk/funds/src/trees/avl-tree.lisp ============================================================================== --- trunk/funds/src/trees/avl-tree.lisp (original) +++ trunk/funds/src/trees/avl-tree.lisp Wed Jun 20 13:06:54 2007 @@ -103,6 +103,11 @@ in their absolute values, by more than one." (> (abs (height-difference left right)) 1)) +(defun balanced (left right) + "Whether the heights of the given sub-trees differ, +in their absolute values, by no more than one." + (< -2 (height-difference left right) 2)) + (defun height-difference (a b) "The difference in heights of the given sub-trees." (- (avl-height a) (avl-height b))) @@ -116,12 +121,12 @@ (defun left-heavy (tree) "Whether the given imbalanced AVL Tree has a left sub-tree taller than its right sub-tree." - (< (balance-factor tree) 0)) + (minusp (balance-factor tree))) (defun right-heavy (tree) "Whether the given imbalanced AVL Tre has a right sub-tree taller than its left sub-tree." - (> (balance-factor tree) 0)) + (plusp (balance-factor tree))) (defun balance-factor (tree) "The difference in heights of the right sub-tree and left From abaine at common-lisp.net Wed Jun 20 18:22:40 2007 From: abaine at common-lisp.net (abaine at common-lisp.net) Date: Wed, 20 Jun 2007 14:22:40 -0400 (EDT) Subject: [funds-cvs] r31 - trunk/funds/src/trees Message-ID: <20070620182240.0238B1129@common-lisp.net> Author: abaine Date: Wed Jun 20 14:22:40 2007 New Revision: 31 Modified: trunk/funds/src/trees/avl-tree.lisp Log: AVL-Insert properly documented. Modified: trunk/funds/src/trees/avl-tree.lisp ============================================================================== --- trunk/funds/src/trees/avl-tree.lisp (original) +++ trunk/funds/src/trees/avl-tree.lisp Wed Jun 20 14:22:40 2007 @@ -18,12 +18,17 @@ (null tree)) (defun avl-insert (tree key value &key (test #'eql) (order #'<)) + "The AVL Tree that results when the given key-value pair is inserted +into the given tree. If the test function determines that the given key +and the root key af the given tree are \"equal\", then a new AVL Tree is +created as if the given key-value pair replaced the root key-value pair. +The given order function, < by default, is used to determine the order of +the resulting AVL Tree." (cond ((avl-empty-p tree) (make-avl :ht 1 :key key :value value :left (empty-avl-tree) :right (empty-avl-tree))) - ((funcall test key (avl-key tree)) (make-avl :ht (avl-ht tree) :key key :value value @@ -38,7 +43,7 @@ should be supplied as arguments." (let ((left (avl-insert (avl-left tree) key value :test test :order order)) (right (avl-right tree))) - (if (imbalanced left right) + (if (imbalanced left right)n (if (left-heavy left) (right-rotate left tree right) (right-rotate (left-rotate (avl-left left) @@ -124,7 +129,7 @@ (minusp (balance-factor tree))) (defun right-heavy (tree) - "Whether the given imbalanced AVL Tre has a right sub-tree + "Whether the given imbalanced AVL Tree has a right sub-tree taller than its left sub-tree." (plusp (balance-factor tree))) From abaine at common-lisp.net Wed Jun 20 18:47:38 2007 From: abaine at common-lisp.net (abaine at common-lisp.net) Date: Wed, 20 Jun 2007 14:47:38 -0400 (EDT) Subject: [funds-cvs] r32 - trunk/funds/src/trees Message-ID: <20070620184738.88D25554BA@common-lisp.net> Author: abaine Date: Wed Jun 20 14:47:38 2007 New Revision: 32 Modified: trunk/funds/src/trees/avl-tree.lisp Log: Added avl-find-value function. Modified: trunk/funds/src/trees/avl-tree.lisp ============================================================================== --- trunk/funds/src/trees/avl-tree.lisp (original) +++ trunk/funds/src/trees/avl-tree.lisp Wed Jun 20 14:47:38 2007 @@ -43,7 +43,7 @@ should be supplied as arguments." (let ((left (avl-insert (avl-left tree) key value :test test :order order)) (right (avl-right tree))) - (if (imbalanced left right)n + (if (imbalanced left right) (if (left-heavy left) (right-rotate left tree right) (right-rotate (left-rotate (avl-left left) @@ -103,6 +103,13 @@ :left a :right new-c))) +(defun avl-find-value (tree key &key (order #'<) (test #'eql)) + (cond ((avl-empty-p tree) (values nil nil)) + ((funcall test key (avl-key tree)) (values (avl-value tree) t)) + ((funcall order key (avl-key tree)) + (avl-find-value (avl-left tree) key :order order :test test)) + (t (avl-find-value (avl-right tree) key :order order :test test)))) + (defun imbalanced (left right) "Whether the heights of the given sub-trees differ, in their absolute values, by more than one." From abaine at common-lisp.net Wed Jun 20 18:50:14 2007 From: abaine at common-lisp.net (abaine at common-lisp.net) Date: Wed, 20 Jun 2007 14:50:14 -0400 (EDT) Subject: [funds-cvs] r33 - trunk/funds/src/trees Message-ID: <20070620185014.E14CD60038@common-lisp.net> Author: abaine Date: Wed Jun 20 14:50:14 2007 New Revision: 33 Modified: trunk/funds/src/trees/avl-tree.lisp Log: Commented avl-find-value Modified: trunk/funds/src/trees/avl-tree.lisp ============================================================================== --- trunk/funds/src/trees/avl-tree.lisp (original) +++ trunk/funds/src/trees/avl-tree.lisp Wed Jun 20 14:50:14 2007 @@ -104,6 +104,10 @@ :right new-c))) (defun avl-find-value (tree key &key (order #'<) (test #'eql)) + "The value associated with the given key in the given AVL Tree. The function +returns nil if the key is not found in the given tree; a second value is returned +to indicate whether nil is returned because it is in fact the value associated with +the given key or, instead, the key could not be found." (cond ((avl-empty-p tree) (values nil nil)) ((funcall test key (avl-key tree)) (values (avl-value tree) t)) ((funcall order key (avl-key tree)) From abaine at common-lisp.net Wed Jun 20 22:25:29 2007 From: abaine at common-lisp.net (abaine at common-lisp.net) Date: Wed, 20 Jun 2007 18:25:29 -0400 (EDT) Subject: [funds-cvs] r34 - trunk/funds/src/trees Message-ID: <20070620222529.AD8CC6824C@common-lisp.net> Author: abaine Date: Wed Jun 20 18:25:29 2007 New Revision: 34 Modified: trunk/funds/src/trees/package.lisp Log: Added avl-find-value to public interface of avl-tree. Modified: trunk/funds/src/trees/package.lisp ============================================================================== --- trunk/funds/src/trees/package.lisp (original) +++ trunk/funds/src/trees/package.lisp Wed Jun 20 18:25:29 2007 @@ -8,6 +8,7 @@ :avl-empty-p :avl-insert :avl-remove + :avl-find-value :avl-key :avl-value From abaine at common-lisp.net Wed Jun 20 22:27:13 2007 From: abaine at common-lisp.net (abaine at common-lisp.net) Date: Wed, 20 Jun 2007 18:27:13 -0400 (EDT) Subject: [funds-cvs] r35 - trunk/funds/src/trees Message-ID: <20070620222713.AF5496824C@common-lisp.net> Author: abaine Date: Wed Jun 20 18:27:13 2007 New Revision: 35 Modified: trunk/funds/src/trees/avl-tree.lisp Log: Rearranged avl-tree.lisp to put public interface at top. Modified: trunk/funds/src/trees/avl-tree.lisp ============================================================================== --- trunk/funds/src/trees/avl-tree.lisp (original) +++ trunk/funds/src/trees/avl-tree.lisp Wed Jun 20 18:27:13 2007 @@ -1,12 +1,8 @@ (in-package :funds.trees) -(defstruct avl - ht - key - value - left - right) +;;;; Public Interface + (defun empty-avl-tree () "An empty AVL Tree." @@ -37,6 +33,32 @@ ((funcall order key (avl-key tree)) (left-insert tree key value test order)) (t (right-insert tree key value test order)))) +(defun avl-find-value (tree key &key (order #'<) (test #'eql)) + "The value associated with the given key in the given AVL Tree. The function +returns nil if the key is not found in the given tree; a second value is returned +to indicate whether nil is returned because it is in fact the value associated with +the given key or, instead, the key could not be found." + (cond ((avl-empty-p tree) (values nil nil)) + ((funcall test key (avl-key tree)) (values (avl-value tree) t)) + ((funcall order key (avl-key tree)) + (avl-find-value (avl-left tree) key :order order :test test)) + (t (avl-find-value (avl-right tree) key :order order :test test)))) + +(defstruct avl + ht + key + value + left + right) + +(defun avl-height (tree) + "The height of the given AVL Tree." + (if (avl-empty-p tree) + 0 + (avl-ht tree))) + +;;;; Insertion Helpers + (defun left-insert (tree key value test order) "The AVL tree that results when the given key-value pair is inserted into left sub-tree of the given AVL tree. Only non-empty avl-trees @@ -77,6 +99,8 @@ :left left :right right)))) +;;;; Rotation Functions + (defun left-rotate (t0 a b) (let ((c (avl-right b)) (new-a (make-avl :ht (1- (avl-ht a)) ; re-calculate? @@ -103,16 +127,7 @@ :left a :right new-c))) -(defun avl-find-value (tree key &key (order #'<) (test #'eql)) - "The value associated with the given key in the given AVL Tree. The function -returns nil if the key is not found in the given tree; a second value is returned -to indicate whether nil is returned because it is in fact the value associated with -the given key or, instead, the key could not be found." - (cond ((avl-empty-p tree) (values nil nil)) - ((funcall test key (avl-key tree)) (values (avl-value tree) t)) - ((funcall order key (avl-key tree)) - (avl-find-value (avl-left tree) key :order order :test test)) - (t (avl-find-value (avl-right tree) key :order order :test test)))) +;;;; AVL Tree utility functions (defun imbalanced (left right) "Whether the heights of the given sub-trees differ, @@ -128,12 +143,6 @@ "The difference in heights of the given sub-trees." (- (avl-height a) (avl-height b))) -(defun avl-height (tree) - "The height of the given AVL Tree." - (if (avl-empty-p tree) - 0 - (avl-ht tree))) - (defun left-heavy (tree) "Whether the given imbalanced AVL Tree has a left sub-tree taller than its right sub-tree." @@ -151,7 +160,7 @@ (avl-left tree))) (defun parent-height (left right) - "The height of the parent of the given sub-trees." + "The height the tree should be, whose children are the given sub-trees." (let ((a (avl-height left)) (b (avl-height right))) (1+ (if (> a b) a b)))) From abaine at common-lisp.net Wed Jun 20 22:28:07 2007 From: abaine at common-lisp.net (abaine at common-lisp.net) Date: Wed, 20 Jun 2007 18:28:07 -0400 (EDT) Subject: [funds-cvs] r36 - trunk/funds/tests/trees Message-ID: <20070620222807.0C81D6824C@common-lisp.net> Author: abaine Date: Wed Jun 20 18:28:06 2007 New Revision: 36 Modified: trunk/funds/tests/trees/avl-tree-test.lisp Log: Modified tests to include keyword arguments to avl-insert. Modified: trunk/funds/tests/trees/avl-tree-test.lisp ============================================================================== --- trunk/funds/tests/trees/avl-tree-test.lisp (original) +++ trunk/funds/tests/trees/avl-tree-test.lisp Wed Jun 20 18:28:06 2007 @@ -1,17 +1,19 @@ (in-package :funds.tests.trees) -(defun random-tree () - (reduce #'(lambda (tr v) - (avl-insert tr v v)) - (loop for i below 20 collect (random 10)) - :initial-value (empty-avl-tree))) +(defun random-tree (&key (test #'eql) (order #'<)) + (print (reduce #'(lambda (tr v) + (avl-insert tr v v :test test :order order)) + (loop for i below 40 collect (random 20)) + :initial-value (empty-avl-tree)))) -(defmacro assert-avl-valid (tree) +(defconstant +never-equal+ #'(lambda (a b) (declare (ignore a b)) nil)) + +(defmacro assert-avl-valid (tree &key (order #'<)) `(progn (assert-true (height-correct-p ,tree) ,tree) (assert-true (balanced-p ,tree) ,tree) - (assert-true (ordered-p ,tree) ,tree))) + (assert-true (ordered-p ,tree :order ,order) ,tree))) (define-test test-avl-empty-p (assert-true (avl-empty-p (empty-avl-tree))) @@ -49,7 +51,7 @@ (avl-height (avl-right tree))) 2)))) -(defun ordered-p (tree &optional (less-than #'<)) +(defun ordered-p (tree &key (order #'<)) "Whether this AVL tree is properly ordered. To be ordered, the tree must be either (a) empty or (b) satisfy each of the following requirements: @@ -64,10 +66,10 @@ (and (ordered-p (avl-left tree)) (ordered-p (avl-right tree)) (or (avl-empty-p (avl-left tree)) - (not (funcall less-than (avl-key tree) + (not (funcall order (avl-key tree) (greatest-key (avl-left tree))))) (or (avl-empty-p (avl-right tree)) - (not (funcall less-than (least-key (avl-right tree)) + (not (funcall order (least-key (avl-right tree)) (avl-key tree))))))) (defun least-key (tree)

Download

Project members

CVS

Funds

Functional Data Structures in Common Lisp

Introduction

Mailing Lists

Download

Project members

CVS

CVS

CVS

Subversion