From 419bd093d185b78b425a61170942c3b1f5a339f8 Mon Sep 17 00:00:00 2001
From: Tony Garnock-Jones <tonygarnockjones@gmail.com>
Date: Thu, 25 Apr 2019 12:58:30 +0100
Subject: [PATCH] Support transformations (e.g. rotation) in the scene prelude

---
 syndicate/drivers/gl-2d.rkt    | 18 ++++++++++++------
 syndicate/examples/gui/gui.rkt | 15 ++++++++++++---
 2 files changed, 24 insertions(+), 9 deletions(-)

diff --git a/syndicate/drivers/gl-2d.rkt b/syndicate/drivers/gl-2d.rkt
index f3cdccd..595d8e6 100644
--- a/syndicate/drivers/gl-2d.rkt
+++ b/syndicate/drivers/gl-2d.rkt
@@ -188,15 +188,18 @@
 ;;                        (Listof Touchable)
 ;;                        (Listof CoordinateMap)
 ;;                        (Listof Resource)
-;;                        (Option TransformationMatrix))
+;;                        (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.
-(struct compiled-instructions (render-proc touchables coordinate-maps resources child-xform))
+;; 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))
@@ -270,7 +273,8 @@
                          touchables
                          coordinate-maps
                          resources
-                         child-xform))
+                         child-xform
+                         final-transformation))
 
 ;; (define (compile-instructions instrs)
 ;;   (define touchables '())
@@ -608,8 +612,10 @@
     (define/override (on-event mouse)
       (with-gl-context
         (lambda ()
-          (define x (send mouse get-x))
-          (define y (send mouse get-y))
+          (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)
diff --git a/syndicate/examples/gui/gui.rkt b/syndicate/examples/gui/gui.rkt
index fe7f2d0..880c0c7 100644
--- a/syndicate/examples/gui/gui.rkt
+++ b/syndicate/examples/gui/gui.rkt
@@ -102,8 +102,14 @@
        (define/query-value touching? #f (touching 'root) #t)
        (on #:when (touching?) (message (mouse-event 'right-down (mouse-state $x $y _ _ _)))
            (send! (pop-up-menu-trigger 'system-menu x y 0 0.5 'right-up)))
+       ;; (during (window $width $height)
+       ;;   (assert-scene `((translate ,width 0) (rotate -90)) `())
+       ;;   (assert (desktop height width))
+       ;;   (assert (c 0 (rectangle 0 0 height width))))
        (during (window $width $height)
-         (assert (c 0 (rectangle 0 0 width height)))))
+         (assert (desktop width height))
+         (assert (c 0 (rectangle 0 0 width height))))
+       )
 
 (define (button-underlay i)
   (define w (+ (*width i) (theme-button-x-padding)))
@@ -172,6 +178,9 @@
                          size
                          rectangle) #:transparent)
 
+;; ASSERTION. Describes the size of the desktop area.
+(struct desktop (width height) #:transparent)
+
 ;;---------------------------------------------------------------------------
 
 (struct layout-item (spec size) #:transparent)
@@ -528,7 +537,7 @@
        (assert (menu-item/text 'testmenu 1 "Second item" '(testmenu second)))
        (assert (menu-item/text 'testmenu 2 "Third item" '(testmenu third)))
 
-       (during (window $width $height)
+       (during (desktop $width $height)
          (on (message `(testmenu ,$which))
              (define box-id (gensym 'box))
              (message-box #:id box-id
@@ -568,7 +577,7 @@
 (spawn #:name 'toolbar
 
        (field [window-width 0] [window-height 0])
-       (on (asserted (window $w $h))
+       (on (asserted (desktop $w $h))
            (window-width w)
            (window-height h))