steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Fix alarms with image saves

db4
Slava Pestov 2008-02-22 16:16:00 -06:00
parent e455dd0362
commit 3f3a6ea1f7
3 changed files with 22 additions and 9 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
core/heaps/heaps-tests.factor
View File

@ -15,8 +15,8 @@ IN: temporary
! Binary Min Heap ! Binary Min Heap
{ 1 2 3 4 5 6 } [ 0 left 0 right 1 left 1 right 2 left 2 right ] unit-test { 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 { t } [ t 5 f <entry> t 3 f <entry> T{ min-heap } heap-compare ] unit-test
{ f } [ t 5 <entry> t 3 <entry> T{ max-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 [ 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

14
core/heaps/heaps.factor
View File

@ -22,9 +22,9 @@ GENERIC: heap-size ( heap -- n )
: <heap> ( class -- heap ) : <heap> ( class -- heap )
>r V{ } clone r> construct-delegate ; inline >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> PRIVATE>
@ -153,7 +153,7 @@ DEFER: down-heap
PRIVATE> PRIVATE>
M: priority-queue heap-push* ( value key heap -- entry ) 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 ; : 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 ) M: priority-queue heap-peek ( heap -- value key )
data-first >entry< ; 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 -- ) M: priority-queue heap-delete ( entry heap -- )
>r entry-index r> [ entry>index ] keep
2dup heap-size 1- = [ 2dup heap-size 1- = [
nip data-pop* nip data-pop*
] [ ] [

13
extra/alarms/alarms.factor
View File

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