funds-cvs July 2007

funds-cvs@common-lisp.net

1 participants
65 discussions

[funds-cvs] r51 - trunk/funds/src
by abaine＠common-lisp.net 04 Jul '07

04 Jul '07

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))

1 0

[funds-cvs] r50 - trunk/funds/src/trees
by abaine＠common-lisp.net 04 Jul '07

04 Jul '07

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

1 0

[funds-cvs] r49 - trunk/funds/src/trees
by abaine＠common-lisp.net 04 Jul '07

04 Jul '07

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

1 0

[funds-cvs] r48 - trunk/funds/src/trees
by abaine＠common-lisp.net 03 Jul '07

03 Jul '07

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))

1 0

[funds-cvs] r47 - trunk/funds/src/trees
by abaine＠common-lisp.net 03 Jul '07

03 Jul '07

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."

1 0

[funds-cvs] r46 - trunk/funds/src/trees
by abaine＠common-lisp.net 03 Jul '07

03 Jul '07

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)

1 0

[funds-cvs] r45 - trunk/funds/src/trees
by abaine＠common-lisp.net 03 Jul '07

03 Jul '07

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)

1 0

[funds-cvs] r44 - trunk/funds/tests/trees
by abaine＠common-lisp.net 03 Jul '07

03 Jul '07

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))

1 0

[funds-cvs] r43 - trunk/funds
by abaine＠common-lisp.net 03 Jul '07

03 Jul '07

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 <andrew.baine(a)gmail.com> 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

1 0

[funds-cvs] r42 - trunk/funds
by abaine＠common-lisp.net 02 Jul '07

02 Jul '07

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.

1 0

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

funds-cvs July 2007