From abaine at common-lisp.net Mon Jul 2 22:39:22 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Mon, 2 Jul 2007 18:39:22 -0400 (EDT)
Subject: [funds-cvs] r37 - trunk/funds/src/stack
Message-ID: <20070702223922.C523632027@common-lisp.net>
Author: abaine
Date: Mon Jul 2 18:39:22 2007
New Revision: 37
Added:
trunk/funds/src/stack/
trunk/funds/src/stack/stack.lisp
Log:
Initial version of stack.
Added: trunk/funds/src/stack/stack.lisp
==============================================================================
--- (empty file)
+++ trunk/funds/src/stack/stack.lisp Mon Jul 2 18:39:22 2007
@@ -0,0 +1,30 @@
+
+(in-package :funds)
+
+(defun make-stack ()
+ "An empty stack."
+ nil)
+
+(defun stack-push (item stack)
+ "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-length (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)))
From abaine at common-lisp.net Mon Jul 2 22:39:54 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Mon, 2 Jul 2007 18:39:54 -0400 (EDT)
Subject: [funds-cvs] r38 - trunk/funds/src
Message-ID: <20070702223954.D85A532027@common-lisp.net>
Author: abaine
Date: Mon Jul 2 18:39:54 2007
New Revision: 38
Modified:
trunk/funds/src/package.lisp
Log:
Added stack functions to funds public API.
Modified: trunk/funds/src/package.lisp
==============================================================================
--- trunk/funds/src/package.lisp (original)
+++ trunk/funds/src/package.lisp Mon Jul 2 18:39:54 2007
@@ -2,4 +2,9 @@
(in-package :cl-user)
(defpackage :funds
- (:use :common-lisp))
+ (:use :common-lisp)
+ (:export :make-stack
+ :stack-length
+ :stack-push
+ :stack-pop
+ :stack-empty-p))
From abaine at common-lisp.net Mon Jul 2 22:40:44 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Mon, 2 Jul 2007 18:40:44 -0400 (EDT)
Subject: [funds-cvs] r39 - trunk/funds/src
Message-ID: <20070702224044.85D0034052@common-lisp.net>
Author: abaine
Date: Mon Jul 2 18:40:44 2007
New Revision: 39
Modified:
trunk/funds/src/funds.asd
Log:
Added stack module to system definition.
Modified: trunk/funds/src/funds.asd
==============================================================================
--- trunk/funds/src/funds.asd (original)
+++ trunk/funds/src/funds.asd Mon Jul 2 18:40:44 2007
@@ -13,5 +13,8 @@
:components ((:module trees
:serial t
:components ((:file "package")
- (:file "avl-tree")))
+ (:file "avl-tree")))
+ (:module stack
+ :serial t
+ :components ((:file "stack")))
(:file "package")))
From abaine at common-lisp.net Mon Jul 2 22:58:55 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Mon, 2 Jul 2007 18:58:55 -0400 (EDT)
Subject: [funds-cvs] r40 - trunk/funds/src
Message-ID: <20070702225855.6C2323E053@common-lisp.net>
Author: abaine
Date: Mon Jul 2 18:58:55 2007
New Revision: 40
Modified:
trunk/funds/src/funds.asd
Log:
Rearranged modules in funds.asd.
Modified: trunk/funds/src/funds.asd
==============================================================================
--- trunk/funds/src/funds.asd (original)
+++ trunk/funds/src/funds.asd Mon Jul 2 18:58:55 2007
@@ -10,11 +10,11 @@
(defsystem funds
:serial t
- :components ((:module trees
+ :components ((:file "package")
+ (:module trees
:serial t
:components ((:file "package")
(:file "avl-tree")))
(:module stack
:serial t
- :components ((:file "stack")))
- (:file "package")))
+ :components ((:file "stack")))))
From abaine at common-lisp.net Mon Jul 2 22:59:43 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Mon, 2 Jul 2007 18:59:43 -0400 (EDT)
Subject: [funds-cvs] r41 - trunk/funds/src/stack
Message-ID: <20070702225943.9BF5A3E053@common-lisp.net>
Author: abaine
Date: Mon Jul 2 18:59:43 2007
New Revision: 41
Modified:
trunk/funds/src/stack/stack.lisp
Log:
Switched the order of stack-push arguments.
Modified: trunk/funds/src/stack/stack.lisp
==============================================================================
--- trunk/funds/src/stack/stack.lisp (original)
+++ trunk/funds/src/stack/stack.lisp Mon Jul 2 18:59:43 2007
@@ -5,7 +5,7 @@
"An empty stack."
nil)
-(defun stack-push (item stack)
+(defun stack-push (stack item)
"The stack that results when the given item is pushed onto the given stack."
(cons item stack))
From abaine at common-lisp.net Mon Jul 2 23:02:16 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Mon, 2 Jul 2007 19:02:16 -0400 (EDT)
Subject: [funds-cvs] r42 - trunk/funds
Message-ID: <20070702230216.1EF10431BF@common-lisp.net>
Author: abaine
Date: Mon Jul 2 19:02:15 2007
New Revision: 42
Added:
trunk/funds/license.txt
Log:
Added MIT License.
Added: trunk/funds/license.txt
==============================================================================
--- (empty file)
+++ trunk/funds/license.txt Mon Jul 2 19:02:15 2007
@@ -0,0 +1,22 @@
+
+The MIT License
+
+Copyright [c] 2007 Andrew Baine
+
+Permission is hereby granted, free of charge, to any person obtaining a copy
+of this software and associated documentation files [the "Software"], to deal
+in the Software without restriction, including without limitation the rights
+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+copies of the Software, and to permit persons to whom the Software is
+furnished to do so, subject to the following conditions:
+
+The above copyright notice and this permission notice shall be included in
+all copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
+THE SOFTWARE.
From abaine at common-lisp.net Tue Jul 3 01:00:05 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Mon, 2 Jul 2007 21:00:05 -0400 (EDT)
Subject: [funds-cvs] r43 - trunk/funds
Message-ID: <20070703010005.46CEC5D0EE@common-lisp.net>
Author: abaine
Date: Mon Jul 2 21:00:04 2007
New Revision: 43
Modified:
trunk/funds/license.txt
Log:
Changed brackets to parens.
Modified: trunk/funds/license.txt
==============================================================================
--- trunk/funds/license.txt (original)
+++ trunk/funds/license.txt Mon Jul 2 21:00:04 2007
@@ -1,10 +1,10 @@
The MIT License
-Copyright [c] 2007 Andrew Baine
+Copyright (c) 2007 Andrew Baine
Permission is hereby granted, free of charge, to any person obtaining a copy
-of this software and associated documentation files [the "Software"], to deal
+of this software and associated documentation files (the "Software"), to deal
in the Software without restriction, including without limitation the rights
to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
copies of the Software, and to permit persons to whom the Software is
From abaine at common-lisp.net Tue Jul 3 01:00:51 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Mon, 2 Jul 2007 21:00:51 -0400 (EDT)
Subject: [funds-cvs] r44 - trunk/funds/tests/trees
Message-ID: <20070703010051.00671650D1@common-lisp.net>
Author: abaine
Date: Mon Jul 2 21:00:51 2007
New Revision: 44
Modified:
trunk/funds/tests/trees/avl-tree-test.lisp
Log:
Removed print statement from random tree generation.
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 Mon Jul 2 21:00:51 2007
@@ -2,10 +2,10 @@
(in-package :funds.tests.trees)
(defun random-tree (&key (test #'eql) (order #'<))
- (print (reduce #'(lambda (tr v)
- (avl-insert tr v v :test test :order order))
+ (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))))
+ :initial-value (empty-avl-tree)))
(defconstant +never-equal+ #'(lambda (a b) (declare (ignore a b)) nil))
From abaine at common-lisp.net Tue Jul 3 01:02:08 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Mon, 2 Jul 2007 21:02:08 -0400 (EDT)
Subject: [funds-cvs] r45 - trunk/funds/src/trees
Message-ID: <20070703010208.3E079650D1@common-lisp.net>
Author: abaine
Date: Mon Jul 2 21:02:07 2007
New Revision: 45
Modified:
trunk/funds/src/trees/avl-tree.lisp
Log:
Began to refactor side-symmetric code left-rotate and 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 Mon Jul 2 21:02:07 2007
@@ -67,12 +67,12 @@
(right (avl-right tree)))
(if (imbalanced left right)
(if (left-heavy left)
- (right-rotate left tree right)
- (right-rotate (left-rotate (avl-left left)
- left
- (avl-right left))
+ (right-rotate right tree left)
+ (right-rotate right
tree
- right))
+ (left-rotate (avl-left left)
+ left
+ (avl-right left))))
(make-avl :ht (parent-height left right)
:key (avl-key tree)
:value (avl-value tree)
@@ -90,9 +90,9 @@
(left-rotate left tree right)
(left-rotate left
tree
- (right-rotate (avl-left right)
+ (right-rotate (avl-right right)
right
- (avl-right right))))
+ (avl-left right))))
(make-avl :ht (parent-height left right)
:key (avl-key tree)
:value (avl-value tree)
@@ -114,7 +114,7 @@
:left new-a
:right c)))
-(defun right-rotate (b c t3)
+(defun right-rotate (t3 c b)
(let ((a (avl-left b))
(new-c (make-avl :ht (1- (avl-ht c)); re-calculate?
:key (avl-key c)
@@ -127,6 +127,32 @@
:left a
:right new-c)))
+(defun rotate (inside root outside &key direction)
+ (let* ((left-p (eq direction :left))
+ (outside-accessor (if left-p
+ #'avl-right
+ #'avl-left))
+ (inside-accessor (if left-p
+ #'avl-left
+ #'avl-right))
+ (inside-init-key (if left-p
+ :left
+ :right))
+ (outside-init-key (if left-p
+ :right
+ :left))
+ (new-outside (funcall outside-accessor outside))
+ (new-inside (make-avl :ht (1- (avl-height root))
+ :key (avl-key root)
+ :value (avl-value root)
+ inside-init-key inside
+ outside-init-key (funcall inside-accessor outside))))
+ (make-avl :ht (1+ (avl-height new-outside))
+ :key (avl-key outside)
+ :value (avl-value outside)
+ inside-init-key new-inside
+ outside-init-key new-outside)))
+
;;;; AVL Tree utility functions
(defun imbalanced (left right)
From abaine at common-lisp.net Tue Jul 3 18:57:05 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Tue, 3 Jul 2007 14:57:05 -0400 (EDT)
Subject: [funds-cvs] r46 - trunk/funds/src/trees
Message-ID: <20070703185705.3E4D87208F@common-lisp.net>
Author: abaine
Date: Tue Jul 3 14:57:04 2007
New Revision: 46
Modified:
trunk/funds/src/trees/avl-tree.lisp
Log:
Refactored left and 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 Tue Jul 3 14:57:04 2007
@@ -102,45 +102,17 @@
;;;; Rotation Functions
(defun left-rotate (t0 a b)
- (let ((c (avl-right b))
- (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 :ht (1+ (avl-ht new-a))
- :key (avl-key b)
- :value (avl-value b)
- :left new-a
- :right c)))
+ (rotate t0 a b :direction :left))
(defun right-rotate (t3 c b)
- (let ((a (avl-left b))
- (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 :ht (1+ (avl-ht new-c)) ; re-calculate?
- :key (avl-key b)
- :value (avl-value b)
- :left a
- :right new-c)))
+ (rotate t3 c b :direction :right))
(defun rotate (inside root outside &key direction)
(let* ((left-p (eq direction :left))
- (outside-accessor (if left-p
- #'avl-right
- #'avl-left))
- (inside-accessor (if left-p
- #'avl-left
- #'avl-right))
- (inside-init-key (if left-p
- :left
- :right))
- (outside-init-key (if left-p
- :right
- :left))
+ (outside-accessor (if left-p #'avl-right #'avl-left))
+ (inside-accessor (if left-p #'avl-left #'avl-right))
+ (inside-init-key (if left-p :left :right))
+ (outside-init-key (if left-p :right :left))
(new-outside (funcall outside-accessor outside))
(new-inside (make-avl :ht (1- (avl-height root))
:key (avl-key root)
From abaine at common-lisp.net Tue Jul 3 20:18:23 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Tue, 3 Jul 2007 16:18:23 -0400 (EDT)
Subject: [funds-cvs] r47 - trunk/funds/src/trees
Message-ID: <20070703201823.D3A4E56008@common-lisp.net>
Author: abaine
Date: Tue Jul 3 16:18:23 2007
New Revision: 47
Modified:
trunk/funds/src/trees/avl-tree.lisp
Log:
Refactored left and right-insert out of program.
Modified: trunk/funds/src/trees/avl-tree.lisp
==============================================================================
--- trunk/funds/src/trees/avl-tree.lisp (original)
+++ trunk/funds/src/trees/avl-tree.lisp Tue Jul 3 16:18:23 2007
@@ -3,7 +3,6 @@
;;;; Public Interface
-
(defun empty-avl-tree ()
"An empty AVL Tree."
nil)
@@ -30,8 +29,12 @@
:value value
:left (avl-left tree)
:right (avl-right tree)))
- ((funcall order key (avl-key tree)) (left-insert tree key value test order))
- (t (right-insert tree key value test order))))
+; ((funcall order key (avl-key tree)) (left-insert tree key value test order))
+; (t (right-insert tree key value test order))
+ (t (funcall (if (funcall order key (avl-key tree))
+ #'left-insert
+ #'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
@@ -63,44 +66,90 @@
"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 :test test :order order))
- (right (avl-right tree)))
- (if (imbalanced left right)
- (if (left-heavy left)
- (right-rotate right tree left)
- (right-rotate right
- tree
- (left-rotate (avl-left left)
- left
- (avl-right left))))
- (make-avl :ht (parent-height left right)
- :key (avl-key tree)
- :value (avl-value tree)
- :left left
- :right right))))
+;; (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)
+;; (right-rotate right tree left)
+;; (right-rotate right
+;; tree
+;; (left-rotate (avl-left left)
+;; left
+;; (avl-right left))))
+;; (make-avl :ht (parent-height left right)
+;; :key (avl-key tree)
+;; :value (avl-value tree)
+;; :left left
+;; :right right)))
+ (side-insert tree key value test order :side :left))
(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 :test test :order order))
- (left (avl-left tree)))
- (if (imbalanced left right)
- (if (right-heavy right)
- (left-rotate left tree right)
- (left-rotate left
- tree
- (right-rotate (avl-right right)
- right
- (avl-left right))))
- (make-avl :ht (parent-height left right)
- :key (avl-key tree)
- :value (avl-value tree)
- :left left
- :right right))))
+;; (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)
+;; (left-rotate left tree right)
+;; (left-rotate left
+;; tree
+;; (right-rotate (avl-right right)
+;; right
+;; (avl-left right))))
+;; (make-avl :ht (parent-height left right)
+;; :key (avl-key tree)
+;; :value (avl-value tree)
+;; :left left
+;; :right right)))
+ (side-insert tree key value test order :side :right)
+)
+
+(defun side-insert (tree key value test order &key side)
+ (let ((out (avl-insert (funcall (side-accessor side) tree) key value :test test :order order))
+ (in (funcall (other-side-accessor side) tree)))
+ (if (balanced out in)
+ (make-avl :ht (parent-height out in)
+ :key (avl-key tree)
+ :value (avl-value tree)
+ side out
+ (other-side side) in)
+ (funcall (other-side-rotator side)
+ in
+ tree
+ (if (funcall (side-heavy-predicate side) out)
+ out
+ (funcall (side-rotator side)
+ (funcall (side-accessor side) out)
+ out
+ (funcall (other-side-accessor side) out)))))))
+
+
;;;; Rotation Functions
+(defun left-p (side)
+ (eq side :left))
+
+(defun other-side (side)
+ (if (left-p side) :right :left))
+
+(defun side-accessor (side)
+ (if (left-p side) #'avl-left #'avl-right))
+
+(defun other-side-accessor (side)
+ (side-accessor (other-side side)))
+
+(defun side-rotator (side)
+ (if (left-p side) #'left-rotate #'right-rotate))
+
+(defun other-side-rotator (side)
+ (side-rotator (other-side side)))
+
+(defun side-heavy-predicate (side)
+ (if (left-p side) #'left-heavy #'right-heavy))
+
+
(defun left-rotate (t0 a b)
(rotate t0 a b :direction :left))
@@ -108,11 +157,10 @@
(rotate t3 c b :direction :right))
(defun rotate (inside root outside &key direction)
- (let* ((left-p (eq direction :left))
- (outside-accessor (if left-p #'avl-right #'avl-left))
- (inside-accessor (if left-p #'avl-left #'avl-right))
- (inside-init-key (if left-p :left :right))
- (outside-init-key (if left-p :right :left))
+ (let* ((outside-accessor (other-side-accessor direction))
+ (inside-accessor (side-accessor direction))
+ (inside-init-key direction)
+ (outside-init-key (other-side direction))
(new-outside (funcall outside-accessor outside))
(new-inside (make-avl :ht (1- (avl-height root))
:key (avl-key root)
@@ -127,6 +175,9 @@
;;;; AVL Tree utility functions
+(defun avl-balanced-p (tree)
+ (< -2 (balance-factor tree) 2))
+
(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 Tue Jul 3 20:35:36 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Tue, 3 Jul 2007 16:35:36 -0400 (EDT)
Subject: [funds-cvs] r48 - trunk/funds/src/trees
Message-ID: <20070703203536.2F5636B0FA@common-lisp.net>
Author: abaine
Date: Tue Jul 3 16:35:35 2007
New Revision: 48
Modified:
trunk/funds/src/trees/avl-tree.lisp
Log:
Refactoring of insert complete.
Modified: trunk/funds/src/trees/avl-tree.lisp
==============================================================================
--- trunk/funds/src/trees/avl-tree.lisp (original)
+++ trunk/funds/src/trees/avl-tree.lisp Tue Jul 3 16:35:35 2007
@@ -24,17 +24,14 @@
:value value
:left (empty-avl-tree)
:right (empty-avl-tree)))
+ ;; Duplicate keys are not allowed:
((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 test order))
-; (t (right-insert tree key value test order))
- (t (funcall (if (funcall order key (avl-key tree))
- #'left-insert
- #'right-insert)
- tree key value test order))))
+ (t (side-insert tree key value test order
+ :side (if (funcall order key (avl-key tree)) :left :right)))))
(defun avl-find-value (tree key &key (order #'<) (test #'eql))
"The value associated with the given key in the given AVL Tree. The function
@@ -62,49 +59,6 @@
;;;; 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
-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 (left-heavy left)
-;; (right-rotate right tree left)
-;; (right-rotate right
-;; tree
-;; (left-rotate (avl-left left)
-;; left
-;; (avl-right left))))
-;; (make-avl :ht (parent-height left right)
-;; :key (avl-key tree)
-;; :value (avl-value tree)
-;; :left left
-;; :right right)))
- (side-insert tree key value test order :side :left))
-
-(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 :test test :order order))
-;; (left (avl-left tree)))
-;; (if (imbalanced left right)
-;; (if (right-heavy right)
-;; (left-rotate left tree right)
-;; (left-rotate left
-;; tree
-;; (right-rotate (avl-right right)
-;; right
-;; (avl-left right))))
-;; (make-avl :ht (parent-height left right)
-;; :key (avl-key tree)
-;; :value (avl-value tree)
-;; :left left
-;; :right right)))
- (side-insert tree key value test order :side :right)
-)
-
(defun side-insert (tree key value test order &key side)
(let ((out (avl-insert (funcall (side-accessor side) tree) key value :test test :order order))
(in (funcall (other-side-accessor side) tree)))
@@ -128,28 +82,6 @@
;;;; Rotation Functions
-(defun left-p (side)
- (eq side :left))
-
-(defun other-side (side)
- (if (left-p side) :right :left))
-
-(defun side-accessor (side)
- (if (left-p side) #'avl-left #'avl-right))
-
-(defun other-side-accessor (side)
- (side-accessor (other-side side)))
-
-(defun side-rotator (side)
- (if (left-p side) #'left-rotate #'right-rotate))
-
-(defun other-side-rotator (side)
- (side-rotator (other-side side)))
-
-(defun side-heavy-predicate (side)
- (if (left-p side) #'left-heavy #'right-heavy))
-
-
(defun left-rotate (t0 a b)
(rotate t0 a b :direction :left))
@@ -175,9 +107,6 @@
;;;; AVL Tree utility functions
-(defun avl-balanced-p (tree)
- (< -2 (balance-factor tree) 2))
-
(defun imbalanced (left right)
"Whether the heights of the given sub-trees differ,
in their absolute values, by more than one."
@@ -192,12 +121,12 @@
"The difference in heights of the given sub-trees."
(- (avl-height a) (avl-height b)))
-(defun left-heavy (tree)
+(defun left-heavy-p (tree)
"Whether the given imbalanced AVL Tree has a left sub-tree
taller than its right sub-tree."
(minusp (balance-factor tree)))
-(defun right-heavy (tree)
+(defun right-heavy-p (tree)
"Whether the given imbalanced AVL Tree has a right sub-tree
taller than its left sub-tree."
(plusp (balance-factor tree)))
@@ -213,3 +142,26 @@
(let ((a (avl-height left))
(b (avl-height right)))
(1+ (if (> a b) a b))))
+
+;;; Functions that return side-appropriate functions
+
+(defun left-p (side)
+ (eq side :left))
+
+(defun other-side (side)
+ (if (left-p side) :right :left))
+
+(defun side-accessor (side)
+ (if (left-p side) #'avl-left #'avl-right))
+
+(defun other-side-accessor (side)
+ (side-accessor (other-side side)))
+
+(defun side-rotator (side)
+ (if (left-p side) #'left-rotate #'right-rotate))
+
+(defun other-side-rotator (side)
+ (side-rotator (other-side side)))
+
+(defun side-heavy-predicate (side)
+ (if (left-p side) #'left-heavy-p #'right-heavy-p))
From abaine at common-lisp.net Wed Jul 4 17:39:42 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Wed, 4 Jul 2007 13:39:42 -0400 (EDT)
Subject: [funds-cvs] r49 - trunk/funds/src/trees
Message-ID: <20070704173942.B53BB431BF@common-lisp.net>
Author: abaine
Date: Wed Jul 4 13:39:42 2007
New Revision: 49
Modified:
trunk/funds/src/trees/avl-tree.lisp
Log:
avl-remove method added.
Modified: trunk/funds/src/trees/avl-tree.lisp
==============================================================================
--- trunk/funds/src/trees/avl-tree.lisp (original)
+++ trunk/funds/src/trees/avl-tree.lisp Wed Jul 4 13:39:42 2007
@@ -33,6 +33,14 @@
(t (side-insert tree key value test order
:side (if (funcall order key (avl-key tree)) :left :right)))))
+(defun avl-remove (tree key &key (test #'eql) (order #'<))
+ "The AVL Tree that results when the given key and its associated value are
+removed from the given tree."
+ (cond ((avl-empty-p tree) tree)
+ ((funcall test key (avl-key tree)) ())
+ (t (side-remove tree key test order
+ :side (if (funcall order key (avl-key tree)) :left :right)))))
+
(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
From abaine at common-lisp.net Wed Jul 4 18:31:42 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Wed, 4 Jul 2007 14:31:42 -0400 (EDT)
Subject: [funds-cvs] r50 - trunk/funds/src/trees
Message-ID: <20070704183142.DE45D60035@common-lisp.net>
Author: abaine
Date: Wed Jul 4 14:31:42 2007
New Revision: 50
Modified:
trunk/funds/src/trees/avl-tree.lisp
Log:
Changed package to funds.
Modified: trunk/funds/src/trees/avl-tree.lisp
==============================================================================
--- trunk/funds/src/trees/avl-tree.lisp (original)
+++ trunk/funds/src/trees/avl-tree.lisp Wed Jul 4 14:31:42 2007
@@ -1,5 +1,5 @@
-(in-package :funds.trees)
+(in-package :funds)
;;;; Public Interface
From abaine at common-lisp.net Wed Jul 4 18:32:35 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Wed, 4 Jul 2007 14:32:35 -0400 (EDT)
Subject: [funds-cvs] r51 - trunk/funds/src
Message-ID: <20070704183235.33AEE60035@common-lisp.net>
Author: abaine
Date: Wed Jul 4 14:32:32 2007
New Revision: 51
Modified:
trunk/funds/src/package.lisp
Log:
Added avl API to exports of funds package.
Modified: trunk/funds/src/package.lisp
==============================================================================
--- trunk/funds/src/package.lisp (original)
+++ trunk/funds/src/package.lisp Wed Jul 4 14:32:32 2007
@@ -7,4 +7,15 @@
:stack-length
:stack-push
:stack-pop
- :stack-empty-p))
+ :stack-empty-p
+
+ :empty-avl-tree
+ :avl-empty-p
+ :avl-insert
+ :avl-remove
+ :avl-find-value
+ :avl-key
+ :avl-value
+ :avl-height
+ :avl-left
+ :avl-right))
From abaine at common-lisp.net Wed Jul 4 18:33:34 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Wed, 4 Jul 2007 14:33:34 -0400 (EDT)
Subject: [funds-cvs] r52 - trunk/funds/tests/trees
Message-ID: <20070704183334.5EA8C60035@common-lisp.net>
Author: abaine
Date: Wed Jul 4 14:33:33 2007
New Revision: 52
Modified:
trunk/funds/tests/trees/package.lisp
Log:
Changed package name to funds-tests.
Modified: trunk/funds/tests/trees/package.lisp
==============================================================================
--- trunk/funds/tests/trees/package.lisp (original)
+++ trunk/funds/tests/trees/package.lisp Wed Jul 4 14:33:33 2007
@@ -1,7 +1,7 @@
(in-package :cl-user)
-(defpackage funds.tests.trees
+(defpackage funds-tests
(:use :cl
- :funds.trees
+ :funds
:lisp-unit))
From abaine at common-lisp.net Wed Jul 4 18:34:20 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Wed, 4 Jul 2007 14:34:20 -0400 (EDT)
Subject: [funds-cvs] r53 - in trunk/funds/tests: . trees
Message-ID: <20070704183420.C48D160035@common-lisp.net>
Author: abaine
Date: Wed Jul 4 14:34:20 2007
New Revision: 53
Added:
trunk/funds/tests/package.lisp
- copied unchanged from r52, trunk/funds/tests/trees/package.lisp
Removed:
trunk/funds/tests/trees/package.lisp
Log:
Moved tests/package.lisp to the correct directory.
From abaine at common-lisp.net Wed Jul 4 19:08:37 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Wed, 4 Jul 2007 15:08:37 -0400 (EDT)
Subject: [funds-cvs] r54 - trunk/funds/tests
Message-ID: <20070704190837.848BA58333@common-lisp.net>
Author: abaine
Date: Wed Jul 4 15:08:37 2007
New Revision: 54
Modified:
trunk/funds/tests/funds-tests.asd
Log:
Changed funds-tests.asd to reflect change in package structure.
Modified: trunk/funds/tests/funds-tests.asd
==============================================================================
--- trunk/funds/tests/funds-tests.asd (original)
+++ trunk/funds/tests/funds-tests.asd Wed Jul 4 15:08:37 2007
@@ -10,9 +10,9 @@
(defsystem funds-tests
:serial t
- :components ((:module trees
+ :components ((:file "package")
+ (:module trees
:serial t
- :components ((:file "package")
- (:file "avl-tree-test"))))
+ :components ((:file "avl-tree-test"))))
:depends-on (:funds
:lisp-unit))
From abaine at common-lisp.net Wed Jul 4 19:09:06 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Wed, 4 Jul 2007 15:09:06 -0400 (EDT)
Subject: [funds-cvs] r55 - trunk/funds/src
Message-ID: <20070704190906.E9ACE58333@common-lisp.net>
Author: abaine
Date: Wed Jul 4 15:09:05 2007
New Revision: 55
Modified:
trunk/funds/src/funds.asd
Log:
Added binary tree.
Modified: trunk/funds/src/funds.asd
==============================================================================
--- trunk/funds/src/funds.asd (original)
+++ trunk/funds/src/funds.asd Wed Jul 4 15:09:05 2007
@@ -13,8 +13,8 @@
:components ((:file "package")
(:module trees
:serial t
- :components ((:file "package")
- (:file "avl-tree")))
+ :components ((:file "avl-tree")
+ (:file "binary-tree")))
(:module stack
:serial t
:components ((:file "stack")))))
From abaine at common-lisp.net Thu Jul 5 02:59:25 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Wed, 4 Jul 2007 22:59:25 -0400 (EDT)
Subject: [funds-cvs] r56 - trunk/funds/src/trees
Message-ID: <20070705025925.EDFD768297@common-lisp.net>
Author: abaine
Date: Wed Jul 4 22:59:25 2007
New Revision: 56
Added:
trunk/funds/src/trees/binary-tree.lisp
Log:
Added binary-tree.lisp.
Added: trunk/funds/src/trees/binary-tree.lisp
==============================================================================
--- (empty file)
+++ trunk/funds/src/trees/binary-tree.lisp Wed Jul 4 22:59:25 2007
@@ -0,0 +1,83 @@
+
+(in-package :funds)
+
+(defstruct bt
+ key
+ value
+ left
+ right)
+
+(defun make-empty-bt ()
+ nil)
+
+(defun bt-empty-p (tree)
+ (null tree))
+
+(defun bt-insert (tree key value &key (order #'<) (test #'eql))
+ (cond ((bt-empty-p tree) (make-bt :key key
+ :value value
+ :left (make-empty-bt)
+ :right (make-empty-bt)))
+ ((funcall test key (bt-key tree)) (make-bt :key key
+ :value value
+ :left (bt-left tree)
+ :right (bt-right tree)))
+
+ ((funcall order key (bt-key tree))
+ (make-bt :key (bt-key tree)
+ :value (bt-value tree)
+ :left (bt-insert (bt-left tree) key value :order order :test test)
+ :right (bt-right tree)))
+ (t (make-bt :key (bt-key tree)
+ :value (bt-value tree)
+ :left (bt-left tree)
+ :right (bt-insert (bt-right tree)key value :order order :test test)))))
+
+(defun bt-find (tree key &key (order #'<) (test #'eql))
+ (cond ((bt-empty-p tree) (values nil nil))
+ ((funcall test key (bt-key tree)) (values (bt-value tree) t))
+ ((funcall order key (bt-key tree)) (bt-find (bt-left tree) key
+ :order order
+ :test test))
+ (t (bt-find (bt-right tree) key
+ :order order
+ :test test))))
+
+(defun bt-remove (tree key &key (order #'<) (test #'eql))
+ (cond ((bt-empty-p tree) tree)
+ ((funcall test key (bt-key tree)) (remove-root tree :order order :test test))
+ ((funcall order key (bt-key tree)) (make-bt :key (bt-key tree)
+ :value (bt-value tree)
+ :left (bt-remove (bt-left tree) key
+ :order order
+ :test test)
+ :right (bt-right tree)))
+ (t (make-bt :key (bt-key tree)
+ :value (bt-value tree)
+ :left (bt-left tree)
+ :right (bt-remove (bt-right tree) key
+ :order order
+ :test test)))))
+
+(defun remove-root (tree &key order test)
+ (cond ((bt-empty-p (bt-left tree)) (bt-right tree))
+ ((bt-empty-p (bt-right tree)) (bt-left tree))
+ (t (let* ((next (next-in-order (bt-right tree) order))
+ (k (bt-key next)))
+ (make-bt :key k
+ :value (bt-value next)
+ :left (bt-left tree)
+ :right (bt-remove (bt-right tree) k
+ :order order
+ :test test))))))
+
+(defun bt->alist (tree)
+ (if (bt-empty-p tree) nil
+ (append (bt->alist (bt-left tree))
+ (cons (cons (bt-key tree) (bt-value tree))
+ (bt->alist (bt-right tree))))))
+
+(defun next-in-order (tree order)
+ (if (bt-empty-p (bt-left tree))
+ tree
+ (next-in-order (bt-left tree) order)))
\ No newline at end of file
From abaine at common-lisp.net Sat Jul 7 13:15:48 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Sat, 7 Jul 2007 09:15:48 -0400 (EDT)
Subject: [funds-cvs] r57 - trunk/public_html
Message-ID: <20070707131548.5F3BB140B1@common-lisp.net>
Author: abaine
Date: Sat Jul 7 09:15:47 2007
New Revision: 57
Modified:
trunk/public_html/index.html
Log:
Changed release date.
Modified: trunk/public_html/index.html
==============================================================================
--- trunk/public_html/index.html (original)
+++ trunk/public_html/index.html Sat Jul 7 09:15:47 2007
@@ -40,7 +40,7 @@
development as a
Google Summer of Code Project, and a release is planned for
- July 6, 2007.
+ July 13, 2007.
From abaine at common-lisp.net Sat Jul 7 20:45:17 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Sat, 7 Jul 2007 16:45:17 -0400 (EDT)
Subject: [funds-cvs] r58 - trunk/funds/src/stack
Message-ID: <20070707204517.D9FED4E00F@common-lisp.net>
Author: abaine
Date: Sat Jul 7 16:45:17 2007
New Revision: 58
Modified:
trunk/funds/src/stack/stack.lisp
Log:
Changed name of stack-length to stack-size.
Modified: trunk/funds/src/stack/stack.lisp
==============================================================================
--- trunk/funds/src/stack/stack.lisp (original)
+++ trunk/funds/src/stack/stack.lisp Sat Jul 7 16:45:17 2007
@@ -21,7 +21,7 @@
"Whether the given stack is empty."
(null stack))
-(defun stack-length (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)
From abaine at common-lisp.net Sun Jul 8 02:52:18 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Sat, 7 Jul 2007 22:52:18 -0400 (EDT)
Subject: [funds-cvs] r59 - in trunk/funds/src: . stack trees trees/heap
Message-ID: <20070708025218.68F3E5F04A@common-lisp.net>
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))
From abaine at common-lisp.net Sun Jul 8 03:06:09 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Sat, 7 Jul 2007 23:06:09 -0400 (EDT)
Subject: [funds-cvs] r60 - trunk/funds/src
Message-ID: <20070708030609.567175060@common-lisp.net>
Author: abaine
Date: Sat Jul 7 23:06:09 2007
New Revision: 60
Removed:
trunk/funds/src/funds-clos.asd
Modified:
trunk/funds/src/funds.asd
Log:
Changed system name from funds-clos to funds.
Modified: trunk/funds/src/funds.asd
==============================================================================
--- trunk/funds/src/funds.asd (original)
+++ trunk/funds/src/funds.asd Sat Jul 7 23:06:09 2007
@@ -1,20 +1,33 @@
-;;;; -*- Lisp -*-
+; -*- Lisp -*-
(in-package :cl-user)
-
-(defpackage #:funds-asd
+(defpackage #:funds-clos-asd
(:use :cl :asdf))
-(in-package :funds-asd)
+(in-package :funds-clos-asd)
-(defsystem funds
+(defsystem funds-clos
:serial t
:components ((:file "package")
+ (:file "stack")
(:module trees
:serial t
- :components ((:file "avl-tree")
- (:file "binary-tree")))
- (:module stack
- :serial t
- :components ((:file "stack")))))
+ :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")))
From abaine at common-lisp.net Sun Jul 8 03:14:20 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Sat, 7 Jul 2007 23:14:20 -0400 (EDT)
Subject: [funds-cvs] r61 - trunk/funds/src
Message-ID: <20070708031420.90A7C13025@common-lisp.net>
Author: abaine
Date: Sat Jul 7 23:14:20 2007
New Revision: 61
Modified:
trunk/funds/src/funds.asd
Log:
Changed funds-clos defsystem form to funds.
Modified: trunk/funds/src/funds.asd
==============================================================================
--- trunk/funds/src/funds.asd (original)
+++ trunk/funds/src/funds.asd Sat Jul 7 23:14:20 2007
@@ -2,12 +2,13 @@
; -*- Lisp -*-
(in-package :cl-user)
-(defpackage #:funds-clos-asd
+
+(defpackage #:funds-asd
(:use :cl :asdf))
-(in-package :funds-clos-asd)
+(in-package :funds-asd)
-(defsystem funds-clos
+(defsystem funds
:serial t
:components ((:file "package")
(:file "stack")
From abaine at common-lisp.net Sun Jul 8 03:23:18 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Sat, 7 Jul 2007 23:23:18 -0400 (EDT)
Subject: [funds-cvs] r62 - in trunk/funds/src: . trees trees/heap
Message-ID: <20070708032318.BBED833080@common-lisp.net>
Author: abaine
Date: Sat Jul 7 23:23:18 2007
New Revision: 62
Modified:
trunk/funds/src/queue.lisp
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/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
Log:
Changed all in-package forms to use funds rather than funds-clos.
Modified: trunk/funds/src/queue.lisp
==============================================================================
--- trunk/funds/src/queue.lisp (original)
+++ trunk/funds/src/queue.lisp Sat Jul 7 23:23:18 2007
@@ -1,5 +1,5 @@
-(in-package :funds-clos)
+(in-package :funds)
(defstruct queue
(next-priority 0)
Modified: trunk/funds/src/stack.lisp
==============================================================================
--- trunk/funds/src/stack.lisp (original)
+++ trunk/funds/src/stack.lisp Sat Jul 7 23:23:18 2007
@@ -1,5 +1,5 @@
-(in-package :funds-clos)
+(in-package :funds)
(defun make-stack ()
"An empty stack."
Modified: trunk/funds/src/trees/avl.lisp
==============================================================================
--- trunk/funds/src/trees/avl.lisp (original)
+++ trunk/funds/src/trees/avl.lisp Sat Jul 7 23:23:18 2007
@@ -1,5 +1,5 @@
-(in-package :funds-clos)
+(in-package :funds)
(defun balance (inside root outside &key heavy-side)
(let ((other-side (other-side heavy-side)))
Modified: trunk/funds/src/trees/bt.lisp
==============================================================================
--- trunk/funds/src/trees/bt.lisp (original)
+++ trunk/funds/src/trees/bt.lisp Sat Jul 7 23:23:18 2007
@@ -1,5 +1,5 @@
-(in-package :funds-clos)
+(in-package :funds)
(defun left-p (side)
(eq side :left))
Modified: trunk/funds/src/trees/classes.lisp
==============================================================================
--- trunk/funds/src/trees/classes.lisp (original)
+++ trunk/funds/src/trees/classes.lisp Sat Jul 7 23:23:18 2007
@@ -1,5 +1,5 @@
-(in-package :funds-clos)
+(in-package :funds)
(defclass tree ()
()
Modified: trunk/funds/src/trees/constructors.lisp
==============================================================================
--- trunk/funds/src/trees/constructors.lisp (original)
+++ trunk/funds/src/trees/constructors.lisp Sat Jul 7 23:23:18 2007
@@ -1,5 +1,5 @@
-(in-package :funds-clos)
+(in-package :funds)
(defun make-bt-leaf ()
(make-instance 'bt-leaf))
Modified: trunk/funds/src/trees/heap/heap-empty-p.lisp
==============================================================================
--- trunk/funds/src/trees/heap/heap-empty-p.lisp (original)
+++ trunk/funds/src/trees/heap/heap-empty-p.lisp Sat Jul 7 23:23:18 2007
@@ -1,5 +1,5 @@
-(in-package :funds-clos)
+(in-package :funds)
(defun heap-empty-p (heap)
(tree-empty-p heap))
\ No newline at end of file
Modified: trunk/funds/src/trees/heap/heap-first.lisp
==============================================================================
--- trunk/funds/src/trees/heap/heap-first.lisp (original)
+++ trunk/funds/src/trees/heap/heap-first.lisp Sat Jul 7 23:23:18 2007
@@ -1,5 +1,5 @@
-(in-package :funds-clos)
+(in-package :funds)
(defun heap-first (heap)
(bt-value heap))
Modified: trunk/funds/src/trees/heap/heap-insert.lisp
==============================================================================
--- trunk/funds/src/trees/heap/heap-insert.lisp (original)
+++ trunk/funds/src/trees/heap/heap-insert.lisp Sat Jul 7 23:23:18 2007
@@ -1,5 +1,5 @@
-(in-package :funds-clos)
+(in-package :funds)
(defgeneric heap-insert (heap value priority &key order))
Modified: trunk/funds/src/trees/heap/heap-remove.lisp
==============================================================================
--- trunk/funds/src/trees/heap/heap-remove.lisp (original)
+++ trunk/funds/src/trees/heap/heap-remove.lisp Sat Jul 7 23:23:18 2007
@@ -1,5 +1,5 @@
-(in-package :funds-clos)
+(in-package :funds)
(defmethod heap-remove ((heap heap-leaf) &key order)
(declare (ignore order))
Modified: trunk/funds/src/trees/tree-as-alist.lisp
==============================================================================
--- trunk/funds/src/trees/tree-as-alist.lisp (original)
+++ trunk/funds/src/trees/tree-as-alist.lisp Sat Jul 7 23:23:18 2007
@@ -1,5 +1,5 @@
-(in-package :funds-clos)
+(in-package :funds)
(defgeneric tree-as-alist (tree)
(:documentation
Modified: trunk/funds/src/trees/tree-empty-p.lisp
==============================================================================
--- trunk/funds/src/trees/tree-empty-p.lisp (original)
+++ trunk/funds/src/trees/tree-empty-p.lisp Sat Jul 7 23:23:18 2007
@@ -1,5 +1,5 @@
-(in-package :funds-clos)
+(in-package :funds)
(defgeneric tree-empty-p (tree)
(:documentation
Modified: trunk/funds/src/trees/tree-find.lisp
==============================================================================
--- trunk/funds/src/trees/tree-find.lisp (original)
+++ trunk/funds/src/trees/tree-find.lisp Sat Jul 7 23:23:18 2007
@@ -1,5 +1,5 @@
-(in-package :funds-clos)
+(in-package :funds)
(defgeneric tree-find (tree key &key test order)
(:documentation
Modified: trunk/funds/src/trees/tree-height.lisp
==============================================================================
--- trunk/funds/src/trees/tree-height.lisp (original)
+++ trunk/funds/src/trees/tree-height.lisp Sat Jul 7 23:23:18 2007
@@ -1,5 +1,5 @@
-(in-package :funds-clos)
+(in-package :funds)
(defgeneric tree-height (tree)
(:documentation "The height of the given tree."))
Modified: trunk/funds/src/trees/tree-insert.lisp
==============================================================================
--- trunk/funds/src/trees/tree-insert.lisp (original)
+++ trunk/funds/src/trees/tree-insert.lisp Sat Jul 7 23:23:18 2007
@@ -1,5 +1,5 @@
-(in-package :funds-clos)
+(in-package :funds)
(defgeneric tree-insert (tree key value &key test order)
(:documentation
Modified: trunk/funds/src/trees/tree-remove.lisp
==============================================================================
--- trunk/funds/src/trees/tree-remove.lisp (original)
+++ trunk/funds/src/trees/tree-remove.lisp Sat Jul 7 23:23:18 2007
@@ -1,5 +1,5 @@
-(in-package :funds-clos)
+(in-package :funds)
(defgeneric tree-remove (tree key &key test order)
(:documentation
Modified: trunk/funds/src/trees/tree-weight.lisp
==============================================================================
--- trunk/funds/src/trees/tree-weight.lisp (original)
+++ trunk/funds/src/trees/tree-weight.lisp Sat Jul 7 23:23:18 2007
@@ -1,5 +1,5 @@
-(in-package :funds-clos)
+(in-package :funds)
(defgeneric tree-weight (tree)
(:documentation
From abaine at common-lisp.net Sun Jul 8 03:25:10 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Sat, 7 Jul 2007 23:25:10 -0400 (EDT)
Subject: [funds-cvs] r63 - trunk/funds/src
Message-ID: <20070708032510.DD2343E05B@common-lisp.net>
Author: abaine
Date: Sat Jul 7 23:25:10 2007
New Revision: 63
Modified:
trunk/funds/src/package.lisp
Log:
Changed defpackage form to funds.
Modified: trunk/funds/src/package.lisp
==============================================================================
--- trunk/funds/src/package.lisp (original)
+++ trunk/funds/src/package.lisp Sat Jul 7 23:25:10 2007
@@ -1,7 +1,7 @@
(in-package :cl-user)
-(defpackage :funds-clos
+(defpackage :funds
(:use :cl)
(:export :make-avl-tree
:make-binary-tree
From abaine at common-lisp.net Sun Jul 8 03:29:15 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Sat, 7 Jul 2007 23:29:15 -0400 (EDT)
Subject: [funds-cvs] r64 - trunk/funds/src/trees
Message-ID: <20070708032915.A9BD55D00B@common-lisp.net>
Author: abaine
Date: Sat Jul 7 23:29:15 2007
New Revision: 64
Modified:
trunk/funds/src/trees/tree-remove.lisp
Log:
Added declaration to avoid compiler warnings.
Modified: trunk/funds/src/trees/tree-remove.lisp
==============================================================================
--- trunk/funds/src/trees/tree-remove.lisp (original)
+++ trunk/funds/src/trees/tree-remove.lisp Sat Jul 7 23:29:15 2007
@@ -20,6 +20,7 @@
(t (remove-side tree key :test test :order order :side :right))))
(defmethod tree-remove ((tree avl-tree) key &key (test #'eql) (order #'<))
+ (declare (ignore test order))
(let* ((temp (call-next-method))
(heavy-side (if (heavier-p temp :side :left)
:left
From abaine at common-lisp.net Sun Jul 8 04:34:52 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Sun, 8 Jul 2007 00:34:52 -0400 (EDT)
Subject: [funds-cvs] r65 - trunk/funds
Message-ID: <20070708043452.AC32413026@common-lisp.net>
Author: abaine
Date: Sun Jul 8 00:34:52 2007
New Revision: 65
Added:
trunk/funds/issues.txt
Log:
issues.txt has some things that have been bugging me.
Added: trunk/funds/issues.txt
==============================================================================
--- (empty file)
+++ trunk/funds/issues.txt Sun Jul 8 00:34:52 2007
@@ -0,0 +1,13 @@
+
+1. Test suite has to be updated to test avl-tree and heap.
+
+2. What is the implication of removing from an empty tree. Probably
+just returning the same empty tree. But perhaps it should
+signal an error?
+
+3. Build dictionary on top of avl tree. Build functional array on top
+of binary tree.
+
+4. Documentation -- sparse in some files, nonexistent in others.
+
+
From abaine at common-lisp.net Sun Jul 8 04:35:18 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Sun, 8 Jul 2007 00:35:18 -0400 (EDT)
Subject: [funds-cvs] r66 - trunk/funds
Message-ID: <20070708043518.599FB1B000@common-lisp.net>
Author: abaine
Date: Sun Jul 8 00:35:18 2007
New Revision: 66
Added:
trunk/funds/README
Log:
Added terse instructions.
Added: trunk/funds/README
==============================================================================
--- (empty file)
+++ trunk/funds/README Sun Jul 8 00:35:18 2007
@@ -0,0 +1,10 @@
+
+Funds is designed to be loaded with asdf, available from
+http://cclan.cvs.sourceforge.net/*checkout*/cclan/asdf/asdf.lisp.
+
+To load the system, type at a lisp prompt:
+
+ > (asdf-operate 'asdf:load-op 'funds)
+
+To see the publicly exported symbols in package "FUNDS," look at
+the file funds/src/package.lisp.
\ No newline at end of file
From abaine at common-lisp.net Sun Jul 8 04:36:03 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Sun, 8 Jul 2007 00:36:03 -0400 (EDT)
Subject: [funds-cvs] r67 - trunk/funds
Message-ID: <20070708043603.91FFD1B000@common-lisp.net>
Author: abaine
Date: Sun Jul 8 00:36:03 2007
New Revision: 67
Modified:
trunk/funds/issues.txt
Log:
Found another issue.
Modified: trunk/funds/issues.txt
==============================================================================
--- trunk/funds/issues.txt (original)
+++ trunk/funds/issues.txt Sun Jul 8 00:36:03 2007
@@ -10,4 +10,3 @@
4. Documentation -- sparse in some files, nonexistent in others.
-
From abaine at common-lisp.net Tue Jul 10 11:36:57 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Tue, 10 Jul 2007 07:36:57 -0400 (EDT)
Subject: [funds-cvs] r68 - trunk/public_html
Message-ID: <20070710113657.7442A1703B@common-lisp.net>
Author: abaine
Date: Tue Jul 10 07:36:55 2007
New Revision: 68
Modified:
trunk/public_html/index.html
Log:
Switched to apache license.
Modified: trunk/public_html/index.html
==============================================================================
--- trunk/public_html/index.html (original)
+++ trunk/public_html/index.html Tue Jul 10 07:36:55 2007
@@ -16,8 +16,8 @@
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
+
+ Apache License
.
Mailing Lists
@@ -40,9 +40,10 @@
development as a
Google Summer of Code Project, and a release is planned for
- July 13, 2007.
+ August 20, 2007. In the meantime, the sources are available from
+ subversion repository.
-
+
Project members
From abaine at common-lisp.net Tue Jul 10 12:00:39 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Tue, 10 Jul 2007 08:00:39 -0400 (EDT)
Subject: [funds-cvs] r69 - trunk/funds
Message-ID: <20070710120039.602631703B@common-lisp.net>
Author: abaine
Date: Tue Jul 10 08:00:38 2007
New Revision: 69
Modified:
trunk/funds/license.txt
Log:
Apache license boilerplate added.
Modified: trunk/funds/license.txt
==============================================================================
--- trunk/funds/license.txt (original)
+++ trunk/funds/license.txt Tue Jul 10 08:00:38 2007
@@ -1,22 +1,14 @@
-The MIT License
-
-Copyright (c) 2007 Andrew Baine
-
-Permission is hereby granted, free of charge, to any person obtaining a copy
-of this software and associated documentation files (the "Software"), to deal
-in the Software without restriction, including without limitation the rights
-to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
-copies of the Software, and to permit persons to whom the Software is
-furnished to do so, subject to the following conditions:
-
-The above copyright notice and this permission notice shall be included in
-all copies or substantial portions of the Software.
-
-THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
-IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
-FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
-AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
-LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
-OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
-THE SOFTWARE.
+;;;; Copyright 2007 Andrew Baine
+;;;;
+;;;; Licensed under the Apache License, Version 2.0 (the "License"); you
+;;;; may not use this file except in compliance with the License. You may
+;;;; obtain a copy of the License at
+;;;;
+;;;; http://www.apache.org/licenses/LICENSE-2.0 Unless required by
+;;;;
+;;;; applicable law or agreed to in writing, software distributed under the
+;;;; License is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR
+;;;; CONDITIONS OF ANY KIND, either express or implied. See the License for
+;;;; the specific language governing permissions and limitations under the
+;;;; License.
From abaine at common-lisp.net Tue Jul 10 12:09:24 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Tue, 10 Jul 2007 08:09:24 -0400 (EDT)
Subject: [funds-cvs] r70 - trunk/funds
Message-ID: <20070710120924.D40975F05C@common-lisp.net>
Author: abaine
Date: Tue Jul 10 08:09:23 2007
New Revision: 70
Modified:
trunk/funds/license.txt
Log:
Fixed typo in license.
Modified: trunk/funds/license.txt
==============================================================================
--- trunk/funds/license.txt (original)
+++ trunk/funds/license.txt Tue Jul 10 08:09:23 2007
@@ -1,14 +1,16 @@
-;;;; Copyright 2007 Andrew Baine
;;;;
-;;;; Licensed under the Apache License, Version 2.0 (the "License"); you
-;;;; may not use this file except in compliance with the License. You may
-;;;; obtain a copy of the License at
-;;;;
-;;;; http://www.apache.org/licenses/LICENSE-2.0 Unless required by
-;;;;
-;;;; applicable law or agreed to in writing, software distributed under the
-;;;; License is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR
-;;;; CONDITIONS OF ANY KIND, either express or implied. See the License for
-;;;; the specific language governing permissions and limitations under the
-;;;; License.
+;;;; Copyright 2007 Andrew Baine
+;;;;
+;;;; Licensed under the Apache License, Version 2.0 (the "License");
+;;;; you may not use this file except in compliance with the License.
+;;;; You may obtain a copy of the License at
+;;;;
+;;;; http://www.apache.org/licenses/LICENSE-2.0
+;;;;
+;;;; Unless required by applicable law or agreed to in writing, software
+;;;; distributed under the License is distributed on an "AS IS" BASIS,
+;;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+;;;; See the License for the specific language governing permissions and
+;;;; limitations under the License.
+;;;;
From abaine at common-lisp.net Tue Jul 10 12:14:31 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Tue, 10 Jul 2007 08:14:31 -0400 (EDT)
Subject: [funds-cvs] r71 - in trunk/funds: src src/trees src/trees/heap
tests tests/trees
Message-ID: <20070710121431.79E8D60035@common-lisp.net>
Author: abaine
Date: Tue Jul 10 08:14:29 2007
New Revision: 71
Modified:
trunk/funds/src/package.lisp
trunk/funds/src/queue.lisp
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/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
trunk/funds/tests/package.lisp
trunk/funds/tests/trees/avl-tree-test.lisp
Log:
Added boilerplate to .lisp files.
Modified: trunk/funds/src/package.lisp
==============================================================================
--- trunk/funds/src/package.lisp (original)
+++ trunk/funds/src/package.lisp Tue Jul 10 08:14:29 2007
@@ -1,4 +1,20 @@
+;;;;
+;;;; Copyright 2007 Andrew Baine
+;;;;
+;;;; Licensed under the Apache License, Version 2.0 (the "License");
+;;;; you may not use this file except in compliance with the License.
+;;;; You may obtain a copy of the License at
+;;;;
+;;;; http://www.apache.org/licenses/LICENSE-2.0
+;;;;
+;;;; Unless required by applicable law or agreed to in writing, software
+;;;; distributed under the License is distributed on an "AS IS" BASIS,
+;;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+;;;; See the License for the specific language governing permissions and
+;;;; limitations under the License.
+;;;;
+
(in-package :cl-user)
(defpackage :funds
Modified: trunk/funds/src/queue.lisp
==============================================================================
--- trunk/funds/src/queue.lisp (original)
+++ trunk/funds/src/queue.lisp Tue Jul 10 08:14:29 2007
@@ -1,4 +1,20 @@
+;;;;
+;;;; Copyright 2007 Andrew Baine
+;;;;
+;;;; Licensed under the Apache License, Version 2.0 (the "License");
+;;;; you may not use this file except in compliance with the License.
+;;;; You may obtain a copy of the License at
+;;;;
+;;;; http://www.apache.org/licenses/LICENSE-2.0
+;;;;
+;;;; Unless required by applicable law or agreed to in writing, software
+;;;; distributed under the License is distributed on an "AS IS" BASIS,
+;;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+;;;; See the License for the specific language governing permissions and
+;;;; limitations under the License.
+;;;;
+
(in-package :funds)
(defstruct queue
Modified: trunk/funds/src/stack.lisp
==============================================================================
--- trunk/funds/src/stack.lisp (original)
+++ trunk/funds/src/stack.lisp Tue Jul 10 08:14:29 2007
@@ -1,4 +1,20 @@
+;;;;
+;;;; Copyright 2007 Andrew Baine
+;;;;
+;;;; Licensed under the Apache License, Version 2.0 (the "License");
+;;;; you may not use this file except in compliance with the License.
+;;;; You may obtain a copy of the License at
+;;;;
+;;;; http://www.apache.org/licenses/LICENSE-2.0
+;;;;
+;;;; Unless required by applicable law or agreed to in writing, software
+;;;; distributed under the License is distributed on an "AS IS" BASIS,
+;;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+;;;; See the License for the specific language governing permissions and
+;;;; limitations under the License.
+;;;;
+
(in-package :funds)
(defun make-stack ()
Modified: trunk/funds/src/trees/avl.lisp
==============================================================================
--- trunk/funds/src/trees/avl.lisp (original)
+++ trunk/funds/src/trees/avl.lisp Tue Jul 10 08:14:29 2007
@@ -1,4 +1,20 @@
+;;;;
+;;;; Copyright 2007 Andrew Baine
+;;;;
+;;;; Licensed under the Apache License, Version 2.0 (the "License");
+;;;; you may not use this file except in compliance with the License.
+;;;; You may obtain a copy of the License at
+;;;;
+;;;; http://www.apache.org/licenses/LICENSE-2.0
+;;;;
+;;;; Unless required by applicable law or agreed to in writing, software
+;;;; distributed under the License is distributed on an "AS IS" BASIS,
+;;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+;;;; See the License for the specific language governing permissions and
+;;;; limitations under the License.
+;;;;
+
(in-package :funds)
(defun balance (inside root outside &key heavy-side)
Modified: trunk/funds/src/trees/bt.lisp
==============================================================================
--- trunk/funds/src/trees/bt.lisp (original)
+++ trunk/funds/src/trees/bt.lisp Tue Jul 10 08:14:29 2007
@@ -1,4 +1,20 @@
+;;;;
+;;;; Copyright 2007 Andrew Baine
+;;;;
+;;;; Licensed under the Apache License, Version 2.0 (the "License");
+;;;; you may not use this file except in compliance with the License.
+;;;; You may obtain a copy of the License at
+;;;;
+;;;; http://www.apache.org/licenses/LICENSE-2.0
+;;;;
+;;;; Unless required by applicable law or agreed to in writing, software
+;;;; distributed under the License is distributed on an "AS IS" BASIS,
+;;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+;;;; See the License for the specific language governing permissions and
+;;;; limitations under the License.
+;;;;
+
(in-package :funds)
(defun left-p (side)
Modified: trunk/funds/src/trees/classes.lisp
==============================================================================
--- trunk/funds/src/trees/classes.lisp (original)
+++ trunk/funds/src/trees/classes.lisp Tue Jul 10 08:14:29 2007
@@ -1,4 +1,20 @@
+;;;;
+;;;; Copyright 2007 Andrew Baine
+;;;;
+;;;; Licensed under the Apache License, Version 2.0 (the "License");
+;;;; you may not use this file except in compliance with the License.
+;;;; You may obtain a copy of the License at
+;;;;
+;;;; http://www.apache.org/licenses/LICENSE-2.0
+;;;;
+;;;; Unless required by applicable law or agreed to in writing, software
+;;;; distributed under the License is distributed on an "AS IS" BASIS,
+;;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+;;;; See the License for the specific language governing permissions and
+;;;; limitations under the License.
+;;;;
+
(in-package :funds)
(defclass tree ()
Modified: trunk/funds/src/trees/constructors.lisp
==============================================================================
--- trunk/funds/src/trees/constructors.lisp (original)
+++ trunk/funds/src/trees/constructors.lisp Tue Jul 10 08:14:29 2007
@@ -1,4 +1,20 @@
+;;;;
+;;;; Copyright 2007 Andrew Baine
+;;;;
+;;;; Licensed under the Apache License, Version 2.0 (the "License");
+;;;; you may not use this file except in compliance with the License.
+;;;; You may obtain a copy of the License at
+;;;;
+;;;; http://www.apache.org/licenses/LICENSE-2.0
+;;;;
+;;;; Unless required by applicable law or agreed to in writing, software
+;;;; distributed under the License is distributed on an "AS IS" BASIS,
+;;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+;;;; See the License for the specific language governing permissions and
+;;;; limitations under the License.
+;;;;
+
(in-package :funds)
(defun make-bt-leaf ()
Modified: trunk/funds/src/trees/heap/heap-empty-p.lisp
==============================================================================
--- trunk/funds/src/trees/heap/heap-empty-p.lisp (original)
+++ trunk/funds/src/trees/heap/heap-empty-p.lisp Tue Jul 10 08:14:29 2007
@@ -1,4 +1,20 @@
+;;;;
+;;;; Copyright 2007 Andrew Baine
+;;;;
+;;;; Licensed under the Apache License, Version 2.0 (the "License");
+;;;; you may not use this file except in compliance with the License.
+;;;; You may obtain a copy of the License at
+;;;;
+;;;; http://www.apache.org/licenses/LICENSE-2.0
+;;;;
+;;;; Unless required by applicable law or agreed to in writing, software
+;;;; distributed under the License is distributed on an "AS IS" BASIS,
+;;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+;;;; See the License for the specific language governing permissions and
+;;;; limitations under the License.
+;;;;
+
(in-package :funds)
(defun heap-empty-p (heap)
Modified: trunk/funds/src/trees/heap/heap-first.lisp
==============================================================================
--- trunk/funds/src/trees/heap/heap-first.lisp (original)
+++ trunk/funds/src/trees/heap/heap-first.lisp Tue Jul 10 08:14:29 2007
@@ -1,4 +1,20 @@
+;;;;
+;;;; Copyright 2007 Andrew Baine
+;;;;
+;;;; Licensed under the Apache License, Version 2.0 (the "License");
+;;;; you may not use this file except in compliance with the License.
+;;;; You may obtain a copy of the License at
+;;;;
+;;;; http://www.apache.org/licenses/LICENSE-2.0
+;;;;
+;;;; Unless required by applicable law or agreed to in writing, software
+;;;; distributed under the License is distributed on an "AS IS" BASIS,
+;;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+;;;; See the License for the specific language governing permissions and
+;;;; limitations under the License.
+;;;;
+
(in-package :funds)
(defun heap-first (heap)
Modified: trunk/funds/src/trees/heap/heap-insert.lisp
==============================================================================
--- trunk/funds/src/trees/heap/heap-insert.lisp (original)
+++ trunk/funds/src/trees/heap/heap-insert.lisp Tue Jul 10 08:14:29 2007
@@ -1,4 +1,20 @@
+;;;;
+;;;; Copyright 2007 Andrew Baine
+;;;;
+;;;; Licensed under the Apache License, Version 2.0 (the "License");
+;;;; you may not use this file except in compliance with the License.
+;;;; You may obtain a copy of the License at
+;;;;
+;;;; http://www.apache.org/licenses/LICENSE-2.0
+;;;;
+;;;; Unless required by applicable law or agreed to in writing, software
+;;;; distributed under the License is distributed on an "AS IS" BASIS,
+;;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+;;;; See the License for the specific language governing permissions and
+;;;; limitations under the License.
+;;;;
+
(in-package :funds)
(defgeneric heap-insert (heap value priority &key order))
Modified: trunk/funds/src/trees/heap/heap-remove.lisp
==============================================================================
--- trunk/funds/src/trees/heap/heap-remove.lisp (original)
+++ trunk/funds/src/trees/heap/heap-remove.lisp Tue Jul 10 08:14:29 2007
@@ -1,4 +1,20 @@
+;;;;
+;;;; Copyright 2007 Andrew Baine
+;;;;
+;;;; Licensed under the Apache License, Version 2.0 (the "License");
+;;;; you may not use this file except in compliance with the License.
+;;;; You may obtain a copy of the License at
+;;;;
+;;;; http://www.apache.org/licenses/LICENSE-2.0
+;;;;
+;;;; Unless required by applicable law or agreed to in writing, software
+;;;; distributed under the License is distributed on an "AS IS" BASIS,
+;;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+;;;; See the License for the specific language governing permissions and
+;;;; limitations under the License.
+;;;;
+
(in-package :funds)
(defmethod heap-remove ((heap heap-leaf) &key order)
Modified: trunk/funds/src/trees/tree-as-alist.lisp
==============================================================================
--- trunk/funds/src/trees/tree-as-alist.lisp (original)
+++ trunk/funds/src/trees/tree-as-alist.lisp Tue Jul 10 08:14:29 2007
@@ -1,4 +1,20 @@
+;;;;
+;;;; Copyright 2007 Andrew Baine
+;;;;
+;;;; Licensed under the Apache License, Version 2.0 (the "License");
+;;;; you may not use this file except in compliance with the License.
+;;;; You may obtain a copy of the License at
+;;;;
+;;;; http://www.apache.org/licenses/LICENSE-2.0
+;;;;
+;;;; Unless required by applicable law or agreed to in writing, software
+;;;; distributed under the License is distributed on an "AS IS" BASIS,
+;;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+;;;; See the License for the specific language governing permissions and
+;;;; limitations under the License.
+;;;;
+
(in-package :funds)
(defgeneric tree-as-alist (tree)
Modified: trunk/funds/src/trees/tree-empty-p.lisp
==============================================================================
--- trunk/funds/src/trees/tree-empty-p.lisp (original)
+++ trunk/funds/src/trees/tree-empty-p.lisp Tue Jul 10 08:14:29 2007
@@ -1,4 +1,20 @@
+;;;;
+;;;; Copyright 2007 Andrew Baine
+;;;;
+;;;; Licensed under the Apache License, Version 2.0 (the "License");
+;;;; you may not use this file except in compliance with the License.
+;;;; You may obtain a copy of the License at
+;;;;
+;;;; http://www.apache.org/licenses/LICENSE-2.0
+;;;;
+;;;; Unless required by applicable law or agreed to in writing, software
+;;;; distributed under the License is distributed on an "AS IS" BASIS,
+;;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+;;;; See the License for the specific language governing permissions and
+;;;; limitations under the License.
+;;;;
+
(in-package :funds)
(defgeneric tree-empty-p (tree)
Modified: trunk/funds/src/trees/tree-find.lisp
==============================================================================
--- trunk/funds/src/trees/tree-find.lisp (original)
+++ trunk/funds/src/trees/tree-find.lisp Tue Jul 10 08:14:29 2007
@@ -1,4 +1,20 @@
+;;;;
+;;;; Copyright 2007 Andrew Baine
+;;;;
+;;;; Licensed under the Apache License, Version 2.0 (the "License");
+;;;; you may not use this file except in compliance with the License.
+;;;; You may obtain a copy of the License at
+;;;;
+;;;; http://www.apache.org/licenses/LICENSE-2.0
+;;;;
+;;;; Unless required by applicable law or agreed to in writing, software
+;;;; distributed under the License is distributed on an "AS IS" BASIS,
+;;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+;;;; See the License for the specific language governing permissions and
+;;;; limitations under the License.
+;;;;
+
(in-package :funds)
(defgeneric tree-find (tree key &key test order)
Modified: trunk/funds/src/trees/tree-height.lisp
==============================================================================
--- trunk/funds/src/trees/tree-height.lisp (original)
+++ trunk/funds/src/trees/tree-height.lisp Tue Jul 10 08:14:29 2007
@@ -1,4 +1,20 @@
+;;;;
+;;;; Copyright 2007 Andrew Baine
+;;;;
+;;;; Licensed under the Apache License, Version 2.0 (the "License");
+;;;; you may not use this file except in compliance with the License.
+;;;; You may obtain a copy of the License at
+;;;;
+;;;; http://www.apache.org/licenses/LICENSE-2.0
+;;;;
+;;;; Unless required by applicable law or agreed to in writing, software
+;;;; distributed under the License is distributed on an "AS IS" BASIS,
+;;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+;;;; See the License for the specific language governing permissions and
+;;;; limitations under the License.
+;;;;
+
(in-package :funds)
(defgeneric tree-height (tree)
Modified: trunk/funds/src/trees/tree-insert.lisp
==============================================================================
--- trunk/funds/src/trees/tree-insert.lisp (original)
+++ trunk/funds/src/trees/tree-insert.lisp Tue Jul 10 08:14:29 2007
@@ -1,4 +1,20 @@
+;;;;
+;;;; Copyright 2007 Andrew Baine
+;;;;
+;;;; Licensed under the Apache License, Version 2.0 (the "License");
+;;;; you may not use this file except in compliance with the License.
+;;;; You may obtain a copy of the License at
+;;;;
+;;;; http://www.apache.org/licenses/LICENSE-2.0
+;;;;
+;;;; Unless required by applicable law or agreed to in writing, software
+;;;; distributed under the License is distributed on an "AS IS" BASIS,
+;;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+;;;; See the License for the specific language governing permissions and
+;;;; limitations under the License.
+;;;;
+
(in-package :funds)
(defgeneric tree-insert (tree key value &key test order)
Modified: trunk/funds/src/trees/tree-remove.lisp
==============================================================================
--- trunk/funds/src/trees/tree-remove.lisp (original)
+++ trunk/funds/src/trees/tree-remove.lisp Tue Jul 10 08:14:29 2007
@@ -1,4 +1,20 @@
+;;;;
+;;;; Copyright 2007 Andrew Baine
+;;;;
+;;;; Licensed under the Apache License, Version 2.0 (the "License");
+;;;; you may not use this file except in compliance with the License.
+;;;; You may obtain a copy of the License at
+;;;;
+;;;; http://www.apache.org/licenses/LICENSE-2.0
+;;;;
+;;;; Unless required by applicable law or agreed to in writing, software
+;;;; distributed under the License is distributed on an "AS IS" BASIS,
+;;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+;;;; See the License for the specific language governing permissions and
+;;;; limitations under the License.
+;;;;
+
(in-package :funds)
(defgeneric tree-remove (tree key &key test order)
Modified: trunk/funds/src/trees/tree-weight.lisp
==============================================================================
--- trunk/funds/src/trees/tree-weight.lisp (original)
+++ trunk/funds/src/trees/tree-weight.lisp Tue Jul 10 08:14:29 2007
@@ -1,4 +1,20 @@
+;;;;
+;;;; Copyright 2007 Andrew Baine
+;;;;
+;;;; Licensed under the Apache License, Version 2.0 (the "License");
+;;;; you may not use this file except in compliance with the License.
+;;;; You may obtain a copy of the License at
+;;;;
+;;;; http://www.apache.org/licenses/LICENSE-2.0
+;;;;
+;;;; Unless required by applicable law or agreed to in writing, software
+;;;; distributed under the License is distributed on an "AS IS" BASIS,
+;;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+;;;; See the License for the specific language governing permissions and
+;;;; limitations under the License.
+;;;;
+
(in-package :funds)
(defgeneric tree-weight (tree)
Modified: trunk/funds/tests/package.lisp
==============================================================================
--- trunk/funds/tests/package.lisp (original)
+++ trunk/funds/tests/package.lisp Tue Jul 10 08:14:29 2007
@@ -1,4 +1,20 @@
+;;;;
+;;;; Copyright 2007 Andrew Baine
+;;;;
+;;;; Licensed under the Apache License, Version 2.0 (the "License");
+;;;; you may not use this file except in compliance with the License.
+;;;; You may obtain a copy of the License at
+;;;;
+;;;; http://www.apache.org/licenses/LICENSE-2.0
+;;;;
+;;;; Unless required by applicable law or agreed to in writing, software
+;;;; distributed under the License is distributed on an "AS IS" BASIS,
+;;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+;;;; See the License for the specific language governing permissions and
+;;;; limitations under the License.
+;;;;
+
(in-package :cl-user)
(defpackage funds-tests
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 Tue Jul 10 08:14:29 2007
@@ -1,4 +1,20 @@
+;;;;
+;;;; Copyright 2007 Andrew Baine
+;;;;
+;;;; Licensed under the Apache License, Version 2.0 (the "License");
+;;;; you may not use this file except in compliance with the License.
+;;;; You may obtain a copy of the License at
+;;;;
+;;;; http://www.apache.org/licenses/LICENSE-2.0
+;;;;
+;;;; Unless required by applicable law or agreed to in writing, software
+;;;; distributed under the License is distributed on an "AS IS" BASIS,
+;;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+;;;; See the License for the specific language governing permissions and
+;;;; limitations under the License.
+;;;;
+
(in-package :funds.tests.trees)
(defun random-tree (&key (test #'eql) (order #'<))
From abaine at common-lisp.net Tue Jul 10 12:19:56 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Tue, 10 Jul 2007 08:19:56 -0400 (EDT)
Subject: [funds-cvs] r72 - in trunk/funds: src tests
Message-ID: <20070710121956.71BE76108F@common-lisp.net>
Author: abaine
Date: Tue Jul 10 08:19:56 2007
New Revision: 72
Modified:
trunk/funds/src/funds.asd
trunk/funds/tests/funds-tests.asd
Log:
Added boilerplate to .asd files.
Modified: trunk/funds/src/funds.asd
==============================================================================
--- trunk/funds/src/funds.asd (original)
+++ trunk/funds/src/funds.asd Tue Jul 10 08:19:56 2007
@@ -1,5 +1,20 @@
-; -*- Lisp -*-
+;;;; -*- Lisp -*-
+;;;;
+;;;; Copyright 2007 Andrew Baine
+;;;;
+;;;; Licensed under the Apache License, Version 2.0 (the "License");
+;;;; you may not use this file except in compliance with the License.
+;;;; You may obtain a copy of the License at
+;;;;
+;;;; http://www.apache.org/licenses/LICENSE-2.0
+;;;;
+;;;; Unless required by applicable law or agreed to in writing, software
+;;;; distributed under the License is distributed on an "AS IS" BASIS,
+;;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+;;;; See the License for the specific language governing permissions and
+;;;; limitations under the License.
+;;;;
(in-package :cl-user)
Modified: trunk/funds/tests/funds-tests.asd
==============================================================================
--- trunk/funds/tests/funds-tests.asd (original)
+++ trunk/funds/tests/funds-tests.asd Tue Jul 10 08:19:56 2007
@@ -1,5 +1,20 @@
;;;; -*- Lisp -*-
+;;;;
+;;;; Copyright 2007 Andrew Baine
+;;;;
+;;;; Licensed under the Apache License, Version 2.0 (the "License");
+;;;; you may not use this file except in compliance with the License.
+;;;; You may obtain a copy of the License at
+;;;;
+;;;; http://www.apache.org/licenses/LICENSE-2.0
+;;;;
+;;;; Unless required by applicable law or agreed to in writing, software
+;;;; distributed under the License is distributed on an "AS IS" BASIS,
+;;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+;;;; See the License for the specific language governing permissions and
+;;;; limitations under the License.
+;;;;
(in-package :cl-user)
From abaine at common-lisp.net Tue Jul 10 12:31:40 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Tue, 10 Jul 2007 08:31:40 -0400 (EDT)
Subject: [funds-cvs] r73 - trunk/funds
Message-ID: <20070710123140.ED4911B018@common-lisp.net>
Author: abaine
Date: Tue Jul 10 08:31:40 2007
New Revision: 73
Modified:
trunk/funds/README
Log:
Made README more explicit about linking to funds.asd.
Modified: trunk/funds/README
==============================================================================
--- trunk/funds/README (original)
+++ trunk/funds/README Tue Jul 10 08:31:40 2007
@@ -2,9 +2,20 @@
Funds is designed to be loaded with asdf, available from
http://cclan.cvs.sourceforge.net/*checkout*/cclan/asdf/asdf.lisp.
+Make a symbolic link to the file funds.asd. On linux, the command
+would be something like:
+
+ prompt$ cd /somewhere/in/*central-registry*
+ prompt$ ln -s /path/to/funds.asd .
+
+On my machine, that translates to:
+
+ wonder$ cd ~/.sbcl/systems
+ wonder$ ln -s /home/andrew/sandbox/funds/src/funds.asd .
+
To load the system, type at a lisp prompt:
> (asdf-operate 'asdf:load-op 'funds)
To see the publicly exported symbols in package "FUNDS," look at
-the file funds/src/package.lisp.
\ No newline at end of file
+the file funds/src/package.lisp.
From abaine at common-lisp.net Tue Jul 10 12:35:09 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Tue, 10 Jul 2007 08:35:09 -0400 (EDT)
Subject: [funds-cvs] r74 - trunk/funds
Message-ID: <20070710123509.EC4AC1C0C6@common-lisp.net>
Author: abaine
Date: Tue Jul 10 08:35:09 2007
New Revision: 74
Modified:
trunk/funds/README
Log:
Fixed typo.
Modified: trunk/funds/README
==============================================================================
--- trunk/funds/README (original)
+++ trunk/funds/README Tue Jul 10 08:35:09 2007
@@ -15,7 +15,7 @@
To load the system, type at a lisp prompt:
- > (asdf-operate 'asdf:load-op 'funds)
+ > (asdf:operate 'asdf:load-op 'funds)
To see the publicly exported symbols in package "FUNDS," look at
the file funds/src/package.lisp.
From abaine at common-lisp.net Tue Jul 10 21:36:04 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Tue, 10 Jul 2007 17:36:04 -0400 (EDT)
Subject: [funds-cvs] r75 - trunk/funds/src/trees
Message-ID: <20070710213604.9D8AE1C008@common-lisp.net>
Author: abaine
Date: Tue Jul 10 17:36:04 2007
New Revision: 75
Modified:
trunk/funds/src/trees/avl.lisp
trunk/funds/src/trees/bt.lisp
Log:
Moved some avl-specific functions from bt.lisp to avl.lisp.
Modified: trunk/funds/src/trees/avl.lisp
==============================================================================
--- trunk/funds/src/trees/avl.lisp (original)
+++ trunk/funds/src/trees/avl.lisp Tue Jul 10 17:36:04 2007
@@ -17,6 +17,23 @@
(in-package :funds)
+
+(defun parent-height (t1 t2)
+ (let ((h1 (tree-height t1))
+ (h2 (tree-height t2)))
+ (1+ (if (> h1 h2) h1 h2))))
+
+(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))))
+
+(defun balanced-p (t1 t2)
+ (< -2 (height-difference t1 t2) 2))
+
(defun balance (inside root outside &key heavy-side)
(let ((other-side (other-side heavy-side)))
(if (balanced-p inside outside)
Modified: trunk/funds/src/trees/bt.lisp
==============================================================================
--- trunk/funds/src/trees/bt.lisp (original)
+++ trunk/funds/src/trees/bt.lisp Tue Jul 10 17:36:04 2007
@@ -32,21 +32,3 @@
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))))
-
-
From abaine at common-lisp.net Wed Jul 11 02:19:09 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Tue, 10 Jul 2007 22:19:09 -0400 (EDT)
Subject: [funds-cvs] r76 - trunk/funds/tests/trees
Message-ID: <20070711021909.B519E6108E@common-lisp.net>
Author: abaine
Date: Tue Jul 10 22:19:09 2007
New Revision: 76
Modified:
trunk/funds/tests/trees/avl-tree-test.lisp
Log:
Tests adapted to rewrite.
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 Tue Jul 10 22:19:09 2007
@@ -15,56 +15,56 @@
;;;; limitations under the License.
;;;;
-(in-package :funds.tests.trees)
+(in-package :funds-tests)
(defun random-tree (&key (test #'eql) (order #'<))
(reduce #'(lambda (tr v)
- (avl-insert tr v v :test test :order order))
+ (tree-insert tr v v :test test :order order))
(loop for i below 40 collect (random 20))
- :initial-value (empty-avl-tree)))
+ :initial-value (make-avl-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 :order ,order) ,tree)))
-
-(define-test test-avl-empty-p
- (assert-true (avl-empty-p (empty-avl-tree)))
- (assert-avl-valid (empty-avl-tree)))
+ (assert-true (height-correct-p ,tree) (funds::tree-as-pre-order-alist ,tree))
+ (assert-true (balanced-p ,tree) (funds::tree-as-pre-order-alist ,tree))
+ (assert-true (ordered-p ,tree :order ,order) (funds::tree-as-pre-order-alist ,tree))))
+
+(define-test test-tree-empty-p
+ (assert-true (tree-empty-p (make-avl-tree)))
+ (assert-avl-valid (make-avl-tree)))
-(define-test test-avl-insert
+(define-test test-tree-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
+ "Whether (tree-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."
- (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)))
+ (or (and (tree-empty-p tree)
+ (zerop (tree-height tree))) ; (a)
+ (and (height-correct-p (funds::bt-left tree)) ; (1)
+ (height-correct-p (funds::bt-right tree)) ; (2)
+ (let* ((a (tree-height (funds::bt-left tree)))
+ (b (tree-height (funds::bt-right tree)))
(c (if (> a b) a b)))
- (eql (1+ c) (avl-height tree)))))) ; (3)
+ (eql (1+ c) (tree-height tree)))))) ; (3)
(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-p (avl-left tree))
- (balanced-p (avl-right tree))
- (< -2 (- (avl-height (avl-left tree))
- (avl-height (avl-right tree)))
+ (or (tree-empty-p tree)
+ (and (balanced-p (funds::bt-left tree))
+ (balanced-p (funds::bt-right tree))
+ (< -2 (- (tree-height (funds::bt-left tree))
+ (tree-height (funds::bt-right tree)))
2))))
(defun ordered-p (tree &key (order #'<))
@@ -78,24 +78,24 @@
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 order (avl-key tree)
- (greatest-key (avl-left tree)))))
- (or (avl-empty-p (avl-right tree))
- (not (funcall order (least-key (avl-right tree))
- (avl-key tree)))))))
+ (or (tree-empty-p tree)
+ (and (ordered-p (funds::bt-left tree))
+ (ordered-p (funds::bt-right tree))
+ (or (tree-empty-p (funds::bt-left tree))
+ (not (funcall order (funds::bt-key tree)
+ (greatest-key (funds::bt-left tree)))))
+ (or (tree-empty-p (funds::bt-right tree))
+ (not (funcall order (least-key (funds::bt-right tree))
+ (funds::bt-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))))
+ (if (tree-empty-p (funds::bt-left tree))
+ (funds::bt-key tree)
+ (least-key (funds::bt-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))))
+ (if (tree-empty-p (funds::bt-right tree))
+ (funds::bt-key tree)
+ (greatest-key (funds::bt-right tree))))
From abaine at common-lisp.net Wed Jul 11 02:45:49 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Tue, 10 Jul 2007 22:45:49 -0400 (EDT)
Subject: [funds-cvs] r77 - trunk/funds/src/trees
Message-ID: <20070711024549.6663D3C078@common-lisp.net>
Author: abaine
Date: Tue Jul 10 22:45:48 2007
New Revision: 77
Modified:
trunk/funds/src/trees/constructors.lisp
Log:
make-leaf functions now all return singletons.
Modified: trunk/funds/src/trees/constructors.lisp
==============================================================================
--- trunk/funds/src/trees/constructors.lisp (original)
+++ trunk/funds/src/trees/constructors.lisp Tue Jul 10 22:45:48 2007
@@ -17,11 +17,18 @@
(in-package :funds)
+(defconstant +bt-leaf+ (make-instance 'bt-leaf))
+(defconstant +avl-leaf+ (make-instance 'avl-leaf))
+(defconstant +heap-leaf+ (make-instance 'heap-leaf))
+
(defun make-bt-leaf ()
- (make-instance 'bt-leaf))
+ +bt-leaf+)
(defun make-avl-leaf ()
- (make-instance 'avl-leaf))
+ +avl-leaf+)
+
+(defun make-heap-leaf ()
+ +heap-leaf+)
(defun make-binary-tree ()
(make-bt-leaf))
@@ -37,8 +44,7 @@
: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)))
From abaine at common-lisp.net Wed Jul 11 02:46:47 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Tue, 10 Jul 2007 22:46:47 -0400 (EDT)
Subject: [funds-cvs] r78 - trunk/funds/src/trees
Message-ID: <20070711024647.741053C078@common-lisp.net>
Author: abaine
Date: Tue Jul 10 22:46:47 2007
New Revision: 78
Modified:
trunk/funds/src/trees/avl.lisp
Log:
Refactored make-avl-tree calls into attach-avl function.
Modified: trunk/funds/src/trees/avl.lisp
==============================================================================
--- trunk/funds/src/trees/avl.lisp (original)
+++ trunk/funds/src/trees/avl.lisp Tue Jul 10 22:46:47 2007
@@ -37,10 +37,9 @@
(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)
+ (attach-avl root
+ heavy-side outside
+ other-side inside)
(rotate inside root
(if (heavier-p outside :side other-side)
(rotate (tree-child outside :side heavy-side)
@@ -52,13 +51,16 @@
(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-inside (attach-avl 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)))
+ (attach-avl outside
+ side new-inside
+ (other-side side) new-outside)))
+
+(defun attach-avl (root &key (right (make-avl-tree)) (left (make-avl-tree)))
+ (make-avl-tree :key (bt-key root)
+ :value (bt-key root)
+ :right right
+ :left left))
From abaine at common-lisp.net Wed Jul 11 03:17:18 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Tue, 10 Jul 2007 23:17:18 -0400 (EDT)
Subject: [funds-cvs] r79 - trunk/funds/src/trees
Message-ID: <20070711031718.C586754173@common-lisp.net>
Author: abaine
Date: Tue Jul 10 23:17:18 2007
New Revision: 79
Modified:
trunk/funds/src/trees/bt.lisp
Log:
Added attach-bt function.
Modified: trunk/funds/src/trees/bt.lisp
==============================================================================
--- trunk/funds/src/trees/bt.lisp (original)
+++ trunk/funds/src/trees/bt.lisp Tue Jul 10 23:17:18 2007
@@ -32,3 +32,10 @@
tree
(f (bt-left tree)))))
(f (bt-right tree))))
+
+(defun attach-bt (root &key left right)
+ (make-instance 'binary-tree
+ :key (bt-key root)
+ :value (bt-value root)
+ :left left
+ :right right))
From abaine at common-lisp.net Wed Jul 11 03:18:01 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Tue, 10 Jul 2007 23:18:01 -0400 (EDT)
Subject: [funds-cvs] r80 - trunk/funds/src/trees
Message-ID: <20070711031801.43DE154173@common-lisp.net>
Author: abaine
Date: Tue Jul 10 23:18:01 2007
New Revision: 80
Modified:
trunk/funds/src/trees/tree-insert.lisp
Log:
Greatly simplified tree-insert.
Modified: trunk/funds/src/trees/tree-insert.lisp
==============================================================================
--- trunk/funds/src/trees/tree-insert.lisp (original)
+++ trunk/funds/src/trees/tree-insert.lisp Tue Jul 10 23:18:01 2007
@@ -38,31 +38,34 @@
(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))))
+ (if (funcall test key (bt-key tree))
+ (make-instance 'binary-tree
+ :key key
+ :value value
+ :left (bt-left tree)
+ :right (bt-right tree))
+ (let* ((side (if (funcall order key (bt-key tree))
+ :left
+ :right))
+ (other-side (other-side side)))
+ (attach-bt tree
+ side (tree-insert (tree-child tree :side side) key value
+ :test test
+ :order order)
+ other-side (tree-child tree :side other-side)))))
-(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)))
+(defmethod tree-insert ((tree avl-tree) key value
+ &key (test #'eql) (order #'<))
+ (if (funcall test key (bt-key tree))
+ (make-avl-tree :key key
+ :value value
+ :left (bt-left tree)
+ :right (bt-right tree))
+ (let* ((temp (call-next-method))
+ (side (if (funcall order key (bt-key tree))
+ :left
+ :right))
+ (outside (tree-child temp :side side))
+ (inside (tree-child temp :side (other-side side))))
+ (balance inside temp outside :heavy-side side))))
+
From abaine at common-lisp.net Wed Jul 11 03:27:29 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Tue, 10 Jul 2007 23:27:29 -0400 (EDT)
Subject: [funds-cvs] r81 - trunk/funds/src/trees
Message-ID: <20070711032729.E6D9154173@common-lisp.net>
Author: abaine
Date: Tue Jul 10 23:27:29 2007
New Revision: 81
Modified:
trunk/funds/src/trees/bt.lisp
Log:
Factored out side-to-insert function.
Modified: trunk/funds/src/trees/bt.lisp
==============================================================================
--- trunk/funds/src/trees/bt.lisp (original)
+++ trunk/funds/src/trees/bt.lisp Tue Jul 10 23:27:29 2007
@@ -39,3 +39,8 @@
:value (bt-value root)
:left left
:right right))
+
+(defun side-to-insert (tree key &key order)
+ (if (funcall order key (bt-key tree))
+ :left
+ :right))
From abaine at common-lisp.net Wed Jul 11 03:28:15 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Tue, 10 Jul 2007 23:28:15 -0400 (EDT)
Subject: [funds-cvs] r82 - trunk/funds/src/trees
Message-ID: <20070711032815.9B12060035@common-lisp.net>
Author: abaine
Date: Tue Jul 10 23:28:15 2007
New Revision: 82
Modified:
trunk/funds/src/trees/tree-insert.lisp
Log:
Factored out side-to-insert function.
Modified: trunk/funds/src/trees/tree-insert.lisp
==============================================================================
--- trunk/funds/src/trees/tree-insert.lisp (original)
+++ trunk/funds/src/trees/tree-insert.lisp Tue Jul 10 23:28:15 2007
@@ -44,9 +44,7 @@
:value value
:left (bt-left tree)
:right (bt-right tree))
- (let* ((side (if (funcall order key (bt-key tree))
- :left
- :right))
+ (let* ((side (side-to-insert tree key :order order))
(other-side (other-side side)))
(attach-bt tree
side (tree-insert (tree-child tree :side side) key value
@@ -62,9 +60,7 @@
:left (bt-left tree)
:right (bt-right tree))
(let* ((temp (call-next-method))
- (side (if (funcall order key (bt-key tree))
- :left
- :right))
+ (side (side-to-insert tree key :order order))
(outside (tree-child temp :side side))
(inside (tree-child temp :side (other-side side))))
(balance inside temp outside :heavy-side side))))
From abaine at common-lisp.net Wed Jul 11 15:18:56 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Wed, 11 Jul 2007 11:18:56 -0400 (EDT)
Subject: [funds-cvs] r83 - trunk/funds/tests
Message-ID: <20070711151856.141F05D00B@common-lisp.net>
Author: abaine
Date: Wed Jul 11 11:18:55 2007
New Revision: 83
Added:
trunk/funds/tests/lisp-unit.lisp
Log:
Included lisp-unit.lisp in the project.
Added: trunk/funds/tests/lisp-unit.lisp
==============================================================================
--- (empty file)
+++ trunk/funds/tests/lisp-unit.lisp Wed Jul 11 11:18:55 2007
@@ -0,0 +1,429 @@
+;;;-*- Mode: Lisp; Package: LISP-UNIT -*-
+
+#|
+Copyright (c) 2004-2005 Christopher K. Riesbeck
+
+Permission is hereby granted, free of charge, to any person obtaining
+a copy of this software and associated documentation files (the "Software"),
+to deal in the Software without restriction, including without limitation
+the rights to use, copy, modify, merge, publish, distribute, sublicense,
+and/or sell copies of the Software, and to permit persons to whom the
+Software is furnished to do so, subject to the following conditions:
+
+The above copyright notice and this permission notice shall be included
+in all copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
+OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
+THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR
+OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE,
+ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
+OTHER DEALINGS IN THE SOFTWARE.
+|#
+
+
+;;; A test suite package, modelled after JUnit.
+;;; Author: Chris Riesbeck
+;;;
+;;; Update history:
+;;;
+;;; 04/07/06 added ~<...~> to remaining error output forms [CKR]
+;;; 04/06/06 added ~<...~> to compact error output better [CKR]
+;;; 04/06/06 fixed RUN-TESTS to get tests dynamically (bug reported
+;;; by Daniel Edward Burke) [CKR]
+;;; 02/08/06 added newlines to error output [CKR]
+;;; 12/30/05 renamed ASSERT-PREDICATE to ASSERT-EQUALITY [CKR]
+;;; 12/29/05 added ASSERT-EQ, ASSERT-EQL, ASSERT-EQUALP [CKR]
+;;; 12/22/05 recoded use-debugger to use handler-bind, added option to prompt for debugger,
+;;; 11/07/05 added *use-debugger* and assert-predicate [DFB]
+;;; 09/18/05 replaced Academic Free License with MIT Licence [CKR]
+;;; 08/30/05 added license notice [CKR]
+;;; 06/28/05 changed RUN-TESTS to compile code at run time, not expand time [CKR]
+;;; 02/21/05 removed length check from SET-EQUAL [CKR]
+;;; 02/17/05 added RUN-ALL-TESTS [CKR]
+;;; 01/18/05 added ASSERT-EQUAL back in [CKR]
+;;; 01/17/05 much clean up, added WITH-TEST-LISTENER [CKR]
+;;; 01/15/05 replaced ASSERT-EQUAL etc. with ASSERT-TRUE and ASSERT-FALSE [CKR]
+;;; 01/04/05 changed COLLECT-RESULTS to echo output on *STANDARD-OUTPuT* [CKR]
+;;; 01/04/05 added optional package argument to REMOVE-ALL-TESTS [CKR]
+;;; 01/04/05 changed OUTPUT-OK-P to trim spaces and returns [CKR]
+;;; 01/04/05 changed OUTPUT-OK-P to not check output except when asked to [CKR]
+;;; 12/03/04 merged REMOVE-TEST into REMOVE-TESTS [CKR]
+;;; 12/03/04 removed ability to pass forms to RUN-TESTS [CKR]
+;;; 12/03/04 refactored RUN-TESTS expansion into RUN-TEST-THUNKS [CKR]
+;;; 12/02/04 changed to group tests under packages [CKR]
+;;; 11/30/04 changed assertions to put expected value first, like JUnit [CKR]
+;;; 11/30/04 improved error handling and summarization [CKR]
+;;; 11/30/04 generalized RUN-TESTS, removed RUN-TEST [CKR]
+;;; 02/27/04 fixed ASSERT-PRINTS not ignoring value [CKR]
+;;; 02/07/04 fixed ASSERT-EXPANDS failure message [CKR]
+;;; 02/07/04 added ASSERT-NULL, ASSERT-NOT-NULL [CKR]
+;;; 01/31/04 added error handling and totalling to RUN-TESTS [CKR]
+;;; 01/31/04 made RUN-TEST/RUN-TESTS macros [CKR]
+;;; 01/29/04 fixed ASSERT-EXPANDS quote bug [CKR]
+;;; 01/28/04 major changes from BUG-FINDER to be more like JUnit [CKR]
+
+
+#|
+How to use
+----------
+
+1. Read the documentation in lisp-unit.html.
+
+2. Make a file of DEFINE-TEST's. See exercise-tests.lisp for many
+examples. If you want, start your test file with (REMOVE-TESTS) to
+clear any previously defined tests.
+
+2. Load this file.
+
+2. (use-package :lisp-unit)
+
+3. Load your code file and your file of tests.
+
+4. Test your code with (RUN-TESTS test-name1 test-name2 ...) -- no quotes! --
+or simply (RUN-TESTS) to run all defined tests.
+
+A summary of how many tests passed and failed will be printed,
+with details on the failures.
+
+Note: Nothing is compiled until RUN-TESTS is expanded. Redefining
+functions or even macros does not require reloading any tests.
+
+For more information, see lisp-unit.html.
+
+|#
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Packages
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(cl:defpackage #:lisp-unit
+ (:use #:common-lisp)
+ (:export #:define-test #:run-all-tests #:run-tests
+ #:assert-eq #:assert-eql #:assert-equal #:assert-equalp
+ #:assert-error #:assert-expands #:assert-false
+ #:assert-equality #:assert-prints #:assert-true
+ #:get-test-code #:get-tests
+ #:remove-all-tests #:remove-tests
+ #:logically-equal #:set-equal
+ #:use-debugger
+ #:with-test-listener)
+ )
+
+(in-package #:lisp-unit)
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Globals
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defparameter *test-listener* nil)
+
+(defparameter *tests* (make-hash-table))
+
+;;; Used by RUN-TESTS to collect summary statistics
+(defvar *test-count* 0)
+(defvar *pass-count* 0)
+
+;;; Set by RUN-TESTS for use by SHOW-FAILURE
+(defvar *test-name* nil)
+
+;;; If nil, errors in tests are caught and counted.
+;;; If :ask, user is given option of entering debugger or not.
+;;; If true and not :ask, debugger is entered.
+(defparameter *use-debugger* nil)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Macros
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;; DEFINE-TEST
+
+(defmacro define-test (name &body body)
+ `(progn
+ (store-test-code ',name ',body)
+ ',name))
+
+;;; ASSERT macros
+
+(defmacro assert-eq (expected form &rest extras)
+ (expand-assert :equal form form expected extras :test #'eq))
+
+(defmacro assert-eql (expected form &rest extras)
+ (expand-assert :equal form form expected extras :test #'eql))
+
+(defmacro assert-equal (expected form &rest extras)
+ (expand-assert :equal form form expected extras :test #'equal))
+
+(defmacro assert-equalp (expected form &rest extras)
+ (expand-assert :equal form form expected extras :test #'equalp))
+
+(defmacro assert-error (condition form &rest extras)
+ (expand-assert :error form (expand-error-form form)
+ condition extras))
+
+(defmacro assert-expands (&environment env expansion form &rest extras)
+ (expand-assert :macro form
+ (expand-macro-form form #+lispworks nil #-lispworks env)
+ expansion extras))
+
+(defmacro assert-false (form &rest extras)
+ (expand-assert :result form form nil extras))
+
+(defmacro assert-equality (test expected form &rest extras)
+ (expand-assert :equal form form expected extras :test test))
+
+(defmacro assert-prints (output form &rest extras)
+ (expand-assert :output form (expand-output-form form)
+ output extras))
+
+(defmacro assert-true (form &rest extras)
+ (expand-assert :result form form t extras))
+
+
+(defun expand-assert (type form body expected extras &key (test #'eql))
+ `(internal-assert
+ ,type ',form #'(lambda () ,body) #'(lambda () ,expected) ,(expand-extras extras), test))
+
+(defun expand-error-form (form)
+ `(handler-case ,form
+ (condition (error) error)))
+
+(defun expand-output-form (form)
+ (let ((out (gensym)))
+ `(let* ((,out (make-string-output-stream))
+ (*standard-output* (make-broadcast-stream *standard-output* ,out)))
+ ,form
+ (get-output-stream-string ,out))))
+
+(defun expand-macro-form (form env)
+ `(macroexpand-1 ',form ,env))
+
+(defun expand-extras (extras)
+ `#'(lambda ()
+ (list ,@(mapcan #'(lambda (form) (list `',form form)) extras))))
+
+
+;;; RUN-TESTS
+
+(defmacro run-all-tests (package &rest tests)
+ `(let ((*package* (find-package ',package)))
+ (run-tests
+ ,@(mapcar #'(lambda (test) (find-symbol (symbol-name test) package))
+ tests))))
+
+(defmacro run-tests (&rest names)
+ `(run-test-thunks (get-test-thunks ,(if (null names) '(get-tests *package*) `',names))))
+
+(defun get-test-thunks (names &optional (package *package*))
+ (mapcar #'(lambda (name) (get-test-thunk name package))
+ names))
+
+(defun get-test-thunk (name package)
+ (assert (get-test-code name package) (name package)
+ "No test defined for ~S in package ~S" name package)
+ (list name (coerce `(lambda () ,@(get-test-code name)) 'function)))
+
+(defun use-debugger (&optional (flag t))
+ (setq *use-debugger* flag))
+
+;;; WITH-TEST-LISTENER
+(defmacro with-test-listener (listener &body body)
+ `(let ((*test-listener* #',listener)) , at body))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Public functions
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun get-test-code (name &optional (package *package*))
+ (let ((table (get-package-table package)))
+ (unless (null table)
+ (gethash name table))))
+
+(defun get-tests (&optional (package *package*))
+ (let ((l nil)
+ (table (get-package-table package)))
+ (cond ((null table) nil)
+ (t
+ (maphash #'(lambda (key val)
+ (declare (ignore val))
+ (push key l))
+ table)
+ (sort l #'string< :key #'string)))))
+
+
+(defun remove-tests (names &optional (package *package*))
+ (let ((table (get-package-table package)))
+ (unless (null table)
+ (if (null names)
+ (clrhash table)
+ (dolist (name names)
+ (remhash name table))))))
+
+(defun remove-all-tests (&optional (package *package*))
+ (if (null package)
+ (clrhash *tests*)
+ (remhash (find-package package) *tests*)))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Private functions
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
+;;; DEFINE-TEST support
+
+(defun get-package-table (package &key create)
+ (let ((table (gethash (find-package package) *tests*)))
+ (or table
+ (and create
+ (setf (gethash package *tests*)
+ (make-hash-table))))))
+
+(defun get-test-name (form)
+ (if (atom form) form (cadr form)))
+
+(defun store-test-code (name code &optional (package *package*))
+ (setf (gethash name
+ (get-package-table package :create t))
+ code))
+
+
+;;; ASSERTION support
+
+(defun internal-assert (type form code-thunk expected-thunk extras test)
+ (let* ((expected (multiple-value-list (funcall expected-thunk)))
+ (actual (multiple-value-list (funcall code-thunk)))
+ (passed (test-passed-p type expected actual test)))
+
+ (incf *test-count*)
+ (when passed
+ (incf *pass-count*))
+
+ (record-result passed type form expected actual extras)
+
+ passed))
+
+(defun record-result (passed type form expected actual extras)
+ (funcall (or *test-listener* 'default-listener)
+ passed type *test-name* form expected actual
+ (and extras (funcall extras))
+ *test-count* *pass-count*))
+
+(defun default-listener
+ (passed type name form expected actual extras test-count pass-count)
+ (declare (ignore test-count pass-count))
+ (unless passed
+ (show-failure type (get-failure-message type)
+ name form expected actual extras)))
+
+(defun test-passed-p (type expected actual test)
+ (ecase type
+ (:error
+ (or (eql (car actual) (car expected))
+ (typep (car actual) (car expected))))
+ (:equal
+ (and (<= (length expected) (length actual))
+ (every test expected actual)))
+ (:macro
+ (equal (car actual) (car expected)))
+ (:output
+ (string= (string-trim '(#\newline #\return #\space)
+ (car actual))
+ (car expected)))
+ (:result
+ (logically-equal (car actual) (car expected)))
+ ))
+
+
+;;; RUN-TESTS support
+
+(defun run-test-thunks (test-thunks)
+ (unless (null test-thunks)
+ (let ((total-test-count 0)
+ (total-pass-count 0)
+ (total-error-count 0))
+ (dolist (test-thunk test-thunks)
+ (multiple-value-bind (test-count pass-count error-count)
+ (run-test-thunk (car test-thunk) (cadr test-thunk))
+ (incf total-test-count test-count)
+ (incf total-pass-count pass-count)
+ (incf total-error-count error-count)))
+ (unless (null (cdr test-thunks))
+ (show-summary 'total total-test-count total-pass-count total-error-count))
+ (values))))
+
+(defun run-test-thunk (*test-name* thunk)
+ (if (null thunk)
+ (format t "~& Test ~S not found" *test-name*)
+ (prog ((*test-count* 0)
+ (*pass-count* 0)
+ (error-count 0))
+ (handler-bind
+ ((error #'(lambda (e)
+ (let ((*print-escape* nil))
+ (setq error-count 1)
+ (format t "~& ~S: ~W" *test-name* e))
+ (if (use-debugger-p e) e (go exit)))))
+ (funcall thunk)
+ (show-summary *test-name* *test-count* *pass-count*))
+ exit
+ (return (values *test-count* *pass-count* error-count)))))
+
+(defun use-debugger-p (e)
+ (and *use-debugger*
+ (or (not (eql *use-debugger* :ask))
+ (y-or-n-p "~A -- debug?" e))))
+
+;;; OUTPUT support
+
+(defun get-failure-message (type)
+ (case type
+ (:error "~&~@[Should have signalled ~{~S~^; ~} but saw~] ~{~S~^; ~}")
+ (:macro "~&Should have expanded to ~{~S~^; ~} ~<~%~:;but saw ~{~S~^; ~}~>")
+ (:output "~&Should have printed ~{~S~^; ~} ~<~%~:;but saw ~{~S~^; ~}~>")
+ (t "~&Expected ~{~S~^; ~} ~<~%~:;but saw ~{~S~^; ~}~>")
+ ))
+
+(defun show-failure (type msg name form expected actual extras)
+ (format t "~&~@[~S: ~]~S failed: " name form)
+ (format t msg expected actual)
+ (format t "~{~& ~S => ~S~}~%" extras)
+ type)
+
+(defun show-summary (name test-count pass-count &optional error-count)
+ (format t "~&~A: ~S assertions passed, ~S failed~@[, ~S execution errors~]."
+ name pass-count (- test-count pass-count) error-count))
+
+(defun collect-form-values (form values)
+ (mapcan #'(lambda (form-arg value)
+ (if (constantp form-arg)
+ nil
+ (list form-arg value)))
+ (cdr form)
+ values))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Useful equality predicates for tests
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;; (LOGICALLY-EQUAL x y) => true or false
+;;; Return true if x and y both false or both true
+
+(defun logically-equal (x y)
+ (eql (not x) (not y)))
+
+;;; (SET-EQUAL l1 l2 :test) => true or false
+;;; Return true if every element of l1 is an element of l2
+;;; and vice versa.
+
+(defun set-equal (l1 l2 &key (test #'equal))
+ (and (listp l1)
+ (listp l2)
+ (subsetp l1 l2 :test test)
+ (subsetp l2 l1 :test test)))
+
+
+(provide "lisp-unit")
From abaine at common-lisp.net Wed Jul 11 15:19:43 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Wed, 11 Jul 2007 11:19:43 -0400 (EDT)
Subject: [funds-cvs] r84 - trunk/funds/tests
Message-ID: <20070711151943.2962B5D00B@common-lisp.net>
Author: abaine
Date: Wed Jul 11 11:19:42 2007
New Revision: 84
Modified:
trunk/funds/tests/funds-tests.asd
Log:
dependency on lisp-unit changed to the file instead of the system.
Modified: trunk/funds/tests/funds-tests.asd
==============================================================================
--- trunk/funds/tests/funds-tests.asd (original)
+++ trunk/funds/tests/funds-tests.asd Wed Jul 11 11:19:42 2007
@@ -25,9 +25,9 @@
(defsystem funds-tests
:serial t
- :components ((:file "package")
+ :components ((:file "lisp-unit")
+ (:file "package")
(:module trees
:serial t
:components ((:file "avl-tree-test"))))
- :depends-on (:funds
- :lisp-unit))
+ :depends-on (:funds))
From abaine at common-lisp.net Wed Jul 11 15:48:40 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Wed, 11 Jul 2007 11:48:40 -0400 (EDT)
Subject: [funds-cvs] r85 - trunk/funds
Message-ID: <20070711154840.67F3F1C008@common-lisp.net>
Author: abaine
Date: Wed Jul 11 11:48:37 2007
New Revision: 85
Modified:
trunk/funds/README
Log:
Better instructions for installation and running test suites.
Modified: trunk/funds/README
==============================================================================
--- trunk/funds/README (original)
+++ trunk/funds/README Wed Jul 11 11:48:37 2007
@@ -1,21 +1,36 @@
-Funds is designed to be loaded with asdf, available from
-http://cclan.cvs.sourceforge.net/*checkout*/cclan/asdf/asdf.lisp.
-
-Make a symbolic link to the file funds.asd. On linux, the command
-would be something like:
+INSTALLING FUNDS
- prompt$ cd /somewhere/in/*central-registry*
- prompt$ ln -s /path/to/funds.asd .
+Funds is designed to be loaded with asdf, available from
+http://cclan.cvs.sourceforge.net/*checkout*/cclan/asdf/asdf.lisp.
+Make a symbolic link to the file funds/src/funds.asd somewhere visible
+to asdf. On linux, the command would be:
-On my machine, that translates to:
+ prompt $ cd /somewhere/in/*central-registry*
+ prompt $ ln -s /path/to/funds/src/funds.asd .
- wonder$ cd ~/.sbcl/systems
- wonder$ ln -s /home/andrew/sandbox/funds/src/funds.asd .
+LOADING FUNDS
To load the system, type at a lisp prompt:
> (asdf:operate 'asdf:load-op 'funds)
-To see the publicly exported symbols in package "FUNDS," look at
-the file funds/src/package.lisp.
+To see the publicly exported symbols in package "FUNDS," look at the
+file funds/src/package.lisp.
+
+RUNNING THE TESTS
+
+Funds' test suite uses lisp-unit, a unit test framework available from
+http://www.cs.northwestern.edu/academics/courses/325/programs/lisp-unit.lisp.
+Because lisp-unit is small and stable, it is included with funds.
+
+Make a symbolic link to funds/tests/funds-tests.asd somewhere visible
+to asdf. As above, this would be:
+
+ prompt $ cd /somewhere/in/*central-registry*
+ prompt $ ln -s /path/to/funds/tests/funds-tests.asd .
+
+Now type at a lisp prompt:
+
+ > (asdf:operate 'asdf:load-op 'funds-tests)
+ > (lisp-unit:run-all-tests :funds-tests)
From abaine at common-lisp.net Wed Jul 11 20:38:12 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Wed, 11 Jul 2007 16:38:12 -0400 (EDT)
Subject: [funds-cvs] r86 - trunk/funds
Message-ID: <20070711203812.9702A4B022@common-lisp.net>
Author: abaine
Date: Wed Jul 11 16:38:12 2007
New Revision: 86
Modified:
trunk/funds/issues.txt
Log:
Typo changed.
Modified: trunk/funds/issues.txt
==============================================================================
--- trunk/funds/issues.txt (original)
+++ trunk/funds/issues.txt Wed Jul 11 16:38:12 2007
@@ -9,4 +9,3 @@
of binary tree.
4. Documentation -- sparse in some files, nonexistent in others.
-
From abaine at common-lisp.net Wed Jul 11 20:39:15 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Wed, 11 Jul 2007 16:39:15 -0400 (EDT)
Subject: [funds-cvs] r87 - trunk/funds/src/trees
Message-ID: <20070711203915.881704D046@common-lisp.net>
Author: abaine
Date: Wed Jul 11 16:39:15 2007
New Revision: 87
Modified:
trunk/funds/src/trees/avl.lisp
Log:
Typographical.
Modified: trunk/funds/src/trees/avl.lisp
==============================================================================
--- trunk/funds/src/trees/avl.lisp (original)
+++ trunk/funds/src/trees/avl.lisp Wed Jul 11 16:39:15 2007
@@ -17,7 +17,6 @@
(in-package :funds)
-
(defun parent-height (t1 t2)
(let ((h1 (tree-height t1))
(h2 (tree-height t2)))
From abaine at common-lisp.net Wed Jul 11 20:41:24 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Wed, 11 Jul 2007 16:41:24 -0400 (EDT)
Subject: [funds-cvs] r88 - trunk/funds/tests/trees
Message-ID: <20070711204124.A36835D09E@common-lisp.net>
Author: abaine
Date: Wed Jul 11 16:41:24 2007
New Revision: 88
Modified:
trunk/funds/tests/trees/avl-tree-test.lisp
Log:
Corrected assert-avl-valid macro per Rahul Jain's suggestion.
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 Jul 11 16:41:24 2007
@@ -17,19 +17,17 @@
(in-package :funds-tests)
-(defun random-tree (&key (test #'eql) (order #'<))
- (reduce #'(lambda (tr v)
- (tree-insert tr v v :test test :order order))
- (loop for i below 40 collect (random 20))
- :initial-value (make-avl-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) (funds::tree-as-pre-order-alist ,tree))
- (assert-true (balanced-p ,tree) (funds::tree-as-pre-order-alist ,tree))
- (assert-true (ordered-p ,tree :order ,order) (funds::tree-as-pre-order-alist ,tree))))
+ (let ((tree-var (gensym "TREE-"))
+ (order-var (gensym "ORDER-")))
+ `(let ((,tree-var ,tree)
+ (,order-var ,order))
+ (assert-true (height-correct-p ,tree-var)
+ (funds::tree-as-pre-order-alist ,tree-var))
+ (assert-true (balanced-p ,tree-var)
+ (funds::tree-as-pre-order-alist ,tree-var))
+ (assert-true (ordered-p ,tree-var :order ,order-var)
+ (funds::tree-as-pre-order-alist ,tree-var)))))
(define-test test-tree-empty-p
(assert-true (tree-empty-p (make-avl-tree)))
@@ -39,6 +37,12 @@
(let ((tree (random-tree)))
(assert-avl-valid tree)))
+(defun random-tree (&key (test #'eql) (order #'<))
+ (reduce #'(lambda (tr v)
+ (tree-insert tr v v :test test :order order))
+ (loop for i below 40 collect (random 20))
+ :initial-value (make-avl-tree)))
+
(defun height-correct-p (tree)
"Whether (tree-height tree) returns the correct height of the given
AVL Tree. The height is correct if (a) the tree is empty and zero
From abaine at common-lisp.net Wed Jul 11 20:42:03 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Wed, 11 Jul 2007 16:42:03 -0400 (EDT)
Subject: [funds-cvs] r89 - trunk/funds/tests/trees
Message-ID: <20070711204203.A45915D09E@common-lisp.net>
Author: abaine
Date: Wed Jul 11 16:42:03 2007
New Revision: 89
Modified:
trunk/funds/tests/trees/avl-tree-test.lisp
Log:
Added test-tree-remove test.
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 Jul 11 16:42:03 2007
@@ -37,6 +37,11 @@
(let ((tree (random-tree)))
(assert-avl-valid tree)))
+(define-test test-tree-remove
+ (loop with tree = (random-tree)
+ until (tree-empty-p tree)
+ do (assert-avl-valid (setf tree (tree-remove tree (random 20))))))
+
(defun random-tree (&key (test #'eql) (order #'<))
(reduce #'(lambda (tr v)
(tree-insert tr v v :test test :order order))
From abaine at common-lisp.net Wed Jul 11 20:51:03 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Wed, 11 Jul 2007 16:51:03 -0400 (EDT)
Subject: [funds-cvs] r90 - trunk/funds/src/trees
Message-ID: <20070711205103.965775D0E1@common-lisp.net>
Author: abaine
Date: Wed Jul 11 16:51:03 2007
New Revision: 90
Modified:
trunk/funds/src/trees/tree-remove.lisp
Log:
Fixed problem where heavier-p was being passed an empty tree.
Modified: trunk/funds/src/trees/tree-remove.lisp
==============================================================================
--- trunk/funds/src/trees/tree-remove.lisp (original)
+++ trunk/funds/src/trees/tree-remove.lisp Wed Jul 11 16:51:03 2007
@@ -37,13 +37,15 @@
(defmethod tree-remove ((tree avl-tree) key &key (test #'eql) (order #'<))
(declare (ignore test 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)))
+ (let ((temp (call-next-method)))
+ (if (tree-empty-p temp)
+ (make-avl-tree)
+ (let* ((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)
From abaine at common-lisp.net Wed Jul 11 21:04:07 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Wed, 11 Jul 2007 17:04:07 -0400 (EDT)
Subject: [funds-cvs] r91 - trunk/funds/src/trees
Message-ID: <20070711210407.0447B1B01C@common-lisp.net>
Author: abaine
Date: Wed Jul 11 17:04:06 2007
New Revision: 91
Modified:
trunk/funds/src/trees/tree-remove.lisp
Log:
Greatly simplified avl-remove.
Modified: trunk/funds/src/trees/tree-remove.lisp
==============================================================================
--- trunk/funds/src/trees/tree-remove.lisp (original)
+++ trunk/funds/src/trees/tree-remove.lisp Wed Jul 11 17:04:06 2007
@@ -29,11 +29,17 @@
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))))
+ (if (funcall test key (bt-key tree))
+ (remove-root tree :order order :test test)
+ (let* ((side (if (funcall order key (bt-key tree))
+ :left
+ :right))
+ (other-side (other-side side)))
+ (attach-bt tree
+ side (tree-remove (tree-child tree :side side) key
+ :test test
+ :order order)
+ other-side (tree-child tree :side other-side)))))
(defmethod tree-remove ((tree avl-tree) key &key (test #'eql) (order #'<))
(declare (ignore test order))
@@ -47,34 +53,13 @@
(outside (tree-child temp :side heavy-side)))
(balance inside temp outside :heavy-side heavy-side)))))
-
-(defmethod remove-root ((tree binary-tree) &key test order)
+(defun remove-root (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))))
-
+(defun remove-root-with-children (tree &key test order)
+ (let* ((next (next-in-order tree)))
+ (attach-bt next
+ :left (bt-left tree)
+ :right (tree-remove (bt-right tree) (bt-key next) :test test :order order))))
From abaine at common-lisp.net Thu Jul 12 00:56:21 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Wed, 11 Jul 2007 20:56:21 -0400 (EDT)
Subject: [funds-cvs] r92 - trunk/funds/tests/trees
Message-ID: <20070712005621.3AAF24B026@common-lisp.net>
Author: abaine
Date: Wed Jul 11 20:56:20 2007
New Revision: 92
Modified:
trunk/funds/tests/trees/avl-tree-test.lisp
Log:
Made test-tree-insert much more rigorous.
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 Jul 11 20:56:20 2007
@@ -34,8 +34,13 @@
(assert-avl-valid (make-avl-tree)))
(define-test test-tree-insert
- (let ((tree (random-tree)))
- (assert-avl-valid tree)))
+ (loop with tree = (make-avl-tree)
+ with elements = '()
+ repeat 1000
+ do (let ((next (random 500)))
+ (assert-avl-valid (setf tree (tree-insert tree next (random 1000))))
+ (assert-equal (length (setf elements (remove-duplicates (cons next elements))))
+ (tree-weight tree)))))
(define-test test-tree-remove
(loop with tree = (random-tree)
From abaine at common-lisp.net Thu Jul 12 01:05:43 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Wed, 11 Jul 2007 21:05:43 -0400 (EDT)
Subject: [funds-cvs] r93 - trunk/funds/src/trees/heap
Message-ID: <20070712010543.5BC544D046@common-lisp.net>
Author: abaine
Date: Wed Jul 11 21:05:43 2007
New Revision: 93
Modified:
trunk/funds/src/trees/heap/heap-insert.lisp
Log:
Factored out attach-heap method.
Modified: trunk/funds/src/trees/heap/heap-insert.lisp
==============================================================================
--- trunk/funds/src/trees/heap/heap-insert.lisp (original)
+++ trunk/funds/src/trees/heap/heap-insert.lisp Wed Jul 11 21:05:43 2007
@@ -31,19 +31,14 @@
: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)
+ (attach-heap h1
+ side (attach-heap 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))))
-
+ other-side h2)
+ (attach-heap heap
+ side h1
+ other-side h2))))
(defun next-direction (heap)
(path-direction (1+ (heap-weight heap))))
@@ -56,3 +51,9 @@
(if (< (- n (expt 2 lg)) (expt 2 (1- lg)))
:left
:right)))
+
+(defun attach-heap (root &key left right)
+ (make-heap :priority (heap-priority root)
+ :value (bt-value heap)
+ :left left
+ :right right))
From abaine at common-lisp.net Thu Jul 12 01:28:27 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Wed, 11 Jul 2007 21:28:27 -0400 (EDT)
Subject: [funds-cvs] r94 - in trunk/funds/src: . trees/heap
Message-ID: <20070712012827.9846174371@common-lisp.net>
Author: abaine
Date: Wed Jul 11 21:28:26 2007
New Revision: 94
Added:
trunk/funds/src/trees/heap/heap.lisp
Modified:
trunk/funds/src/funds.asd
trunk/funds/src/trees/heap/heap-insert.lisp
trunk/funds/src/trees/heap/heap-remove.lisp
Log:
Eliminated attach-heap from heap-remove.lisp; moved attach-heap from heap-insert.lisp to heap.lisp; made sure that all calls were consistent.
Modified: trunk/funds/src/funds.asd
==============================================================================
--- trunk/funds/src/funds.asd (original)
+++ trunk/funds/src/funds.asd Wed Jul 11 21:28:26 2007
@@ -42,7 +42,8 @@
(:file "tree-height")
(:module heap
:serial t
- :components ((:file "heap-empty-p")
+ :components ((:file "heap")
+ (:file "heap-empty-p")
(:file "heap-insert")
(:file "heap-remove")
(:file "heap-first")))))
Modified: trunk/funds/src/trees/heap/heap-insert.lisp
==============================================================================
--- trunk/funds/src/trees/heap/heap-insert.lisp (original)
+++ trunk/funds/src/trees/heap/heap-insert.lisp Wed Jul 11 21:28:26 2007
@@ -33,8 +33,8 @@
(if (funcall order (bt-key h1) (bt-key heap)) ; if we need to bubble up
(attach-heap h1
side (attach-heap heap
- :left (bt-left h1)
- :right (bt-right h1))
+ :left (bt-left h1)
+ :right (bt-right h1))
other-side h2)
(attach-heap heap
side h1
@@ -51,9 +51,3 @@
(if (< (- n (expt 2 lg)) (expt 2 (1- lg)))
:left
:right)))
-
-(defun attach-heap (root &key left right)
- (make-heap :priority (heap-priority root)
- :value (bt-value heap)
- :left left
- :right right))
Modified: trunk/funds/src/trees/heap/heap-remove.lisp
==============================================================================
--- trunk/funds/src/trees/heap/heap-remove.lisp (original)
+++ trunk/funds/src/trees/heap/heap-remove.lisp Wed Jul 11 21:28:26 2007
@@ -38,26 +38,20 @@
(or (heap-empty-p right)
(in-order-p left right :order order)))
(attach-heap left
- (bubble-down root
+ :left (bubble-down root
:left (bt-left left)
:right (bt-right left)
:order order)
- right))
+ :right right))
((and (not (heap-empty-p right))
(in-order-p right root :order order))
(attach-heap right
- left
- (bubble-down root
+ :left left
+ :right (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))
+ (t (attach-heap root :left left :right right))))
(defun in-order-p (h1 h2 &key order)
(funcall order (heap-priority h1) (heap-priority h2)))
Added: trunk/funds/src/trees/heap/heap.lisp
==============================================================================
--- (empty file)
+++ trunk/funds/src/trees/heap/heap.lisp Wed Jul 11 21:28:26 2007
@@ -0,0 +1,8 @@
+
+(in-package :funds)
+
+(defun attach-heap (root &key left right)
+ (make-heap :priority (heap-priority root)
+ :value (bt-value root)
+ :left left
+ :right right))
From abaine at common-lisp.net Thu Jul 12 01:37:11 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Wed, 11 Jul 2007 21:37:11 -0400 (EDT)
Subject: [funds-cvs] r95 - trunk/funds/src/trees
Message-ID: <20070712013711.3E21513017@common-lisp.net>
Author: abaine
Date: Wed Jul 11 21:37:11 2007
New Revision: 95
Modified:
trunk/funds/src/trees/tree-height.lisp
Log:
Typo.
Modified: trunk/funds/src/trees/tree-height.lisp
==============================================================================
--- trunk/funds/src/trees/tree-height.lisp (original)
+++ trunk/funds/src/trees/tree-height.lisp Wed Jul 11 21:37:11 2007
@@ -30,4 +30,3 @@
(defmethod tree-height ((tree avl-tree))
(avl-height tree))
-
From abaine at common-lisp.net Tue Jul 31 14:59:58 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Tue, 31 Jul 2007 10:59:58 -0400 (EDT)
Subject: [funds-cvs] r96 - trunk/funds/src/trees
Message-ID: <20070731145958.99EA2650D3@common-lisp.net>
Author: abaine
Date: Tue Jul 31 10:59:57 2007
New Revision: 96
Modified:
trunk/funds/src/trees/constructors.lisp
Log:
superficial edit.
Modified: trunk/funds/src/trees/constructors.lisp
==============================================================================
--- trunk/funds/src/trees/constructors.lisp (original)
+++ trunk/funds/src/trees/constructors.lisp Tue Jul 31 10:59:57 2007
@@ -44,8 +44,6 @@
:height (parent-height left right))
(make-avl-leaf)))
-
-
(defun make-heap (&key (priority 0 p-p) value
(left (make-heap-leaf)) (right (make-heap-leaf)))
(if p-p
From abaine at common-lisp.net Tue Jul 31 15:06:18 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Tue, 31 Jul 2007 11:06:18 -0400 (EDT)
Subject: [funds-cvs] r97 - trunk/funds/src
Message-ID: <20070731150618.378C66B0FA@common-lisp.net>
Author: abaine
Date: Tue Jul 31 11:06:17 2007
New Revision: 97
Modified:
trunk/funds/src/package.lisp
Log:
superficial edit.
Modified: trunk/funds/src/package.lisp
==============================================================================
--- trunk/funds/src/package.lisp (original)
+++ trunk/funds/src/package.lisp Tue Jul 31 11:06:17 2007
@@ -47,5 +47,3 @@
:stack-push
:stack-top
:stack-size))
-
-
From abaine at common-lisp.net Tue Jul 31 15:20:26 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Tue, 31 Jul 2007 11:20:26 -0400 (EDT)
Subject: [funds-cvs] r98 - trunk/funds/src/trees
Message-ID: <20070731152026.F1C742F048@common-lisp.net>
Author: abaine
Date: Tue Jul 31 11:20:25 2007
New Revision: 98
Modified:
trunk/funds/src/trees/tree-insert.lisp
Log:
superficial edit.
Modified: trunk/funds/src/trees/tree-insert.lisp
==============================================================================
--- trunk/funds/src/trees/tree-insert.lisp (original)
+++ trunk/funds/src/trees/tree-insert.lisp Tue Jul 31 11:20:25 2007
@@ -64,4 +64,3 @@
(outside (tree-child temp :side side))
(inside (tree-child temp :side (other-side side))))
(balance inside temp outside :heavy-side side))))
-
From abaine at common-lisp.net Tue Jul 31 15:47:57 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Tue, 31 Jul 2007 11:47:57 -0400 (EDT)
Subject: [funds-cvs] r99 - trunk/funds/src/trees
Message-ID: <20070731154757.6CF4961051@common-lisp.net>
Author: abaine
Date: Tue Jul 31 11:47:57 2007
New Revision: 99
Modified:
trunk/funds/src/trees/avl.lisp
Log:
Added make-avl-node function.
Modified: trunk/funds/src/trees/avl.lisp
==============================================================================
--- trunk/funds/src/trees/avl.lisp (original)
+++ trunk/funds/src/trees/avl.lisp Tue Jul 31 11:47:57 2007
@@ -63,3 +63,11 @@
:value (bt-key root)
:right right
:left left))
+
+(defun make-avl-node (key value left right)
+ (make-instance 'avl-tree
+ :key key
+ :value value
+ :left left
+ :right right
+ :height (parent-height left right)))
From abaine at common-lisp.net Tue Jul 31 15:49:46 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Tue, 31 Jul 2007 11:49:46 -0400 (EDT)
Subject: [funds-cvs] r100 - trunk/funds/src/trees
Message-ID: <20070731154946.3466E9@common-lisp.net>
Author: abaine
Date: Tue Jul 31 11:49:46 2007
New Revision: 100
Modified:
trunk/funds/src/trees/constructors.lisp
Log:
Hid functionality of constructor by simplifying make-avl-tree.
Modified: trunk/funds/src/trees/constructors.lisp
==============================================================================
--- trunk/funds/src/trees/constructors.lisp (original)
+++ trunk/funds/src/trees/constructors.lisp Tue Jul 31 11:49:46 2007
@@ -33,16 +33,8 @@
(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-avl-tree ()
+ (make-avl-leaf))
(defun make-heap (&key (priority 0 p-p) value
(left (make-heap-leaf)) (right (make-heap-leaf)))
From abaine at common-lisp.net Tue Jul 31 15:54:33 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Tue, 31 Jul 2007 11:54:33 -0400 (EDT)
Subject: [funds-cvs] r101 - trunk/funds/src/trees
Message-ID: <20070731155433.A307E1B020@common-lisp.net>
Author: abaine
Date: Tue Jul 31 11:54:33 2007
New Revision: 101
Modified:
trunk/funds/src/trees/avl.lisp
Log:
Added &key arguments to make-avl-node.
Modified: trunk/funds/src/trees/avl.lisp
==============================================================================
--- trunk/funds/src/trees/avl.lisp (original)
+++ trunk/funds/src/trees/avl.lisp Tue Jul 31 11:54:33 2007
@@ -64,7 +64,7 @@
:right right
:left left))
-(defun make-avl-node (key value left right)
+(defun make-avl-node (&key key value (left make-avl-tree) (right make-avl-tree))
(make-instance 'avl-tree
:key key
:value value