funds-cvs August 2007

funds-cvs@common-lisp.net

1 participants
113 discussions

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

04 Aug '07

Author: abaine Date: Sat Aug 4 10:03:17 2007 New Revision: 114 Added: trunk/funds/src/trees/stitch-tree.lisp Log: Added stitch-tree methods and functions to replace constructors. These are responsible for making sure that the nodes that are stitched together actually satisfy avl properties in the case of avl trees. Added: trunk/funds/src/trees/stitch-tree.lisp ============================================================================== --- (empty file) +++ trunk/funds/src/trees/stitch-tree.lisp Sat Aug 4 10:03:17 2007 @@ -0,0 +1,41 @@ + +;;;; +;;;; 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 stitch-tree ((tree binary-tree) + &key (key (bt-key tree)) (value (bt-value tree)) left right) + (stitch-binary-tree :key key :value value :left left :right right)) + +(defmethod stitch-tree ((tree avl-tree) + &key (key (bt-key tree)) (value (bt-value tree)) left right) + (balance key value left right)) + +(defun stitch-avl-tree (&key root (key (bt-key root)) (value (bt-value root)) + (left (make-avl-leaf)) (right (make-avl-leaf))) + (make-instance 'avl-tree + :key key :value value + :left left :right right + :height (parent-height left right))) + +(defun stitch-binary-tree (&key root (key (bt-key root)) (value (bt-value root)) + (left (make-binary-tree)) (right (make-binary-tree))) + (make-instance 'binary-tree + :key key + :value value + :left left + :right right))

1 0

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

04 Aug '07

Author: abaine Date: Sat Aug 4 10:01:11 2007 New Revision: 113 Modified: trunk/funds/src/funds.asd Log: Added stitch-tree to defsystem form. Modified: trunk/funds/src/funds.asd ============================================================================== --- trunk/funds/src/funds.asd (original) +++ trunk/funds/src/funds.asd Sat Aug 4 10:01:11 2007 @@ -33,6 +33,7 @@ (:file "constructors") (:file "bt") (:file "avl") + (:file "stitch-tree") (:file "tree-as-alist") (:file "tree-empty-p") (:file "tree-insert")

1 0

[funds-cvs] r112 - trunk/funds/src/trees
by abaine＠common-lisp.net 02 Aug '07

02 Aug '07

Author: abaine Date: Thu Aug 2 15:41:49 2007 New Revision: 112 Modified: trunk/funds/src/trees/tree-insert.lisp Log: Got rid of avl specializer for tree-insert and instead made generic stitch-tree that balances tree as it is created. Modified: trunk/funds/src/trees/tree-insert.lisp ============================================================================== --- trunk/funds/src/trees/tree-insert.lisp (original) +++ trunk/funds/src/trees/tree-insert.lisp Thu Aug 2 15:41:49 2007 @@ -36,31 +36,25 @@ (stitch-avl-tree :key key :value value)) -(defmethod tree-insert ((tree binary-tree) key value - &key (test #'eql) (order #'<)) +(defmethod tree-insert ((tree binary-tree) key value &key (test #'eql) (order #'<)) (if (funcall test key (bt-key tree)) - (make-instance 'binary-tree - :key key - :value value - :left (bt-left tree) - :right (bt-right tree)) + (stitch-tree tree :key key :value value :left (bt-left tree) :right (bt-right tree)) (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 + (stitch-tree tree + side (tree-insert (tree-child tree :side side) key value :test test :order order) - other-side (tree-child tree :side other-side))))) + other-side (tree-child tree :side other-side))))) -(defmethod tree-insert ((tree avl-tree) key value - &key (test #'eql) (order #'<)) - (if (funcall test key (bt-key tree)) - (stitch-avl-tree :key key - :value value - :left (bt-left tree) - :right (bt-right tree)) - (let* ((temp (call-next-method)) - (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)))) +(defmethod stitch-tree ((tree binary-tree) + &key (key (bt-key tree)) (value (bt-value tree)) left right) + (make-instance 'binary-tree + :key key + :value value + :left left + :right right)) + +(defmethod stitch-tree ((tree avl-tree) + &key (key (bt-key tree)) (value (bt-value tree)) left right) + (balance key value left right))

1 0

[funds-cvs] r111 - trunk/funds/src/trees
by abaine＠common-lisp.net 02 Aug '07

02 Aug '07

Author: abaine Date: Thu Aug 2 15:40:23 2007 New Revision: 111 Modified: trunk/funds/src/trees/avl.lisp Log: Totally changed balance function so that it doesn't require the creation of intermediate nodes. Modified: trunk/funds/src/trees/avl.lisp ============================================================================== --- trunk/funds/src/trees/avl.lisp (original) +++ trunk/funds/src/trees/avl.lisp Thu Aug 2 15:40:23 2007 @@ -33,24 +33,26 @@ (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) - (stitch-avl-tree :root 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 balance (key value left right) + (let ((height-difference (- (tree-height left) (tree-height right)))) + (if (< -2 height-difference 2) + (stitch-avl-tree :key key :value value :left left :right right) + (let* ((heavy-side (if (plusp height-difference) :left :right)) + (other-side (other-side heavy-side)) + (inside (if (left-p heavy-side) right left)) + (outside (if (left-p heavy-side) left right))) + (rotate inside key value + (if (heavier-p outside :side other-side) + (rotate (tree-child outside :side heavy-side) + (bt-key outside) (bt-value outside) + (tree-child outside :side other-side) + :side heavy-side) + outside) + :side other-side))))) -(defun rotate (inside root outside &key side) +(defun rotate (inside root-key root-value outside &key side) (let* ((t1 (tree-child outside :side side)) - (new-inside (stitch-avl-tree :root root + (new-inside (stitch-avl-tree :key root-key :value root-value side inside (other-side side) t1)) (new-outside (tree-child outside :side (other-side side))))

1 0

[funds-cvs] r110 - trunk/funds/src/trees
by abaine＠common-lisp.net 02 Aug '07

02 Aug '07

Author: abaine Date: Thu Aug 2 15:38:18 2007 New Revision: 110 Modified: trunk/funds/src/trees/tree-remove.lisp Log: Deleted avl specializer for tree-remove because general bt method works fine; replaced attach-bt forms with stitch-tree. Modified: trunk/funds/src/trees/tree-remove.lisp ============================================================================== --- trunk/funds/src/trees/tree-remove.lisp (original) +++ trunk/funds/src/trees/tree-remove.lisp Thu Aug 2 15:38:18 2007 @@ -35,23 +35,11 @@ :left :right)) (other-side (other-side side))) - (attach-bt tree - side (tree-remove (tree-child tree :side side) key + (stitch-tree 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)) - (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))))) + other-side (tree-child tree :side other-side))))) (defun remove-root (tree &key test order) (cond ((tree-empty-p (bt-left tree)) (bt-right tree)) @@ -60,6 +48,6 @@ (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)))) + (stitch-tree next + :left (bt-left tree) + :right (tree-remove (bt-right tree) (bt-key next) :test test :order order))))

