From e95721ad084c0d7db9356aa779405ea214e10d1f Mon Sep 17 00:00:00 2001
From: Dan Ehrenberg <littledan@littledan-desktop.(none)>
Date: Fri, 11 Jul 2008 09:42:16 -0700
Subject: [PATCH] Persistent heaps

---
 extra/persistent-heaps/authors.txt            |   1 +
 .../persistent-heaps-tests.factor             |  11 ++
 .../persistent-heaps/persistent-heaps.factor  | 102 ++++++++++++++++++
 extra/persistent-heaps/summary.txt            |   1 +
 extra/persistent-heaps/tags.txt               |   1 +
 5 files changed, 116 insertions(+)
 create mode 100644 extra/persistent-heaps/authors.txt
 create mode 100644 extra/persistent-heaps/persistent-heaps-tests.factor
 create mode 100644 extra/persistent-heaps/persistent-heaps.factor
 create mode 100644 extra/persistent-heaps/summary.txt
 create mode 100644 extra/persistent-heaps/tags.txt

diff --git a/extra/persistent-heaps/authors.txt b/extra/persistent-heaps/authors.txt
new file mode 100644
index 0000000000..f990dd0ed2
--- /dev/null
+++ b/extra/persistent-heaps/authors.txt
@@ -0,0 +1 @@
+Daniel Ehrenberg
diff --git a/extra/persistent-heaps/persistent-heaps-tests.factor b/extra/persistent-heaps/persistent-heaps-tests.factor
new file mode 100644
index 0000000000..6e559971a0
--- /dev/null
+++ b/extra/persistent-heaps/persistent-heaps-tests.factor
@@ -0,0 +1,11 @@
+USING: persistent-heaps tools.test ;
+IN: persistent-heaps.tests
+
+: test-input
+    { { "hello" 3 } { "goodbye" 2 } { "whatever" 5 }
+      { "foo" 1 } { "bar" -1 } { "baz" -7 } { "bing" 0 } } ;
+
+[
+    { { "baz" -7 } { "bar" -1 } { "bing" 0 } { "foo" 1 }
+      { "goodbye" 2 } { "hello" 3 } { "whatever" 5 } }
+] [ test-input assoc>pheap pheap>alist ] unit-test
diff --git a/extra/persistent-heaps/persistent-heaps.factor b/extra/persistent-heaps/persistent-heaps.factor
new file mode 100644
index 0000000000..5b57898da0
--- /dev/null
+++ b/extra/persistent-heaps/persistent-heaps.factor
@@ -0,0 +1,102 @@
+USING: kernel accessors multi-methods locals combinators math arrays
+assocs namespaces sequences ;
+IN: persistent-heaps
+! These are minheaps
+
+<PRIVATE
+TUPLE: branch value prio left right ;
+TUPLE: empty-heap ;
+
+PREDICATE: singleton-heap < branch
+    [ left>> ] [ right>> ] bi [ empty-heap? ] both? ;
+
+C: <branch> branch
+: >branch< ( branch -- value prio left right )
+    { [ value>> ] [ prio>> ] [ left>> ] [ right>> ] } cleave ;
+PRIVATE>
+
+: <persistent-heap> ( -- heap ) T{ empty-heap } ;
+
+: <singleton-heap> ( value prio -- heap )
+    <persistent-heap> <persistent-heap> <branch> ;
+
+: pheap-empty? ( heap -- ? ) empty-heap? ;
+
+: empty-pheap ( -- * )
+    "Attempt to delete from an empty heap" throw ;
+
+<PRIVATE
+: remove-left ( heap -- value prio newheap )
+    dup [ left>> ] [ right>> ] bi [ pheap-empty? ] both?
+    [ [ value>> ] [ prio>> ] bi <persistent-heap> ]
+    [ >branch< swap remove-left -rot [ <branch> ] 2dip rot ] if ;
+
+: both-with? ( obj a b quot -- ? )
+   swap >r with r> swap both? ; inline
+
+GENERIC: sift-down ( value prio left right -- heap )
+
+METHOD: sift-down { empty-heap empty-heap } <branch> ;
+
+METHOD: sift-down { singleton-heap empty-heap }
+    3dup drop prio>> <= [ <branch> ] [
+        drop -rot [ [ value>> ] [ prio>> ] bi ] 2dip
+        <singleton-heap> <persistent-heap> <branch>
+    ] if ;
+
+:: reroot-left ( value prio left right -- heap )
+    left value>> left prio>>
+    value prio left left>> left right>> sift-down
+    right <branch> ;
+
+:: reroot-right ( value prio left right -- heap )
+    right value>> right prio>> left
+    value prio right left>> right right>> sift-down
+    <branch> ;
+
+METHOD: sift-down { branch branch }
+    3dup [ prio>> <= ] both-with? [ <branch> ] [
+        2dup [ prio>> ] bi@ <= [ reroot-left ] [ reroot-right ] if
+    ] if ;
+PRIVATE>
+
+GENERIC: pheap-peek ( heap -- value prio )
+M: empty-heap pheap-peek empty-pheap ;
+M: branch pheap-peek [ value>> ] [ prio>> ] bi ;
+
+GENERIC: pheap-push ( value prio heap -- newheap )
+
+M: empty-heap pheap-push
+    drop <singleton-heap> ;
+
+<PRIVATE
+: push-top ( value prio heap -- newheap )
+    [ [ value>> ] [ prio>> ] [ right>> ] tri pheap-push ]
+    [ left>> ] bi <branch> ;
+
+: push-in ( value prio heap -- newheap )
+    [ 2nip [ value>> ] [ prio>> ] bi ]
+    [ right>> pheap-push ]
+    [ 2nip left>> ] 3tri <branch> ;
+PRIVATE>
+
+M: branch pheap-push
+    2dup prio>> <= [ push-top ] [ push-in ] if ;
+
+: pheap-pop* ( heap -- newheap )
+    dup pheap-empty? [ empty-pheap ] [
+        dup left>> pheap-empty?
+        [ drop <persistent-heap> ]
+        [ [ left>> remove-left ] keep right>> swap sift-down ] if
+    ] if ;
+
+: pheap-pop ( heap -- newheap value prio )
+    [ pheap-pop* ] [ pheap-peek ] bi ;
+
+: assoc>pheap ( assoc -- heap ) ! Assoc is value => prio
+    <persistent-heap> swap [ rot pheap-push ] assoc-each ;
+
+: pheap>alist ( heap -- alist )
+    [ dup pheap-empty? not ] [ pheap-pop 2array ] [ ] produce nip ;
+
+: pheap>values ( heap -- seq ) pheap>alist keys ;
diff --git a/extra/persistent-heaps/summary.txt b/extra/persistent-heaps/summary.txt
new file mode 100644
index 0000000000..1451439c65
--- /dev/null
+++ b/extra/persistent-heaps/summary.txt
@@ -0,0 +1 @@
+Datastructure for functional peristent heaps, from ML for the Working Programmer
diff --git a/extra/persistent-heaps/tags.txt b/extra/persistent-heaps/tags.txt
new file mode 100644
index 0000000000..42d711b32b
--- /dev/null
+++ b/extra/persistent-heaps/tags.txt
@@ -0,0 +1 @@
+collections