Add a bunch of window manipulation procedures.

1 files changed, 108 insertions, 19 deletions

diff --git a/chickadee.scm b/chickadee.scm
index 58513d4..8250e19 100644
--- a/chickadee.scm
+++ b/chickadee.scm
@@ -22,15 +22,6 @@
 ;;; Code:
 
 (define-module (chickadee)
-  #:use-module (sdl2)
-  #:use-module (sdl2 events)
-  #:use-module ((sdl2 input game-controller) #:prefix sdl2:)
-  #:use-module (sdl2 input joystick)
-  #:use-module ((sdl2 input keyboard) #:prefix sdl2:)
-  #:use-module ((sdl2 input mouse) #:prefix sdl2:)
-  #:use-module (sdl2 input text)
-  #:use-module (sdl2 mixer)
-  #:use-module (sdl2 video)
   #:use-module (chickadee config)
   #:use-module (chickadee game-loop)
   #:use-module (chickadee math matrix)
@@ -40,7 +31,35 @@
   #:use-module (chickadee render gpu)
   #:use-module (chickadee render viewport)
   #:use-module (chickadee utils)
+  #:use-module (ice-9 match)
+  #:use-module (sdl2)
+  #:use-module (sdl2 events)
+  #:use-module ((sdl2 input game-controller) #:prefix sdl2:)
+  #:use-module (sdl2 input joystick)
+  #:use-module ((sdl2 input keyboard) #:prefix sdl2:)
+  #:use-module ((sdl2 input mouse) #:prefix sdl2:)
+  #:use-module (sdl2 input text)
+  #:use-module (sdl2 mixer)
+  #:use-module ((sdl2 video) #:prefix sdl2:)
+  #:use-module (srfi srfi-9)
   #:export (current-window
+            window?
+            window-width
+            window-height
+            window-x
+            window-y
+            window-title
+            hide-window!
+            show-window!
+            maximize-window!
+            minimize-window!
+            raise-window!
+            restore-window!
+            set-window-border!
+            set-window-title!
+            set-window-size!
+            set-window-position!
+            set-window-fullscreen!
             controller-button-pressed?
             controller-axis
             controller-name
@@ -111,8 +130,78 @@ not being pushed at all."
    (lambda (controller)
      (sdl2:game-controller-name controller))))
 
+(define-record-type <window>
+  (wrap-sdl-window sdl-window)
+  window?
+  (sdl-window unwrap-window))
+
 (define current-window (make-parameter #f))
 
+(define-syntax-rule (define-window-wrapper (name args ...) sdl-proc docstring)
+  (define (name window args ...)
+    docstring
+    (sdl-proc (unwrap-window window) args ...)))
+
+(define-window-wrapper (window-title) sdl2:window-title
+  "Return the title of WINDOW.")
+
+(define-window-wrapper (hide-window!) sdl2:hide-window!
+  "Hide WINDOW.")
+
+(define-window-wrapper (show-window!) sdl2:show-window!
+  "Show WINDOW.")
+
+(define-window-wrapper (maximize-window!) sdl2:maximize-window!
+  "Maximize WINDOW.")
+
+(define-window-wrapper (minimize-window!) sdl2:minimize-window!
+  "Minimize WINDOW.")
+
+(define-window-wrapper (raise-window!) sdl2:raise-window!
+  "Make WINDOW visible over all other windows.")
+
+(define-window-wrapper (restore-window!) sdl2:restore-window!
+  "Restore the size and position of a minimized or maximized WINDOW.")
+
+(define-window-wrapper (set-window-border! border?) sdl2:set-window-border!
+  "Enable/disable the border around WINDOW.  If BORDER? is #f, the
+border is disabled, otherwise it is enabled.")
+
+(define-window-wrapper (set-window-title! title) sdl2:set-window-title!
+  "Set the title of WINDOW to TITLE.")
+
+(define-window-wrapper (set-window-fullscreen! fullscreen?) sdl2:set-window-fullscreen!
+  "Enable or disable fullscreen mode for WINDOW.  If FULLSCREEN? is
+#f, fullscreen mode is disabled, otherwise it is enabled.")
+
+(define (window-width window)
+  "Return the width of WINDOW."
+  (match (sdl2:window-size (unwrap-window window))
+    ((x _) x)))
+
+(define (window-height window)
+  "Return the height of WINDOW."
+  (match (sdl2:window-size (unwrap-window window))
+    ((_ y) y)))
+
+(define (window-x window)
+  "Return the X coordinate of the upper-left corner of WINDOW."
+  (match (sdl2:window-position (unwrap-window window))
+    ((x _) x)))
+
+(define (window-y window)
+  "Return the Y coordinate of the upper-left corner of WINDOW."
+  (match (sdl2:window-position (unwrap-window window))
+    ((_ y) y)))
+
+(define (set-window-size! window width height)
+  "Change the dimensions of WINDOW to WIDTH x HEIGHT pixels."
+  (sdl2:set-window-size! (unwrap-window window) (list width height)))
+
+(define (set-window-position! window x y)
+  "Move the upper-left corner of WINDOW to pixel coordinates (X, Y)."
+  (sdl2:set-window-position! (unwrap-window window) (list x y)))
+
 (define* (run-game #:key
                    (window-title "Chickadee!")
                    (window-width 640)
@@ -139,11 +228,11 @@ not being pushed at all."
   (false-if-exception (mixer-init))
   (open-audio)
   (start-text-input)
-  (let* ((window (make-window #:opengl? #t
-                              #:title window-title
-                              #:size (list window-width window-height)
-                              #:fullscreen? window-fullscreen?))
-         (gl-context (make-gl-context window))
+  (let* ((window (sdl2:make-window #:opengl? #t
+                                   #:title window-title
+                                   #:size (list window-width window-height)
+                                   #:fullscreen? window-fullscreen?))
+         (gl-context (sdl2:make-gl-context window))
          (gpu (make-gpu gl-context))
          (default-viewport (make-viewport 0 0 window-width window-height))
          (default-projection (orthographic-projection 0 window-width
@@ -226,17 +315,17 @@ not being pushed at all."
       (with-viewport default-viewport
         (with-projection default-projection
           (draw alpha)))
-      (swap-gl-window window))
+      (sdl2:swap-gl-window window))
     (dynamic-wind
       (const #t)
       (lambda ()
-        (parameterize ((current-window window)
+        (parameterize ((current-window (wrap-sdl-window window))
                        (current-gpu gpu))
           ;; Attempt to activate vsync, if possible.  Some systems do
           ;; not support setting the OpenGL swap interval.
           (catch #t
             (lambda ()
-              (set-gl-swap-interval! 'vsync))
+              (sdl2:set-gl-swap-interval! 'vsync))
             (lambda args
               (display "warning: could not enable vsync\n"
                        (current-error-port))))
@@ -249,5 +338,5 @@ not being pushed at all."
                      #:time sdl-ticks
                      #:update-hz update-hz)))
       (lambda ()
-        (delete-gl-context! gl-context)
-        (close-window! window)))))
+        (sdl2:delete-gl-context! gl-context)
+        (sdl2:close-window! window)))))