;;; SPDX-License-Identifier: LGPL-3.0-or-later
;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>

#lang syndicate

(provide (struct-out window)
         (struct-out frame-event)
         (struct-out key-event)
         (struct-out key-pressed)
         (struct-out mouse-event)
         (struct-out mouse-state)
         (struct-out touching)
         (struct-out coordinate-map)
         (struct-out scene)
         (except-out (struct-out sprite) sprite)
         (rename-out [sprite <sprite>] [make-sprite sprite])
         (struct-out gl-control)
         in-unit-circle?
         in-unit-square?
         simple-sprite
         assert-scene
         spawn-keyboard-integrator
         spawn-mouse-integrator
         spawn-gl-2d-driver)

(require data/order)
(require data/splay-tree)
(require data/queue)
(require sgl/gl)
(require sgl/gl-vectors)

(require racket/gui/base)
(require racket/dict)
(require (only-in racket/class
                  send is-a? make-object class class* inherit this new super-new init
                  define/public define/override define/augment))
(require (only-in racket/math sqr))

(require (prefix-in image: 2htdp/image))
(require (prefix-in pict: pict))

(require syndicate/drivers/gl-2d/texture)
(require syndicate/drivers/gl-2d/affine)

(require/activate syndicate/drivers/timer)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; Shared state maintained by dataspace. Describes current window dimensions.
(assertion-struct window (width height))

;; Message sent by dataspace. Describes render time.
(message-struct frame-event (counter timestamp elapsed-ms target-frame-rate))

;; Message sent by dataspace. Describes a key event. Key is a sealed
;; key-event%. `press?` is #t when the key is pressed (or
;; autorepeated!), and #f when it is released.
(message-struct key-event (code press? key))

;; Assertion. Indicates that the named key is held down. See role
;; KeyboardIntegrator and spawn-keyboard-integrator.
(assertion-struct key-pressed (code))

;; Message sent by dataspace. Describes a mouse event. State is a
;; MouseState.
(message-struct mouse-event (type state))

;; Assertion. Indicates that the mouse is in a particular state. See
;; role MouseIntegrator and spawn-mouse-integrator.
(assertion-struct mouse-state (x y left-down? middle-down? right-down?))

;; Assertion. Indicates that the mouse is touching a particular touchable.
(assertion-struct touching (id))

;; Assertion. Communicates aggregate device-to-user transformation
;; requested as part of sprite instruction sequences.
(assertion-struct coordinate-map (id matrix))

;; Shared state maintained by program. Prelude and postlude are to be
;; sealed instruction lists. It is an error to have more than exactly
;; one active such record at a given time.
(assertion-struct scene (prelude postlude))

;; A SpriteID is an equal?-comparable dataspace-unique value.

;; Shared state maintained by program. `id` is a SpriteID, and
;; `parent-id` is an (Option SpriteID); #f in `parent-id` means that
;; this sprite is a child of the root. Z is to be a number, negative
;; toward camera. Instructions to be a sealed instruction list.
(assertion-struct sprite (id parent-id z instructions))

;; Message and assertion.
;;
;; When sent as a message with `body` of `'stop`, closes the GL window
;; and terminates the driver.
;;
;; When asserted with `body` of `'fullscreen`, causes the window to be
;; fullscreen; otherwise, it is a normal window.
;;
(assertion-struct gl-control (body))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define-syntax-rule (assert-scene prelude postlude)
  (assert (scene (seal prelude) (seal postlude))))

