diff --git a/chaos.rkt b/chaos.rkt new file mode 100644 index 0000000..1feb8aa --- /dev/null +++ b/chaos.rkt @@ -0,0 +1,37 @@ +#lang racket/base +(require racket/contract/base + data/queue + racket/generic) + +(define-generics chaos + (chaos-fps chaos) + (chaos-yield chaos evt) + (chaos-inputs chaos) + (chaos-output! chaos outputs) + (chaos-label! chaos label) + (chaos-swap! chaos thunk) + #:fallbacks + [(define (chaos-fps c) + 60.0) + (define (chaos-yield c e) + (sync e)) + (define iq (make-queue)) + (define (chaos-inputs c) + iq) + (define (chaos-output! c os) + (void)) + (define (chaos-label! c l) + (void)) + (define (chaos-swap! chaos thunk) + (thunk))]) + +(provide + gen:chaos + (contract-out + [chaos? (-> any/c boolean?)] + [chaos-fps (-> chaos? flonum?)] + [chaos-yield (-> chaos? evt? any)] + [chaos-inputs (-> chaos? queue?)] + [chaos-output! (-> chaos? vector? any)] + [chaos-label! (-> chaos? string? any)] + [chaos-swap! (-> chaos? (-> any) any)])) diff --git a/main.rkt b/main.rkt index 42ffcb7..5abf2e6 100644 --- a/main.rkt +++ b/main.rkt @@ -4,7 +4,8 @@ racket/contract/base racket/flonum racket/format - racket/generic) + racket/generic + lux/chaos) ;; xxx abstract away sources (input events) and sinks (gui and sound)? (define draw-mode/c @@ -12,26 +13,11 @@ (define-generics word (word-label word frame-time) - (word-fps word) (word-tick word events) - (word-draw-mode word) - (word-draw! word width height dc) - (word-pause word) - (word-resume word state) - (word-stop? word) - (word-value word) #:fallbacks [(define (word-label w frame-time) (lux-standard-label "Lux" frame-time)) - (define (word-fps w) - 60.0) - (define (word-tick w es) w) - (define (word-draw-mode w) 'draw) - (define (word-draw! w width height dc) (void)) - (define (word-pause w) w) - (define (word-resume w) w) - (define (word-stop? w) #f) - (define (word-value w) w)]) + (define (word-tick w es) (values w empty))]) (define (lux-standard-label l frame-time) (~a l @@ -46,97 +32,53 @@ #:min-width 7 #:precision 2))) -(define current-world (make-parameter #f)) -(struct world (t ch)) -(struct message (w pmz return-t return-ch time-evt)) -(define-syntax-rule (call pmz e) - (call-with-continuation-barrier - (λ () (call-with-parameterization pmz (λ () e))))) -(define (start-world) - (define submit-ch (make-channel)) - (define the-gui (start-gui)) - (define (body old-stack) - ;; xxx i dislike that i don't know if old-stack is '() - (gui-yield - the-gui - (choice-evt - (match old-stack - ['() - never-evt] - [(cons old-m stack) - (match-define (message w pmz return-t return-ch time-evt) old-m) - (handle-evt - time-evt - (λ (_) - (define start-time (current-inexact-milliseconds)) - (define es (gui-events the-gui)) - ;; I fear that (call pmz e) is slow and I do it a lot - ;; here. So maybe change tick to return all this stuff? - (define new-w (call pmz (word-tick w es))) - (gui-draw! - the-gui - (call pmz (word-draw-mode new-w)) - (λ (width height dc) - (call pmz (word-draw! new-w width height dc)))) - (define end-time (current-inexact-milliseconds)) - (define frame-time (fl- end-time start-time)) - (define new-label - (call pmz (word-label new-w frame-time))) - (gui-label! the-gui new-label) - (match (call pmz (word-stop? new-w)) - [#f - (define fps (call pmz (word-fps new-w))) - (define next-time (fl+ start-time (fl* (fl/ 1.0 fps) 1000.0))) - (define next-time-evt (alarm-evt next-time)) - (define new-m - (message new-w pmz return-t return-ch next-time-evt)) - (body (cons new-m stack))] - [#t - (thread-resume return-t) - (channel-put return-ch (word-value w)) - (body - (match stack - ['() - stack] - [(cons old-m stack) - (match-define (message w pmz return-t return-ch time-evt) old-m) - (cons (message (call pmz (word-resume w)) - pmz return-t return-ch time-evt) - stack)]))])))]) - (handle-evt - submit-ch - (λ (new-m) - (body - (cons new-m - (match old-stack - ['() - old-stack] - [(cons old-m stack) - (match-define (message w pmz return-t return-ch time-evt) old-m) - (cons (message (call pmz (word-pause w)) - pmz return-t return-ch time-evt) - stack)])))))))) - (define world-t - (thread - (λ () - (body empty)))) - (world world-t submit-ch)) +(define current-chaos (make-parameter #f)) + +(define (call-with-chaos c t) + (parameterize ([current-chaos c]) + (t))) (define (fiat-lux w) - (if (current-world) - (fictio-fiat-lux w) - (factum-fiat-lux w))) + (define c (current-chaos)) + (unless c + (error 'fiat-lux "Not called within call-with-chaos")) + (factum-fiat-lux c w)) -(define (factum-fiat-lux w) - (parameterize ([current-world (start-world)]) - (fictio-fiat-lux w))) -;; xxx this isn't going to work because the server won't be listening inside tick -(define (fictio-fiat-lux w) - (define return-ch (make-channel)) - (match-define (world world-t submit-ch) (current-world)) - (thread-resume world-t) - (define m (message w (current-parameterization) - (current-thread) return-ch - always-evt)) - (channel-put! submit-ch m) - (channel-get return-ch)) +(define (factum-fiat-lux c w) + (define fps (chaos-fps c)) + (define time-incr (fl* (fl/ 1.0 fps) 1000.0)) + (define (body tick-evt w) + (chaos-yield + c + (handle-evt + tick-evt + (λ (_) + (define start-time (current-inexact-milliseconds)) + (define inputs (chaos-inputs c)) + (define-values (new-w outputs) (word-tick w inputs)) + (match new-w + [#f + (apply values outputs)] + [_ + (chaos-output! c outputs) + (define end-time (current-inexact-milliseconds)) + (define frame-time (fl- end-time start-time)) + (define new-label + (word-label new-w frame-time)) + (chaos-label! c new-label) + (define next-time (fl+ start-time time-incr)) + (define next-tick-evt (alarm-evt next-time)) + (body next-tick-evt new-w)]))))) + (chaos-swap! c (λ () (body always-evt w)))) + +(provide gen:word + (contract-out + [lux-standard-label + (-> string? flonum? + string?)] + [call-with-chaos + (-> chaos? (-> any) + any)] + [fiat-lux + (-> word? + any)]))