Doug Coleman
parent
c3efd8a60d
commit
f301d36535
|
|
@ -1 +1,2 @@
|
|||
Mackenzie Straight
|
||||
Doug Coleman
|
||||
|
|
@ -0,0 +1,74 @@
|
|||
USING: help.markup help.syntax kernel ;
|
||||
IN: dlists
|
||||
|
||||
ARTICLE: "dlists" "Doubly-linked lists"
|
||||
"A doubly-linked list is a list of nodes. Each node has a link to the previous and next nodes, and a slot to store an object. Objects can be pushed and popped from the front and back of the list. The linked list keeps track of its length, so finding the length is O(1)."
|
||||
;
|
||||
|
||||
HELP: dlist-empty?
|
||||
{ $values { "dlist" { $link dlist } } { "?" "a boolean" } }
|
||||
{ $description "Returns true if a " { $link dlist } " is empty." }
|
||||
{ $notes "This operation is O(1)." } ;
|
||||
|
||||
HELP: push-front
|
||||
{ $values { "obj" "an object" } { "dlist" dlist } }
|
||||
{ $description "Push the object onto the front of the " { $link dlist } "." }
|
||||
{ $notes "This operation is O(1)." }
|
||||
{ $see-also push-back pop-front pop-front* pop-back pop-back* } ;
|
||||
|
||||
HELP: push-back
|
||||
{ $values { "obj" "an object" } { "dlist" dlist } }
|
||||
{ $description "Push the object onto the back of the " { $link dlist } "." }
|
||||
{ $notes "This operation is O(1)." }
|
||||
{ $see-also push-front pop-front pop-front* pop-back pop-back* } ;
|
||||
|
||||
HELP: pop-front
|
||||
{ $values { "dlist" dlist } { "obj" "an object" } }
|
||||
{ $description "Pop the object off the front of the " { $link dlist } " and return the object." }
|
||||
{ $notes "This operation is O(1)." }
|
||||
{ $see-also push-front push-back pop-front* pop-back pop-back* } ;
|
||||
|
||||
HELP: pop-front*
|
||||
{ $values { "dlist" dlist } }
|
||||
{ $description "Pop the object off the front of the " { $link dlist } "." }
|
||||
{ $notes "This operation is O(1)." }
|
||||
{ $see-also push-front push-back pop-front pop-back pop-back* } ;
|
||||
|
||||
HELP: pop-back
|
||||
{ $values { "dlist" dlist } { "obj" "an object" } }
|
||||
{ $description "Pop the object off the back of the " { $link dlist } " and return the object." }
|
||||
{ $notes "This operation is O(1)." }
|
||||
{ $see-also push-front push-back pop-front pop-front* pop-back* } ;
|
||||
|
||||
HELP: pop-back*
|
||||
{ $values { "dlist" dlist } }
|
||||
{ $description "Pop the object off the back of the " { $link dlist } "." }
|
||||
{ $notes "This operation is O(1)." }
|
||||
{ $see-also push-front push-back pop-front pop-front* pop-back } ;
|
||||
|
||||
HELP: dlist-find
|
||||
{ $values { "quot" "a quotation" } { "dlist" { $link dlist } } { "obj/f" "an object or " { $link f } } { "?" "a boolean" } }
|
||||
{ $description "Applies the quotation to each element of the " { $link dlist } " in turn, until it outputs a true value or the end of the " { $link dlist } " is reached. Outputs either the object it found or " { $link f } ", and a boolean which is true if an object is found." }
|
||||
{ $notes "Returns a boolean to allow dlists to store " { $link f } "."
|
||||
$nl
|
||||
"This operation is O(n)."
|
||||
} ;
|
||||
|
||||
HELP: dlist-contains?
|
||||
{ $values { "quot" "a quotation" } { "dlist" { $link dlist } } { "?" "a boolean" } }
|
||||
{ $description "Just like " { $link dlist-find } " except it doesn't return the object." }
|
||||
{ $notes "This operation is O(n)." } ;
|
||||
|
||||
HELP: delete-node*
|
||||
{ $values { "quot" "a quotation" } { "dlist" { $link dlist } } { "obj/f" "an object or " { $link f } } { "?" "a boolean" } }
|
||||
{ $description "Calls " { $link dlist-find } " on the " { $link dlist } " and deletes the node returned, if any. Returns the value of the deleted node and a boolean to allow the deleted value to distinguished from " { $link f } ", for nothing deleted." }
|
||||
{ $notes "This operation is O(n)." } ;
|
||||
|
||||
HELP: delete-node
|
||||
{ $values { "quot" "a quotation" } { "dlist" { $link dlist } } { "obj/f" "an object or " { $link f } } }
|
||||
{ $description "Like " { $link delete-node* } " but cannot distinguish from deleting a node whose value is " { $link f } " or not deleting an element." }
|
||||
{ $notes "This operation is O(n)." } ;
|
||||
|
||||
HELP: dlist-each
|
||||
{ $values { "quot" "a quotation" } { "dlist" { $link dlist } } }
|
||||
{ $description "Iterate a " { $link dlist } ", calling quot on each element." } ;
|
||||
|
|
@ -0,0 +1,61 @@
|
|||
USING: dlists dlists.private kernel tools.test ;
|
||||
IN: temporary
|
||||
|
||||
[ t ] [ <dlist> dlist-empty? ] unit-test
|
||||
|
||||
[ T{ dlist f T{ dlist-node f 1 f f } T{ dlist-node f 1 f f } 1 } ]
|
||||
[ <dlist> 1 over push-front ] unit-test
|
||||
|
||||
! Make sure empty lists are empty
|
||||
[ t ] [ <dlist> dlist-empty? ] unit-test
|
||||
[ f ] [ <dlist> 1 over push-front dlist-empty? ] unit-test
|
||||
[ f ] [ <dlist> 1 over push-back dlist-empty? ] unit-test
|
||||
|
||||
[ 1 ] [ <dlist> 1 over push-front pop-front ] unit-test
|
||||
[ 1 ] [ <dlist> 1 over push-front pop-back ] unit-test
|
||||
[ 1 ] [ <dlist> 1 over push-back pop-front ] unit-test
|
||||
[ 1 ] [ <dlist> 1 over push-back pop-back ] unit-test
|
||||
[ T{ dlist f f f 0 } ] [ <dlist> 1 over push-front dup pop-front* ] unit-test
|
||||
[ T{ dlist f f f 0 } ] [ <dlist> 1 over push-front dup pop-back* ] unit-test
|
||||
[ T{ dlist f f f 0 } ] [ <dlist> 1 over push-back dup pop-front* ] unit-test
|
||||
[ T{ dlist f f f 0 } ] [ <dlist> 1 over push-back dup pop-back* ] unit-test
|
||||
|
||||
! Test the prev,next links for two nodes
|
||||
[ f ] [
|
||||
<dlist> 1 over push-back 2 over push-back
|
||||
dlist-front dlist-node-prev
|
||||
] unit-test
|
||||
|
||||
[ 2 ] [
|
||||
<dlist> 1 over push-back 2 over push-back
|
||||
dlist-front dlist-node-next dlist-node-obj
|
||||
] unit-test
|
||||
|
||||
[ 1 ] [
|
||||
<dlist> 1 over push-back 2 over push-back
|
||||
dlist-front dlist-node-next dlist-node-prev dlist-node-obj
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
<dlist> 1 over push-back 2 over push-back
|
||||
dlist-front dlist-node-next dlist-node-next
|
||||
] unit-test
|
||||
|
||||
[ f f ] [ <dlist> [ 1 = ] swap dlist-find ] unit-test
|
||||
[ 1 t ] [ <dlist> 1 over push-back [ 1 = ] swap dlist-find ] unit-test
|
||||
[ f f ] [ <dlist> 1 over push-back [ 2 = ] swap dlist-find ] unit-test
|
||||
[ f ] [ <dlist> 1 over push-back [ 2 = ] swap dlist-contains? ] unit-test
|
||||
[ t ] [ <dlist> 1 over push-back [ 1 = ] swap dlist-contains? ] unit-test
|
||||
|
||||
[ 1 ] [ <dlist> 1 over push-back [ 1 = ] swap delete-node ] unit-test
|
||||
[ t ] [ <dlist> 1 over push-back [ 1 = ] over delete-node drop dlist-empty? ] unit-test
|
||||
[ t ] [ <dlist> 1 over push-back [ 1 = ] over delete-node drop dlist-empty? ] unit-test
|
||||
[ 0 ] [ <dlist> 1 over push-back [ 1 = ] over delete-node drop dlist-length ] unit-test
|
||||
[ 1 ] [ <dlist> 1 over push-back 2 over push-back [ 1 = ] over delete-node drop dlist-length ] unit-test
|
||||
[ 2 ] [ <dlist> 1 over push-back 2 over push-back 3 over push-back [ 1 = ] over delete-node drop dlist-length ] unit-test
|
||||
[ 2 ] [ <dlist> 1 over push-back 2 over push-back 3 over push-back [ 2 = ] over delete-node drop dlist-length ] unit-test
|
||||
[ 2 ] [ <dlist> 1 over push-back 2 over push-back 3 over push-back [ 3 = ] over delete-node drop dlist-length ] unit-test
|
||||
|
||||
[ 0 ] [ <dlist> dlist-length ] unit-test
|
||||
[ 1 ] [ <dlist> 1 over push-front dlist-length ] unit-test
|
||||
[ 0 ] [ <dlist> 1 over push-front dup pop-front* dlist-length ] unit-test
|
||||
|
|
@ -0,0 +1,121 @@
|
|||
! Copyright (C) 2007 Mackenzie Straight, Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: combinators kernel math ;
|
||||
IN: dlists
|
||||
|
||||
TUPLE: dlist front back length ;
|
||||
: <dlist> ( -- obj )
|
||||
dlist construct-empty
|
||||
0 over set-dlist-length ;
|
||||
|
||||
<PRIVATE
|
||||
TUPLE: dlist-node obj prev next ;
|
||||
C: <dlist-node> dlist-node
|
||||
|
||||
: dlist-empty? ( dlist -- ? ) dlist-front not ;
|
||||
|
||||
: inc-length ( dlist -- )
|
||||
[ dlist-length 1+ ] keep set-dlist-length ; inline
|
||||
|
||||
: dec-length ( dlist -- )
|
||||
[ dlist-length 1- ] keep set-dlist-length ; inline
|
||||
|
||||
: set-prev-when ( dlist-node dlist-node/f -- )
|
||||
[ set-dlist-node-prev ] [ drop ] if* ;
|
||||
|
||||
: set-next-when ( dlist-node dlist-node/f -- )
|
||||
[ set-dlist-node-next ] [ drop ] if* ;
|
||||
|
||||
: set-next-prev ( dlist-node -- )
|
||||
dup dlist-node-next set-prev-when ;
|
||||
|
||||
: normalize-front ( dlist -- )
|
||||
dup dlist-back [ drop ] [ f swap set-dlist-front ] if ;
|
||||
|
||||
: normalize-back ( dlist -- )
|
||||
dup dlist-front [ drop ] [ f swap set-dlist-back ] if ;
|
||||
|
||||
: set-back-to-front ( dlist -- )
|
||||
dup dlist-back
|
||||
[ drop ] [ dup dlist-front swap set-dlist-back ] if ;
|
||||
|
||||
: set-front-to-back ( dlist -- )
|
||||
dup dlist-front
|
||||
[ drop ] [ dup dlist-back swap set-dlist-front ] if ;
|
||||
PRIVATE>
|
||||
|
||||
: push-front ( obj dlist -- )
|
||||
[ dlist-front f swap <dlist-node> dup set-next-prev ] keep
|
||||
[ set-dlist-front ] keep
|
||||
[ set-back-to-front ] keep
|
||||
inc-length ;
|
||||
|
||||
: push-back ( obj dlist -- )
|
||||
[ dlist-back f <dlist-node> ] keep
|
||||
[ dlist-back set-next-when ] 2keep
|
||||
[ set-dlist-back ] keep
|
||||
[ set-front-to-back ] keep
|
||||
inc-length ;
|
||||
|
||||
: pop-front ( dlist -- obj )
|
||||
dup dlist-front [
|
||||
dlist-node-next
|
||||
f over set-prev-when
|
||||
swap set-dlist-front
|
||||
] 2keep dlist-node-obj
|
||||
swap [ normalize-back ] keep dec-length ;
|
||||
|
||||
: pop-front* ( dlist -- ) pop-front drop ;
|
||||
|
||||
: pop-back ( dlist -- obj )
|
||||
[
|
||||
dlist-back dup dlist-node-prev f over set-next-when
|
||||
] keep
|
||||
[ set-dlist-back ] keep
|
||||
[ normalize-front ] keep
|
||||
dec-length
|
||||
dlist-node-obj ;
|
||||
|
||||
: pop-back* ( dlist -- ) pop-back drop ;
|
||||
|
||||
: (dlist-find-node) ( quot dlist-node -- node/f ? )
|
||||
dup dlist-node-obj pick dupd call [
|
||||
drop nip t
|
||||
] [
|
||||
drop dlist-node-next [ (dlist-find-node) ] [ drop f f ] if*
|
||||
] if ;
|
||||
|
||||
: dlist-find-node ( quot dlist -- node/f ? )
|
||||
dlist-front [ (dlist-find-node) ] [ drop f f ] if* ;
|
||||
|
||||
: dlist-find ( quot dlist -- obj/f ? )
|
||||
dlist-find-node dup [ >r dlist-node-obj r> ] when ;
|
||||
|
||||
: dlist-contains? ( quot dlist -- ? )
|
||||
dlist-find nip ;
|
||||
|
||||
: (delete-node) ( dlist dlist-node -- )
|
||||
{
|
||||
{ [ 2dup >r dlist-front r> = ] [ drop pop-front* ] }
|
||||
{ [ 2dup >r dlist-back r> = ] [ drop pop-back* ] }
|
||||
{ [ t ] [ dup dlist-node-prev swap dlist-node-next set-prev-when
|
||||
dec-length ] }
|
||||
} cond ;
|
||||
|
||||
: delete-node ( quot dlist -- obj/f )
|
||||
tuck dlist-find-node [
|
||||
[ (delete-node) ] keep [ dlist-node-obj ] [ f ] if*
|
||||
] [
|
||||
2drop f
|
||||
] if ;
|
||||
|
||||
: (dlist-each-node) ( quot dlist -- )
|
||||
over
|
||||
[ 2dup call >r dlist-node-next r> (dlist-each-node) ]
|
||||
[ 2drop ] if ;
|
||||
|
||||
: dlist-each-node ( quot dlist -- )
|
||||
>r dlist-front r> (dlist-each-node) ; inline
|
||||
|
||||
: dlist-each ( dlist quot -- )
|
||||
[ dlist-node-obj ] swap compose dlist-each-node ; inline
|
||||
|
|
@ -1,54 +0,0 @@
|
|||
IN: temporary
|
||||
USING: dlists kernel strings tools.test math ;
|
||||
|
||||
[ "junk" ] [
|
||||
<dlist>
|
||||
5 over dlist-push-end
|
||||
"junk" over dlist-push-end
|
||||
20 over dlist-push-end
|
||||
[ string? ] swap dlist-remove
|
||||
] unit-test
|
||||
|
||||
[ 5 20 ] [
|
||||
<dlist>
|
||||
5 over dlist-push-end
|
||||
"junk" over dlist-push-end
|
||||
20 over dlist-push-end
|
||||
[ string? ] over dlist-remove drop
|
||||
[ ] dlist-each
|
||||
] unit-test
|
||||
|
||||
[ "junk" ] [
|
||||
<dlist>
|
||||
5 over dlist-push-end
|
||||
"junk" over dlist-push-end
|
||||
20 over dlist-push-end
|
||||
[ integer? ] over dlist-remove drop
|
||||
[ integer? ] over dlist-remove drop
|
||||
[ ] dlist-each
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
<dlist>
|
||||
5 over dlist-push-end
|
||||
"junk" over dlist-push-end
|
||||
20 over dlist-push-end
|
||||
[ string? ] swap dlist-contains?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
<dlist>
|
||||
5 over dlist-push-end
|
||||
"junk" over dlist-push-end
|
||||
20 over dlist-push-end
|
||||
[ integer? ] swap dlist-contains?
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
<dlist>
|
||||
5 over dlist-push-end
|
||||
"junk" over dlist-push-end
|
||||
20 over dlist-push-end
|
||||
[ string? ] over dlist-remove drop
|
||||
[ string? ] swap dlist-contains?
|
||||
] unit-test
|
||||
|
|
@ -1,100 +0,0 @@
|
|||
! Copyright (C) 2005 Mackenzie Straight.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
IN: dlists
|
||||
USING: kernel math ;
|
||||
|
||||
! Double-linked lists.
|
||||
|
||||
TUPLE: dlist first last ;
|
||||
|
||||
: <dlist> dlist construct-empty ;
|
||||
|
||||
TUPLE: dlist-node data prev next ;
|
||||
|
||||
C: <dlist-node> dlist-node
|
||||
|
||||
: dlist-push-end ( data dlist -- )
|
||||
[ dlist-last f <dlist-node> ] keep
|
||||
[ dlist-last [ dupd set-dlist-node-next ] when* ] keep
|
||||
2dup set-dlist-last
|
||||
dup dlist-first [ 2drop ] [ set-dlist-first ] if ;
|
||||
|
||||
: dlist-empty? ( dlist -- ? )
|
||||
dlist-first f = ;
|
||||
|
||||
: (unlink-prev) ( dlist dnode -- )
|
||||
dup dlist-node-prev [
|
||||
dupd swap dlist-node-next swap set-dlist-node-next
|
||||
] when*
|
||||
2dup swap dlist-first eq? [
|
||||
dlist-node-next swap set-dlist-first
|
||||
] [ 2drop ] if ;
|
||||
|
||||
: (unlink-next) ( dlist dnode -- )
|
||||
dup dlist-node-next [
|
||||
dupd swap dlist-node-prev swap set-dlist-node-prev
|
||||
] when*
|
||||
2dup swap dlist-last eq? [
|
||||
dlist-node-prev swap set-dlist-last
|
||||
] [ 2drop ] if ;
|
||||
|
||||
: (dlist-unlink) ( dlist dnode -- )
|
||||
[ (unlink-prev) ] 2keep (unlink-next) ;
|
||||
|
||||
: (dlist-pop-front) ( dlist -- data )
|
||||
[ dlist-first dlist-node-data ] keep dup dlist-first (dlist-unlink) ;
|
||||
|
||||
: dlist-pop-front ( dlist -- data )
|
||||
dup dlist-empty? [ drop f ] [ (dlist-pop-front) ] if ;
|
||||
|
||||
: (dlist-remove) ( dlist quot dnode -- obj/f )
|
||||
[
|
||||
[ dlist-node-data swap call ] 2keep rot [
|
||||
swapd [ (dlist-unlink) ] keep dlist-node-data nip
|
||||
] [
|
||||
dlist-node-next (dlist-remove)
|
||||
] if
|
||||
] [
|
||||
2drop f
|
||||
] if* ; inline
|
||||
|
||||
: dlist-remove ( quot dlist -- obj/f )
|
||||
#! Return first item in the dlist that when passed to the
|
||||
#! predicate quotation, true is left on the stack. The
|
||||
#! item is removed from the dlist. The quotation
|
||||
#! must have stack effect ( obj -- bool ).
|
||||
#! TODO: needs a better name.
|
||||
dup dlist-first swapd (dlist-remove) ; inline
|
||||
|
||||
: (dlist-contains?) ( pred dnode -- bool )
|
||||
[
|
||||
[ dlist-node-data swap call ] 2keep rot [
|
||||
2drop t
|
||||
] [
|
||||
dlist-node-next (dlist-contains?)
|
||||
] if
|
||||
] [
|
||||
drop f
|
||||
] if* ; inline
|
||||
|
||||
: dlist-contains? ( quot dlist -- obj/f )
|
||||
#! Return true if any item in the dlist that when passed to the
|
||||
#! predicate quotation, true is left on the stack.
|
||||
#! The 'pred' quotation must have stack effect ( obj -- bool ).
|
||||
#! TODO: needs a better name.
|
||||
dlist-first (dlist-contains?) ; inline
|
||||
|
||||
: (dlist-each) ( quot dnode -- )
|
||||
[
|
||||
[ dlist-node-data swap call ] 2keep
|
||||
dlist-node-next (dlist-each)
|
||||
] [
|
||||
drop
|
||||
] if* ; inline
|
||||
|
||||
: dlist-each ( dlist quot -- )
|
||||
swap dlist-first (dlist-each) ; inline
|
||||
|
||||
: dlist-length ( dlist -- length )
|
||||
0 swap [ drop 1+ ] dlist-each ;
|
||||
|
||||
|
|
@ -1,32 +0,0 @@
|
|||
! Copyright 2007 Ryan Murphy
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
|
||||
USING: kernel math tools.test heaps heaps.private ;
|
||||
IN: temporary
|
||||
|
||||
[ <min-heap> pop-heap ] unit-test-fails
|
||||
[ <max-heap> pop-heap ] unit-test-fails
|
||||
|
||||
[ t ] [ <min-heap> heap-empty? ] unit-test
|
||||
[ f ] [ <min-heap> 1 over push-heap heap-empty? ] unit-test
|
||||
[ t ] [ <max-heap> heap-empty? ] unit-test
|
||||
[ f ] [ <max-heap> 1 over push-heap heap-empty? ] unit-test
|
||||
|
||||
! 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 3 T{ min-heap } heap-compare ] unit-test
|
||||
{ f } [ 5 3 T{ max-heap } heap-compare ] unit-test
|
||||
|
||||
[ T{ min-heap T{ heap f V{ -6 -4 2 1 5 3 2 4 3 7 6 8 3 4 4 6 5 5 } } } ]
|
||||
[ <min-heap> { 3 5 4 6 7 8 2 4 3 5 6 1 3 2 4 5 -6 -4 } over push-heap* ] unit-test
|
||||
|
||||
[ T{ min-heap T{ heap f V{ 5 6 6 7 8 } } } ] [
|
||||
<min-heap> { 3 5 4 6 5 7 6 8 } over push-heap*
|
||||
3 [ dup pop-heap* ] times
|
||||
] unit-test
|
||||
|
||||
[ 2 ] [ <min-heap> 300 over push-heap 200 over push-heap 400 over push-heap 3 over push-heap 2 over push-heap pop-heap ] unit-test
|
||||
|
||||
[ 1 ] [ <min-heap> 300 over push-heap 200 over push-heap 400 over push-heap 3 over push-heap 2 over push-heap 1 over push-heap pop-heap ] unit-test
|
||||
|
||||
[ 400 ] [ <max-heap> 300 over push-heap 200 over push-heap 400 over push-heap 3 over push-heap 2 over push-heap 1 over push-heap pop-heap ] unit-test
|
||||
|
|
@ -1,112 +0,0 @@
|
|||
! Copyright (C) 2007 Ryan Murphy, Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel math sequences ;
|
||||
IN: heaps
|
||||
|
||||
<PRIVATE
|
||||
TUPLE: heap data ;
|
||||
|
||||
: <heap> ( -- obj )
|
||||
V{ } clone heap construct-boa ;
|
||||
PRIVATE>
|
||||
|
||||
TUPLE: min-heap ;
|
||||
|
||||
: <min-heap> ( -- obj )
|
||||
<heap> min-heap construct-delegate ;
|
||||
|
||||
TUPLE: max-heap ;
|
||||
|
||||
: <max-heap> ( -- obj )
|
||||
<heap> max-heap construct-delegate ;
|
||||
|
||||
<PRIVATE
|
||||
: left ( n -- m ) 2 * 1+ ;
|
||||
: right ( n -- m ) 2 * 2 + ;
|
||||
: up ( n -- m ) 1- 2 /i ;
|
||||
: left-value ( n heap -- obj ) >r left r> nth ;
|
||||
: right-value ( n heap -- obj ) >r right r> nth ;
|
||||
: up-value ( n vec -- obj ) >r up r> nth ;
|
||||
: swap-up ( n vec -- ) >r dup up r> exchange ;
|
||||
: last-index ( vec -- n ) length 1- ;
|
||||
|
||||
GENERIC: heap-compare ( obj1 obj2 heap -- ? )
|
||||
|
||||
M: min-heap heap-compare drop <=> 0 > ;
|
||||
M: max-heap heap-compare drop <=> 0 < ;
|
||||
|
||||
: left-bounds-check? ( m heap -- ? )
|
||||
>r left r> heap-data length >= ;
|
||||
|
||||
: right-bounds-check? ( m heap -- ? )
|
||||
>r right r> heap-data length >= ;
|
||||
|
||||
: (up-heap) ( vec heap -- )
|
||||
[
|
||||
>r [ last-index ] keep [ up-value ] keep peek r> heap-compare
|
||||
] 2keep rot [
|
||||
>r dup last-index
|
||||
[ over swap-up ] keep
|
||||
up 1+ head-slice
|
||||
r> (up-heap)
|
||||
] [
|
||||
2drop
|
||||
] if ;
|
||||
|
||||
: up-heap ( heap -- )
|
||||
[ heap-data ] keep (up-heap) ;
|
||||
|
||||
: child ( m heap -- n )
|
||||
2dup right-bounds-check? [
|
||||
drop left
|
||||
] [
|
||||
dupd
|
||||
[ heap-data left-value ] 2keep
|
||||
[ heap-data right-value ] keep heap-compare [
|
||||
right
|
||||
] [
|
||||
left
|
||||
] if
|
||||
] if ;
|
||||
|
||||
: swap-down ( m heap -- )
|
||||
[ child ] 2keep heap-data exchange ;
|
||||
|
||||
DEFER: down-heap
|
||||
|
||||
: (down-heap) ( m heap -- )
|
||||
2dup [ heap-data nth ] 2keep child pick
|
||||
dupd [ heap-data nth swapd ] keep
|
||||
heap-compare [
|
||||
-rot [ swap-down ] keep down-heap
|
||||
] [
|
||||
3drop
|
||||
] if ;
|
||||
|
||||
: down-heap ( m heap -- )
|
||||
2dup left-bounds-check? [ 2drop ] [ (down-heap) ] if ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: push-heap ( obj heap -- )
|
||||
tuck heap-data push up-heap ;
|
||||
|
||||
: push-heap* ( seq heap -- )
|
||||
swap [ swap push-heap ] curry* each ;
|
||||
|
||||
: peek-heap ( heap -- obj )
|
||||
heap-data first ;
|
||||
|
||||
: pop-heap* ( heap -- )
|
||||
dup heap-data length 1 > [
|
||||
[ heap-data pop 0 ] keep
|
||||
[ heap-data set-nth ] keep
|
||||
>r 0 r> down-heap
|
||||
] [
|
||||
heap-data pop*
|
||||
] if ;
|
||||
|
||||
: pop-heap ( heap -- fist ) [ heap-data first ] keep pop-heap* ;
|
||||
|
||||
: heap-empty? ( heap -- ? )
|
||||
heap-data empty? ;
|
||||
Loading…
Reference in New Issue