(define (make-sprite z instructions #:id [id #f] #:parent [parent-id #f])
  (sprite (or id (gensym 'sprite)) parent-id z (seal instructions)))

(define (in-unit-circle? x y)
  (<= (+ (sqr (- x 0.5)) (sqr (- y 0.5))) (sqr 0.5)))

(define (in-unit-square? x y)
  (and (<= 0 x 1)
       (<= 0 y 1)))

(define (simple-sprite z x y w h i
                       #:parent [parent-id #f]
                       #:rotation [rotation 0]
                       #:coordinate-map-id [coordinate-map-id #f]
                       #:touchable-id [touchable-id #f]
                       #:touchable-predicate [touchable-predicate in-unit-square?])
  (make-sprite #:id touchable-id
               #:parent parent-id
               z
               `((translate ,x ,y)
                 ,@(if (zero? rotation) `() `((rotate ,rotation)))
                 (push-matrix
                  (scale ,w ,h)
                  ,@(if touchable-id
                        `((touchable ,touchable-id ,touchable-predicate))
                        `())
                  (texture ,i))
                 ,@(if coordinate-map-id
                       `((coordinate-map ,coordinate-map-id))
                       `())
                 (render-children))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; KeyboardIntegrator. Integrates key-events into key-pressed assertions.
(define (spawn-keyboard-integrator)
  (spawn #:name 'gl-2d/keyboard-integratpr
         (local-require racket/set)
         (define keys-pressed (mutable-set))
         ;; TODO: consider adding set-semantics assert!/retract! API for this kind of thing
         (on (message (key-event $code #t _))
             (unless (set-member? keys-pressed code)
               (set-add! keys-pressed code)
               (assert! (key-pressed code))))
         (on (message (key-event $code #f _))
             (when (set-member? keys-pressed code)
               (set-remove! keys-pressed code)
               (retract! (key-pressed code))))))

;; MouseIntegrator. Integrates mouse-events into mouse-state assertions.
(define (spawn-mouse-integrator)
  (spawn #:name 'gl-2d/mouse-integrator
         (field [in-bounds? #f] [state #f])
         (assert #:when (in-bounds?) (state))
         (on (message (mouse-event $type $new-state))
             (in-bounds? (not (eq? type 'leave)))
             (state new-state))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; A Touchable is one of
;;
;; - (touchable Any TransformationMatrix (Number Number -> Boolean))
;;   Represents a composed device-to-user transformation, plus a
;;   predicate on user coordinates, and an ID to use when the
;;   predicate answers truthily.
;;
;; - (touchable-map)
;;   Represents the location in a sequence of touchables where the
;;   aggregate partial device-to-user transformation used when mapping
;;   along parent-child relationship edges in the sprite tree should
;;   be applied to child sprites.
;;
(struct touchable (id transformation predicate) #:transparent)
(struct touchable-map () #:transparent)

;; A Children is a (SplayTree Sprite CompiledInstructions), ordered
;; first by sprite-z, then sprite-id hash code, then
;; sprite-instructions hash-code.
;;
;; A ChildMap is a (Hash SpriteID Children), mapping sprite-id to the
;; children of that sprite.

;; (compiled-instructions (ChildMap SpriteID -> Void)
;;                        (Listof Touchable)
;;                        (Listof CoordinateMap)
;;                        (Listof Resource)
;;                        (Option TransformationMatrix)
;;                        TransformationMatrix)
;; A single compiled sprite. The resources and coordinate-maps aren't
;; in any particular order, but the touchables are: the leftmost
;; touchable is the first to check; that is, it is the *topmost*
;; touchable in this sprite. The child-xform, if present, is the
;; transformation needed to map between mouse coordinates and child
;; sprite space; if absent, no (render-children) instruction was found
;; in this sprite's render code. The final-xform is the final
;; transformation after the render instructions have completed.
(struct compiled-instructions
  (render-proc touchables coordinate-maps resources child-xform final-xform))

(define-namespace-anchor ns-anchor)
(define ns (namespace-anchor->namespace ns-anchor))

(define (compile-instructions instrs)
  (define touchables '())
  (define coordinate-maps '())
  (define resources '())
  (define child-xform #f)

  (define (instructions->racket-code instrs xform)
    (define-values (code-rev new-xform)
      (for/fold [(code-rev '()) (xform xform)] [(instr (in-list instrs))]
        (define-values (new-code new-xform) (instruction->racket-code instr xform))
        (values (cons new-code code-rev) new-xform)))
    (let ((code (reverse code-rev)))
      (values (lambda (CHILDMAP SELF-ID)
                (for [(p (in-list code))]
                  (p CHILDMAP SELF-ID)))
              new-xform)))

  (define (instruction->racket-code instr xform)
    (match instr
      [`(rotate ,(? number? deg))
       (values (lambda (CHILDMAP SELF-ID) (glRotated deg 0 0 -1))
               (compose-transformation xform (rotation-transformation (- deg))))]
      [`(scale ,(? number? x) ,(? number? y))
       (values (lambda (CHILDMAP SELF-ID) (glScaled x y 1))
               (compose-transformation xform (stretching-transformation x y)))]
      [`(translate ,(? number? x) ,(? number? y))
       (values (lambda (CHILDMAP SELF-ID) (glTranslated x y 0))
               (compose-transformation xform (translation-transformation x y)))]
      [`(color ,(? color-number? r) ,(? color-number? g) ,(? color-number? b) ,(? color-number? a))
       (values (lambda (CHILDMAP SELF-ID) (glColor4d r g b a)) xform)]
      [`(texture ,i)
       (define entry (image->texture-cache-entry i))
       (define tex (send entry get-texture))
       (set! resources (cons entry resources))
       (values (lambda (CHILDMAP SELF-ID) (draw-gl-face tex)) xform)]
      [`(texture ,i ,l ,t ,w ,h) #:when (andmap number? (list l t w h))
       (define entry (image->texture-cache-entry i))
       (define tex (send entry get-texture))
       (set! resources (cons entry resources))
       (values (lambda (CHILDMAP SELF-ID) (draw-gl-face tex l t w h)) xform)]
      [`(touchable ,id ,predicate)
       (set! touchables (cons (touchable id xform predicate) touchables))
       (values void xform)]
      [`(coordinate-map ,id)
       (set! coordinate-maps (cons (coordinate-map id xform) coordinate-maps))
       (values void xform)]
      [`(push-matrix ,instr ...)
       (define-values (code _new-xform) (instructions->racket-code instr xform))
       (values (lambda (CHILDMAP SELF-ID)
                 (glPushMatrix)
                 (code CHILDMAP SELF-ID)
                 (glPopMatrix))
               xform)]
      [`(begin ,instr ...)
       (define-values (code new-xform) (instructions->racket-code instr xform))
       (values code new-xform)]
      [`(render-children) ;; we assume that there will only be one of these
       (set! child-xform xform)
       (set! touchables (cons (touchable-map) touchables))
       (values render-sprites! xform)]
      [other
       (error 'instruction->racket-code "unknown render instruction: ~v" other)]))

  (define-values (render-proc final-transformation)
    (instruction->racket-code `(begin ,@instrs) identity-transformation))
  (compiled-instructions render-proc
                         touchables
                         coordinate-maps
                         resources
                         child-xform
                         final-transformation))

(define empty-instructions (compile-instructions '()))

(define (compiled-instructions-dispose! i)
  (when i
    (for [(resource (in-list (compiled-instructions-resources i)))]
      (send resource dispose))))

(define (color-number? n)
  (and (number? n)
       (<= 0.0 n 1.0)))

(define (image->bitmap i)
  (cond
    [(is-a? i bitmap%)
     i]
    [(image:image? i)
     (define w (max 1 (image:image-width i)))
     (define h (max 1 (image:image-height i)))
     (define bm (make-object bitmap% w h #f #t))
     (define dc (send bm make-dc))
     (send i draw dc
           0 0
           0 0
           w h
           0 0
           #f)
     bm]
    [(pict:pict? i)
     (pict:pict->bitmap i)]
    [else
     (error 'image->bitmap "unsupported image type ~v" i)]))

(define (image->texture-cache-entry i)
  (texture-cache-get i image->bitmap))

;; (define (lerp a b v) (+ (* v a) (* (- 1 v) b)))

(define (draw-gl-face texture [left 0] [top 0] [width 1] [height 1])
  (define bot (+ top height))
  (define right (+ left width))
  (send texture bind-texture)
  (glBegin GL_QUADS)
  (glNormal3d 0 0 -1)
  (glTexCoord2d left top)
  (glVertex3d 0 0 0)
  (glTexCoord2d right top)
  (glVertex3d 1 0 0)
  (glTexCoord2d right bot)
  (glVertex3d 1 1 0)
  (glTexCoord2d left bot)
  (glVertex3d 0 1 0)
  (glEnd))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define sprite-order
  (order 'sprite-order
         sprite?
         (lambda (a b) (and (equal? (sprite-id a) (sprite-id b))
                            (= (sprite-z a) (sprite-z b))
                            (eq? (sprite-instructions a)
                                 (sprite-instructions b))))
         (lambda (a b) (or (> (sprite-z a) (sprite-z b))
                           (and (= (sprite-z a) (sprite-z b))
                                (let ((a-id-code (equal-hash-code (sprite-id a)))
                                      (b-id-code (equal-hash-code (sprite-id b))))
                                  (or (< a-id-code b-id-code)
                                      (and (= a-id-code b-id-code)
                                           (< (eq-hash-code (sprite-instructions a))
                                              (eq-hash-code (sprite-instructions b)))))))))))

(define (remove-sprite! childmap s)
  (define sprites (hash-ref childmap (sprite-parent-id s) #f))
  (when sprites
    (compiled-instructions-dispose! (splay-tree-ref sprites s #f))
    (splay-tree-remove! sprites s)
    (when (dict-empty? sprites) (hash-remove! childmap (sprite-parent-id s)))))

(define (add-sprite! childmap s)
  (define sprites (hash-ref childmap (sprite-parent-id s)
                            (lambda ()
                              (define ss (make-splay-tree sprite-order))
                              (hash-set! childmap (sprite-parent-id s) ss)
                              ss)))
  (define instrs `((color 1 1 1 1)
                   (push-matrix ,@(seal-contents (sprite-instructions s)))))
  (define i (compile-instructions instrs))
  (splay-tree-set! sprites s i))

(define (for-each-child-sprite childmap id f)
  (define children (hash-ref childmap id #f))
  (let loop ((iter (and children (splay-tree-iterate-first children))))
    (when iter
      (define s (splay-tree-iterate-key children iter))
      (define ci (splay-tree-iterate-value children iter))
      (f s ci)
      (loop (splay-tree-iterate-next children iter)))))

(define (render-sprites! childmap self-id)
  (for-each-child-sprite childmap self-id
                         (lambda (s ci)
                           ((compiled-instructions-render-proc ci) childmap (sprite-id s)))))

(define (render-scene! prelude childmap postlude)
  ((compiled-instructions-render-proc prelude) childmap #f)
  (render-sprites! childmap #f)
  ((compiled-instructions-render-proc postlude) childmap #f))

(define (detect-touch prelude childmap postlude state)
  (and state
       (let ()
         (define x (mouse-state-x state))
         (define y (mouse-state-y state))
         (or (detect-touch* childmap #f postlude x y)
             (detect-sprites-touch childmap #f x y)
             (detect-touch* childmap #f prelude x y)))))

(define (detect-sprites-touch childmap self-id x y)
  (define sprites (hash-ref childmap self-id #f))
  (let loop ((iter (and sprites (splay-tree-iterate-greatest sprites))))
    (and iter
         (let ((s (splay-tree-iterate-key sprites iter)))
           (define ci (splay-tree-iterate-value sprites iter))
           (or (detect-touch* childmap (sprite-id s) ci x y)
               (loop (splay-tree-iterate-greatest/<? sprites s)))))))

(define (detect-touch* childmap self-id ci x y)
  (for/or [(t (in-list (compiled-instructions-touchables ci)))]
    (match t
      [(touchable id xform contains?)
       (define-values (ux uy) (untransform-point* xform x y))
       (and (contains? ux uy) (touching id))]
      [(touchable-map)
       (define xform (compiled-instructions-child-xform ci))
       (define-values (ux uy) (untransform-point* xform x y))
       (detect-sprites-touch childmap self-id ux uy)])))

(define (untransform-point* xform x y)
  (define p (untransform-point xform (make-rectangular x y)))
  (values (real-part p) (imag-part p)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define dataspace-frame%
  (class* frame% ()
    (init ground-ch)
    (super-new)
    (define (stop!)
      (parameterize ((current-ground-event-async-channel ground-ch))
        (ground-send! (gl-control 'stop))))
    (define/augment (on-close) (stop!))))

(define dataspace-canvas%
  (class canvas%
    (inherit refresh with-gl-context swap-gl-buffers)

    (init [(eventspace0 eventspace)])
    (init ground-ch)

    (define eventspace eventspace0)

    (define (! msg)
      (parameterize ((current-ground-event-async-channel ground-ch))
        (ground-send! msg)))

    (define (++ assertion)
      (parameterize ((current-ground-event-async-channel ground-ch))
        (ground-assert! assertion)))

    (define (-- assertion)
      (parameterize ((current-ground-event-async-channel ground-ch))
        (ground-retract! assertion)))

    ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

    (define initialised? #f)

    (define near-depth 10) ;; 2.5D
    (define far-depth 15) ;; 2.5D

    (define prelude empty-instructions)
    (define childmap (make-hash))
    (define postlude empty-instructions)

    (define current-window-width #f)
    (define current-window-height #f)
    (define current-mouse-state #f)
    (define current-coordinate-maps (hash))
    (define current-touching #f)

    (define render-needed? #t)

    ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

    (define (mark-dirty!)
      (when (not render-needed?)
        (parameterize ((current-eventspace eventspace))
          (queue-callback (lambda () (refresh)))))
      (set! render-needed? #t))

    (define/public (replace-scene! new-prelude new-postlude)
      (with-gl-context
        (lambda ()
          (compiled-instructions-dispose! prelude)
          (compiled-instructions-dispose! postlude)
          (set! prelude (compile-instructions new-prelude))
          (set! postlude (compile-instructions new-postlude)))))

    (define/public (alter-sprites! changes)
      (with-gl-context
        (lambda ()
          (for [(change (in-list changes))]
            (match change
              [(cons '+ s) (add-sprite! childmap s)]
              [(cons '- s) (remove-sprite! childmap s)]))
          (mark-dirty!))))

    (define/public (initialize!)
      (unless initialised?
        (with-gl-context
          (lambda ()
            (glBlendFunc GL_ONE GL_ONE_MINUS_SRC_ALPHA) ;; premultiplied
            (glEnable GL_BLEND)
            (glEnable GL_TEXTURE_2D)
            (glClearColor 0 0 0 1)
            (set! initialised? #t)))))

    ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

    (define/override (on-paint)
      (initialize!)

      (with-gl-context
        (lambda ()
          (update-touching!)
          (update-coordinate-maps!)
          (flush-texture-cache!)

          (glClear GL_COLOR_BUFFER_BIT)
          (glLoadIdentity)
          (glTranslated 0 0 (- near-depth))
          (render-scene! prelude childmap postlude)
          (glFlush)
          (swap-gl-buffers)

          (set! render-needed? #f))))

    (define/override (on-size width height)
      (with-gl-context
        (lambda ()
          (when (not (and (equal? current-window-width width)
                          (equal? current-window-height height)))
            (-- (window current-window-width current-window-height))
            (set! current-window-width width)
            (set! current-window-height height)
            (++ (window current-window-width current-window-height)))
          (glViewport 0 0 width height)
          (glMatrixMode GL_PROJECTION)
          (glLoadIdentity)
          (glOrtho 0 width height 0 0.1 100)
          (glMatrixMode GL_MODELVIEW)
          (glLoadIdentity)
          (mark-dirty!))))

    (define/override (on-char key)
      (with-gl-context
        (lambda ()
          (! (match (send key get-key-code)
               ['release (key-event (send key get-key-release-code) #f (seal key))]
               [code     (key-event code                            #t (seal key))])))))

    (define/override (on-event mouse)
      (with-gl-context
        (lambda ()
          (define-values (x y)
            (untransform-point* (compiled-instructions-final-xform prelude)
                                (send mouse get-x)
                                (send mouse get-y)))
          (define s (mouse-state x
                                 y
                                 (send mouse get-left-down)
                                 (send mouse get-middle-down)
                                 (send mouse get-right-down)))
          (set! current-mouse-state s)
          (update-touching!)
          (! (mouse-event (send mouse get-event-type) s)))))

    (define (update-touching!)
      (define new-touching (detect-touch prelude childmap postlude current-mouse-state))
      (when (not (equal? current-touching new-touching))
        (when current-touching (-- current-touching))
        (set! current-touching new-touching)
        (when current-touching (++ current-touching))))

    (define (update-coordinate-maps!)
      (define (update-single-map! cmid cmx)
        (define existing (hash-ref current-coordinate-maps cmid #f))
        (define proposed (coordinate-map cmid cmx))
        (when (not (equal? existing proposed))
          (set! current-coordinate-maps (hash-set current-coordinate-maps cmid proposed))
          (-- existing)
          (++ proposed)))

      (let process-children-of ((id #f) (xform identity-transformation))
        (for-each-child-sprite childmap id
                               (lambda (s ci)
                                 (for [(cm (in-list (compiled-instructions-coordinate-maps ci)))]
                                   (match-define (coordinate-map cmid cmx) cm)
                                   (update-single-map! cmid (compose-transformation xform cmx)))
                                 (define child-xform (compiled-instructions-child-xform ci))
                                 (when child-xform
                                   (process-children-of (sprite-id s)
                                                        (compose-transformation xform
                                                                                child-xform)))))))

    (super-new (style '(gl no-autoclear)))))

(define (spawn-gl-2d-driver #:label [frame-label "syndicate-gl"]
                            #:width [width #f]
                            #:height [height #f])
  (spawn #:name 'gl-2d/driver
         (define frame #f) ;; "frame" here refers to *window frame* onscreen, i.e. GUI, not GL
         (define c #f)

         (parameterize ((current-eventspace (make-eventspace)))
           (set! frame (new dataspace-frame%
                            [style '(fullscreen-button)]
                            [label frame-label]
                            [width (or width 640)]
                            [height (or height 480)]
                            [ground-ch (current-ground-event-async-channel)]))
           (set! c (new dataspace-canvas%
                        [parent frame]
                        [eventspace (current-eventspace)]
                        [ground-ch (current-ground-event-async-channel)]))
           (unless (send (send (send c get-dc) get-gl-context) ok?)
             (error 'gl-2d "OpenGL context failed to initialize"))
           (send c focus)
           (send frame show #t))

         (define start-time (current-inexact-milliseconds))
         (define frame-counter 0)
         (define target-frame-rate 60)
         (define changes '())
         (define dirty? #f)

         (field [sim-time 0])

         (on (asserted (later-than (+ (sim-time) start-time)))
             (define per-frame-ms (* (/ target-frame-rate) 1000.0))
             (send! (frame-event frame-counter (sim-time) per-frame-ms target-frame-rate))
             (set! frame-counter (+ frame-counter 1))
             (sim-time (* frame-counter per-frame-ms))
             (when dirty?
               (send c alter-sprites! (reverse changes))
               (set! changes '())
               (set! dirty? #f)))

         ;; TODO: maybe add a means of setting target frame rate?
         ;; (define/public (set-target-frame-rate! r)
         ;;   (set! target-frame-rate r))

         (on (asserted (scene $sealed-prelude $sealed-postlude))
             (send c replace-scene!
                   (seal-contents sealed-prelude)
                   (seal-contents sealed-postlude))
             (set! dirty? #t))

         (on (retracted ($ s (sprite _ _ _ _)))
             (set! changes (cons (cons '- s) changes))
             (set! dirty? #t))
         (on (asserted ($ s (sprite _ _ _ _)))
             (set! changes (cons (cons '+ s) changes))
             (set! dirty? #t))

         (on (message (gl-control 'stop))
             (send frame show #f)
             (stop-current-facet))

         (during (gl-control 'fullscreen)
           (on-start (send frame fullscreen #t))
           (on-stop  (send frame fullscreen #f)))

         ))