From e95721ad084c0d7db9356aa779405ea214e10d1f Mon Sep 17 00:00:00 2001 From: Dan Ehrenberg Date: Fri, 11 Jul 2008 09:42:16 -0700 Subject: [PATCH 1/3] 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 + +> ] [ right>> ] bi [ empty-heap? ] both? ; + +C: branch +: >branch< ( branch -- value prio left right ) + { [ value>> ] [ prio>> ] [ left>> ] [ right>> ] } cleave ; +PRIVATE> + +: ( -- heap ) T{ empty-heap } ; + +: ( value prio -- heap ) + ; + +: pheap-empty? ( heap -- ? ) empty-heap? ; + +: empty-pheap ( -- * ) + "Attempt to delete from an empty heap" throw ; + +> ] [ right>> ] bi [ pheap-empty? ] both? + [ [ value>> ] [ prio>> ] bi ] + [ >branch< swap remove-left -rot [ ] 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 } ; + +METHOD: sift-down { singleton-heap empty-heap } + 3dup drop prio>> <= [ ] [ + drop -rot [ [ value>> ] [ prio>> ] bi ] 2dip + + ] if ; + +:: reroot-left ( value prio left right -- heap ) + left value>> left prio>> + value prio left left>> left right>> sift-down + right ; + +:: reroot-right ( value prio left right -- heap ) + right value>> right prio>> left + value prio right left>> right right>> sift-down + ; + +METHOD: sift-down { branch branch } + 3dup [ prio>> <= ] both-with? [ ] [ + 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 ; + +> ] [ prio>> ] [ right>> ] tri pheap-push ] + [ left>> ] bi ; + +: push-in ( value prio heap -- newheap ) + [ 2nip [ value>> ] [ prio>> ] bi ] + [ right>> pheap-push ] + [ 2nip left>> ] 3tri ; +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 ] + [ [ 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 + 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 From 01714ae37f94f02cd14f41db160eb064f164cf8d Mon Sep 17 00:00:00 2001 From: Dan Ehrenberg Date: Fri, 11 Jul 2008 10:37:51 -0700 Subject: [PATCH 2/3] Persistent heaps documentation --- .../persistent-heaps-docs.factor | 58 +++++++++++++++++++ 1 file changed, 58 insertions(+) create mode 100644 extra/persistent-heaps/persistent-heaps-docs.factor diff --git a/extra/persistent-heaps/persistent-heaps-docs.factor b/extra/persistent-heaps/persistent-heaps-docs.factor new file mode 100644 index 0000000000..d538fe88d4 --- /dev/null +++ b/extra/persistent-heaps/persistent-heaps-docs.factor @@ -0,0 +1,58 @@ +USING: help.syntax help.markup kernel arrays assocs ; +IN: persistent-heaps + +HELP: +{ $values { "heap" "a persistent heap" } } +{ $description "Creates a new persistent heap" } ; + +HELP: +{ $values { "value" object } { "prio" "a priority" } { "heap" "a persistent heap" } } +{ $description "Creates a new persistent heap consisting of one object with the given priority." } ; + +HELP: pheap-empty? +{ $values { "heap" "a persistent heap" } { "?" "a boolean" } } +{ $description "Returns true if this is an empty persistent heap." } ; + +HELP: pheap-peek +{ $values { "heap" "a persistent heap" } { "value" "an object in the heap" } { "prio" "the minimum priority" } } +{ $description "Gets the object in the heap with minumum priority." } ; + +HELP: pheap-push +{ $values { "heap" "a persistent heap" } { "value" object } { "prio" "a priority" } { "newheap" "a new persistent heap" } } +{ $description "Creates a new persistent heap also containing the given object of the given priority." } ; + +HELP: pheap-pop* +{ $values { "heap" "a persistent heap" } { "newheap" "a new persistent heap" } } +{ $description "Creates a new persistent heap with the minimum element removed." } ; + +HELP: pheap-pop +{ $values { "heap" "a persistent heap" } { "newheap" "a new persistent heap" } { "value" object } { "prio" "a priority" } } +{ $description "Creates a new persistent heap with the minimum element removed, returning that element and its priority." } ; + +HELP: assoc>pheap +{ $values { "assoc" assoc } { "heap" "a persistent heap" } } +{ $description "Creates a new persistent heap from an associative mapping whose keys are the entries in the heap and whose values are the associated priorities." } ; + +HELP: pheap>alist +{ $values { "heap" "a persistent heap" } { "alist" "an association list" } } +{ $description "Creates an association list whose keys are the entries in the heap and whose values are the associated priorities. It is in sorted order by priority. This does not modify the heap." } ; + +HELP: pheap>values +{ $values { "heap" "a persistent heap" } { "values" array } } +{ $description "Creates an an array of all of the values in the heap, in sorted order by priority. This does not modify the heap." } ; + +ARTICLE: "persistent-heaps" "Persistent heaps" +"This vocabulary implements persistent minheaps, aka priority queues. They are purely functional and support efficient O(log n) operations of pushing and popping, with O(1) time access to the minimum element. To create heaps, use the following words:" +{ $subsection } +{ $subsection } +"To manipulate them:" +{ $subsection pheap-peek } +{ $subsection pheap-push } +{ $subsection pheap-pop } +{ $subsection pheap-pop* } +{ $subsection pheap-empty? } +{ $subsection assoc>pheap } +{ $subsection pheap>alist } +{ $subsection pheap>values } ; + +ABOUT: "persistent-heaps" From 1e829b18e5ab09dec2173ce2bd36baa31e22a252 Mon Sep 17 00:00:00 2001 From: Dan Ehrenberg Date: Sat, 12 Jul 2008 14:56:51 -0700 Subject: [PATCH 3/3] Delegate removed from tuple arrays --- extra/tuple-arrays/tuple-arrays-tests.factor | 2 +- extra/tuple-arrays/tuple-arrays.factor | 31 ++++++++------------ 2 files changed, 13 insertions(+), 20 deletions(-) diff --git a/extra/tuple-arrays/tuple-arrays-tests.factor b/extra/tuple-arrays/tuple-arrays-tests.factor index dd9510405f..132a11f4a6 100755 --- a/extra/tuple-arrays/tuple-arrays-tests.factor +++ b/extra/tuple-arrays/tuple-arrays-tests.factor @@ -6,7 +6,7 @@ TUPLE: foo bar ; C: foo [ 2 ] [ 2 T{ foo } dup mat set length ] unit-test [ T{ foo } ] [ mat get first ] unit-test -[ T{ foo f 1 } ] [ T{ foo 2 1 } 0 mat get [ set-nth ] keep first ] unit-test +[ T{ foo 2 1 } ] [ T{ foo 2 1 } 0 mat get [ set-nth ] keep first ] unit-test [ t ] [ { T{ foo f 1 } T{ foo f 2 } } >tuple-array dup mat set tuple-array? ] unit-test [ T{ foo f 3 } t ] [ mat get [ foo-bar 2 + ] map [ first ] keep tuple-array? ] unit-test diff --git a/extra/tuple-arrays/tuple-arrays.factor b/extra/tuple-arrays/tuple-arrays.factor index 6a31dac808..63e7541c95 100644 --- a/extra/tuple-arrays/tuple-arrays.factor +++ b/extra/tuple-arrays/tuple-arrays.factor @@ -1,35 +1,26 @@ ! Copyright (C) 2007 Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. USING: splitting grouping classes.tuple classes math kernel -sequences arrays ; +sequences arrays accessors ; IN: tuple-arrays -TUPLE: tuple-array example ; - -: prepare-example ( tuple -- seq n ) - dup class over delegate [ 1array ] [ f 2array ] if - swap tuple>array length over length - ; +TUPLE: tuple-array seq class ; : ( length example -- tuple-array ) - prepare-example [ rot * { } new-sequence ] keep - tuple-array construct-delegate - [ set-tuple-array-example ] keep ; - -: reconstruct ( seq example -- tuple ) - prepend >tuple ; + [ tuple>array length 1- [ * { } new-sequence ] keep ] + [ class ] bi tuple-array boa ; M: tuple-array nth - [ delegate nth ] keep - tuple-array-example reconstruct ; + [ seq>> nth ] [ class>> ] bi prefix >tuple ; -: deconstruct ( tuple example -- seq ) - >r tuple>array r> length tail-slice ; +: deconstruct ( tuple -- seq ) + tuple>array 1 tail ; M: tuple-array set-nth ( elt n seq -- ) - tuck >r >r tuple-array-example deconstruct r> r> - delegate set-nth ; + >r >r deconstruct r> r> seq>> set-nth ; -M: tuple-array new-sequence tuple-array-example >tuple ; +M: tuple-array new-sequence + class>> new ; : >tuple-array ( seq -- tuple-array/seq ) dup empty? [ @@ -39,4 +30,6 @@ M: tuple-array new-sequence tuple-array-example >tuple ; M: tuple-array like drop dup tuple-array? [ >tuple-array ] unless ; +M: tuple-array length seq>> length ; + INSTANCE: tuple-array sequence