funds-cvs June 2007

funds-cvs@common-lisp.net

1 participants
43 discussions

[funds-cvs] r36 - trunk/funds/tests/trees
by abaine＠common-lisp.net 20 Jun '07

20 Jun '07

Author: abaine Date: Wed Jun 20 18:28:06 2007 New Revision: 36 Modified: trunk/funds/tests/trees/avl-tree-test.lisp Log: Modified tests to include keyword arguments to avl-insert. Modified: trunk/funds/tests/trees/avl-tree-test.lisp ============================================================================== --- trunk/funds/tests/trees/avl-tree-test.lisp (original) +++ trunk/funds/tests/trees/avl-tree-test.lisp Wed Jun 20 18:28:06 2007 @@ -1,17 +1,19 @@ (in-package :funds.tests.trees) -(defun random-tree () - (reduce #'(lambda (tr v) - (avl-insert tr v v)) - (loop for i below 20 collect (random 10)) - :initial-value (empty-avl-tree))) +(defun random-tree (&key (test #'eql) (order #'<)) + (print (reduce #'(lambda (tr v) + (avl-insert tr v v :test test :order order)) + (loop for i below 40 collect (random 20)) + :initial-value (empty-avl-tree)))) -(defmacro assert-avl-valid (tree) +(defconstant +never-equal+ #'(lambda (a b) (declare (ignore a b)) nil)) + +(defmacro assert-avl-valid (tree &key (order #'<)) `(progn (assert-true (height-correct-p ,tree) ,tree) (assert-true (balanced-p ,tree) ,tree) - (assert-true (ordered-p ,tree) ,tree))) + (assert-true (ordered-p ,tree :order ,order) ,tree))) (define-test test-avl-empty-p (assert-true (avl-empty-p (empty-avl-tree))) @@ -49,7 +51,7 @@ (avl-height (avl-right tree))) 2)))) -(defun ordered-p (tree &optional (less-than #'<)) +(defun ordered-p (tree &key (order #'<)) "Whether this AVL tree is properly ordered. To be ordered, the tree must be either (a) empty or (b) satisfy each of the following requirements: @@ -64,10 +66,10 @@ (and (ordered-p (avl-left tree)) (ordered-p (avl-right tree)) (or (avl-empty-p (avl-left tree)) - (not (funcall less-than (avl-key tree) + (not (funcall order (avl-key tree) (greatest-key (avl-left tree))))) (or (avl-empty-p (avl-right tree)) - (not (funcall less-than (least-key (avl-right tree)) + (not (funcall order (least-key (avl-right tree)) (avl-key tree))))))) (defun least-key (tree)

1 0

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

20 Jun '07

Author: abaine Date: Wed Jun 20 18:27:13 2007 New Revision: 35 Modified: trunk/funds/src/trees/avl-tree.lisp Log: Rearranged avl-tree.lisp to put public interface at top. Modified: trunk/funds/src/trees/avl-tree.lisp ============================================================================== --- trunk/funds/src/trees/avl-tree.lisp (original) +++ trunk/funds/src/trees/avl-tree.lisp Wed Jun 20 18:27:13 2007 @@ -1,12 +1,8 @@ (in-package :funds.trees) -(defstruct avl - ht - key - value - left - right) +;;;; Public Interface + (defun empty-avl-tree () "An empty AVL Tree." @@ -37,6 +33,32 @@ ((funcall order key (avl-key tree)) (left-insert tree key value test order)) (t (right-insert tree key value test order)))) +(defun avl-find-value (tree key &key (order #'<) (test #'eql)) + "The value associated with the given key in the given AVL Tree. The function +returns nil if the key is not found in the given tree; a second value is returned +to indicate whether nil is returned because it is in fact the value associated with +the given key or, instead, the key could not be found." + (cond ((avl-empty-p tree) (values nil nil)) + ((funcall test key (avl-key tree)) (values (avl-value tree) t)) + ((funcall order key (avl-key tree)) + (avl-find-value (avl-left tree) key :order order :test test)) + (t (avl-find-value (avl-right tree) key :order order :test test)))) + +(defstruct avl + ht + key + value + left + right) + +(defun avl-height (tree) + "The height of the given AVL Tree." + (if (avl-empty-p tree) + 0 + (avl-ht tree))) + +;;;; Insertion Helpers + (defun left-insert (tree key value test order) "The AVL tree that results when the given key-value pair is inserted into left sub-tree of the given AVL tree. Only non-empty avl-trees @@ -77,6 +99,8 @@ :left left :right right)))) +;;;; Rotation Functions + (defun left-rotate (t0 a b) (let ((c (avl-right b)) (new-a (make-avl :ht (1- (avl-ht a)) ; re-calculate? @@ -103,16 +127,7 @@ :left a :right new-c))) -(defun avl-find-value (tree key &key (order #'<) (test #'eql)) - "The value associated with the given key in the given AVL Tree. The function -returns nil if the key is not found in the given tree; a second value is returned -to indicate whether nil is returned because it is in fact the value associated with -the given key or, instead, the key could not be found." - (cond ((avl-empty-p tree) (values nil nil)) - ((funcall test key (avl-key tree)) (values (avl-value tree) t)) - ((funcall order key (avl-key tree)) - (avl-find-value (avl-left tree) key :order order :test test)) - (t (avl-find-value (avl-right tree) key :order order :test test)))) +;;;; AVL Tree utility functions (defun imbalanced (left right) "Whether the heights of the given sub-trees differ, @@ -128,12 +143,6 @@ "The difference in heights of the given sub-trees." (- (avl-height a) (avl-height b))) -(defun avl-height (tree) - "The height of the given AVL Tree." - (if (avl-empty-p tree) - 0 - (avl-ht tree))) - (defun left-heavy (tree) "Whether the given imbalanced AVL Tree has a left sub-tree taller than its right sub-tree." @@ -151,7 +160,7 @@ (avl-left tree))) (defun parent-height (left right) - "The height of the parent of the given sub-trees." + "The height the tree should be, whose children are the given sub-trees." (let ((a (avl-height left)) (b (avl-height right))) (1+ (if (> a b) a b))))

1 0

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

20 Jun '07

Author: abaine Date: Wed Jun 20 18:25:29 2007 New Revision: 34 Modified: trunk/funds/src/trees/package.lisp Log: Added avl-find-value to public interface of avl-tree. Modified: trunk/funds/src/trees/package.lisp ============================================================================== --- trunk/funds/src/trees/package.lisp (original) +++ trunk/funds/src/trees/package.lisp Wed Jun 20 18:25:29 2007 @@ -8,6 +8,7 @@ :avl-empty-p :avl-insert :avl-remove + :avl-find-value :avl-key :avl-value

1 0

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

20 Jun '07

Author: abaine Date: Wed Jun 20 14:50:14 2007 New Revision: 33 Modified: trunk/funds/src/trees/avl-tree.lisp Log: Commented avl-find-value Modified: trunk/funds/src/trees/avl-tree.lisp ============================================================================== --- trunk/funds/src/trees/avl-tree.lisp (original) +++ trunk/funds/src/trees/avl-tree.lisp Wed Jun 20 14:50:14 2007 @@ -104,6 +104,10 @@ :right new-c))) (defun avl-find-value (tree key &key (order #'<) (test #'eql)) + "The value associated with the given key in the given AVL Tree. The function +returns nil if the key is not found in the given tree; a second value is returned +to indicate whether nil is returned because it is in fact the value associated with +the given key or, instead, the key could not be found." (cond ((avl-empty-p tree) (values nil nil)) ((funcall test key (avl-key tree)) (values (avl-value tree) t)) ((funcall order key (avl-key tree))

1 0

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

20 Jun '07

Author: abaine Date: Wed Jun 20 14:47:38 2007 New Revision: 32 Modified: trunk/funds/src/trees/avl-tree.lisp Log: Added avl-find-value function. Modified: trunk/funds/src/trees/avl-tree.lisp ============================================================================== --- trunk/funds/src/trees/avl-tree.lisp (original) +++ trunk/funds/src/trees/avl-tree.lisp Wed Jun 20 14:47:38 2007 @@ -43,7 +43,7 @@ should be supplied as arguments." (let ((left (avl-insert (avl-left tree) key value :test test :order order)) (right (avl-right tree))) - (if (imbalanced left right)n + (if (imbalanced left right) (if (left-heavy left) (right-rotate left tree right) (right-rotate (left-rotate (avl-left left) @@ -103,6 +103,13 @@ :left a :right new-c))) +(defun avl-find-value (tree key &key (order #'<) (test #'eql)) + (cond ((avl-empty-p tree) (values nil nil)) + ((funcall test key (avl-key tree)) (values (avl-value tree) t)) + ((funcall order key (avl-key tree)) + (avl-find-value (avl-left tree) key :order order :test test)) + (t (avl-find-value (avl-right tree) key :order order :test test)))) + (defun imbalanced (left right) "Whether the heights of the given sub-trees differ, in their absolute values, by more than one."

1 0

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

20 Jun '07

Author: abaine Date: Wed Jun 20 14:22:40 2007 New Revision: 31 Modified: trunk/funds/src/trees/avl-tree.lisp Log: AVL-Insert properly documented. Modified: trunk/funds/src/trees/avl-tree.lisp ============================================================================== --- trunk/funds/src/trees/avl-tree.lisp (original) +++ trunk/funds/src/trees/avl-tree.lisp Wed Jun 20 14:22:40 2007 @@ -18,12 +18,17 @@ (null tree)) (defun avl-insert (tree key value &key (test #'eql) (order #'<)) + "The AVL Tree that results when the given key-value pair is inserted +into the given tree. If the test function determines that the given key +and the root key af the given tree are \"equal\", then a new AVL Tree is +created as if the given key-value pair replaced the root key-value pair. +The given order function, < by default, is used to determine the order of +the resulting AVL Tree." (cond ((avl-empty-p tree) (make-avl :ht 1 :key key :value value :left (empty-avl-tree) :right (empty-avl-tree))) - ((funcall test key (avl-key tree)) (make-avl :ht (avl-ht tree) :key key :value value @@ -38,7 +43,7 @@ should be supplied as arguments." (let ((left (avl-insert (avl-left tree) key value :test test :order order)) (right (avl-right tree))) - (if (imbalanced left right) + (if (imbalanced left right)n (if (left-heavy left) (right-rotate left tree right) (right-rotate (left-rotate (avl-left left) @@ -124,7 +129,7 @@ (minusp (balance-factor tree))) (defun right-heavy (tree) - "Whether the given imbalanced AVL Tre has a right sub-tree + "Whether the given imbalanced AVL Tree has a right sub-tree taller than its left sub-tree." (plusp (balance-factor tree)))

1 0

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

20 Jun '07

Author: abaine Date: Wed Jun 20 13:06:54 2007 New Revision: 30 Modified: trunk/funds/src/trees/avl-tree.lisp Log: Minor semantic changes. Modified: trunk/funds/src/trees/avl-tree.lisp ============================================================================== --- trunk/funds/src/trees/avl-tree.lisp (original) +++ trunk/funds/src/trees/avl-tree.lisp Wed Jun 20 13:06:54 2007 @@ -103,6 +103,11 @@ in their absolute values, by more than one." (> (abs (height-difference left right)) 1)) +(defun balanced (left right) + "Whether the heights of the given sub-trees differ, +in their absolute values, by no more than one." + (< -2 (height-difference left right) 2)) + (defun height-difference (a b) "The difference in heights of the given sub-trees." (- (avl-height a) (avl-height b))) @@ -116,12 +121,12 @@ (defun left-heavy (tree) "Whether the given imbalanced AVL Tree has a left sub-tree taller than its right sub-tree." - (< (balance-factor tree) 0)) + (minusp (balance-factor tree))) (defun right-heavy (tree) "Whether the given imbalanced AVL Tre has a right sub-tree taller than its left sub-tree." - (> (balance-factor tree) 0)) + (plusp (balance-factor tree))) (defun balance-factor (tree) "The difference in heights of the right sub-tree and left

1 0

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

20 Jun '07

Author: abaine Date: Wed Jun 20 12:37:53 2007 New Revision: 29 Modified: trunk/funds/src/trees/avl-tree.lisp Log: Changed left-insert and right-insert to provide for test and order arguments. Modified: trunk/funds/src/trees/avl-tree.lisp ============================================================================== --- trunk/funds/src/trees/avl-tree.lisp (original) +++ trunk/funds/src/trees/avl-tree.lisp Wed Jun 20 12:37:53 2007 @@ -29,14 +29,14 @@ :value value :left (avl-left tree) :right (avl-right tree))) - ((funcall order key (avl-key tree)) (left-insert tree key value)) - (t (right-insert tree key value)))) + ((funcall order key (avl-key tree)) (left-insert tree key value test order)) + (t (right-insert tree key value test order)))) -(defun left-insert (tree key value) +(defun left-insert (tree key value test order) "The AVL tree that results when the given key-value pair is inserted into left sub-tree of the given AVL tree. Only non-empty avl-trees should be supplied as arguments." - (let ((left (avl-insert (avl-left tree) key value)) + (let ((left (avl-insert (avl-left tree) key value :test test :order order)) (right (avl-right tree))) (if (imbalanced left right) (if (left-heavy left) @@ -52,11 +52,11 @@ :left left :right right)))) -(defun right-insert (tree key value) +(defun right-insert (tree key value test order) "The AVL tree that results when the given key-value pair is inserted into the right sub-tree of the given AVL tree. Only non-empty avl-trees should be supplied as the tree argument." - (let ((right (avl-insert (avl-right tree) key value)) + (let ((right (avl-insert (avl-right tree) key value :test test :order order)) (left (avl-left tree))) (if (imbalanced left right) (if (right-heavy right)

1 0

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

20 Jun '07

Author: abaine Date: Wed Jun 20 12:27:20 2007 New Revision: 28 Modified: trunk/funds/src/trees/avl-tree.lisp Log: Changed avl-insert signature to accept keyword arguments test and order Modified: trunk/funds/src/trees/avl-tree.lisp ============================================================================== --- trunk/funds/src/trees/avl-tree.lisp (original) +++ trunk/funds/src/trees/avl-tree.lisp Wed Jun 20 12:27:20 2007 @@ -17,13 +17,19 @@ t if it is empty; nil else." (null tree)) -(defun avl-insert (tree key value) +(defun avl-insert (tree key value &key (test #'eql) (order #'<)) (cond ((avl-empty-p tree) (make-avl :ht 1 :key key :value value - :left nil - :right nil)) - ((< key (avl-key tree)) (left-insert tree key value)) + :left (empty-avl-tree) + :right (empty-avl-tree))) + + ((funcall test key (avl-key tree)) (make-avl :ht (avl-ht tree) + :key key + :value value + :left (avl-left tree) + :right (avl-right tree))) + ((funcall order key (avl-key tree)) (left-insert tree key value)) (t (right-insert tree key value)))) (defun left-insert (tree key value)

1 0

[funds-cvs] r27 - trunk/funds/tests/trees
by abaine＠common-lisp.net 20 Jun '07

20 Jun '07

Author: abaine Date: Wed Jun 20 12:15:00 2007 New Revision: 27 Modified: trunk/funds/tests/trees/avl-tree-test.lisp Log: Changed a couple of comments. Modified: trunk/funds/tests/trees/avl-tree-test.lisp ============================================================================== --- trunk/funds/tests/trees/avl-tree-test.lisp (original) +++ trunk/funds/tests/trees/avl-tree-test.lisp Wed Jun 20 12:15:00 2007 @@ -29,14 +29,14 @@ 2. the height of the right sub-tree is correct; 3. the height of the given tree is 1 more than the greater of the heights of the left and right sub-trees." - (if (avl-empty-p tree) - (zerop (avl-height tree)) - (and (height-correct-p (avl-left tree)) - (height-correct-p (avl-right tree)) + (or (and (avl-empty-p tree) + (zerop (avl-height tree))) ; (a) + (and (height-correct-p (avl-left tree)) ; (1) + (height-correct-p (avl-right tree)) ; (2) (let* ((a (avl-height (avl-left tree))) (b (avl-height (avl-right tree))) (c (if (> a b) a b))) - (eql (1+ c) (avl-height tree)))))) + (eql (1+ c) (avl-height tree)))))) ; (3) (defun balanced-p (tree) "Whether the given AVL Tree is properly balanced. To be balanced,

1 0

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

funds-cvs June 2007