funds-cvs June 2007

funds-cvs@common-lisp.net

1 participants
43 discussions

[funds-cvs] r16 - trunk/funds/src/trees
by abaine＠common-lisp.net 15 Jun '07

15 Jun '07

Author: abaine Date: Fri Jun 15 14:29:33 2007 New Revision: 16 Modified: trunk/funds/src/trees/avl-tree.lisp Log: Renamed trees package to funds.trees Modified: trunk/funds/src/trees/avl-tree.lisp ============================================================================== --- trunk/funds/src/trees/avl-tree.lisp (original) +++ trunk/funds/src/trees/avl-tree.lisp Fri Jun 15 14:29:33 2007 @@ -1,5 +1,5 @@ -(in-package :funds-trees) +(in-package :funds.trees) (defstruct avl ht

1 0

[funds-cvs] r15 - trunk/funds/src/trees
by abaine＠common-lisp.net 15 Jun '07

15 Jun '07

Author: abaine Date: Fri Jun 15 14:29:02 2007 New Revision: 15 Modified: trunk/funds/src/trees/package.lisp Log: Renamed trees package to funds.trees Modified: trunk/funds/src/trees/package.lisp ============================================================================== --- trunk/funds/src/trees/package.lisp (original) +++ trunk/funds/src/trees/package.lisp Fri Jun 15 14:29:02 2007 @@ -1,7 +1,7 @@ (in-package :cl-user) -(defpackage :funds-trees +(defpackage :funds.trees (:use :cl) (:export ; AVL Tree public interface :empty-avl-tree

1 0

[funds-cvs] r14 - trunk/funds/src/trees/tests
by abaine＠common-lisp.net 15 Jun '07

15 Jun '07

Author: abaine Date: Fri Jun 15 13:57:14 2007 New Revision: 14 Modified: trunk/funds/src/trees/tests/avl-tree-test.lisp Log: Wrote unit tests for insert and empty Modified: trunk/funds/src/trees/tests/avl-tree-test.lisp ============================================================================== --- trunk/funds/src/trees/tests/avl-tree-test.lisp (original) +++ trunk/funds/src/trees/tests/avl-tree-test.lisp Fri Jun 15 13:57:14 2007 @@ -4,29 +4,80 @@ (defun random-tree () (reduce #'(lambda (tr v) (avl-insert tr v v)) - (loop for i below 100 collect (random 10000)) + (loop for i below 20 collect (random 10)) :initial-value (empty-avl-tree))) -(define-test empty-avl-tree - (assert-true (avl-empty-p (empty-avl-tree))) - (assert-equal 0 (avl-height (empty-avl-tree)))) - +(defmacro assert-avl-valid (tree) + `(progn + (assert-true (height-correct-p ,tree) ,tree) + (assert-true (balanced-p ,tree) ,tree) + (assert-true (ordered-p ,tree) ,tree))) -(define-test avl-insert - (assert-true (balanced (random-tree)))) +(define-test test-avl-empty-p + (assert-true (avl-empty-p (empty-avl-tree))) + (assert-avl-valid (empty-avl-tree))) -(defun balanced (tree) +(define-test test-avl-insert + (let ((tree (random-tree))) + (assert-avl-valid tree))) + +(defun height-correct-p (tree) + "Whether (avl-height tree) returns the correct height of the given +AVL Tree. The height is correct if (a) the tree is empty and zero +is returned or (b) each of the following is true: + 1. the height of the left sub-tree is correct; + 2. the height of the right sub-tree is correct; + 3. the height of the given tree is 1 more than the greater + of the heights of the left and right sub-trees." + (if (avl-empty-p tree) + (zerop (avl-height tree)) + (and (height-correct-p (avl-left tree)) + (height-correct-p (avl-right tree)) + (let* ((a (avl-height (avl-left tree))) + (b (avl-height (avl-right tree))) + (c (if (> a b) a b))) + (eql (1+ c) (avl-height tree)))))) + +(defun balanced-p (tree) + "Whether the given AVL Tree is properly balanced. To be balanced, +the tree must be either (a) empty or (b) have left and right sub-trees +that differ in height by no more than 1." (or (avl-empty-p tree) - (and (balanced (avl-left tree)) - (balanced (avl-right tree)) + (and (balanced-p (avl-left tree)) + (balanced-p (avl-right tree)) (< -2 (- (avl-height (avl-left tree)) (avl-height (avl-right tree))) 2)))) - -(defun root-height-correct (tree) - (let* ((a (avl-height (avl-left tree))) - (b (avl-height (avl-right tree))) - (c (if (> a b) a b))) - (eql (1+ c) (avl-height tree)))) - +(defun ordered-p (tree &optional (less-than #'<)) + "Whether this AVL tree is properly ordered. To be ordered, +the tree must be either (a) empty or (b) satisfy each of the following +requirements: + + 1. the left sub-tree is properly ordered; + 2. the right sub-tree is properly ordered; + 3. every key in the left sub-tree is less than + the root key; and + 4. every key in the right sub-tree is not less + than the root key." + (or (avl-empty-p tree) + (and (ordered-p (avl-left tree)) + (ordered-p (avl-right tree)) + (or (avl-empty-p (avl-left tree)) + (not (funcall less-than (avl-key tree) + (greatest-key (avl-left tree))))) + (or (avl-empty-p (avl-right tree)) + (not (funcall less-than (least-key (avl-right tree)) + (avl-key tree))))))) + +(defun least-key (tree) + "The least key in a properly ordered AVL tree." + (if (avl-empty-p (avl-left tree)) + (avl-key tree) + (least-key (avl-left tree)))) + +(defun greatest-key (tree) + "The greatest key in a properly ordered AVL tree." + (if (avl-empty-p (avl-right tree)) + (avl-key tree) + (greatest-key (avl-right tree))))

1 0

[funds-cvs] r13 - trunk/public_html
by abaine＠common-lisp.net 15 Jun '07

15 Jun '07

Author: abaine Date: Fri Jun 15 11:56:02 2007 New Revision: 13 Modified: trunk/public_html/index.html Log: Changed CVS header to SVN Modified: trunk/public_html/index.html ============================================================================== --- trunk/public_html/index.html (original) +++ trunk/public_html/index.html Fri Jun 15 11:56:02 2007 @@ -50,17 +50,13 @@ <a href="mailto:andrew.baine@gmail.com">Andrew Baine</a> </li> </ul> - <h3>CVS</h3> + <h3>Subversion</h3> <p>You can <a - - - href="http://common-lisp.net/websvn/listing.php?repname=funds"> browse our Subversion repository</a> or download the current development tree via anonymous SVN, as described <a href="http://common-lisp.net/faq.shtml">here</a></p> - <div class="footer"> </div>

1 0

[funds-cvs] r12 - trunk/funds/src/trees/tests
by abaine＠common-lisp.net 14 Jun '07

14 Jun '07

Author: abaine Date: Wed Jun 13 22:09:33 2007 New Revision: 12 Added: trunk/funds/src/trees/tests/ trunk/funds/src/trees/tests/avl-tree-test.lisp trunk/funds/src/trees/tests/package.lisp Log: Began to implement unit tests for AVL Trees Added: trunk/funds/src/trees/tests/avl-tree-test.lisp ============================================================================== --- (empty file) +++ trunk/funds/src/trees/tests/avl-tree-test.lisp Wed Jun 13 22:09:33 2007 @@ -0,0 +1,32 @@ + +(in-package :funds-trees-tests) + +(defun random-tree () + (reduce #'(lambda (tr v) + (avl-insert tr v v)) + (loop for i below 100 collect (random 10000)) + :initial-value (empty-avl-tree))) + +(define-test empty-avl-tree + (assert-true (avl-empty-p (empty-avl-tree))) + (assert-equal 0 (avl-height (empty-avl-tree)))) + + +(define-test avl-insert + (assert-true (balanced (random-tree)))) + +(defun balanced (tree) + (or (avl-empty-p tree) + (and (balanced (avl-left tree)) + (balanced (avl-right tree)) + (< -2 (- (avl-height (avl-left tree)) + (avl-height (avl-right tree))) + 2)))) + + +(defun root-height-correct (tree) + (let* ((a (avl-height (avl-left tree))) + (b (avl-height (avl-right tree))) + (c (if (> a b) a b))) + (eql (1+ c) (avl-height tree)))) + Added: trunk/funds/src/trees/tests/package.lisp ============================================================================== --- (empty file) +++ trunk/funds/src/trees/tests/package.lisp Wed Jun 13 22:09:33 2007 @@ -0,0 +1,7 @@ + +(in-package :cl-user) + +(defpackage funds-trees-tests + (:use :cl + :funds-trees + :lisp-unit))

1 0

[funds-cvs] r11 - trunk/funds/src
by abaine＠common-lisp.net 14 Jun '07

14 Jun '07

Author: abaine Date: Wed Jun 13 22:08:32 2007 New Revision: 11 Modified: trunk/funds/src/funds.asd Log: Added lisp-unit dependency Modified: trunk/funds/src/funds.asd ============================================================================== --- trunk/funds/src/funds.asd (original) +++ trunk/funds/src/funds.asd Wed Jun 13 22:08:32 2007 @@ -1,13 +1,21 @@ ;;;; -*- Lisp -*- +(in-package :cl-user) + (defpackage #:funds-asd (:use :cl :asdf)) (in-package :funds-asd) (defsystem funds - :components ((:file "package") - (:module trees - :components ((:file "avl-tree")) - :depends-on ("package")))) + :serial t + :components ((:module trees + :serial t + :components ((:file "package") + (:file "avl-tree") + (:module "tests" + :components ((:file "package") + (:file "avl-tree-test"))))) + (:file "package")) + :depends-on (:lisp-unit))

1 0

[funds-cvs] r10 - trunk/funds/src/trees
by abaine＠common-lisp.net 14 Jun '07

14 Jun '07

Author: abaine Date: Wed Jun 13 22:07:48 2007 New Revision: 10 Modified: trunk/funds/src/trees/avl-tree.lisp Log: Added comments and fixed problem with right-rotate. Modified: trunk/funds/src/trees/avl-tree.lisp ============================================================================== --- trunk/funds/src/trees/avl-tree.lisp (original) +++ trunk/funds/src/trees/avl-tree.lisp Wed Jun 13 22:07:48 2007 @@ -1,29 +1,35 @@ -(in-package :funds) +(in-package :funds-trees) (defstruct avl - height + ht key value left right) -(defun make-avl-tree () +(defun empty-avl-tree () + "An empty AVL Tree." nil) +(defun avl-empty-p (tree) + "Whether the given AVL Tree is empty: +t if it is empty; nil else." + (null tree)) + (defun avl-insert (tree key value) - (cond ((avl-empty tree) (make-avl :height 1 - :key key - :value value - :left nil - :right nil)) + (cond ((avl-empty-p tree) (make-avl :ht 1 + :key key + :value value + :left nil + :right nil)) ((< key (avl-key tree)) (left-insert tree key value)) (t (right-insert tree key value)))) -(defun avl-empty (tree) - (null tree)) - (defun left-insert (tree key value) + "The AVL tree that results when the given key-value pair is inserted +into left sub-tree of the given AVL tree. Only non-empty avl-trees +should be supplied as arguments." (let ((left (avl-insert (avl-left tree) key value)) (right (avl-right tree))) (if (imbalanced left right) @@ -34,22 +40,27 @@ (avl-right left)) tree right)) - (make-avl :height (parent-height left right) + (make-avl :ht (parent-height left right) :key (avl-key tree) :value (avl-value tree) :left left :right right)))) (defun right-insert (tree key value) + "The AVL tree that results when the given key-value pair is inserted +into the right sub-tree of the given AVL tree. Only non-empty avl-trees +should be supplied as the tree argument." (let ((right (avl-insert (avl-right tree) key value)) (left (avl-left tree))) (if (imbalanced left right) (if (right-heavy right) (left-rotate left tree right) - (left-rotate (right-rotate (avl-right right) + (left-rotate left + tree + (right-rotate (avl-left right) right - (avl-left right)))) - (make-avl :height (parent-height left right) + (avl-right right)))) + (make-avl :ht (parent-height left right) :key (avl-key tree) :value (avl-value tree) :left left @@ -57,12 +68,12 @@ (defun left-rotate (t0 a b) (let ((c (avl-right b)) - (new-a (make-avl :height (1- (avl-height a)) ; re-calculate? + (new-a (make-avl :ht (1- (avl-ht a)) ; re-calculate? :key (avl-key a) :value (avl-value a) :left t0 :right (avl-left b)))) - (make-avl :height (1+ (avl-height new-a)) + (make-avl :ht (1+ (avl-ht new-a)) :key (avl-key b) :value (avl-value b) :left new-a @@ -70,37 +81,50 @@ (defun right-rotate (b c t3) (let ((a (avl-left b)) - (new-c (make-avl :height (1- (avl-height c)); re-calculate? + (new-c (make-avl :ht (1- (avl-ht c)); re-calculate? :key (avl-key c) :value (avl-value c) :left (avl-right b) :right t3))) - (make-avl :height (1+ (avl-height new-c)) ; re-calculate? + (make-avl :ht (1+ (avl-ht new-c)) ; re-calculate? :key (avl-key b) :value (avl-value b) :left a :right new-c))) (defun imbalanced (left right) - (> (abs (- (height right) (height left))) - 1)) + "Whether the heights of the given sub-trees differ, +in their absolute values, by more than one." + (> (abs (height-difference left right)) 1)) + +(defun height-difference (a b) + "The difference in heights of the given sub-trees." + (- (avl-height a) (avl-height b))) + +(defun avl-height (tree) + "The height of the given AVL Tree." + (if (avl-empty-p tree) + 0 + (avl-ht tree))) (defun left-heavy (tree) + "Whether the given imbalanced AVL Tree has a left sub-tree +taller than its right sub-tree." (< (balance-factor tree) 0)) (defun right-heavy (tree) + "Whether the given imbalanced AVL Tre has a right sub-tree +taller than its left sub-tree." (> (balance-factor tree) 0)) (defun balance-factor (tree) - (- (height (avl-right tree)) - (height (avl-left tree)))) - -(defun height (tree) - (if (null tree) - 0 - (avl-height tree))) + "The difference in heights of the right sub-tree and left +sub-tree of the given AVL Tree." + (height-difference (avl-right tree) + (avl-left tree))) (defun parent-height (left right) - (let ((a (height left)) - (b (height right))) + "The height of the parent of the given sub-trees." + (let ((a (avl-height left)) + (b (avl-height right))) (1+ (if (> a b) a b))))

1 0

[funds-cvs] r9 - trunk/funds/src
by abaine＠common-lisp.net 14 Jun '07

14 Jun '07

Author: abaine Date: Wed Jun 13 22:04:25 2007 New Revision: 9 Modified: trunk/funds/src/package.lisp Log: formatting changes Modified: trunk/funds/src/package.lisp ============================================================================== --- trunk/funds/src/package.lisp (original) +++ trunk/funds/src/package.lisp Wed Jun 13 22:04:25 2007 @@ -1,3 +1,5 @@ +(in-package :cl-user) + (defpackage :funds - (:use :common-lisp)) \ No newline at end of file + (:use :common-lisp))

1 0

[funds-cvs] r8 - trunk/funds/src/trees
by abaine＠common-lisp.net 13 Jun '07

13 Jun '07

Author: abaine Date: Wed Jun 13 19:12:10 2007 New Revision: 8 Added: trunk/funds/src/trees/package.lisp Log: funds-trees package Added: trunk/funds/src/trees/package.lisp ============================================================================== --- (empty file) +++ trunk/funds/src/trees/package.lisp Wed Jun 13 19:12:10 2007 @@ -0,0 +1,16 @@ + +(in-package :cl-user) + +(defpackage :funds-trees + (:use :cl) + (:export ; AVL Tree public interface + :empty-avl-tree + :avl-empty-p + :avl-insert + :avl-remove + + :avl-key + :avl-value + :avl-height + :avl-left + :avl-right))

1 0

[funds-cvs] r7 - trunk/funds/src/trees
by abaine＠common-lisp.net 12 Jun '07

12 Jun '07

Author: abaine Date: Tue Jun 12 10:11:16 2007 New Revision: 7 Modified: trunk/funds/src/trees/avl-tree.lisp Log: avl insertion now seems to work. Modified: trunk/funds/src/trees/avl-tree.lisp ============================================================================== --- trunk/funds/src/trees/avl-tree.lisp (original) +++ trunk/funds/src/trees/avl-tree.lisp Tue Jun 12 10:11:16 2007 @@ -8,60 +8,79 @@ left right) -(defun make-avl () +(defun make-avl-tree () nil) (defun avl-insert (tree key value) - (cond ((null tree) (make-avl :height 1 - :key key - :value value - :left nil - :right nil)) - ((< key (avl-key tree)) (left-insert tree)) - (t (right-insert tree)))) + (cond ((avl-empty tree) (make-avl :height 1 + :key key + :value value + :left nil + :right nil)) + ((< key (avl-key tree)) (left-insert tree key value)) + (t (right-insert tree key value)))) + +(defun avl-empty (tree) + (null tree)) (defun left-insert (tree key value) - (let* ((left (avl-insert (avl-left tree))) - (right (avl-right tree))) + (let ((left (avl-insert (avl-left tree) key value)) + (right (avl-right tree))) (if (imbalanced left right) (if (left-heavy left) (right-rotate left tree right) - (right-rotate (left-rotate left (avl-left left) ) + (right-rotate (left-rotate (avl-left left) + left + (avl-right left)) tree - right) - ()) + right)) (make-avl :height (parent-height left right) :key (avl-key tree) :value (avl-value tree) :left left :right right)))) -(defun right-rotate (b c t3) - (let ((a (avl-left b)) - (new-c (make-avl :height (avl-height c); not sure if this needs to be recalculated - :key (avl-key c) - :value (avl-value c) - :left (avl-right b) - :right t3))) - (make-avl :height (parent-height a new-c) - :key (avl-key b) - :value (avl-value b) - :left a - :right new-c))) +(defun right-insert (tree key value) + (let ((right (avl-insert (avl-right tree) key value)) + (left (avl-left tree))) + (if (imbalanced left right) + (if (right-heavy right) + (left-rotate left tree right) + (left-rotate (right-rotate (avl-right right) + right + (avl-left right)))) + (make-avl :height (parent-height left right) + :key (avl-key tree) + :value (avl-value tree) + :left left + :right right)))) (defun left-rotate (t0 a b) (let ((c (avl-right b)) - (new-a (make-avl :height (avl-height a) + (new-a (make-avl :height (1- (avl-height a)) ; re-calculate? :key (avl-key a) :value (avl-value a) :left t0 :right (avl-left b)))) - (make-avl :height (parent-height (new-a) c) + (make-avl :height (1+ (avl-height new-a)) :key (avl-key b) :value (avl-value b) :left new-a :right c))) +(defun right-rotate (b c t3) + (let ((a (avl-left b)) + (new-c (make-avl :height (1- (avl-height c)); re-calculate? + :key (avl-key c) + :value (avl-value c) + :left (avl-right b) + :right t3))) + (make-avl :height (1+ (avl-height new-c)) ; re-calculate? + :key (avl-key b) + :value (avl-value b) + :left a + :right new-c))) + (defun imbalanced (left right) (> (abs (- (height right) (height left))) 1)) @@ -72,9 +91,6 @@ (defun right-heavy (tree) (> (balance-factor tree) 0)) -(defun right-insert (tree key value) - ()) - (defun balance-factor (tree) (- (height (avl-right tree)) (height (avl-left tree)))) @@ -83,3 +99,8 @@ (if (null tree) 0 (avl-height tree))) + +(defun parent-height (left right) + (let ((a (height left)) + (b (height right))) + (1+ (if (> a b) a b))))

1 0

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

funds-cvs June 2007