<commit_before>! Copyright (C) 2005, 2008 <NAME>, <NAME>.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs boxes calendar
combinators.short-circuit fry heaps init kernel math.order
namespaces quotations threads math system ;
IN: alarms

TUPLE: alarm
    { quot callable initial: [ ] }
    { start integer }
    interval
    { entry box } ;

<PRIVATE

SYMBOL: alarms
SYMBOL: alarm-thread

: notify-alarm-thread ( -- )
    alarm-thread get-global interrupt ;

: normalize-argument ( obj -- nanoseconds )
    >duration duration>nanoseconds >integer ;

: <alarm> ( quot start interval -- alarm )
    alarm new
        swap dup [ normalize-argument ] when >>interval
        swap dup [ normalize-argument nano-count + ] when >>start
        swap >>quot
        <box> >>entry ;

: register-alarm ( alarm -- )
    [ dup start>> alarms get-global heap-push* ]
    [ entry>> >box ] bi
    notify-alarm-thread ;

: alarm-expired? ( alarm n -- ? )
    [ start>> ] dip <= ;

: reschedule-alarm ( alarm -- )
    dup interval>> nano-count + >>start register-alarm ;

: call-alarm ( alarm -- )
    [ entry>> box> drop ]
    [ dup interval>> [ reschedule-alarm ] [ drop ] if ]
    [ quot>> "Alarm execution" spawn drop ] tri ;

: (trigger-alarms) ( alarms n -- )
    over heap-empty? [
        2drop
    ] [
        over heap-peek drop over alarm-expired? [
            over heap-pop drop call-alarm (trigger-alarms)
        ] [
            2drop
        ] if
    ] if ;

: trigger-alarms ( alarms -- )
    nano-count (trigger-alarms) ;

: next-alarm ( alarms -- timestamp/f )
    dup heap-empty? [ drop f ] [
        heap-peek drop start>>
        nano-count swap -
    ] if ;

: alarm-thread-loop ( -- )
    alarms get-global
    dup next-alarm sleep-until
    trigger-alarms ;

: cancel-alarms ( alarms -- )
    [
        heap-pop-all [ nip entry>> box> drop ] assoc-each
    ] when* ;

: init-alarms ( -- )
    alarms [ cancel-alarms <min-heap> ] change-global
    [ alarm-thread-loop t ] "Alarms" spawn-server
    alarm-thread set-global ;

[ init-alarms ] "alarms" add-startup-hook

PRIVATE>

: add-alarm ( quot start interval -- alarm )
    <alarm> [ register-alarm ] keep ;

: later ( quot duration -- alarm ) f add-alarm ;

: every ( quot duration -- alarm ) dup add-alarm ;
<commit_msg>alarms: pass correct parameter to sleep-until, fixes 100% CPU usage in UI<commit_after>! Copyright (C) 2005, 2008 <NAME>, <NAME>.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs boxes calendar
combinators.short-circuit fry heaps init kernel math.order
namespaces quotations threads math system ;
IN: alarms

TUPLE: alarm
    { quot callable initial: [ ] }
    { start integer }
    interval
    { entry box } ;

<PRIVATE

SYMBOL: alarms
SYMBOL: alarm-thread

: notify-alarm-thread ( -- )
    alarm-thread get-global interrupt ;

: normalize-argument ( obj -- nanoseconds )
    >duration duration>nanoseconds >integer ;

: <alarm> ( quot start interval -- alarm )
    alarm new
        swap dup [ normalize-argument ] when >>interval
        swap dup [ normalize-argument nano-count + ] when >>start
        swap >>quot
        <box> >>entry ;

: register-alarm ( alarm -- )
    [ dup start>> alarms get-global heap-push* ]
    [ entry>> >box ] bi
    notify-alarm-thread ;

: alarm-expired? ( alarm n -- ? )
    [ start>> ] dip <= ;

: reschedule-alarm ( alarm -- )
    dup interval>> nano-count + >>start register-alarm ;

: call-alarm ( alarm -- )
    [ entry>> box> drop ]
    [ dup interval>> [ reschedule-alarm ] [ drop ] if ]
    [ quot>> "Alarm execution" spawn drop ] tri ;

: (trigger-alarms) ( alarms n -- )
    over heap-empty? [
        2drop
    ] [
        over heap-peek drop over alarm-expired? [
            over heap-pop drop call-alarm (trigger-alarms)
        ] [
            2drop
        ] if
    ] if ;

: trigger-alarms ( alarms -- )
    nano-count (trigger-alarms) ;

: next-alarm ( alarms -- nanos/f )
    dup heap-empty? [ drop f ] [ heap-peek drop start>> ] if ;

: alarm-thread-loop ( -- )
    alarms get-global
    dup next-alarm sleep-until
    trigger-alarms ;

: cancel-alarms ( alarms -- )
    [
        heap-pop-all [ nip entry>> box> drop ] assoc-each
    ] when* ;

: init-alarms ( -- )
    alarms [ cancel-alarms <min-heap> ] change-global
    [ alarm-thread-loop t ] "Alarms" spawn-server
    alarm-thread set-global ;

[ init-alarms ] "alarms" add-startup-hook

PRIVATE>

: add-alarm ( quot start interval -- alarm )
    <alarm> [ register-alarm ] keep ;

: later ( quot duration -- alarm ) f add-alarm ;

: every ( quot duration -- alarm ) dup add-alarm ;

{'fraction_non_alphanumeric': 0.13356311934510987, 'fraction_numerical': 0.004954760878931495, 'mean_word_length': 2.3451008645533142, 'pattern_counts': {'":': 0, '<': 19, '<?xml version=': 0, '>': 85, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 0, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '6313188', 'n_tokens_mistral': 1557, 'n_tokens_neox': 1504, 'n_words': 415}