52 lines
1.5 KiB
Racket
52 lines
1.5 KiB
Racket
#lang racket/gui
|
|
|
|
;; The module provides a timer mixing for world and universe.
|
|
|
|
;; The interface ensures that super class provides start and stop method,
|
|
;; BUT if fails to ensure that the class comes with a _tick_ field.
|
|
;; plus a call back for clock ticks. The super-init call sets the
|
|
;; tick field, which the super-class uses to define the callback.
|
|
|
|
|
|
(require "check-aux.rkt" "stop.rkt")
|
|
|
|
(provide clock-mixin start-stop<%>)
|
|
|
|
(define start-stop<%> (interface () start! ptock pptock name-of-tick-handler stop!))
|
|
|
|
(define clock-mixin
|
|
(mixin (start-stop<%>) ()
|
|
(inherit ptock)
|
|
(init-field [on-tick #f])
|
|
(field [rate 0]
|
|
[limit #f]
|
|
[tick void]
|
|
[tick# 0]
|
|
[timer (new timer% [notify-callback (lambda () (set! tick# (+ tick# 1)) (ptock))])])
|
|
(match on-tick
|
|
[`(,handler ,r ,l)
|
|
(set! limit l)
|
|
(set! rate r)
|
|
(set! tick (first on-tick))]
|
|
[`(,handler ,r)
|
|
(set! rate r)
|
|
(set! tick handler)]
|
|
[(? procedure? handler)
|
|
(set! rate RATE)
|
|
(set! tick handler)]
|
|
[else (void)])
|
|
(define/override (start!)
|
|
(unless (<= rate 0)
|
|
(send timer start (number->integer (* 1000 rate) 'big-bang/universe 'clock-rate)))
|
|
(super start!))
|
|
(define/override (stop! w)
|
|
(send timer stop)
|
|
(super stop! w))
|
|
(define/override (pptock w)
|
|
(if (and limit (> tick# limit))
|
|
(make-stop-the-world w)
|
|
(tick w)))
|
|
(define/override (name-of-tick-handler)
|
|
(object-name tick))
|
|
(super-new)))
|