funds-cvs

funds-cvs@common-lisp.net

225 discussions

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

31 Jul '07

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

1 0

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

31 Jul '07

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

1 0

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

31 Jul '07

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

1 0

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

12 Jul '07

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

1 0

[funds-cvs] r94 - in trunk/funds/src: . trees/heap
by abaine＠common-lisp.net 12 Jul '07

12 Jul '07

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

1 0

[funds-cvs] r93 - trunk/funds/src/trees/heap
by abaine＠common-lisp.net 12 Jul '07

12 Jul '07

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

1 0

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

12 Jul '07

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)

1 0

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

11 Jul '07

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

1 0

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

11 Jul '07

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)

1 0

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

11 Jul '07

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

1 0

← Newer
1
...
10
11
12
13
14
15
16
...
23
Older →

Jump to page:

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

funds-cvs