1 ! Copyright (C) 2007, 2008 Ryan Murphy, Doug Coleman,
3 ! See http://factorcode.org/license.txt for BSD license.
4 USING: kernel math sequences arrays assocs sequences.private
5 growable accessors math.order summary vectors fry combinators ;
8 GENERIC: heap-push* ( value key heap -- entry )
9 GENERIC: heap-peek ( heap -- value key )
10 GENERIC: heap-pop* ( heap -- )
11 GENERIC: heap-pop ( heap -- value key )
12 GENERIC: heap-delete ( entry heap -- )
13 GENERIC: heap-empty? ( heap -- ? )
14 GENERIC: heap-size ( heap -- n )
18 TUPLE: heap { data vector } ;
20 : <heap> ( class -- heap )
21 [ V{ } clone ] dip boa ; inline
23 TUPLE: entry value key heap index ;
25 : <entry> ( value key heap -- entry ) f entry boa ; inline
29 TUPLE: min-heap < heap ;
31 : <min-heap> ( -- min-heap ) min-heap <heap> ;
33 TUPLE: max-heap < heap ;
35 : <max-heap> ( -- max-heap ) max-heap <heap> ;
37 M: heap heap-empty? ( heap -- ? )
38 data>> empty? ; inline
40 M: heap heap-size ( heap -- n )
45 : left ( n -- m ) 1 shift 1 + ; inline
47 : right ( n -- m ) 1 shift 2 + ; inline
49 : up ( n -- m ) 1 - 2/ ; inline
51 : data-nth ( n heap -- entry )
52 data>> nth-unsafe ; inline
54 : left-value ( n heap -- entry )
55 [ left ] dip data-nth ; inline
57 : right-value ( n heap -- entry )
58 [ right ] dip data-nth ; inline
60 : data-set-nth ( entry n heap -- )
61 [ [ >>index drop ] [ ] 2bi ] dip
62 data>> set-nth-unsafe ; inline
64 : data-push ( entry heap -- n )
66 swap 2dup data>> ensure 2drop data-set-nth
70 : data-first ( heap -- entry )
73 : data-exchange ( m n heap -- )
74 [ '[ _ data-nth ] bi@ ]
75 [ '[ _ data-set-nth ] bi@ ] 3bi ; inline
77 GENERIC: heap-compare ( entry1 entry2 heap -- ? )
79 : (heap-compare) ( entry1 entry2 heap -- <=> )
80 drop [ key>> ] compare ; inline
82 M: min-heap heap-compare (heap-compare) +gt+ eq? ;
84 M: max-heap heap-compare (heap-compare) +lt+ eq? ;
86 : heap-bounds-check? ( m heap -- ? )
89 : left-bounds-check? ( m heap -- ? )
90 [ left ] dip heap-bounds-check? ; inline
92 : right-bounds-check? ( m heap -- ? )
93 [ right ] dip heap-bounds-check? ; inline
95 : continue? ( m n heap -- ? )
98 [ 2nip ] 3tri heap-compare ;
102 : (up-heap) ( n heap -- )
105 [ data-exchange ] [ up-heap ] 2bi
108 ] if ; inline recursive
110 : up-heap ( n heap -- )
111 over 0 > [ (up-heap) ] [ 2drop ] if ; inline recursive
113 : (child) ( m heap -- n )
114 { [ drop ] [ left-value ] [ right-value ] [ nip ] } 2cleave
115 heap-compare [ right ] [ left ] if ;
117 : child ( m heap -- n )
118 2dup right-bounds-check?
119 [ drop left ] [ (child) ] if ;
123 : (down-heap) ( m heap -- )
124 [ drop ] [ child ] [ nip ] 2tri
128 [ data-exchange ] [ down-heap ] 2bi
129 ] if ; inline recursive
131 : down-heap ( m heap -- )
132 2dup left-bounds-check? [ 2drop ] [ (down-heap) ] if ; inline recursive
136 M: heap heap-push* ( value key heap -- entry )
137 [ <entry> dup ] [ data-push ] [ ] tri up-heap ;
139 : heap-push ( value key heap -- ) heap-push* drop ;
141 : heap-push-all ( assoc heap -- )
142 '[ swap _ heap-push ] assoc-each ;
144 : >entry< ( entry -- value key )
145 [ value>> ] [ key>> ] bi ; inline
147 M: heap heap-peek ( heap -- value key )
150 ERROR: bad-heap-delete ;
152 M: bad-heap-delete summary
153 drop "Invalid entry passed to heap-delete" ;
155 : entry>index ( entry heap -- n )
156 over heap>> eq? [ bad-heap-delete ] unless
159 M: heap heap-delete ( entry heap -- )
160 [ entry>index ] [ ] bi
161 2dup heap-size 1 - = [
170 M: heap heap-pop* ( heap -- )
171 [ data-first ] keep heap-delete ;
173 M: heap heap-pop ( heap -- value key )
175 [ heap-delete ] [ drop ] 2bi >entry< ;
177 : heap-pop-all ( heap -- alist )
178 [ dup heap-empty? not ]
179 [ dup heap-pop swap 2array ]
182 : slurp-heap ( heap quot: ( elt -- ) -- )
183 over heap-empty? [ 2drop ] [
184 [ [ heap-pop drop ] dip call ] [ slurp-heap ] 2bi
185 ] if ; inline recursive