From 7758070defbf3fb65d1b0993b2217b5a2f8f2624 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Wed, 31 Oct 2007 15:47:32 -0500
Subject: [PATCH] Port heaps to the new module system, add min-heap and
max-heap
---
extra/heaps/heaps-tests.factor | 32 ++++++++++
extra/heaps/heaps.factor | 112 +++++++++++++++++++++++++++++++++
2 files changed, 144 insertions(+)
create mode 100644 extra/heaps/heaps-tests.factor
create mode 100644 extra/heaps/heaps.factor
diff --git a/extra/heaps/heaps-tests.factor b/extra/heaps/heaps-tests.factor
new file mode 100644
index 0000000000..a8087916e7
--- /dev/null
+++ b/extra/heaps/heaps-tests.factor
@@ -0,0 +1,32 @@
+! Copyright 2007 Ryan Murphy
+! See http://factorcode.org/license.txt for BSD license.
+
+USING: kernel math tools.test heaps heaps.private ;
+IN: temporary
+
+[ <min-heap> pop-heap ] unit-test-fails
+[ <max-heap> pop-heap ] unit-test-fails
+
+[ t ] [ <min-heap> heap-empty? ] unit-test
+[ f ] [ <min-heap> 1 over push-heap heap-empty? ] unit-test
+[ t ] [ <max-heap> heap-empty? ] unit-test
+[ f ] [ <max-heap> 1 over push-heap heap-empty? ] unit-test
+
+! Binary Min Heap
+{ 1 2 3 4 5 6 } [ 0 left 0 right 1 left 1 right 2 left 2 right ] unit-test
+{ t } [ 5 3 T{ min-heap } heap-compare ] unit-test
+{ f } [ 5 3 T{ max-heap } heap-compare ] unit-test
+
+[ T{ min-heap T{ heap f V{ -6 -4 2 1 5 3 2 4 3 7 6 8 3 4 4 6 5 5 } } } ]
+[ <min-heap> { 3 5 4 6 7 8 2 4 3 5 6 1 3 2 4 5 -6 -4 } over push-heap* ] unit-test
+
+[ T{ min-heap T{ heap f V{ 5 6 6 7 8 } } } ] [
+ <min-heap> { 3 5 4 6 5 7 6 8 } over push-heap*
+ 3 [ dup pop-heap* ] times
+] unit-test
+
+[ 2 ] [ <min-heap> 300 over push-heap 200 over push-heap 400 over push-heap 3 over push-heap 2 over push-heap pop-heap ] unit-test
+
+[ 1 ] [ <min-heap> 300 over push-heap 200 over push-heap 400 over push-heap 3 over push-heap 2 over push-heap 1 over push-heap pop-heap ] unit-test
+
+[ 400 ] [ <max-heap> 300 over push-heap 200 over push-heap 400 over push-heap 3 over push-heap 2 over push-heap 1 over push-heap pop-heap ] unit-test
diff --git a/extra/heaps/heaps.factor b/extra/heaps/heaps.factor
new file mode 100644
index 0000000000..2ff9096483
--- /dev/null
+++ b/extra/heaps/heaps.factor
@@ -0,0 +1,112 @@
+! Copyright (C) 2007 Ryan Murphy, Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel math sequences ;
+IN: heaps
+
+<PRIVATE
+TUPLE: heap data ;
+
+: <heap> ( -- obj )
+ V{ } clone heap construct-boa ;
+PRIVATE>
+
+TUPLE: min-heap ;
+
+: <min-heap> ( -- obj )
+ <heap> min-heap construct-delegate ;
+
+TUPLE: max-heap ;
+
+: <max-heap> ( -- obj )
+ <heap> max-heap construct-delegate ;
+
+<PRIVATE
+: left ( n -- m ) 2 * 1+ ;
+: right ( n -- m ) 2 * 2 + ;
+: up ( n -- m ) 1- 2 /i ;
+: left-value ( n heap -- obj ) >r left r> nth ;
+: right-value ( n heap -- obj ) >r right r> nth ;
+: up-value ( n vec -- obj ) >r up r> nth ;
+: swap-up ( n vec -- ) >r dup up r> exchange ;
+: last-index ( vec -- n ) length 1- ;
+
+GENERIC: heap-compare ( obj1 obj2 heap -- ? )
+
+M: min-heap heap-compare drop <=> 0 > ;
+M: max-heap heap-compare drop <=> 0 < ;
+
+: left-bounds-check? ( m heap -- ? )
+ >r left r> heap-data length >= ;
+
+: right-bounds-check? ( m heap -- ? )
+ >r right r> heap-data length >= ;
+
+: (up-heap) ( vec heap -- )
+ [
+ >r [ last-index ] keep [ up-value ] keep peek r> heap-compare
+ ] 2keep rot [
+ >r dup last-index
+ [ over swap-up ] keep
+ up 1+ head-slice
+ r> (up-heap)
+ ] [
+ 2drop
+ ] if ;
+
+: up-heap ( heap -- )
+ [ heap-data ] keep (up-heap) ;
+
+: child ( m heap -- n )
+ 2dup right-bounds-check? [
+ drop left
+ ] [
+ dupd
+ [ heap-data left-value ] 2keep
+ [ heap-data right-value ] keep heap-compare [
+ right
+ ] [
+ left
+ ] if
+ ] if ;
+
+: swap-down ( m heap -- )
+ [ child ] 2keep heap-data exchange ;
+
+DEFER: down-heap
+
+: (down-heap) ( m heap -- )
+ 2dup [ heap-data nth ] 2keep child pick
+ dupd [ heap-data nth swapd ] keep
+ heap-compare [
+ -rot [ swap-down ] keep down-heap
+ ] [
+ 3drop
+ ] if ;
+
+: down-heap ( m heap -- )
+ 2dup left-bounds-check? [ 2drop ] [ (down-heap) ] if ;
+
+PRIVATE>
+
+: push-heap ( obj heap -- )
+ tuck heap-data push up-heap ;
+
+: push-heap* ( seq heap -- )
+ swap [ swap push-heap ] curry* each ;
+
+: peek-heap ( heap -- obj )
+ heap-data first ;
+
+: pop-heap* ( heap -- )
+ dup heap-data length 1 > [
+ [ heap-data pop 0 ] keep
+ [ heap-data set-nth ] keep
+ >r 0 r> down-heap
+ ] [
+ heap-data pop*
+ ] if ;
+
+: pop-heap ( heap -- fist ) [ heap-data first ] keep pop-heap* ;
+
+: heap-empty? ( heap -- ? )
+ heap-data empty? ;