misc-deps
/
lux
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Updating chaos interface

This commit is contained in:
Jay McCarthy 2014-11-26 17:21:55 -05:00
parent 9ca19d016a
commit fd7d1512bc
5 changed files with 52 additions and 20 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
chaos.rkt
View File

@ -3,13 +3,17 @@
racket/generic)
(define-generics chaos
(chaos-start! chaos)
(chaos-yield chaos evt)
(chaos-event chaos)
(chaos-output! chaos output)
(chaos-label! chaos label)
(chaos-swap! chaos thunk)
(chaos-stop! chaos)
#:fallbacks
[(define (chaos-yield c e)
[(define (chaos-start! c)
(void))
(define (chaos-yield c e)
(sync e))
(define (chaos-event c)
never-evt)
@ -18,14 +22,18 @@
(define (chaos-label! c l)
(void))
(define (chaos-swap! chaos thunk)
(thunk))])
(thunk))
(define (chaos-stop! c)
(void))])
(provide
gen:chaos
(contract-out
[chaos? (-> any/c boolean?)]
[chaos-start! (-> chaos? any)]
[chaos-yield (-> chaos? evt? any)]
[chaos-event (-> chaos? evt?)]
[chaos-output! (-> chaos? any/c any)]
[chaos-label! (-> chaos? string? any)]
[chaos-swap! (-> chaos? (-> any) any)]))
[chaos-swap! (-> chaos? (-> any) any)]
[chaos-stop! (-> chaos? any)]))

25
chaos/gui.rkt
View File

@ -6,7 +6,7 @@
racket/async-channel
lux/chaos)
(struct gui (depth-box event-ch drawer frame refresh!)
(struct gui (event-ch drawer frame refresh!)
#:methods gen:chaos
[(define (chaos-yield c e)
(yield e))
@ -18,16 +18,11 @@
((gui-refresh! c)))
(define (chaos-label! c l)
(send (gui-frame c) set-label l))
(define (chaos-swap! c t)
(define db (gui-depth-box c))
(define og (unbox db))
(set-box! db (add1 og))
(begin0 (t)
(if (zero? og)
(send (gui-frame c) show #f)
(set-box! db og))))])
(define (chaos-stop! c)
(send (gui-frame c) show #f))])
(define (make-gui #:mode [mode 'draw]
#:start-fullscreen? [start-fullscreen? #f]
#:icon [icon #f]
#:width [init-w 800]
#:height [init-h 600])
@ -65,13 +60,15 @@
(new gl-config%)]
['gl-core
(define gl-config (new gl-config%))
(send gl-config set-legacy? #f)]
(send gl-config set-legacy? #f)
gl-config]
[gl-config
gl-config]))
(define c
(new canvas% [parent f]
[paint-callback paint-canvas]
[gl-config gl-config]
[style
(cons 'no-autoclear
(if gl-config '(gl) '()))]))
@ -80,6 +77,8 @@
(send f center)
(send f show #t)
(when start-fullscreen?
(send f fullscreen #t))
(when icon
(define icon-bm
@ -90,9 +89,7 @@
((dynamic-require 'drracket/private/dock-icon 'set-dock-tile-bitmap)
icon-bm)))
(define depth-box (box 0))
(gui depth-box events-ch drawer f refresh!))
(gui events-ch drawer f refresh!))
(provide
(contract-out
@ -101,6 +98,8 @@
(#:mode
(or/c (one-of/c 'draw 'gl-compat 'gl-core)
(is-a?/c gl-config%))
#:start-fullscreen?
boolean?
#:icon
(or/c #f path-string? (is-a?/c bitmap%))
#:width

14
chaos/pair.rkt
View File

@ -7,11 +7,17 @@
(struct pair (l r)
#:methods gen:chaos
[(define/generic super-yield chaos-yield)
[(define/generic super-start! chaos-start!)
(define/generic super-yield chaos-yield)
(define/generic super-event chaos-event)
(define/generic super-output! chaos-output!)
(define/generic super-label! chaos-label!)
(define/generic super-swap! chaos-swap!)
(define/generic super-stop! chaos-stop!)
(define (chaos-start! c)
(match-define (pair l r) c)
(super-start! l)
(super-start! r))
(define (chaos-yield c e)
(match-define (pair l r) c)
(super-yield l
@ -33,7 +39,11 @@
(super-label! r lab))
(define (chaos-swap! c t)
(match-define (pair l r) c)
(super-swap! l (λ () (super-swap! r t))))])
(super-swap! l (λ () (super-swap! r t))))
(define (chaos-stop! c)
(match-define (pair l r) c)
(super-stop! l)
(super-stop! r))])
(define (make-pair l r)
(pair l r))

15
scribblings/lux.scrbl
View File

@ -124,6 +124,8 @@ This module provides the standard @tech{chaos} that most users of
@defproc[(make-gui [#:mode mode (or/c (one-of/c 'draw 'gl-compat 'gl-core)
(is-a?/c gl-config%))
'draw]
[#:start-fullscreen? start-fullscreen? boolean?
#f]
[#:icon icon
(or/c #f path-string? (is-a?/c bitmap%))
#f]
@ -138,7 +140,8 @@ This module provides the standard @tech{chaos} that most users of
Returns a @tech{chaos} that opens a GUI frame with a canvas to draw
on. The default size of the frame is
@racket[width]x@racket[height]. The icon for the application is set to
@racket[icon].
@racket[icon]. If @racket[start-fullscreen?] is true, then the frame
is initially fullscreen.
The canvas is set up for drawing based on @racket[mode]. If
@racket[mode] is @racket['draw], then the canvas assumes that
@ -280,6 +283,11 @@ The generic interface binding for @tech{chaos}es.}
The @tech{chaos} methods are as follows:
@defproc[(chaos-start! [c chaos?]) any]{
Called at the start of using @racket[c] as the current
@tech{chaos}. By default, does nothing.}
@defproc[(chaos-yield [c chaos?] [e evt?]) any]{
Synchronizes on @racket[e] in a way safe for @racket[c]. By default,
@ -304,3 +312,8 @@ nothing.}
Calls @racket[t] while preparing @racket[c] to run a different
@tech{word}. By default, just calls @racket[t].}
@defproc[(chaos-stop! [c chaos?]) any]{
Called at the end of using @racket[c] as the current @tech{chaos}. By
default, does nothing.}

4
word.rkt
View File

@ -40,8 +40,10 @@
(define current-chaos (make-parameter #f))
(define (call-with-chaos c t)
(chaos-start! c)
(parameterize ([current-chaos c])
(t)))
(begin0 (t)
(chaos-stop! c))))
(define (fiat-lux w)
(define c (current-chaos))