Updating chaos interface

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)]))

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 (chaos-stop! c)
-           (define db (gui-depth-box c))
+           (send (gui-frame c) show #f))])
-           (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 (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 events-ch drawer f refresh!))
-
-  (gui depth-box 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

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))

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.}

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))