Fix alarms with image saves

core/heaps/heaps-tests.factor

@@ -15,8 +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 } [ 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 } [ t 5 f <entry> t 3 f <entry> T{ min-heap } heap-compare ] unit-test
+{ f } [ t 5 f <entry> t 3 f <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
 

core/heaps/heaps.factor

@@ -22,9 +22,9 @@ GENERIC: heap-size ( heap -- n )
 : <heap> ( class -- heap )
     >r V{ } clone r> construct-delegate ; inline
 
-TUPLE: entry value key index ;
+TUPLE: entry value key heap index ;
 
-: <entry> ( value key -- entry ) f entry construct-boa ;
+: <entry> ( value key heap -- entry ) f entry construct-boa ;
 
 PRIVATE>
 
@@ -153,7 +153,7 @@ DEFER: down-heap
 PRIVATE>
 
 M: priority-queue heap-push* ( value key heap -- entry )
-    >r <entry> dup r> [ data-push ] keep up-heap ;
+    [ <entry> dup ] keep [ data-push ] keep up-heap ;
 
 : heap-push ( value key heap -- ) heap-push* drop ;
 
@@ -166,8 +166,14 @@ M: priority-queue heap-push* ( value key heap -- entry )
 M: priority-queue heap-peek ( heap -- value key )
     data-first >entry< ;
 
+: entry>index ( entry heap -- n )
+    over entry-heap eq? [
+        "Invalid entry passed to heap-delete" throw
+    ] unless
+    entry-index ;
+
 M: priority-queue heap-delete ( entry heap -- )
-    >r entry-index r>
+    [ entry>index ] keep
     2dup heap-size 1- = [
         nip data-pop*
     ] [

extra/alarms/alarms.factor

@@ -1,7 +1,8 @@
 ! Copyright (C) 2005, 2008 Slava Pestov, Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays calendar combinators generic init kernel math
-namespaces sequences heaps boxes threads debugger quotations ;
+namespaces sequences heaps boxes threads debugger quotations
+assocs ;
 IN: alarms
 
 TUPLE: alarm quot time interval entry ;
@@ -67,8 +68,13 @@ SYMBOL: alarm-thread
     dup trigger-alarms
     alarm-thread-loop ;
 
+: cancel-alarms ( alarms -- )
+    [
+        heap-pop-all [ nip alarm-entry box> drop ] assoc-each
+    ] when* ;
+
 : init-alarms ( -- )
-    <min-heap> alarms set-global
+    alarms global [ cancel-alarms <min-heap> ] change-at
     [ alarm-thread-loop ] "Alarms" spawn
     alarm-thread set-global ;
 
@@ -83,4 +89,5 @@ PRIVATE>
     from-now f add-alarm ;
 
 : cancel-alarm ( alarm -- )
-    alarm-entry box> alarms get-global heap-delete ;
+    alarm-entry ?box
+    [ alarms get-global heap-delete ] [ drop ] if ;