From fd7d1512bc350e57f5bc592cd5df3d68abf0b4e0 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Wed, 26 Nov 2014 17:21:55 -0500 Subject: [PATCH] Updating chaos interface --- chaos.rkt | 14 +++++++++++--- chaos/gui.rkt | 25 ++++++++++++------------- chaos/pair.rkt | 14 ++++++++++++-- scribblings/lux.scrbl | 15 ++++++++++++++- word.rkt | 4 +++- 5 files changed, 52 insertions(+), 20 deletions(-) diff --git a/chaos.rkt b/chaos.rkt index b68d85a..1a3b867 100644 --- a/chaos.rkt +++ b/chaos.rkt @@ -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)])) diff --git a/chaos/gui.rkt b/chaos/gui.rkt index 6854db2..1c52a88 100644 --- a/chaos/gui.rkt +++ b/chaos/gui.rkt @@ -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 diff --git a/chaos/pair.rkt b/chaos/pair.rkt index 143257a..da7e199 100644 --- a/chaos/pair.rkt +++ b/chaos/pair.rkt @@ -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)) diff --git a/scribblings/lux.scrbl b/scribblings/lux.scrbl index e570fb1..fe0e51b 100644 --- a/scribblings/lux.scrbl +++ b/scribblings/lux.scrbl @@ -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.} diff --git a/word.rkt b/word.rkt index da5d662..06a0e60 100644 --- a/word.rkt +++ b/word.rkt @@ -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))