Remove old heap from unmaintained
Doug Coleman
parent
a86a138b08
commit
3c28446ac3
|
|
@ -1,74 +0,0 @@
|
||||||
! Binary Min Heap
|
|
||||||
! Copyright 2007 Ryan Murphy
|
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
|
||||||
|
|
||||||
USING: kernel math sequences ;
|
|
||||||
IN: heap
|
|
||||||
|
|
||||||
: [comp] ( elt elt -- ? ) <=> 0 > ;
|
|
||||||
|
|
||||||
: <heap> ( -- heap ) V{ } clone ;
|
|
||||||
|
|
||||||
: left ( index -- index ) ! left child
|
|
||||||
2 * 1 + ;
|
|
||||||
|
|
||||||
: leftv ( heap index -- value )
|
|
||||||
left swap nth ;
|
|
||||||
|
|
||||||
: right ( index -- index ) ! right child
|
|
||||||
2 * 2 + ;
|
|
||||||
|
|
||||||
: rightv ( heap index -- value )
|
|
||||||
right swap nth ;
|
|
||||||
|
|
||||||
: l-oob ( i heap -- ? ) swap left swap length >= ;
|
|
||||||
: r-oob ( i heap -- ? ) swap right swap length >= ;
|
|
||||||
|
|
||||||
: up ( index -- index ) ! parent node
|
|
||||||
1 - 2 /i ;
|
|
||||||
|
|
||||||
: upv ( heap index -- value ) ! parent's value
|
|
||||||
up swap nth ;
|
|
||||||
|
|
||||||
: lasti ( seq -- index ) length 1 - ;
|
|
||||||
|
|
||||||
: swapup ( heap index -- ) dup up rot exchange ;
|
|
||||||
|
|
||||||
: (farchild) ( heap index -- index ) tuck 2dup leftv -rot rightv [comp] [ right ] [ left ] if ;
|
|
||||||
|
|
||||||
: farchild ( heap index -- index ) dup right pick length >= [ nip left ] [ (farchild) ] if ;
|
|
||||||
|
|
||||||
: farchildv ( heap index -- value ) dupd farchild swap nth ;
|
|
||||||
|
|
||||||
: swapdown ( heap index -- ) 2dup farchild rot exchange ;
|
|
||||||
|
|
||||||
: upheap ( heap -- )
|
|
||||||
dup dup lasti upv over peek [comp]
|
|
||||||
[ dup lasti 2dup swapup up 1 + head-slice upheap ] [ drop ] if ;
|
|
||||||
|
|
||||||
: add ( elt heap -- )
|
|
||||||
tuck push upheap ;
|
|
||||||
|
|
||||||
: add-many ( seq heap -- )
|
|
||||||
swap [ swap add ] each-with ;
|
|
||||||
|
|
||||||
DEFER: (downheap)
|
|
||||||
|
|
||||||
: (downheap2) ( i heap -- )
|
|
||||||
2dup nth -rot
|
|
||||||
2dup swap farchild dup pick nth 2swap
|
|
||||||
>r >r
|
|
||||||
swapd [comp]
|
|
||||||
[ r> r> tuck swap swapdown (downheap) ] [ drop r> r> 2drop ] if ;
|
|
||||||
|
|
||||||
: (downheap) ( i heap -- )
|
|
||||||
over left over length >= [ 2drop ] [ (downheap2) ] if ;
|
|
||||||
|
|
||||||
: downheap ( heap -- )
|
|
||||||
0 swap (downheap) ;
|
|
||||||
|
|
||||||
: bump ( heap -- )
|
|
||||||
dup peek 0 pick set-nth dup pop* downheap ;
|
|
||||||
|
|
||||||
: gbump ( heap -- first )
|
|
||||||
dup first swap bump ;
|
|
||||||
|
|
@ -1,76 +0,0 @@
|
||||||
! Binary Min Heap
|
|
||||||
! Copyright 2007 Ryan Murphy
|
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
|
||||||
|
|
||||||
USING: help heap sequences ;
|
|
||||||
|
|
||||||
ARTICLE: { "heap" "heap" } "Binary Min Heap"
|
|
||||||
"A vector-based implementation of a binary min heap. Elements are simply stored in a vector, so use " { $link first } " to access the root of the heap."
|
|
||||||
{ $subsection <heap> }
|
|
||||||
{ $subsection add }
|
|
||||||
{ $subsection add-many }
|
|
||||||
{ $subsection bump }
|
|
||||||
{ $subsection gbump }
|
|
||||||
{ $subsection print-heap }
|
|
||||||
;
|
|
||||||
|
|
||||||
HELP: <heap>
|
|
||||||
"Creates a new heap with nothing on it." ;
|
|
||||||
|
|
||||||
HELP: add
|
|
||||||
"Adds 1 element to the heap."
|
|
||||||
{ $examples
|
|
||||||
{ $code
|
|
||||||
"USE: heap"
|
|
||||||
"<heap> 3 over add 4 over add 5 over add"
|
|
||||||
"print-heap"
|
|
||||||
}
|
|
||||||
}
|
|
||||||
;
|
|
||||||
|
|
||||||
HELP: add-many
|
|
||||||
"For each element in the sequence, add it to the heap."
|
|
||||||
{ $examples
|
|
||||||
{ $code
|
|
||||||
"USE: heap"
|
|
||||||
"<heap> { 7 6 5 4 3 2 1 } over add-many"
|
|
||||||
"print-heap"
|
|
||||||
}
|
|
||||||
}
|
|
||||||
;
|
|
||||||
|
|
||||||
HELP: bump
|
|
||||||
"\"Bumps\" the root element off of the heap, rearranging the remaining elements so that the heap remains valid."
|
|
||||||
{ $examples
|
|
||||||
{ $code
|
|
||||||
"USE: heap"
|
|
||||||
"<heap> { 7 6 5 4 3 2 1 } over add-many"
|
|
||||||
"dup print-heap"
|
|
||||||
"dup bump \"(bump)\" print dup print-heap"
|
|
||||||
"dup bump \"(bump)\" print dup print-heap"
|
|
||||||
"dup bump \"(bump)\" print dup print-heap"
|
|
||||||
}
|
|
||||||
}
|
|
||||||
;
|
|
||||||
|
|
||||||
HELP: gbump
|
|
||||||
"(\"Get-bump\") Does a " { $link bump } ", but leaves the bumped element on the stack instead of discarding it."
|
|
||||||
{ $examples
|
|
||||||
{ $code
|
|
||||||
"USE: heap"
|
|
||||||
"<heap> { 7 6 5 4 3 2 1 } over add-many"
|
|
||||||
"dup gbump"
|
|
||||||
}
|
|
||||||
}
|
|
||||||
;
|
|
||||||
|
|
||||||
HELP: print-heap
|
|
||||||
"Prints the heap in tree form."
|
|
||||||
{ $examples
|
|
||||||
{ $code
|
|
||||||
"USE: heap"
|
|
||||||
"<heap> { 7 6 5 4 3 2 1 } over add-many"
|
|
||||||
"print-heap"
|
|
||||||
}
|
|
||||||
}
|
|
||||||
;
|
|
||||||
|
|
@ -1,100 +0,0 @@
|
||||||
: test-agg2 ( -- )
|
|
||||||
{
|
|
||||||
} >vector
|
|
||||||
{
|
|
||||||
"bbbbbbb"
|
|
||||||
"bbbbbbb"
|
|
||||||
} >vector
|
|
||||||
aggregate2 [ print ] each "" print
|
|
||||||
|
|
||||||
{
|
|
||||||
"aa"
|
|
||||||
"aa"
|
|
||||||
} >vector
|
|
||||||
{
|
|
||||||
} >vector
|
|
||||||
aggregate2 [ print ] each "" print
|
|
||||||
|
|
||||||
{
|
|
||||||
} >vector
|
|
||||||
{
|
|
||||||
} >vector
|
|
||||||
aggregate2 [ print ] each "" print
|
|
||||||
|
|
||||||
{
|
|
||||||
"aaaaaaa"
|
|
||||||
"aaaaaaa"
|
|
||||||
"aaaaaaa"
|
|
||||||
"aaaaaaa"
|
|
||||||
"aaaaaaa"
|
|
||||||
"aaaaaaa"
|
|
||||||
} >vector
|
|
||||||
{
|
|
||||||
"bbbb"
|
|
||||||
"bbbb"
|
|
||||||
"bbbb"
|
|
||||||
} >vector
|
|
||||||
aggregate2 [ print ] each "" print
|
|
||||||
|
|
||||||
{
|
|
||||||
"aaaa"
|
|
||||||
"aaaa"
|
|
||||||
"aaaa"
|
|
||||||
} >vector
|
|
||||||
{
|
|
||||||
"bbbbbbb"
|
|
||||||
"bbbbbbb"
|
|
||||||
"bbbbbbb"
|
|
||||||
"bbbbbbb"
|
|
||||||
"bbbbbbb"
|
|
||||||
"bbbbbbb"
|
|
||||||
"bbbbbbb"
|
|
||||||
"bbbbbbb"
|
|
||||||
} >vector
|
|
||||||
aggregate2 [ print ] each "" print
|
|
||||||
;
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
: test-agg ( -- )
|
|
||||||
{
|
|
||||||
"....5.."
|
|
||||||
"...|.|."
|
|
||||||
"..7...9"
|
|
||||||
".|....."
|
|
||||||
"8......"
|
|
||||||
} >vector
|
|
||||||
{
|
|
||||||
"..3.."
|
|
||||||
".|.|."
|
|
||||||
"4...4"
|
|
||||||
} >vector
|
|
||||||
{
|
|
||||||
".2."
|
|
||||||
"|.|"
|
|
||||||
} >vector
|
|
||||||
aggregate3 [ print ] each "" print
|
|
||||||
|
|
||||||
{
|
|
||||||
"....5.."
|
|
||||||
"...|.|."
|
|
||||||
"..7...9"
|
|
||||||
".|....."
|
|
||||||
"8......"
|
|
||||||
} >vector
|
|
||||||
{
|
|
||||||
"......3...."
|
|
||||||
".....|.|..."
|
|
||||||
"....4...4.."
|
|
||||||
"...|.|....."
|
|
||||||
"..5...6...."
|
|
||||||
".|........."
|
|
||||||
"6.........."
|
|
||||||
} >vector
|
|
||||||
{
|
|
||||||
".2."
|
|
||||||
"|.|"
|
|
||||||
} >vector
|
|
||||||
aggregate3 [ print ] each "" print
|
|
||||||
;
|
|
||||||
|
|
@ -1,16 +0,0 @@
|
||||||
! Binary Min Heap
|
|
||||||
! Copyright 2007 Ryan Murphy
|
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
|
||||||
|
|
||||||
PROVIDE: libs/heap
|
|
||||||
|
|
||||||
{ +files+ {
|
|
||||||
"heap.factor"
|
|
||||||
"print.factor"
|
|
||||||
|
|
||||||
"heap.facts"
|
|
||||||
} }
|
|
||||||
|
|
||||||
{ +tests+ {
|
|
||||||
"tests.factor"
|
|
||||||
} } ;
|
|
||||||
|
|
@ -1,51 +0,0 @@
|
||||||
! Binary Min Heap
|
|
||||||
! Copyright 2007 Ryan Murphy
|
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
|
||||||
|
|
||||||
USING: namespaces kernel math sequences prettyprint io ;
|
|
||||||
IN: heap
|
|
||||||
|
|
||||||
: spaces ( n -- str )
|
|
||||||
[ [ " " % ] times ] "" make ;
|
|
||||||
|
|
||||||
: prepend-s ( v1 n -- v1' )
|
|
||||||
spaces swap [ append ] map-with ;
|
|
||||||
|
|
||||||
: append-s ( v1 v2 -- v1' )
|
|
||||||
spaces swap [ swap append ] map-with ;
|
|
||||||
|
|
||||||
: pad-r ( lv rv -- rv' )
|
|
||||||
dup first length spaces pick length pick length -
|
|
||||||
[ [ dup , ] times ] V{ } make
|
|
||||||
nip append nip ;
|
|
||||||
|
|
||||||
: pad-l ( lv rv -- lv' )
|
|
||||||
swap pad-r ;
|
|
||||||
|
|
||||||
: (aggregate2) ( lv rv -- v )
|
|
||||||
over length over length >= [ dupd pad-r ] [ tuck pad-l swap ] if
|
|
||||||
[ append ] 2map ;
|
|
||||||
|
|
||||||
: aggregate2 ( lv rv -- v )
|
|
||||||
dup empty? [ drop ] [ over empty? [ nip ] [ (aggregate2) ] if ] if ;
|
|
||||||
|
|
||||||
: (agg3len) ( v -- len )
|
|
||||||
dup empty? [ drop 0 ] [ first length ] if ;
|
|
||||||
|
|
||||||
: aggregate3 ( lv rv pv -- v )
|
|
||||||
dup (agg3len) -roll
|
|
||||||
pick (agg3len) prepend-s
|
|
||||||
over (agg3len) append-s
|
|
||||||
-roll -rot swap append-s
|
|
||||||
swap aggregate2 append ;
|
|
||||||
|
|
||||||
: output-node ( elt -- str ) [ [ pprint ] string-out , ] V{ } make ;
|
|
||||||
|
|
||||||
: (print-heap) ( i heap -- vector )
|
|
||||||
2dup l-oob [ V{ } clone ] [ over left over (print-heap) ] if -rot
|
|
||||||
2dup r-oob [ V{ } clone ] [ over right over (print-heap) ] if -rot
|
|
||||||
V{ } clone pick pick nth output-node append
|
|
||||||
-rot 2drop aggregate3 ;
|
|
||||||
|
|
||||||
: print-heap ( heap -- )
|
|
||||||
dup empty? [ drop ] [ 0 swap (print-heap) [ print ] each ] if ;
|
|
||||||
|
|
@ -1,35 +0,0 @@
|
||||||
! Binary Min Heap
|
|
||||||
! Copyright 2007 Ryan Murphy
|
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
|
||||||
|
|
||||||
USING: heap test kernel ;
|
|
||||||
|
|
||||||
{ 1 2 3 4 5 6 } [ 0 left 0 right 1 left 1 right 2 left 2 right ] unit-test
|
|
||||||
{ t } [ 5 3 [comp] ] unit-test
|
|
||||||
{ V{ } } [ <heap> ] unit-test
|
|
||||||
|
|
||||||
{ V{ -6 -4 2 1 5 3 2 4 3 7 6 8 3 4 4 6 5 5 } } [ <heap> { 3 5 4 6 7 8 2 4 3 5 6 1 3 2 4 5 -6 -4 } over add-many ] unit-test
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
{ V{ "hire" "hose" } } [ V{ "hi" "ho" } V{ "re" "se" } aggregate2 ] unit-test
|
|
||||||
{ V{ "hire" "hose" " it" } } [ V{ "hi" "ho" } V{ "re" "se" "it" } aggregate2 ] unit-test
|
|
||||||
{ V{ "tracks" "snacks" "crack " } } [ V{ "track" "snack" "crack" } V{ "s" "s" } aggregate2 ] unit-test
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
{ V{ " top " "left right" } } [ V{ "left" } V{ "right" } V{ "top" } aggregate3 ] unit-test
|
|
||||||
|
|
||||||
{ V{ " top "
|
|
||||||
" dog "
|
|
||||||
"left right"
|
|
||||||
"over on "
|
|
||||||
" man " } } [ V{ "left" "over" } V{ "right" "on " "man " } V{ "top" "dog" } aggregate3 ] unit-test
|
|
||||||
|
|
||||||
{ V{ " -6 "
|
|
||||||
" -4 2 "
|
|
||||||
" 1 5 3 2 "
|
|
||||||
" 4 3 7 6 8 3 4 4"
|
|
||||||
"6 5 5 " } } [ 0 <heap> { 3 5 4 6 7 8 2 4 3 5 6 1 3 2 4 5 -6 -4 } over add-many (print-heap) ] unit-test
|
|
||||||
|
|
||||||
{ V{ 5 6 6 7 8 } } [ <heap> { 3 5 4 6 5 7 6 8 } over add-many dup bump dup bump dup bump ] unit-test
|
|
||||||
Loading…
Reference in New Issue