1 0

[funds-cvs] r109 - trunk/funds/src/trees
by abaine＠common-lisp.net 02 Aug '07

02 Aug '07

Author: abaine Date: Thu Aug 2 15:35:51 2007 New Revision: 109 Modified: trunk/funds/src/trees/bt.lisp Log: Deleted attach-bt. Modified: trunk/funds/src/trees/bt.lisp ============================================================================== --- trunk/funds/src/trees/bt.lisp (original) +++ trunk/funds/src/trees/bt.lisp Thu Aug 2 15:35:51 2007 @@ -33,13 +33,6 @@ (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)) - (defun side-to-insert (tree key &key order) (if (funcall order key (bt-key tree)) :left

1 0

[funds-cvs] r108 - trunk/funds/src/trees
by abaine＠common-lisp.net 02 Aug '07

02 Aug '07

Author: abaine Date: Thu Aug 2 12:14:58 2007 New Revision: 108 Modified: trunk/funds/src/trees/tree-insert.lisp Log: Corrected make-avl-tree to stitch-avl-tree. Modified: trunk/funds/src/trees/tree-insert.lisp ============================================================================== --- trunk/funds/src/trees/tree-insert.lisp (original) +++ trunk/funds/src/trees/tree-insert.lisp Thu Aug 2 12:14:58 2007 @@ -55,10 +55,10 @@ (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)) + (stitch-avl-tree :key key + :value value + :left (bt-left tree) + :right (bt-right tree)) (let* ((temp (call-next-method)) (side (side-to-insert tree key :order order)) (outside (tree-child temp :side side))

1 0

[funds-cvs] r107 - trunk/funds/src/trees
by abaine＠common-lisp.net 02 Aug '07

02 Aug '07

Author: abaine Date: Thu Aug 2 12:14:20 2007 New Revision: 107 Modified: trunk/funds/src/trees/avl.lisp Log: Corrected nesting problem. Modified: trunk/funds/src/trees/avl.lisp ============================================================================== --- trunk/funds/src/trees/avl.lisp (original) +++ trunk/funds/src/trees/avl.lisp Thu Aug 2 12:14:20 2007 @@ -59,7 +59,7 @@ (other-side side) new-outside))) (defun stitch-avl-tree (&key root (key (bt-key root)) (value (bt-value root)) - (left (make-avl-leaf)) (right make-avl-leaf)) + (left (make-avl-leaf)) (right (make-avl-leaf))) (make-instance 'avl-tree :key key :value value :left left :right right

1 0

[funds-cvs] r106 - trunk/funds/src/trees
by abaine＠common-lisp.net 02 Aug '07

02 Aug '07

Author: abaine Date: Thu Aug 2 11:41:43 2007 New Revision: 106 Modified: trunk/funds/src/trees/tree-remove.lisp Log: Cosmetic. Modified: trunk/funds/src/trees/tree-remove.lisp ============================================================================== --- trunk/funds/src/trees/tree-remove.lisp (original) +++ trunk/funds/src/trees/tree-remove.lisp Thu Aug 2 11:41:43 2007 @@ -47,8 +47,8 @@ (if (tree-empty-p temp) (make-avl-tree) (let* ((heavy-side (if (heavier-p temp :side :left) - :left - :right)) + :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)))))

1 0

[funds-cvs] r105 - trunk/funds/src/trees
by abaine＠common-lisp.net 02 Aug '07

02 Aug '07

Author: abaine Date: Thu Aug 2 11:39:01 2007 New Revision: 105 Modified: trunk/funds/src/trees/avl.lisp Log: Deleted attach-avl and make-avl-node, which are obviated by stitch-avl-tree. Modified: trunk/funds/src/trees/avl.lisp ============================================================================== --- trunk/funds/src/trees/avl.lisp (original) +++ trunk/funds/src/trees/avl.lisp Thu Aug 2 11:39:01 2007 @@ -64,17 +64,3 @@ :key key :value value :left left :right right :height (parent-height left right))) - -(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)) - -(defun make-avl-node (&key key value (left make-avl-tree) (right make-avl-tree)) - (make-instance 'avl-tree - :key key - :value value - :left left - :right right - :height (parent-height left right)))

1 0

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

funds-cvs August 2007