Port alarms to the new modules system
parent
0093d3575a
commit
e5b4177487
|
@ -0,0 +1,87 @@
|
|||
! Copyright (C) 2007 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays calendar combinators concurrency generic
|
||||
init kernel math namespaces sequences threads ;
|
||||
IN: alarms
|
||||
|
||||
TUPLE: alarm time quot ;
|
||||
|
||||
C: <alarm> alarm
|
||||
|
||||
<PRIVATE
|
||||
|
||||
! for now a V{ }, eventually a min-heap to store alarms
|
||||
SYMBOL: alarms
|
||||
SYMBOL: alarm-receiver
|
||||
SYMBOL: alarm-looper
|
||||
|
||||
: add-alarm ( alarm -- )
|
||||
alarms get-global push ;
|
||||
|
||||
: remove-alarm ( alarm -- )
|
||||
alarms get-global remove alarms set-global ;
|
||||
|
||||
: handle-alarm ( alarm -- )
|
||||
dup delegate {
|
||||
{ "register" [ add-alarm ] }
|
||||
{ "unregister" [ remove-alarm ] }
|
||||
} case ;
|
||||
|
||||
: expired-alarms ( -- seq )
|
||||
now alarms get-global
|
||||
[ alarm-time <=> 0 > ] curry* subset ;
|
||||
|
||||
: unexpired-alarms ( -- seq )
|
||||
now alarms get-global
|
||||
[ alarm-time <=> 0 <= ] curry* subset ;
|
||||
|
||||
: call-alarm ( alarm -- )
|
||||
alarm-quot spawn drop ;
|
||||
|
||||
: do-alarms ( -- )
|
||||
expired-alarms [ call-alarm ] each
|
||||
unexpired-alarms alarms set-global ;
|
||||
|
||||
: alarm-receive-loop ( -- )
|
||||
receive dup alarm? [ handle-alarm ] [ drop ] if
|
||||
alarm-receive-loop ;
|
||||
|
||||
: start-alarm-receiver ( -- )
|
||||
[
|
||||
alarm-receive-loop
|
||||
] spawn alarm-receiver set-global ;
|
||||
|
||||
: alarm-loop ( -- )
|
||||
alarms get-global empty? [
|
||||
do-alarms
|
||||
] unless 100 sleep alarm-loop ;
|
||||
|
||||
: start-alarm-looper ( -- )
|
||||
[
|
||||
alarm-loop
|
||||
] spawn alarm-looper set-global ;
|
||||
|
||||
: send-alarm ( str alarm -- )
|
||||
over set-delegate
|
||||
alarm-receiver get-global send ;
|
||||
|
||||
: start-alarm-daemon ( -- )
|
||||
alarms get-global [ V{ } clone alarms set-global ] unless
|
||||
start-alarm-looper
|
||||
start-alarm-receiver ;
|
||||
|
||||
[ start-alarm-daemon ] "alarms" add-init-hook
|
||||
PRIVATE>
|
||||
|
||||
: register-alarm ( alarm -- )
|
||||
"register" send-alarm ;
|
||||
|
||||
: unregister-alarm ( alarm -- )
|
||||
"unregister" send-alarm ;
|
||||
|
||||
: change-alarm ( alarm-old alarm-new -- )
|
||||
"register" send-alarm
|
||||
"unregister" send-alarm ;
|
||||
|
||||
! Example:
|
||||
! 5 seconds from-now [ "hi" print flush ] <alarm> register-alarm
|
Loading…
Reference in New Issue