basis/alarms/alarms.factor

   1 ! Copyright (C) 2005, 2008 Slava Pestov, Doug Coleman.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors assocs boxes calendar
   4 combinators.short-circuit fry heaps init kernel math.order
   5 namespaces quotations threads ;
   6 IN: alarms
   7
   8 TUPLE: alarm
   9     { quot callable initial: [ ] }
  10     { time timestamp }
  11     interval
  12     { entry box } ;
  13
  14 <PRIVATE
  15
  16 SYMBOL: alarms
  17 SYMBOL: alarm-thread
  18
  19 : notify-alarm-thread ( -- )
  20     alarm-thread get-global interrupt ;
  21
  22 ERROR: bad-alarm-frequency frequency ;
  23 : check-alarm ( frequency/f -- frequency/f )
  24     dup { [ duration? ] [ not ] } 1|| [ bad-alarm-frequency ] unless ;
  25
  26 : <alarm> ( quot time frequency -- alarm )
  27     check-alarm <box> alarm boa ;
  28
  29 : register-alarm ( alarm -- )
  30     [ dup time>> alarms get-global heap-push* ]
  31     [ entry>> >box ] bi
  32     notify-alarm-thread ;
  33
  34 : alarm-expired? ( alarm now -- ? )
  35     [ time>> ] dip before=? ;
  36
  37 : reschedule-alarm ( alarm -- )
  38     dup '[ _ interval>> time+ now max ] change-time register-alarm ;
  39
  40 : call-alarm ( alarm -- )
  41     [ entry>> box> drop ]
  42     [ quot>> "Alarm execution" spawn drop ]
  43     [ dup interval>> [ reschedule-alarm ] [ drop ] if ] tri ;
  44
  45 : (trigger-alarms) ( alarms now -- )
  46     over heap-empty? [
  47         2drop
  48     ] [
  49         over heap-peek drop over alarm-expired? [
  50             over heap-pop drop call-alarm (trigger-alarms)
  51         ] [
  52             2drop
  53         ] if
  54     ] if ;
  55
  56 : trigger-alarms ( alarms -- )
  57     now (trigger-alarms) ;
  58
  59 : next-alarm ( alarms -- timestamp/f )
  60     dup heap-empty?
  61     [ drop f ] [ heap-peek drop time>> ] if ;
  62
  63 : alarm-thread-loop ( -- )
  64     alarms get-global
  65     dup next-alarm sleep-until
  66     trigger-alarms ;
  67
  68 : cancel-alarms ( alarms -- )
  69     [
  70         heap-pop-all [ nip entry>> box> drop ] assoc-each
  71     ] when* ;
  72
  73 : init-alarms ( -- )
  74     alarms [ cancel-alarms <min-heap> ] change-global
  75     [ alarm-thread-loop t ] "Alarms" spawn-server
  76     alarm-thread set-global ;
  77
  78 [ init-alarms ] "alarms" add-init-hook
  79
  80 PRIVATE>
  81
  82 : add-alarm ( quot time frequency -- alarm )
  83     <alarm> [ register-alarm ] keep ;
  84
  85 : later ( quot duration -- alarm )
  86     hence f add-alarm ;
  87
  88 : every ( quot duration -- alarm )
  89     [ hence ] keep add-alarm ;
  90
  91 : cancel-alarm ( alarm -- )
  92     entry>> [ alarms get-global heap-delete ] if-box? ;