├── .gitignore ├── .travis.yml ├── LICENSE ├── README.md ├── chaos.rkt ├── chaos ├── gui.rkt ├── gui │ ├── key.rkt │ ├── mouse.rkt │ ├── utils.rkt │ └── val.rkt └── pair.rkt ├── examples ├── spin.png ├── spin.rkt └── val-demo.rkt ├── info.rkt ├── main.rkt ├── scribblings └── lux.scrbl └── word.rkt /.gitignore: -------------------------------------------------------------------------------- 1 | *~ 2 | \#* 3 | .\#* 4 | .DS_Store 5 | compiled 6 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: c 2 | 3 | # Supply at least one RACKET_VERSION environment variable definition 4 | # here. RACKET_VERSION is used by the install-racket.sh script 5 | # (specifed below under before_install) to select the version of 6 | # Racket to download and install. 7 | # 8 | # If you supply more than one, you can create multiple builds (a 9 | # Travis-CI build matrix resulting in multiple builds). You can use 10 | # this to test against multiple Racket versions. 11 | env: 12 | - RACKET_VERSION=6.0 13 | - RACKET_VERSION=6.0.1 14 | - RACKET_VERSION=6.1 15 | - RACKET_VERSION=6.1.1 16 | - RACKET_VERSION=HEAD 17 | 18 | before_install: 19 | - git clone https://github.com/greghendershott/travis-racket.git 20 | - cat travis-racket/install-racket.sh | bash # pipe to bash not sh! 21 | 22 | install: 23 | 24 | before_script: 25 | 26 | # Here supply steps such as raco make, raco test, etc. Note that you 27 | # need to supply /usr/racket/bin/ -- it's not in PATH. You can run 28 | # `raco pkg install --deps search-auto <>` to install any required 29 | # packages without it getting stuck on a confirmation prompt. 30 | script: 31 | - /usr/racket/bin/raco make main.rkt 32 | - /usr/racket/bin/raco test -x . 33 | 34 | # NOTE: If your repo is a Racket package with an info.rkt that 35 | # includes some `deps`, the following is more elegant: 36 | # 37 | # script: 38 | # - cd .. # Travis did a cd into the dir. Back up, for the next: 39 | # - /usr/racket/bin/raco pkg install --deps search-auto --link <> 40 | # - /usr/racket/bin/raco test -x -p <> 41 | 42 | after_script: 43 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | This code is available according to same terms as Racket: 2 | 3 | http://download.racket-lang.org/license.html 4 | 5 | Copyright © Jay McCarthy 6 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # lux - a simple library for creating real-time graphical apps 2 | 3 | [Docs](http://docs.racket-lang.org/lux/index.html) 4 | 5 | Installation: ```raco pkg install lux``` 6 | 7 | [Examples](https://github.com/jeapostrophe/lux/tree/master/examples) 8 | 9 | Text revolving around the mouse pointer: 10 | 11 | ![Screenshot](/examples/spin.png) 12 | 13 | Clone this repository, then open `examples/spin.rkt` in DrRacket, press F5 - a 14 | new window should appears. Move the mouse inside this window. 15 | -------------------------------------------------------------------------------- /chaos.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/contract/base 3 | racket/generic) 4 | 5 | (define-generics chaos 6 | (chaos-start! chaos) 7 | (chaos-yield chaos evt) 8 | (chaos-event chaos) 9 | (chaos-output! chaos output) 10 | (chaos-label! chaos label) 11 | (chaos-swap! chaos thunk) 12 | (chaos-stop! chaos) 13 | #:fallbacks 14 | [(define (chaos-start! c) 15 | (void)) 16 | (define (chaos-yield c e) 17 | (sync e)) 18 | (define (chaos-event c) 19 | never-evt) 20 | (define (chaos-output! c o) 21 | (void)) 22 | (define (chaos-label! c l) 23 | (void)) 24 | (define (chaos-swap! chaos thunk) 25 | (thunk)) 26 | (define (chaos-stop! c) 27 | (void))]) 28 | 29 | (provide 30 | gen:chaos 31 | (contract-out 32 | [chaos? (-> any/c boolean?)] 33 | [chaos-start! (-> chaos? any)] 34 | [chaos-yield (-> chaos? evt? any)] 35 | [chaos-event (-> chaos? evt?)] 36 | [chaos-output! (-> chaos? any/c any)] 37 | [chaos-label! (-> chaos? string? any)] 38 | [chaos-swap! (-> chaos? (-> any) any)] 39 | [chaos-stop! (-> chaos? any)])) 40 | -------------------------------------------------------------------------------- /chaos/gui.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/match 3 | racket/class 4 | racket/contract/base 5 | racket/gui/base 6 | racket/async-channel 7 | lux/chaos 8 | "gui/utils.rkt") 9 | 10 | ;; Robby says that I could rework this to remove the event-ch by 11 | ;; having capturing the continuation, storing it, and then calling it 12 | ;; from within the callback once an event is ready. 13 | 14 | (struct gui (event-ch drawer frame refresh!) 15 | #:methods gen:chaos 16 | [(define (chaos-yield c e) 17 | (yield e)) 18 | (define (chaos-event c) 19 | (gui-event-ch c)) 20 | (define (chaos-output! c o) 21 | (when o 22 | (set-box! (gui-drawer c) o)) 23 | ((gui-refresh! c))) 24 | (define (chaos-label! c l) 25 | (send (gui-frame c) set-label l)) 26 | (define (chaos-stop! c) 27 | (send (gui-frame c) show #f))]) 28 | 29 | (define (make-gui #:mode [mode 'draw] 30 | #:opengl-hires? [opengl-hires? #f] 31 | #:start-fullscreen? [start-fullscreen? #f] 32 | #:icon [icon #f] 33 | #:frame-style [frame-style '()] 34 | #:x [the-start-x 'center] 35 | #:y [the-start-y 'center] 36 | #:width [the-init-w 800] 37 | #:height [the-init-h 600] 38 | #:monitor [monitor #f]) 39 | (define-values (start-x start-y init-w init-h) 40 | (cond 41 | [start-fullscreen? 42 | (define-values (x y) (get-display-left-top-inset #t)) 43 | (define-values (w h) (get-display-size #t)) 44 | (values x y w h)] 45 | [else 46 | (values the-start-x the-start-y the-init-w the-init-h)])) 47 | 48 | (define events-ch (make-async-channel)) 49 | (define gframe% 50 | (class frame% 51 | (define/override (on-size w h) 52 | (define-values (cw ch) (send c get-scaled-client-size)) 53 | (async-channel-put events-ch (list 'resize cw ch)) 54 | (refresh!)) 55 | (define/augment (on-close) 56 | (async-channel-put events-ch 'close)) 57 | (define/override (on-subwindow-char w ke) 58 | (async-channel-put events-ch ke)) 59 | (define/override (on-subwindow-event w me) 60 | (async-channel-put events-ch me)) 61 | (super-new))) 62 | 63 | (define drawer (box void)) 64 | (define (paint-canvas c dc) 65 | (define-values (cw ch) 66 | (if (or gl-config the-hires?) 67 | (if gl-config 68 | (send c get-gl-client-size) 69 | (send c get-scaled-client-size)) 70 | (send c get-client-size))) 71 | ((unbox drawer) cw ch dc)) 72 | 73 | (define f 74 | (new gframe% 75 | [label ""] 76 | [width init-w] 77 | [height init-h] 78 | [style frame-style])) 79 | 80 | (define gl-config 81 | (match mode 82 | ['draw #f] 83 | ['gl-compat 84 | (new gl-config%)] 85 | ['gl-core 86 | (define gl-config (new gl-config%)) 87 | (send gl-config set-legacy? #f) 88 | gl-config] 89 | [gl-config 90 | gl-config])) 91 | 92 | (when (and gl-config opengl-hires?) 93 | (send gl-config set-hires-mode #t)) 94 | 95 | (define the-hires? 96 | (and gl-config (send gl-config get-hires-mode))) 97 | 98 | (define c 99 | (new canvas% [parent f] 100 | [paint-callback paint-canvas] 101 | [gl-config gl-config] 102 | [style 103 | (cons 'no-autoclear 104 | (if gl-config '(gl) '()))])) 105 | (define the-refresh-sema (make-semaphore 0)) 106 | (define (refresh!) 107 | (queue-callback 108 | (λ () 109 | (send c refresh-now) 110 | (semaphore-post the-refresh-sema)) 111 | #f) 112 | (yield the-refresh-sema)) 113 | 114 | (define-values (x y) 115 | (find-x/y start-x 116 | start-y 117 | #:width (send f get-width) 118 | #:height (send f get-height) 119 | #:monitor monitor)) 120 | (send f move x y) 121 | 122 | (send f show #t) 123 | 124 | (when icon 125 | (define icon-bm 126 | (if (is-a? icon bitmap%) 127 | icon 128 | (read-bitmap icon))) 129 | (when (eq? 'macosx (system-type 'os)) 130 | ((dynamic-require 'drracket/private/dock-icon 'set-dock-tile-bitmap) 131 | icon-bm))) 132 | 133 | (gui events-ch drawer f refresh!)) 134 | 135 | (provide 136 | (contract-out 137 | [make-gui 138 | (->* () 139 | (#:mode 140 | (or/c (one-of/c 'draw 'gl-compat 'gl-core) 141 | (is-a?/c gl-config%)) 142 | #:opengl-hires? 143 | boolean? 144 | #:start-fullscreen? 145 | boolean? 146 | #:frame-style 147 | (listof symbol?) 148 | #:icon 149 | (or/c #f path-string? (is-a?/c bitmap%)) 150 | #:x 151 | (or/c exact-nonnegative-integer? (one-of/c 'left 'center 'right)) 152 | #:y 153 | (or/c exact-nonnegative-integer? (one-of/c 'top 'center 'bottom)) 154 | #:width 155 | exact-nonnegative-integer? 156 | #:height 157 | exact-nonnegative-integer? 158 | #:monitor 159 | (or/c false/c exact-nonnegative-integer?)) 160 | chaos?)])) 161 | -------------------------------------------------------------------------------- /chaos/gui/key.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require (for-syntax racket/base 3 | racket/syntax) 4 | racket/match 5 | racket/class 6 | racket/gui/base 7 | racket/contract/base) 8 | 9 | (struct key-state 10 | (keys 11 | shift? control? meta? alt? 12 | mod3? mod4? mod5?) 13 | #:mutable) 14 | 15 | (define-syntax (set-key-state stx) 16 | (syntax-case stx () 17 | [(_ ks ke id) 18 | (with-syntax ([set-key-state-id?! 19 | (format-id #'id "set-key-state-~a?!" #'id)] 20 | [get-id-down 21 | (format-id #'id "get-~a-down" #'id)]) 22 | (syntax/loc stx 23 | (set-key-state-id?! ks (send ke get-id-down))))])) 24 | (define-syntax-rule (set-key-states ks ke (id ...)) 25 | (begin (set-key-state ks ke id) ...)) 26 | 27 | (define (key-event? x) 28 | (is-a? x key-event%)) 29 | (define (key-event-code ke) 30 | (match (send ke get-key-code) 31 | ['release 32 | (cons 'release (send ke get-key-release-code))] 33 | [kc 34 | kc])) 35 | 36 | (define (key-state-update! ks ke) 37 | (define ht (key-state-keys ks)) 38 | (match (key-event-code ke) 39 | [(cons 'release kc) 40 | (hash-set! ht kc #f)] 41 | [kc 42 | (hash-set! ht kc #t)]) 43 | (set-key-states 44 | ks ke 45 | (shift control meta alt mod3 mod4 mod5))) 46 | 47 | (define (make-key-state) 48 | (key-state (make-hasheq) #f #f #f #f #f #f #f)) 49 | 50 | (define (key-state-set? ks kc) 51 | (hash-ref (key-state-keys ks) kc #f)) 52 | (define (key-state-set?! ks kc) 53 | (begin0 (key-state-set? ks kc) 54 | (hash-set! (key-state-keys ks) kc #f))) 55 | 56 | (provide 57 | (contract-out 58 | [struct key-state 59 | ([keys hash?] 60 | [shift? boolean?] 61 | [control? boolean?] 62 | [meta? boolean?] 63 | [alt? boolean?] 64 | [mod3? boolean?] 65 | [mod4? boolean?] 66 | [mod5? boolean?])] 67 | [key-event? 68 | (-> any/c boolean?)] 69 | [key-event-code 70 | (-> key-event? 71 | (or/c (cons/c 'release (or/c char? key-code-symbol?)) 72 | (or/c char? key-code-symbol?)))] 73 | [make-key-state 74 | (-> key-state?)] 75 | [key-state-update! 76 | (-> key-state? key-event? 77 | any)] 78 | [key-state-set? 79 | (-> key-state? (or/c char? key-code-symbol?) 80 | boolean?)] 81 | [key-state-set?! 82 | (-> key-state? (or/c char? key-code-symbol?) 83 | boolean?)])) 84 | -------------------------------------------------------------------------------- /chaos/gui/mouse.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require (for-syntax racket/base 3 | racket/syntax) 4 | racket/class 5 | racket/gui/base 6 | racket/contract/base) 7 | 8 | (struct mouse-state 9 | (x y 10 | left? right? middle? 11 | shift? control? meta? alt? 12 | mod3? mod4? mod5?) 13 | #:mutable) 14 | 15 | (define-syntax (set-mouse-state stx) 16 | (syntax-case stx () 17 | [(_ ms me id) 18 | (with-syntax ([set-mouse-state-id?! 19 | (format-id #'id "set-mouse-state-~a?!" #'id)] 20 | [get-id-down 21 | (format-id #'id "get-~a-down" #'id)]) 22 | (syntax/loc stx 23 | (set-mouse-state-id?! ms (send me get-id-down))))])) 24 | (define-syntax-rule (set-mouse-states ms me (id ...)) 25 | (begin (set-mouse-state ms me id) ...)) 26 | 27 | (define (mouse-event? x) 28 | (is-a? x mouse-event%)) 29 | (define (mouse-event-xy me) 30 | (values (send me get-x) (send me get-y))) 31 | 32 | (define (mouse-state-update! ms me) 33 | (set-mouse-state-x! ms (send me get-x)) 34 | (set-mouse-state-y! ms (send me get-y)) 35 | (set-mouse-states 36 | ms me 37 | (left right middle shift control meta alt mod3 mod4 mod5))) 38 | 39 | (define (make-mouse-state) 40 | (mouse-state 0 0 #f #f #f #f #f #f #f #f #f #f)) 41 | (provide 42 | (contract-out 43 | [struct mouse-state 44 | ([x real?] 45 | [y real?] 46 | [left? boolean?] 47 | [right? boolean?] 48 | [middle? boolean?] 49 | [shift? boolean?] 50 | [control? boolean?] 51 | [meta? boolean?] 52 | [alt? boolean?] 53 | [mod3? boolean?] 54 | [mod4? boolean?] 55 | [mod5? boolean?])] 56 | [mouse-event? 57 | (-> any/c boolean?)] 58 | [mouse-event-xy 59 | (-> mouse-event? (values real? real?))] 60 | [make-mouse-state 61 | (-> mouse-state?)] 62 | [mouse-state-update! 63 | (-> mouse-state? (is-a?/c mouse-event%) 64 | any)])) 65 | -------------------------------------------------------------------------------- /chaos/gui/utils.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/gui 2 | (require racket/contract/base) 3 | 4 | (define nnint? exact-nonnegative-integer?) 5 | (provide 6 | (contract-out 7 | [get-mouse-x/y 8 | (->* () 9 | () 10 | (values nnint? nnint?))] 11 | [get-display-info 12 | (->* (nnint?) 13 | () 14 | (values nnint? nnint? nnint? nnint?))] 15 | [find-monitor 16 | (->* (nnint? nnint?) 17 | () 18 | (or/c false/c nnint?))] 19 | [find-mouse-monitor 20 | (->* () 21 | () 22 | (or/c false/c nnint?))] 23 | [find-x/y 24 | (->* ((or/c nnint? (one-of/c 'left 'center 'right)) 25 | (or/c nnint? (one-of/c 'top 'center 'bottom))) 26 | (#:width 27 | nnint? 28 | #:height 29 | nnint? 30 | #:monitor 31 | (or/c false/c nnint?)) 32 | (values nnint? nnint?))])) 33 | 34 | 35 | ;; Returns the coordinates of the mouse pointer 36 | (define (get-mouse-x/y) 37 | (define-values (pt st) 38 | (get-current-mouse-state)) 39 | (values (send pt get-x) 40 | (send pt get-y))) 41 | 42 | ;; Returns the position x, y and the sizes w, h of the provided display/monitor number 43 | (define (get-display-info disp) 44 | (define-values (-x0 -y0) 45 | (if (= disp 0) 46 | (values 0 0) ; to avoid the bars and menus on first monitor 47 | (get-display-left-top-inset #:monitor disp))) 48 | (define-values (w h) 49 | (get-display-size #:monitor disp)) 50 | (values (- -x0) (- -y0) w h)) 51 | 52 | ;; Returns the display/monitor that contains the coordinates x,y, or #f if not found 53 | (define (find-monitor x y) 54 | (define n-disp (get-display-count)) 55 | (let loop ([disp 0]) 56 | (cond 57 | [(>= disp n-disp) #f] 58 | [else 59 | (define-values (x0 y0 w h) 60 | (get-display-info disp)) 61 | (if (and (<= x0 x (+ x0 w)) 62 | (<= y0 y (+ y0 h))) 63 | disp 64 | (loop (+ disp 1)))]))) 65 | 66 | ;; Returns the display/monitor number that contains the mouse pointer 67 | (define (find-mouse-monitor) 68 | (define-values (pt st) 69 | (get-current-mouse-state)) 70 | (find-monitor (send pt get-x) (send pt get-y))) 71 | 72 | ;; Returns the position x, y in pixels for where to place a frame of size fr-w, fr-h 73 | ;; on the specified monitor. If monitor is #f, then the monitor where the mouse 74 | ;; pointer is is used. 75 | ;; pos-x: (or/c non-negative-integer? (one-of 'left 'center 'right)) 76 | ;; pos-y: (or/c non-negative-integer? 77 | (define (find-x/y pos-x pos-y 78 | #:width [fr-w 0] 79 | #:height [fr-h 0] 80 | #:monitor [monitor #f]) 81 | (when (and monitor (not (<= 0 monitor (- (get-display-count) 1)))) 82 | (error "Invalid monitor number" monitor)) 83 | (define disp (or monitor (find-mouse-monitor) 0)) 84 | (define-values (disp-x0 disp-y0 disp-w disp-h) 85 | (get-display-info disp)) 86 | (define x 87 | (cond [(eq? pos-x 'left) 88 | disp-x0] 89 | [(eq? pos-x 'center) 90 | (+ disp-x0 (quotient (- disp-w fr-w) 2))] 91 | [(eq? pos-x 'right) 92 | (+ disp-x0 disp-w (- fr-w))] 93 | [else (+ disp-x0 pos-x)])) 94 | (define y 95 | (cond [(eq? pos-y 'top) 96 | disp-y0] 97 | [(eq? pos-y 'center) 98 | (+ disp-y0 (quotient (- disp-h fr-h) 2))] 99 | [(eq? pos-y 'bottom) 100 | (+ disp-y0 disp-h (- fr-h))] 101 | [else (+ disp-y0 pos-y)])) 102 | (values x y)) 103 | 104 | (module+ drracket 105 | 106 | (define n-displays (get-display-count)) 107 | (for/list ([d (in-range n-displays)]) 108 | (define-values (x y) 109 | (get-display-left-top-inset #:monitor d)) 110 | (define-values (w h) 111 | (get-display-size #:monitor d)) 112 | (list d x y w h)) 113 | 114 | (define fr 115 | (new frame% 116 | [label "test"] 117 | [width 400] 118 | [height 100])) 119 | (send fr show true) 120 | (for* ([monitor (in-sequences (in-value #f) 121 | (in-range (get-display-count)))] 122 | [xx (in-list '(0 100 300 left center right))] 123 | [yy (in-list '(0 200 400 top center bottom))]) 124 | (displayln (list monitor xx yy)) 125 | (define-values (x y) 126 | (find-x/y xx yy 127 | #:width (send fr get-width) 128 | #:height (send fr get-height) 129 | #:monitor monitor)) 130 | (send fr set-label (format "~a, ~a(~a), ~a(~a)" monitor xx x yy y)) 131 | (send fr move x y) 132 | (sleep/yield 0.25)) 133 | ) 134 | 135 | -------------------------------------------------------------------------------- /chaos/gui/val.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/class 3 | racket/draw 4 | racket/fixnum 5 | racket/contract/base 6 | pict 7 | pict/convert) 8 | 9 | (define (make-gui/val #:scale? [scale? #t]) 10 | (λ (o) 11 | (define p (pict-convert o)) 12 | (λ (w h dc) 13 | (parameterize ([dc-for-text-size dc]) 14 | (send dc set-background "black") 15 | (send dc clear) 16 | (define sp 17 | (if scale? 18 | (scale-to-fit p w h) 19 | p)) 20 | (define spw (pict-width sp)) 21 | (define left (/ (- w spw) 2)) 22 | (define sph (pict-height sp)) 23 | (define top (/ (- h sph) 2)) 24 | (send dc set-brush "white" 'solid) 25 | (send dc draw-rectangle left top spw sph) 26 | (draw-pict sp dc left top))))) 27 | 28 | (provide 29 | (contract-out 30 | [make-gui/val 31 | (->* () (#:scale? boolean?) 32 | (-> pict-convertible? 33 | (-> real? real? (is-a?/c dc<%>) 34 | any)))])) 35 | -------------------------------------------------------------------------------- /chaos/pair.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/generic 3 | racket/match 4 | racket/sequence 5 | racket/contract/base 6 | lux/chaos) 7 | 8 | (struct pair (l r) 9 | #:methods gen:chaos 10 | [(define/generic super-start! chaos-start!) 11 | (define/generic super-yield chaos-yield) 12 | (define/generic super-event chaos-event) 13 | (define/generic super-output! chaos-output!) 14 | (define/generic super-label! chaos-label!) 15 | (define/generic super-swap! chaos-swap!) 16 | (define/generic super-stop! chaos-stop!) 17 | (define (chaos-start! c) 18 | (match-define (pair l r) c) 19 | (super-start! l) 20 | (super-start! r)) 21 | (define (chaos-yield c e) 22 | (match-define (pair l r) c) 23 | (super-yield l 24 | (handle-evt always-evt 25 | (λ (_) 26 | (super-yield r e))))) 27 | (define (chaos-event c) 28 | (match-define (pair l r) c) 29 | (choice-evt (super-event l) 30 | (super-event r))) 31 | (define (chaos-output! c o) 32 | (match-define (pair l r) c) 33 | (match-define (cons l.o r.o) o) 34 | (super-output! l l.o) 35 | (super-output! r r.o)) 36 | (define (chaos-label! c lab) 37 | (match-define (pair l r) c) 38 | (super-label! l lab) 39 | (super-label! r lab)) 40 | (define (chaos-swap! c t) 41 | (match-define (pair l r) c) 42 | (super-swap! l (λ () (super-swap! r t)))) 43 | (define (chaos-stop! c) 44 | (match-define (pair l r) c) 45 | (super-stop! l) 46 | (super-stop! r))]) 47 | 48 | (define (make-pair l r) 49 | (pair l r)) 50 | (provide 51 | (contract-out 52 | [make-pair 53 | (-> chaos? chaos? 54 | chaos?)])) 55 | -------------------------------------------------------------------------------- /examples/spin.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jeapostrophe/lux/23caa1996bde1a88e53ae0e1cf8d650e18dcbc24/examples/spin.png -------------------------------------------------------------------------------- /examples/spin.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/match 3 | racket/fixnum 4 | racket/draw 5 | racket/class 6 | lux 7 | lux/chaos/gui 8 | lux/chaos/gui/key 9 | lux/chaos/gui/mouse) 10 | 11 | (define COLORS 12 | '("red" "orange" "yellow" "green" "blue" "indigo" "violet")) 13 | 14 | (struct spin (layer color frame x y) 15 | #:methods gen:word 16 | [(define (word-fps w) 17 | 60.0) 18 | (define (word-label s ft) 19 | (lux-standard-label "Spin!" ft)) 20 | (define (word-event w e) 21 | (match-define (spin layer color f x y) w) 22 | (cond 23 | [(or (eq? e 'close) 24 | (and (key-event? e) 25 | (eq? (send e get-key-code) 'escape))) 26 | #f] 27 | [(and (key-event? e) 28 | (eq? (send e get-key-code) #\space)) 29 | (spin layer (fxmodulo (fx+ 1 color) (length COLORS)) f x y)] 30 | [(mouse-event? e) 31 | (spin layer color f 32 | (send e get-x) 33 | (send e get-y))] 34 | [(and (key-event? e) 35 | (eq? (send e get-key-code) #\return)) 36 | (spin-it (add1 layer)) 37 | w] 38 | [else 39 | w])) 40 | (define (word-output w) 41 | (match-define (spin layer color f x y) w) 42 | (lambda (width height dc) 43 | (send dc set-background (list-ref COLORS color)) 44 | (send dc clear) 45 | (send dc set-rotation (* (/ f 360) 2 3.14)) 46 | (send dc set-origin x y) 47 | (send dc draw-text (format "~a: Spinning!" layer) 0 0))) 48 | (define (word-tick w) 49 | (match-define (spin layer color f x y) w) 50 | (spin layer color (fxmodulo (fx+ f 1) 360) x y))]) 51 | 52 | (define (spin-it layer) 53 | (define s 54 | (spin layer 0 0 0 0)) 55 | (fiat-lux s)) 56 | 57 | (module+ main 58 | (call-with-chaos 59 | (make-gui) 60 | (λ () 61 | (spin-it 0)))) 62 | -------------------------------------------------------------------------------- /examples/val-demo.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/match 3 | racket/fixnum 4 | racket/gui/base 5 | racket/class 6 | (prefix-in pict: pict) 7 | (prefix-in image: 2htdp/image) 8 | lux 9 | lux/chaos/gui 10 | lux/chaos/gui/val 11 | lux/chaos/gui/key) 12 | 13 | (define MODES 14 | (list (pict:arrowhead 30 0) 15 | (image:add-line 16 | (image:rectangle 100 100 "solid" "darkolivegreen") 17 | 25 25 75 75 18 | (image:make-pen "goldenrod" 30 "solid" "round" "round")))) 19 | 20 | (struct demo 21 | (g/v mode) 22 | #:methods gen:word 23 | [(define (word-fps w) 24 | 60.0) 25 | (define (word-label s ft) 26 | (lux-standard-label "Values" ft)) 27 | (define (word-output w) 28 | (match-define (demo g/v mode-n) w) 29 | (g/v (list-ref MODES mode-n))) 30 | (define (word-event w e) 31 | (match-define (demo g/v mode-n) w) 32 | (define closed? #f) 33 | (cond 34 | [(eq? e 'close) 35 | #f] 36 | [(and (key-event? e) 37 | (not (eq? 'release (send e get-key-code)))) 38 | (demo g/v (fxmodulo (fx+ 1 mode-n) (length MODES)))] 39 | [else 40 | (demo g/v mode-n)])) 41 | (define (word-tick w) 42 | w)]) 43 | 44 | (module+ main 45 | (call-with-chaos 46 | (make-gui) 47 | (λ () (fiat-lux (demo (make-gui/val) 0))))) 48 | -------------------------------------------------------------------------------- /info.rkt: -------------------------------------------------------------------------------- 1 | #lang info 2 | (define collection "lux") 3 | (define deps '("draw-lib" 4 | "drracket" 5 | ["gui-lib" #:version "1.13"] 6 | "htdp-lib" 7 | "pict-lib" 8 | ["base" #:version "6.3.0.2"] 9 | "rackunit-lib")) 10 | (define build-deps '("draw-doc" 11 | "gui-doc" 12 | "htdp-doc" 13 | "pict-doc" 14 | "scribble-lib" "racket-doc")) 15 | (define scribblings '(("scribblings/lux.scrbl" () ("UI")))) 16 | (define pkg-desc "a simple library for creating real-time graphical apps") 17 | (define version "0.0") 18 | (define pkg-authors '(jay)) 19 | -------------------------------------------------------------------------------- /main.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require lux/word) 3 | (provide (all-from-out lux/word)) 4 | -------------------------------------------------------------------------------- /scribblings/lux.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/manual 2 | @require[@for-label[lux 3 | lux/chaos 4 | lux/chaos/gui 5 | lux/chaos/gui/val 6 | lux/chaos/gui/key 7 | lux/chaos/gui/mouse 8 | racket/contract 9 | pict/convert 10 | racket/gui/base 11 | racket/base]] 12 | 13 | @title{lux: brilliant interactive programs} 14 | @author{Jay McCarthy} 15 | 16 | @defmodule[lux] 17 | 18 | The @racketmodname[lux] module provides an efficient way to build 19 | interactive programs that consist of plain mathematical functions. It 20 | is comparable to @racketmodname[2htdp/universe], although designed to 21 | allow more parameterization of how the program interacts. 22 | 23 | Check out some examples in the 24 | @link["https://github.com/jeapostrophe/lux/tree/master/examples"]{examples} 25 | directory in the source. 26 | 27 | @local-table-of-contents[] 28 | 29 | @section{Structure of a @racketmodname[lux] Program} 30 | 31 | A @racketmodname[lux] program chooses how it will interact be 32 | selecting a @tech{chaos} and calling @racket[call-with-chaos] with 33 | that @tech{chaos} and a thunk that calls @racket[fiat-lux] with a 34 | @tech{word}. @racket[fiat-lux] may be called any number of nested 35 | times within a call to @racket[call-with-chaos]. Each subsequent 36 | @racket[fiat-lux] takes over the @tech{chaos} until the @tech{word} 37 | completes. It is not typically possible to use @tech{word}s with 38 | arbitrary @tech{chaos}es, as the @tech{chaos} specifies how the 39 | @tech{word} interacts through events and output values. 40 | 41 | When designing @tech{word}s, it is important to realize that 42 | @tech{word} updating functions like @racket[word-tick] do not have to 43 | return a @tech{word} of the same kind. 44 | 45 | @defproc[(call-with-chaos [c chaos?] [t (-> any)]) any]{ 46 | 47 | Runs @racket[t] with @racket[c] as the current @tech{chaos}.} 48 | 49 | @defproc[(fiat-lux [w word?]) any]{ 50 | 51 | Runs @racket[w] with the current @tech{chaos}.} 52 | 53 | @section{The Word} 54 | 55 | A @deftech{word} is a generic interface the encapsulates the 56 | interactive behavior of a @racketmodname[lux] program. 57 | 58 | @defproc[(word? [x any/c]) boolean?]{ 59 | 60 | Identifies @tech{word}s.} 61 | 62 | @defthing[gen:word any/c]{ 63 | 64 | The generic interface binding for @tech{word}s.} 65 | 66 | The @tech{word} methods are as follows: 67 | 68 | @defproc[(word-fps [w word?]) flonum?]{ 69 | 70 | Returns the desired rate of updating for @racket[w] as 71 | frames-per-second. By default, @racket[60.0] is returned.} 72 | 73 | @defproc[(word-label [w word?] [frame-time flonum?]) string?]{ 74 | 75 | Returns a label for @racket[w] that could use @racket[frame-time] to 76 | show the performance of the @tech{word} rendering. By default, returns 77 | @racket[(lux-standard-label "Lux" frame-time)].} 78 | 79 | @defproc[(word-evt [w word?]) evt?]{ 80 | 81 | Returns a synchronizable event that the @tech{word} @racket[w] 82 | requires notification of. By default, returns @racket[never-evt].} 83 | 84 | @defproc[(word-event [w word?] [e any/c]) word?]{ 85 | 86 | Returns a @tech{word} based on @racket[w] that integrates the 87 | information from the event @racket[e]. The type of @racket[e] is 88 | dependent on the current @tech{chaos}. If this returns @racket[#f], 89 | then the @racketmodname[lux] programs stops. By default, returns 90 | @racket[w].} 91 | 92 | @defproc[(word-tick [w word?]) word?]{ 93 | 94 | Returns a @tech{word} based on @racket[w] after one tick of abstract 95 | time. This will be called @racket[(word-fps w)] times per second. If 96 | this returns @racket[#f], then the @racketmodname[lux] programs stops. 97 | By default, returns @racket[w].} 98 | 99 | @defproc[(word-output [w word?]) any/c]{ 100 | 101 | Returns the output value of @racket[w]. The type that this returns is 102 | dependent on the current @tech{chaos}. By default, returns 103 | @racket[#f]. @tech{chaos}es should always allow @racket[#f] and use it 104 | to mean "no output".} 105 | 106 | @defproc[(word-return [w word?]) any/c]{ 107 | 108 | Returns a value for @racket[w] when the @racketmodname[lux] programs 109 | stops, which happens if @racket[word-event] or @racket[word-tick] 110 | return @racket[#f]. By default, returns @racket[w].} 111 | 112 | @subsection{Word Construction} 113 | 114 | A @tech{word} can be created by defining a new @racket[struct] that 115 | implements the @racket[gen:word] generic interface@";" or, it can be 116 | defined using @racket[word]. The first method is best when it is easy 117 | to capture the state of the creation in a structure and the second is 118 | preferable when it is better to capture the state implicitly in the 119 | captured closures. In the author's experience, the second is also best 120 | for creations with complex control flow, because different sorts of 121 | @tech{word}s can be returned in different circumstances. 122 | 123 | @defproc[(word [base (or/c #f word?) #f] 124 | [#:fps fps real? ....] 125 | [#:label label (or/c string? (-> real? string?)) ....] 126 | [#:evt evt evt? ....] 127 | [#:event event (-> any/c (or/c #f word?)) ....] 128 | [#:tick tick (-> (or/c #f word?)) ....] 129 | [#:output output any/c ....] 130 | [#:return return any/c ....]) 131 | word?]{ 132 | 133 | Return a @tech{word} where the implementations of the methods are as 134 | given or inherited from @racket[base] or the defaults (described 135 | above). The only subtleties are that: (1) @racket[label] may be a 136 | string which is used directly and the frame time is not 137 | available@";" (2) @racket[event] is a function that only receives the 138 | generated event@";" (3) @racket[tick] is a thunk. The assumption is 139 | that the caller of @racket[word] can arrange for the value returned to 140 | be captured by these closures if necessary. 141 | 142 | } 143 | 144 | @defform[(word/rec x:id word-args ...)]{Expands to @racket[(letrec ([x (word word-args ...)]) x)].} 145 | 146 | @subsection{Helpers} 147 | 148 | @defproc[(lux-standard-label [s string?] [frame-time flonum?]) string?]{ 149 | 150 | Returns @racket[(string-append s ": " _fts)] where @racket[_fts] 151 | formats @racket[frame-time] as milliseconds and as frames per 152 | second.} 153 | 154 | @section{Chaos} 155 | 156 | A @deftech{chaos} is generic interface for an empty manifestation of 157 | an interactive space that is given form by the @tech{word} and 158 | @racket[fiat-lux]. 159 | 160 | @subsection{Racket GUI Chaos} 161 | 162 | @defmodule[lux/chaos/gui] 163 | 164 | This module provides the standard @tech{chaos} that most users of 165 | @racketmodname[lux] will use. 166 | 167 | @defproc[(make-gui [#:mode mode (or/c (one-of/c 'draw 'gl-compat 'gl-core) 168 | (is-a?/c gl-config%)) 169 | 'draw] 170 | [#:opengl-hires? opengl-hires? boolean? #f] 171 | [#:start-fullscreen? start-fullscreen? boolean? 172 | #f] 173 | [#:frame-style frame-style (listof symbol?) '()] 174 | [#:icon icon 175 | (or/c #f path-string? (is-a?/c bitmap%)) 176 | #f] 177 | [#:x x 178 | (or/c exact-nonnegative-integer? (one-of/c 'left 'center 'right)) 179 | 'center] 180 | [#:y y 181 | (or/c exact-nonnegative-integer? (one-of/c 'top 'center 'bottom)) 182 | 'center] 183 | [#:width width 184 | exact-nonnegative-integer? 185 | 800] 186 | [#:height height 187 | exact-nonnegative-integer? 188 | 600] 189 | [#:monitor monitor 190 | (or/c false/c exact-nonnegative-integer?) 191 | #f]) 192 | chaos?]{ 193 | 194 | Returns a @tech{chaos} that opens a GUI frame with a canvas to draw on. 195 | The frame is placed at position @racket[x],@racket[y] on monitor @racket[monitor]; 196 | if @racket[monitor] is @racket[#f], the monitor containing the mouse pointer is used. 197 | The default size of the frame is 198 | @racket[width]x@racket[height]. The icon for the application is set to 199 | @racket[icon]. If @racket[start-fullscreen?] is true, then the frame 200 | is initially fullscreen. The frame's style is set to 201 | @racket[frame-style]. 202 | 203 | The canvas is set up for drawing based on @racket[mode]. If 204 | @racket[mode] is @racket['draw], then the canvas assumes that 205 | @racketmodname[racket/draw] is used. If other values are used, then 206 | the canvas is drawn with OpenGL. If @racket[mode] is 207 | @racket['gl-compat], then a compatibility OpenGL profile is used. If 208 | @racket[mode] is @racket['gl-core], then a core OpenGL profile is 209 | used. If @racket[mode] is a @racket[gl-config%] object, then it is 210 | used to initialize the canvas. If @racket[opengl-hires?] is 211 | @racket[#t], then the resulting @racket[gl-config%] object will have 212 | high resolution mode set. 213 | 214 | The values that @racket[word-event] is called with are either 215 | @racket['close] (for when the window's close button is pressed), a 216 | @racket[key-event%] object for when keys are pressed, or a 217 | @racket[mouse-event%] object for when the mouse is used. 218 | 219 | The values that @racket[word-output] should return are functions that 220 | satisfy the contract @racket[(-> real? real? (is-a?/c dc<%>) any)] 221 | where the first argument is the width of the canvas, the second is the 222 | height, and the third is the canvas's drawing context.} 223 | 224 | @subsubsection{Drawing Values} 225 | 226 | @defmodule[lux/chaos/gui/val] 227 | 228 | This module provides a helpful function for drawing functional images 229 | with @racketmodname[lux/chaos/gui]. 230 | 231 | @defproc[(make-gui/val [#:scale? scale? boolean? #t]) 232 | (-> pict-convertible? 233 | (-> real? real? (is-a?/c dc<%>) any))]{ 234 | 235 | Produces a function that draws @racket[pict-convertible?] values on to 236 | @racketmodname[lux/chaos/gui]'s drawing context. If @racket[scale?] is 237 | true, then the value will be scaled to file the drawing context (while 238 | preserving aspect ratio), otherwise the value will be drawn in the 239 | center as-is.} 240 | 241 | @subsubsection{Tracking Keyboard State} 242 | 243 | @defmodule[lux/chaos/gui/key] 244 | 245 | This module provides a set of functions for tracking keyboard state 246 | for use inside of @racket[word-tick], rather than updating word state 247 | with each event as in @racket[word-event]. Such as system may be 248 | appropriate for interactive programs where input is only has an impact 249 | at a consistent tick rate. 250 | 251 | @defstruct*[key-state ([keys hash?] [shift? boolean?] [control? boolean?] 252 | [meta? boolean?] [alt? boolean?] [mod3? boolean?] 253 | [mod4? boolean?] [mod5? boolean?])]{ 254 | 255 | Stores a mapping of which keys are presently pressed.} 256 | 257 | @defproc[(make-key-state) key-state?]{ 258 | 259 | Produces a @racket[key-state?] object with appropriate defaults.} 260 | 261 | @defproc[(key-event? [x any/c]) boolean?]{ 262 | 263 | Identifies key events.} 264 | 265 | @defproc[(key-event-code [ke key-event?]) (or/c (cons/c 'release (or/c char? key-code-symbol?)) (or/c char? key-code-symbol?))]{ 266 | 267 | Returns the code of the key event.} 268 | 269 | @defproc[(key-state-update! [ks key-state?] [ke key-event?]) any]{ 270 | 271 | Updates @racket[ks] with @racket[ke].} 272 | 273 | @defproc[(key-state-set? [ks key-state?] [kc (or/c char? key-code-symbol?)]) boolean?]{ 274 | 275 | Returns true if @racket[kc] is pressed in @racket[kc].} 276 | 277 | @defproc[(key-state-set?! [ks key-state?] [kc (or/c char? key-code-symbol?)]) boolean?]{ 278 | 279 | Returns true if @racket[kc] is pressed in @racket[kc] and sets its 280 | pressed status to false..} 281 | 282 | @subsubsection{Tracking Mouse State} 283 | 284 | @defmodule[lux/chaos/gui/mouse] 285 | 286 | This module provides a set of functions for tracking mouse state 287 | for use inside of @racket[word-tick], rather than updating word state 288 | with each event as in @racket[word-event]. Such as system may be 289 | appropriate for interactive programs where input is only has an impact 290 | at a consistent tick rate. 291 | 292 | @defstruct*[mouse-state ([x real?] 293 | [y real?] 294 | [left? boolean?] 295 | [right? boolean?] 296 | [middle? boolean?] 297 | [shift? boolean?] 298 | [control? boolean?] 299 | [meta? boolean?] 300 | [alt? boolean?] 301 | [mod3? boolean?] 302 | [mod4? boolean?] 303 | [mod5? boolean?])]{ 304 | 305 | Stores the active state of the mouse.} 306 | 307 | @defproc[(make-mouse-state) mouse-state?]{ 308 | 309 | Produces a @racket[mouse-state?] object with appropriate defaults.} 310 | 311 | @defproc[(mouse-event? [x any/c]) boolean?]{ 312 | 313 | Identifies mouse events.} 314 | 315 | @defproc[(mouse-event-xy [me mouse-event?]) (values real? real?)]{ 316 | 317 | Returns the position of the mouse event.} 318 | 319 | @defproc[(mouse-state-update! [ms mouse-state?] [me mouse-event?]) any]{ 320 | 321 | Updates @racket[ms] with @racket[me].} 322 | 323 | @subsection{Pair Chaos} 324 | 325 | @defmodule[lux/chaos/pair] 326 | 327 | This module provides a @tech{chaos} that pairs two other @tech{chaos} 328 | objects for @racketmodname[lux] programs with multiple interfaces. 329 | 330 | @defproc[(make-pair [left chaos?] [right chaos?]) chaos?]{ 331 | 332 | Returns a @tech{chaos} where the input event type is the union of the 333 | input events of @racket[left] and @racket[right] and the output type 334 | is a pair of the output types of @racket[left] and @racket[right].} 335 | 336 | @subsection{Implementing a Chaos} 337 | 338 | @defmodule[lux/chaos] 339 | 340 | Users of @racketmodname[lux] will probably not need to implement 341 | @tech{chaos}es, but will use those that are standard. 342 | 343 | @defproc[(chaos? [x any/c]) boolean?]{ 344 | 345 | Identifies @tech{chaos}s.} 346 | 347 | @defthing[gen:chaos any/c]{ 348 | 349 | The generic interface binding for @tech{chaos}es.} 350 | 351 | The @tech{chaos} methods are as follows: 352 | 353 | @defproc[(chaos-start! [c chaos?]) any]{ 354 | 355 | Called at the start of using @racket[c] as the current 356 | @tech{chaos}. By default, does nothing.} 357 | 358 | @defproc[(chaos-yield [c chaos?] [e evt?]) any]{ 359 | 360 | Synchronizes on @racket[e] in a way safe for @racket[c]. By default, 361 | calls @racket[sync].} 362 | 363 | @defproc[(chaos-event [c chaos?]) evt?]{ 364 | 365 | Returns an event that when ready returns a @racket[c] event value. By 366 | default, returns @racket[never-evt].} 367 | 368 | @defproc[(chaos-output! [c chaos?] [o any/c]) any]{ 369 | 370 | Outputs @racket[o] to @racket[c]. @tech{chaos}es should always allow 371 | @racket[#f] and use it to mean "no output". By default, does nothing.} 372 | 373 | @defproc[(chaos-label! [c chaos?] [s string?]) any]{ 374 | 375 | Outputs @racket[s] as the label of @racket[c]. By default, does 376 | nothing.} 377 | 378 | @defproc[(chaos-swap! [c chaos?] [t (-> any)]) any]{ 379 | 380 | Calls @racket[t] while preparing @racket[c] to run a different 381 | @tech{word}. By default, just calls @racket[t].} 382 | 383 | @defproc[(chaos-stop! [c chaos?]) any]{ 384 | 385 | Called at the end of using @racket[c] as the current @tech{chaos}. By 386 | default, does nothing.} 387 | -------------------------------------------------------------------------------- /word.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/list 3 | racket/match 4 | racket/contract/base 5 | racket/flonum 6 | racket/math 7 | racket/format 8 | racket/generic 9 | lux/chaos) 10 | 11 | (define-generics word 12 | (word-fps word) 13 | (word-label word frame-time) 14 | (word-evt word) 15 | (word-event word evt) 16 | (word-tick word) 17 | (word-output word) 18 | (word-return word) 19 | #:fallbacks 20 | [(define (word-fps w) 21 | 60.0) 22 | (define (word-label w frame-time) 23 | (lux-standard-label "Lux" frame-time)) 24 | (define (word-evt w) 25 | never-evt) 26 | (define (word-event w e) w) 27 | (define (word-tick w) w) 28 | (define (word-output w) #f) 29 | (define (word-return w) w)]) 30 | 31 | (define (default b f d) (if b (f b) d)) 32 | (struct *word (fps label evt event tick output return) 33 | #:methods gen:word 34 | [(define (word-fps w) (*word-fps w)) 35 | (define (word-label w ft) 36 | (define h (*word-label w)) 37 | (if (string? h) h (h ft))) 38 | (define (word-evt w) (*word-evt w)) 39 | (define (word-event w e) 40 | (define h (*word-event w)) 41 | (if h (h e) w)) 42 | (define (word-tick w) 43 | (define h (*word-tick w)) 44 | (if h (h) w)) 45 | (define (word-output w) (*word-output w)) 46 | (define (word-return w) 47 | (or (*word-return w) w))]) 48 | (define (word [b #f] 49 | #:fps [fps (default b word-fps 60.0)] 50 | #:label [label (if b 51 | (λ (ft) (word-label b ft)) 52 | (λ (ft) (lux-standard-label "Lux" ft)))] 53 | #:evt [evt (default b word-evt never-evt)] 54 | #:event [event 55 | (if b 56 | (λ (e) (word-event b e)) 57 | #f)] 58 | #:tick [tick 59 | (if b 60 | (λ () (word-tick b)) 61 | #f)] 62 | #:output [output (default b word-output #f)] 63 | #:return [return (default b word-return #f)]) 64 | (*word fps label evt event tick output return)) 65 | 66 | (define (lux-standard-label l frame-time) 67 | (define fps (fl/ 1000.0 frame-time)) 68 | (~a l 69 | ": " 70 | "Frame time: " 71 | (~r frame-time 72 | #:min-width 5 73 | #:precision 1) 74 | "ms; " 75 | "FPS: " 76 | (if (infinite? fps) 77 | "inf" 78 | (~r fps 79 | #:min-width 10 80 | #:precision 2)))) 81 | 82 | (define current-chaos (make-parameter #f)) 83 | 84 | (define (call-with-chaos c t) 85 | (chaos-start! c) 86 | (parameterize ([current-chaos c]) 87 | (dynamic-wind void t (λ () (chaos-stop! c))))) 88 | 89 | (define (fiat-lux w) 90 | (define c (current-chaos)) 91 | (unless c 92 | (error 'fiat-lux "Not called within call-with-chaos")) 93 | (factum-fiat-lux c w)) 94 | 95 | (define (compute-next-time start-time fps) 96 | (define time-incr (fl* (fl/ 1.0 fps) 1000.0)) 97 | (define next-time (fl+ start-time time-incr)) 98 | next-time) 99 | 100 | (define (continue-or-word-return next-w old-w k) 101 | (cond 102 | [(not next-w) 103 | (word-return old-w)] 104 | [else 105 | (k next-w)])) 106 | 107 | (define (factum-fiat-lux c w) 108 | (define (output&process-input&wait frame-start-time w) 109 | (define pre-output-time (current-inexact-milliseconds)) 110 | (chaos-output! c (word-output w)) 111 | (define frame-end-time (current-inexact-milliseconds)) 112 | (define frame-time (- frame-end-time frame-start-time)) 113 | #;(printf "W: ~v\tG: ~v\tT: ~v\n" 114 | (- pre-output-time frame-start-time) 115 | (- frame-end-time pre-output-time) 116 | frame-time) 117 | (define new-label (word-label w frame-time)) 118 | (chaos-label! c new-label) 119 | 120 | ;; Ideally we could compute how much time we have available for GC 121 | ;; and just use that so we never have any pauses. That's a very 122 | ;; big wish though. 123 | (collect-garbage 'incremental) 124 | 125 | (define fps (word-fps w)) 126 | (define next-time (compute-next-time frame-start-time #;frame-end-time fps)) 127 | (define deadline-evt (alarm-evt next-time)) 128 | (define input-enabled? (fl= 0.0 fps)) 129 | 130 | (define w-evt (word-evt w)) 131 | (define c-evt (chaos-event c)) 132 | (define w-or-c-evt (choice-evt w-evt c-evt)) 133 | 134 | (define continue 135 | (λ (next-w) 136 | (output&process-input&wait frame-end-time next-w))) 137 | 138 | (define THE-W w) 139 | (define wait-evt 140 | (handle-evt deadline-evt 141 | (λ (_) 142 | (define next-w (word-tick THE-W)) 143 | (continue-or-word-return 144 | next-w THE-W 145 | continue)))) 146 | (define input-continue 147 | (λ (next-w) 148 | (cond 149 | [input-enabled? 150 | (output&process-input&wait frame-end-time next-w)] 151 | [else 152 | (set! THE-W next-w) 153 | (process-input&wait)]))) 154 | (define input-evt 155 | (handle-evt w-or-c-evt 156 | (λ (e) 157 | (define next-w (word-event THE-W e)) 158 | (continue-or-word-return 159 | next-w THE-W 160 | input-continue)))) 161 | (define both-evt 162 | (choice-evt input-evt wait-evt)) 163 | (define timeout-f 164 | (λ () (chaos-yield c both-evt))) 165 | (define (process-input&wait) 166 | (sync/timeout timeout-f input-evt)) 167 | 168 | (process-input&wait)) 169 | 170 | (chaos-swap! c (λ () (output&process-input&wait (current-inexact-milliseconds) w)))) 171 | 172 | (define-syntax-rule (word/rec id . more) 173 | (letrec ([id (word . more)]) id)) 174 | 175 | (provide 176 | gen:word 177 | word/rec 178 | (contract-out 179 | [word? 180 | (-> any/c word?)] 181 | [word (->* () ((or/c #f word?) 182 | #:fps real? 183 | #:label (or/c string? (-> real? string?)) 184 | #:evt evt? 185 | #:event (-> any/c (or/c #f word?)) 186 | #:tick (-> (or/c #f word?)) 187 | #:output any/c 188 | #:return any/c) 189 | word?)] 190 | [lux-standard-label 191 | (-> string? flonum? 192 | string?)] 193 | [call-with-chaos 194 | (-> chaos? (-> any) 195 | any)] 196 | [fiat-lux 197 | (-> word? 198 | any)])) 199 | 200 | (module+ generics 201 | (provide 202 | (contract-out 203 | [word-fps 204 | (-> word? flonum?)] 205 | [word-label 206 | (-> word? flonum? string?)] 207 | [word-evt 208 | (-> word? evt?)] 209 | [word-event 210 | (-> word? any/c word?)] 211 | [word-tick 212 | (-> word? word?)] 213 | [word-output 214 | (-> word? any/c)] 215 | [word-return 216 | (-> word? any/c)]))) 217 | --------------------------------------------------------------------------------