lux/word.rkt

146 lines
3.9 KiB
Racket
Raw Normal View History

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)
(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)
(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))
(define new-label (word-label w frame-time))
2015-09-04 13:18:16 +00:00
(chaos-label! c new-label)
(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))
(define input-enabled? (fl= 0.0 fps))
2015-09-04 13:18:16 +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))
(define continue
(λ (next-w)
(output&process-input&wait frame-end-time next-w)))
2015-09-04 13:18:16 +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
(process-input&wait))
(chaos-swap! c (λ () (output&process-input&wait (current-inexact-milliseconds) w))))
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)]))