Clean up heaps and add heap-push*, heap-delete words
Slava Pestov
parent
2535436f19
commit
748c2b4b33
|
|
@ -11,9 +11,9 @@ $nl
|
|||
{ $subsection min-heap? }
|
||||
{ $subsection <min-heap> }
|
||||
"Max-heaps sort their elements so that the maximum element is first:"
|
||||
{ $subsection min-heap }
|
||||
{ $subsection min-heap? }
|
||||
{ $subsection <min-heap> }
|
||||
{ $subsection max-heap }
|
||||
{ $subsection max-heap? }
|
||||
{ $subsection <max-heap> }
|
||||
"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: <min-heap>
|
||||
{ $values { "min-heap" min-heap } }
|
||||
{ $description "Create a new " { $link min-heap } "." }
|
||||
{ $see-also <max-heap> } ;
|
||||
{ $description "Create a new " { $link min-heap } "." } ;
|
||||
|
||||
HELP: <max-heap>
|
||||
{ $values { "max-heap" max-heap } }
|
||||
{ $description "Create a new " { $link max-heap } "." }
|
||||
{ $see-also <min-heap> } ;
|
||||
{ $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" } ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
[ <min-heap> 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 } } } } ]
|
||||
[ <min-heap> { { 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 } } } } ] [
|
||||
<min-heap> { { 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 <entry> t 3 <entry> T{ min-heap } heap-compare ] unit-test
|
||||
{ f } [ t 5 <entry> t 3 <entry> T{ max-heap } heap-compare ] unit-test
|
||||
|
||||
[ t 2 ] [ <min-heap> 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 ] [ <max-heap> 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 ] [ <max-heap> heap-length ] unit-test
|
||||
[ 1 ] [ <max-heap> t 1 pick heap-push heap-length ] unit-test
|
||||
[ 0 ] [ <max-heap> heap-size ] unit-test
|
||||
[ 1 ] [ <max-heap> t 1 pick heap-push heap-size ] unit-test
|
||||
|
||||
: heap-sort ( alist -- keys )
|
||||
<min-heap> [ 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
|
||||
<min-heap> [ 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
|
||||
<min-heap> [ 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
|
||||
|
|
|
|||
|
|
@ -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 )
|
||||
|
||||
<PRIVATE
|
||||
|
||||
TUPLE: heap data ;
|
||||
: heap-data delegate ; inline
|
||||
|
||||
: <heap> ( class -- heap )
|
||||
>r V{ } clone heap construct-boa r>
|
||||
construct-delegate ; inline
|
||||
>r V{ } clone r> construct-delegate ; inline
|
||||
|
||||
TUPLE: entry value key index ;
|
||||
|
||||
: <entry> f entry construct-boa ;
|
||||
: <entry> ( value key -- entry ) f entry construct-boa ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
|
|
@ -47,44 +47,48 @@ M: priority-queue heap-size ( heap -- n )
|
|||
|
||||
<PRIVATE
|
||||
|
||||
: left ( n -- m ) 1 shift 1+ ; inline
|
||||
: left ( n -- m ) 1 shift 1 + ; inline
|
||||
|
||||
: right ( n -- m ) 1 shift 2 + ; inline
|
||||
|
||||
: up ( n -- m ) 1- 2/ ; inline
|
||||
|
||||
: data-nth ( n heap -- obj )
|
||||
heap-data nth ; inline
|
||||
: data-nth ( n heap -- entry )
|
||||
heap-data nth-unsafe ; inline
|
||||
|
||||
: up-value ( n heap -- obj )
|
||||
: up-value ( n heap -- entry )
|
||||
>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 <heap-entry> r> data-push ] keep up-heap ;
|
||||
M: priority-queue heap-push* ( value key heap -- entry )
|
||||
>r <entry> 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 ;
|
||||
|
|
|
|||
Loading…
Reference in New Issue