2014-11-19 22:48:05 +00:00
|
|
|
#lang racket/base
|
|
|
|
(require racket/list
|
|
|
|
racket/match
|
|
|
|
racket/contract/base
|
|
|
|
racket/flonum
|
|
|
|
racket/format
|
|
|
|
racket/generic
|
|
|
|
lux/chaos)
|
|
|
|
|
|
|
|
(define-generics word
|
2014-11-21 18:26:01 +00:00
|
|
|
(word-fps word)
|
2014-11-19 22:48:05 +00:00
|
|
|
(word-label word frame-time)
|
2015-04-14 18:00:59 +00:00
|
|
|
(word-evt word)
|
2014-11-20 15:53:15 +00:00
|
|
|
(word-event word evt)
|
|
|
|
(word-tick word)
|
|
|
|
(word-output word)
|
|
|
|
(word-return word)
|
2014-11-19 22:48:05 +00:00
|
|
|
#:fallbacks
|
2014-11-21 18:26:01 +00:00
|
|
|
[(define (word-fps w)
|
|
|
|
60.0)
|
|
|
|
(define (word-label w frame-time)
|
2014-11-19 22:48:05 +00:00
|
|
|
(lux-standard-label "Lux" frame-time))
|
2015-04-14 18:00:59 +00:00
|
|
|
(define (word-evt w)
|
|
|
|
never-evt)
|
2014-11-20 15:53:15 +00:00
|
|
|
(define (word-event w e) w)
|
|
|
|
(define (word-tick w) w)
|
2014-11-22 18:54:08 +00:00
|
|
|
(define (word-output w) #f)
|
2014-11-20 15:53:15 +00:00
|
|
|
(define (word-return w) w)])
|
2014-11-19 22:48:05 +00:00
|
|
|
|
|
|
|
(define (lux-standard-label l frame-time)
|
|
|
|
(~a l
|
|
|
|
": "
|
|
|
|
"Frame time: "
|
|
|
|
(~r frame-time
|
|
|
|
#:min-width 5
|
|
|
|
#:precision 1)
|
|
|
|
"ms; "
|
|
|
|
"FPS: "
|
|
|
|
(~r (fl/ 1000.0 frame-time)
|
|
|
|
#:min-width 10
|
|
|
|
#:precision 2)))
|
|
|
|
|
|
|
|
(define current-chaos (make-parameter #f))
|
|
|
|
|
|
|
|
(define (call-with-chaos c t)
|
2014-11-26 22:21:55 +00:00
|
|
|
(chaos-start! c)
|
2014-11-19 22:48:05 +00:00
|
|
|
(parameterize ([current-chaos c])
|
2014-11-26 22:21:55 +00:00
|
|
|
(begin0 (t)
|
|
|
|
(chaos-stop! c))))
|
2014-11-19 22:48:05 +00:00
|
|
|
|
|
|
|
(define (fiat-lux w)
|
|
|
|
(define c (current-chaos))
|
|
|
|
(unless c
|
|
|
|
(error 'fiat-lux "Not called within call-with-chaos"))
|
|
|
|
(factum-fiat-lux c w))
|
|
|
|
|
2015-07-30 19:56:57 +00:00
|
|
|
;; XXX In the process of adding (collect-garbage? #t) to this, I
|
|
|
|
;; noticed a problem with the way that things are timed. Right now, if
|
|
|
|
;; an input event occurs, then the alarm can be put off. Also, the
|
|
|
|
;; output occurs on input events even when there is an FPS. What
|
|
|
|
;; really should happen, however, is that output should only occur at
|
|
|
|
;; the FPS and the alarm deadlines should never reset. It needs to be
|
|
|
|
;; considerably changed to fix that. I did something in the last
|
|
|
|
;; reverted commit, but I don't likw it.
|
2015-09-04 13:18:16 +00:00
|
|
|
(define (compute-next-time start-time fps)
|
|
|
|
(define time-incr (fl* (fl/ 1.0 fps) 1000.0))
|
|
|
|
(define next-time (fl+ start-time time-incr))
|
|
|
|
next-time)
|
|
|
|
|
2015-09-04 13:51:11 +00:00
|
|
|
(define (continue-or-word-return next-w old-w k)
|
|
|
|
(cond
|
|
|
|
[(not next-w)
|
|
|
|
(word-return old-w)]
|
|
|
|
[else
|
|
|
|
(k next-w)]))
|
|
|
|
|
2014-11-19 22:48:05 +00:00
|
|
|
(define (factum-fiat-lux c w)
|
2015-09-04 13:18:16 +00:00
|
|
|
(define (output&process-input&wait frame-start-time w)
|
2015-09-04 13:51:11 +00:00
|
|
|
(chaos-output! c (word-output w))
|
2015-09-04 13:18:16 +00:00
|
|
|
(define frame-end-time (current-inexact-milliseconds))
|
|
|
|
(define frame-time (- frame-end-time frame-start-time))
|
2015-09-04 13:51:11 +00:00
|
|
|
(define new-label (word-label w frame-time))
|
2015-09-04 13:18:16 +00:00
|
|
|
(chaos-label! c new-label)
|
|
|
|
|
2015-09-04 13:51:11 +00:00
|
|
|
(define fps (word-fps w))
|
2015-09-04 13:18:16 +00:00
|
|
|
(define next-time (compute-next-time frame-end-time fps))
|
|
|
|
(define deadline-evt (alarm-evt next-time))
|
2015-09-04 13:51:11 +00:00
|
|
|
(define input-enabled? (fl= 0.0 fps))
|
2015-09-04 13:18:16 +00:00
|
|
|
|
2015-09-04 13:51:11 +00:00
|
|
|
(define w-evt (word-evt w))
|
2015-09-04 13:18:16 +00:00
|
|
|
(define c-evt (chaos-event c))
|
|
|
|
(define w-or-c-evt (choice-evt w-evt c-evt))
|
|
|
|
|
2015-09-04 13:51:11 +00:00
|
|
|
(define continue
|
|
|
|
(λ (next-w)
|
|
|
|
(output&process-input&wait frame-end-time next-w)))
|
2015-09-04 13:18:16 +00:00
|
|
|
|
2015-09-04 13:51:11 +00:00
|
|
|
(define THE-W w)
|
|
|
|
(define wait-evt
|
|
|
|
(handle-evt deadline-evt
|
|
|
|
(λ (_)
|
|
|
|
(define next-w (word-tick THE-W))
|
|
|
|
(continue-or-word-return
|
|
|
|
next-w THE-W
|
|
|
|
continue))))
|
|
|
|
(define input-continue
|
|
|
|
(λ (next-w)
|
|
|
|
(cond
|
|
|
|
[input-enabled?
|
|
|
|
(output&process-input&wait frame-end-time next-w)]
|
|
|
|
[else
|
|
|
|
(set! THE-W next-w)
|
|
|
|
(process-input&wait)])))
|
|
|
|
(define input-evt
|
|
|
|
(handle-evt w-or-c-evt
|
|
|
|
(λ (e)
|
|
|
|
(define next-w (word-event THE-W e))
|
|
|
|
(continue-or-word-return
|
|
|
|
next-w THE-W
|
|
|
|
input-continue))))
|
|
|
|
(define both-evt
|
|
|
|
(choice-evt input-evt wait-evt))
|
|
|
|
(define timeout-f
|
|
|
|
(λ () (chaos-yield c both-evt)))
|
|
|
|
(define (process-input&wait)
|
|
|
|
(sync/timeout timeout-f input-evt))
|
2014-11-19 22:48:05 +00:00
|
|
|
|
2015-09-04 13:51:11 +00:00
|
|
|
(process-input&wait))
|
|
|
|
|
|
|
|
(chaos-swap! c (λ () (output&process-input&wait (current-inexact-milliseconds) w))))
|
2015-09-03 19:12:53 +00:00
|
|
|
|
2014-11-19 22:48:05 +00:00
|
|
|
(provide
|
|
|
|
gen:word
|
|
|
|
(contract-out
|
2014-11-22 18:54:08 +00:00
|
|
|
[word?
|
|
|
|
(-> any/c word?)]
|
2014-11-19 22:48:05 +00:00
|
|
|
[lux-standard-label
|
|
|
|
(-> string? flonum?
|
|
|
|
string?)]
|
|
|
|
[call-with-chaos
|
|
|
|
(-> chaos? (-> any)
|
|
|
|
any)]
|
|
|
|
[fiat-lux
|
|
|
|
(-> word?
|
|
|
|
any)]))
|