From 748c2b4b339f45ad60be3a712fd7802d67ae13c2 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 21 Feb 2008 17:07:26 -0600 Subject: [PATCH] Clean up heaps and add heap-push*, heap-delete words --- core/heaps/heaps-docs.factor | 55 ++++++++-------- core/heaps/heaps-tests.factor | 66 +++++++++++++++----- core/heaps/heaps.factor | 114 ++++++++++++++++++++-------------- 3 files changed, 150 insertions(+), 85 deletions(-) mode change 100644 => 100755 core/heaps/heaps-docs.factor mode change 100644 => 100755 core/heaps/heaps-tests.factor mode change 100644 => 100755 core/heaps/heaps.factor diff --git a/core/heaps/heaps-docs.factor b/core/heaps/heaps-docs.factor old mode 100644 new mode 100755 index 3605ec519a..e912355a5c --- a/core/heaps/heaps-docs.factor +++ b/core/heaps/heaps-docs.factor @@ -11,9 +11,9 @@ $nl { $subsection min-heap? } { $subsection } "Max-heaps sort their elements so that the maximum element is first:" -{ $subsection min-heap } -{ $subsection min-heap? } -{ $subsection } +{ $subsection max-heap } +{ $subsection max-heap? } +{ $subsection } "Both obey a protocol." $nl "Queries:" @@ -22,58 +22,61 @@ $nl { $subsection heap-peek } "Insertion:" { $subsection heap-push } +{ $subsection heap-push* } { $subsection heap-push-all } "Removal:" { $subsection heap-pop* } -{ $subsection heap-pop } ; +{ $subsection heap-pop } +{ $subsection heap-delete } ; ABOUT: "heaps" HELP: { $values { "min-heap" min-heap } } -{ $description "Create a new " { $link min-heap } "." } -{ $see-also } ; +{ $description "Create a new " { $link min-heap } "." } ; HELP: { $values { "max-heap" max-heap } } -{ $description "Create a new " { $link max-heap } "." } -{ $see-also } ; +{ $description "Create a new " { $link max-heap } "." } ; HELP: heap-push { $values { "key" "a comparable object" } { "value" object } { "heap" heap } } -{ $description "Push an pair onto a heap. The key must be comparable with all other keys by the " { $link <=> } " generic word." } -{ $side-effects "heap" } -{ $see-also heap-push-all heap-pop } ; +{ $description "Push a pair onto a heap. The key must be comparable with all other keys by the " { $link <=> } " generic word." } +{ $side-effects "heap" } ; + +HELP: heap-push* +{ $values { "key" "a comparable object" } { "value" object } { "heap" heap } { "entry" entry } } +{ $description "Push a pair onto a heap, and output an entry which may later be passed to " { $link heap-delete } "." } +{ $side-effects "heap" } ; HELP: heap-push-all { $values { "assoc" assoc } { "heap" heap } } { $description "Push every key/value pair of an assoc onto a heap." } -{ $side-effects "heap" } -{ $see-also heap-push heap-pop } ; +{ $side-effects "heap" } ; HELP: heap-peek { $values { "heap" heap } { "key" object } { "value" object } } -{ $description "Outputs the first element in the heap, leaving it in the heap." } -{ $see-also heap-pop heap-pop* } ; +{ $description "Output the first element in the heap, leaving it in the heap." } ; HELP: heap-pop* { $values { "heap" heap } } -{ $description "Removes the first element from the heap." } -{ $side-effects "heap" } -{ $see-also heap-pop heap-push heap-peek } ; +{ $description "Remove the first element from the heap." } +{ $side-effects "heap" } ; HELP: heap-pop { $values { "heap" heap } { "key" object } { "value" object } } -{ $description "Outputs the first element in the heap and removes it from the heap." } -{ $side-effects "heap" } -{ $see-also heap-pop* heap-push heap-peek } ; +{ $description "Output and remove the first element in the heap." } +{ $side-effects "heap" } ; HELP: heap-empty? { $values { "heap" heap } { "?" "a boolean" } } -{ $description "Tests if a " { $link heap } " has no nodes." } -{ $see-also heap-length heap-peek } ; +{ $description "Tests if a " { $link heap } " has no nodes." } ; -HELP: heap-length +HELP: heap-size { $values { "heap" heap } { "n" integer } } -{ $description "Returns the number of key/value pairs in the heap." } -{ $see-also heap-empty? } ; +{ $description "Returns the number of key/value pairs in the heap." } ; + +HELP: heap-delete +{ $values { "heap" heap } { "key" object } { "value" object } } +{ $description "Output and remove the first element in the heap." } +{ $side-effects "heap" } ; diff --git a/core/heaps/heaps-tests.factor b/core/heaps/heaps-tests.factor old mode 100644 new mode 100755 index 9c7f1e9b2f..ce9a417476 --- a/core/heaps/heaps-tests.factor +++ b/core/heaps/heaps-tests.factor @@ -1,8 +1,8 @@ -! Copyright 2007 Ryan Murphy +! Copyright 2007, 2008 Ryan Murphy, Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: arrays kernel math namespaces tools.test -heaps heaps.private ; +heaps heaps.private math.parser random assocs sequences sorting ; IN: temporary [ heap-pop ] must-fail @@ -15,16 +15,8 @@ IN: temporary ! 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 t } { 3 t } T{ min-heap } heap-compare ] unit-test -{ f } [ { 5 t } { 3 t } T{ max-heap } heap-compare ] unit-test - -[ T{ min-heap T{ heap f V{ { -6 t } { -4 t } { 2 t } { 1 t } { 5 t } { 3 t } { 2 t } { 4 t } { 3 t } { 7 t } { 6 t } { 8 t } { 3 t } { 4 t } { 4 t } { 6 t } { 5 t } { 5 t } } } } ] -[ { { 3 t } { 5 t } { 4 t } { 6 t } { 7 t } { 8 t } { 2 t } { 4 t } { 3 t } { 5 t } { 6 t } { 1 t } { 3 t } { 2 t } { 4 t } { 5 t } { -6 t } { -4 t } } over heap-push-all ] unit-test - -[ T{ min-heap T{ heap f V{ { 5 t } { 6 t } { 6 t } { 7 t } { 8 t } } } } ] [ - { { 3 t } { 5 t } { 4 t } { 6 t } { 5 t } { 7 t } { 6 t } { 8 t } } over heap-push-all - 3 [ dup heap-pop* ] times -] unit-test +{ t } [ t 5 t 3 T{ min-heap } heap-compare ] unit-test +{ f } [ t 5 t 3 T{ max-heap } heap-compare ] unit-test [ t 2 ] [ t 300 pick heap-push t 200 pick heap-push t 400 pick heap-push t 3 pick heap-push t 2 pick heap-push heap-pop ] unit-test @@ -32,5 +24,51 @@ IN: temporary [ t 400 ] [ t 300 pick heap-push t 200 pick heap-push t 400 pick heap-push t 3 pick heap-push t 2 pick heap-push t 1 pick heap-push heap-pop ] unit-test -[ 0 ] [ heap-length ] unit-test -[ 1 ] [ t 1 pick heap-push heap-length ] unit-test +[ 0 ] [ heap-size ] unit-test +[ 1 ] [ t 1 pick heap-push heap-size ] unit-test + +: heap-sort ( alist -- keys ) + [ heap-push-all ] keep heap-pop-all ; + +: random-alist ( n -- alist ) + [ + [ + (random) dup number>string swap set + ] times + ] H{ } make-assoc ; + +: test-heap-sort ( n -- ? ) + random-alist dup >alist sort-keys swap heap-sort = ; + +14 [ + [ t ] swap [ 2^ test-heap-sort ] curry unit-test +] each + +: test-entry-indices ( n -- ? ) + random-alist + [ heap-push-all ] keep + heap-data dup length swap [ entry-index ] map sequence= ; + +14 [ + [ t ] swap [ 2^ test-entry-indices ] curry unit-test +] each + +: delete-random ( seq -- elt ) + dup length random dup pick nth >r swap delete-nth r> ; + +: sort-entries ( entries -- entries' ) + [ [ entry-key ] compare ] sort ; + +: delete-test ( n -- ? ) + [ + random-alist + [ heap-push-all ] keep + dup heap-data clone swap + ] keep 3 /i [ 2dup >r delete-random r> heap-delete ] times + heap-data + [ [ entry-key ] map ] 2apply + [ natural-sort ] 2apply ; + +11 [ + [ t ] swap [ 2^ delete-test sequence= ] curry unit-test +] each diff --git a/core/heaps/heaps.factor b/core/heaps/heaps.factor old mode 100644 new mode 100755 index 870346995c..64571b6990 --- a/core/heaps/heaps.factor +++ b/core/heaps/heaps.factor @@ -1,30 +1,30 @@ -! Copyright (C) 2007 Ryan Murphy, Doug Coleman. +! Copyright (C) 2007, 2008 Ryan Murphy, Doug Coleman, +! Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel math sequences arrays assocs ; +USING: kernel math sequences arrays assocs sequences.private +growable ; IN: heaps MIXIN: priority-queue -GENERIC: heap-push ( value key heap -- ) +GENERIC: heap-push* ( value key heap -- entry ) GENERIC: heap-peek ( heap -- value key ) GENERIC: heap-pop* ( heap -- ) GENERIC: heap-pop ( heap -- value key ) -GENERIC: heap-delete ( key heap -- ) -GENERIC: heap-delete* ( key heap -- old ? ) +GENERIC: heap-delete ( entry -- ) GENERIC: heap-empty? ( heap -- ? ) GENERIC: heap-size ( heap -- n ) ( class -- heap ) - >r V{ } clone heap construct-boa r> - construct-delegate ; inline + >r V{ } clone r> construct-delegate ; inline TUPLE: entry value key index ; -: f entry construct-boa ; +: ( value key -- entry ) f entry construct-boa ; PRIVATE> @@ -47,44 +47,48 @@ M: priority-queue heap-size ( heap -- n ) r up r> data-nth ; inline -: left-value ( n heap -- obj ) +: left-value ( n heap -- entry ) >r left r> data-nth ; inline -: right-value ( n heap -- obj ) +: right-value ( n heap -- entry ) >r right r> data-nth ; inline -: data-push ( obj heap -- ) - heap-data push ; inline +: data-set-nth ( entry n heap -- ) + >r [ swap set-entry-index ] 2keep r> + heap-data set-nth-unsafe ; -: data-pop ( heap -- obj ) +: data-push ( entry heap -- n ) + dup heap-size [ + swap 2dup heap-data ensure 2drop data-set-nth + ] keep ; inline + +: data-pop ( heap -- entry ) heap-data pop ; inline -: data-pop* ( heap -- obj ) +: data-pop* ( heap -- ) heap-data pop* ; inline -: data-peek ( heap -- obj ) +: data-peek ( heap -- entry ) heap-data peek ; inline -: data-first ( heap -- obj ) +: data-first ( heap -- entry ) heap-data first ; inline -: data-set-first ( obj heap -- ) - heap-data set-first ; inline - : data-exchange ( m n heap -- ) - heap-data exchange ; inline + [ tuck data-nth >r data-nth r> ] 3keep + tuck >r >r data-set-nth r> r> data-set-nth ; inline GENERIC: heap-compare ( pair1 pair2 heap -- ? ) @@ -103,18 +107,23 @@ M: max-heap heap-compare (heap-compare) < ; : right-bounds-check? ( m heap -- ? ) >r right r> heap-bounds-check? ; inline -: up-heap-continue? ( m up[m] heap -- ? ) +: continue? ( m up[m] heap -- ? ) [ data-nth swap ] keep [ data-nth ] keep heap-compare ; inline -: up-heap ( n heap -- ) +DEFER: up-heap + +: (up-heap) ( n heap -- ) >r dup up r> - 3dup up-heap-continue? [ + 3dup continue? [ [ data-exchange ] 2keep up-heap ] [ - 2drop + 3drop ] if ; +: up-heap ( n heap -- ) + over 0 > [ (up-heap) ] [ 2drop ] if ; + : (child) ( m heap -- n ) 2dup right-value >r 2dup left-value r> @@ -122,7 +131,8 @@ M: max-heap heap-compare (heap-compare) < ; [ right ] [ left ] if ; : child ( m heap -- n ) - 2dup right-bounds-check? [ drop left ] [ (child) ] if ; + 2dup right-bounds-check? + [ drop left ] [ (child) ] if ; : swap-down ( m heap -- ) [ child ] 2keep data-exchange ; @@ -130,11 +140,11 @@ M: max-heap heap-compare (heap-compare) < ; DEFER: down-heap : (down-heap) ( m heap -- ) - 2dup [ data-nth ] 2keep child pick - dupd [ data-nth swapd ] keep heap-compare [ - -rot [ swap-down ] keep down-heap - ] [ + [ child ] 2keep swapd + 3dup continue? [ 3drop + ] [ + [ data-exchange ] 2keep down-heap ] if ; : down-heap ( m heap -- ) @@ -142,23 +152,37 @@ DEFER: down-heap PRIVATE> -M: priority-queue heap-push ( value key heap -- ) - [ >r r> data-push ] keep up-heap ; +M: priority-queue heap-push* ( value key heap -- entry ) + >r dup r> [ data-push ] keep up-heap ; + +: heap-push ( value key heap -- ) heap-push* drop ; : heap-push-all ( assoc heap -- ) [ swapd heap-push ] curry assoc-each ; -M: priority-queue heap-peek ( heap -- value key ) - data-first { entry-value entry-key } get-slots ; +: >entry< ( entry -- key value ) + { entry-value entry-key } get-slots ; -M: priority-queue heap-pop* ( heap -- ) - dup heap-size 1 > [ - [ heap-pop ] keep - [ set-data-first ] keep - 0 swap down-heap +M: priority-queue heap-peek ( heap -- value key ) + data-first >entry< ; + +M: priority-queue heap-delete ( entry heap -- ) + >r entry-index r> + 2dup heap-size 1- = [ + nip data-pop* ] [ - data-pop* + [ nip data-pop ] 2keep + [ data-set-nth ] 2keep + down-heap ] if ; +M: priority-queue heap-pop* ( heap -- ) + dup data-first swap heap-delete ; + M: priority-queue heap-pop ( heap -- value key ) - dup heap-peek rot heap-pop* ; + dup data-first [ swap heap-delete ] keep >entry< ; + +: heap-pop-all ( heap -- alist ) + [ dup heap-empty? not ] + [ dup heap-pop swap 2array ] + [ ] unfold nip ;