diff --git a/core/heaps/heaps-tests.factor b/core/heaps/heaps-tests.factor new file mode 100644 index 0000000000..a8087916e7 --- /dev/null +++ b/core/heaps/heaps-tests.factor @@ -0,0 +1,32 @@ +! Copyright 2007 Ryan Murphy +! See http://factorcode.org/license.txt for BSD license. + +USING: kernel math tools.test heaps heaps.private ; +IN: temporary + +[ pop-heap ] unit-test-fails +[ pop-heap ] unit-test-fails + +[ t ] [ heap-empty? ] unit-test +[ f ] [ 1 over push-heap heap-empty? ] unit-test +[ t ] [ heap-empty? ] unit-test +[ f ] [ 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 } } } ] +[ { 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 } } } ] [ + { 3 5 4 6 5 7 6 8 } over push-heap* + 3 [ dup pop-heap* ] times +] unit-test + +[ 2 ] [ 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 ] [ 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 ] [ 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 diff --git a/core/heaps/heaps.factor b/core/heaps/heaps.factor new file mode 100644 index 0000000000..2ff9096483 --- /dev/null +++ b/core/heaps/heaps.factor @@ -0,0 +1,112 @@ +! Copyright (C) 2007 Ryan Murphy, Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel math sequences ; +IN: heaps + + ( -- obj ) + V{ } clone heap construct-boa ; +PRIVATE> + +TUPLE: min-heap ; + +: ( -- obj ) + min-heap construct-delegate ; + +TUPLE: max-heap ; + +: ( -- obj ) + max-heap construct-delegate ; + +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? ; diff --git a/vm/os-windows.c b/vm/os-windows.c index 6e39422134..421d90b223 100755 --- a/vm/os-windows.c +++ b/vm/os-windows.c @@ -51,8 +51,7 @@ void ffi_dlopen (F_DLL *dll, bool error) { dll->dll = NULL; if(error) - general_error(ERROR_FFI,F,F, - (void*)tag_object(get_error_message())); + general_error(ERROR_FFI,F,tag_object(get_error_message()),NULL); else return; }