From: Matt Birkholz <matt@birchwood-abbey.net>
Date: Thu, 7 Jun 2018 21:06:13 +0000 (-0700)
Subject: gl: Scale gl:viewport's dimensions per gdk_window_get_scale_factor.
X-Git-Tag: mit-scheme-pucked-gl-0.4~3
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=329a11c99f2d8b0b3c6c4937a6cdc66b5bbef714;p=mit-scheme.git

gl: Scale gl:viewport's dimensions per gdk_window_get_scale_factor.
---

diff --git a/src/gl/gl-glx.scm b/src/gl/gl-glx.scm
index 0b3e70d41..11de2df14 100644
--- a/src/gl/gl-glx.scm
+++ b/src/gl/gl-glx.scm
@@ -231,10 +231,12 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
 
 (define-method fix-widget-new-geometry-callback ((widget <glx-viewport>))
   (call-next-method widget)
-  (if (glx-widget-xwindow widget)
-      (let ((geometry (fix-widget-geometry widget)))
-	(let ((w (fix-rect-width geometry))
-	      (h (fix-rect-height geometry)))
+  (let ((xwindow (glx-widget-xwindow widget)))
+    (if xwindow
+	(let ((geometry (fix-widget-geometry widget))
+	      (scale (C-call "gdk_window_get_scale_factor" xwindow)))
+	(let ((w (fix:* scale (fix-rect-width geometry)))
+	      (h (fix:* scale (fix-rect-height geometry))))
 	  (let ((aspect (->flonum (/ w h))))
 	    (with-glx-widget widget
 	      (lambda ()
@@ -244,7 +246,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
 		(glu:perspective (glx-viewport-fovy widget)
 				 aspect
 				 (glx-viewport-near widget)
-				 (glx-viewport-far widget)))))))))
+				 (glx-viewport-far widget))))))))))
 
 (define (draw-callback widget cr)
   (declare (ignore cr))