From: Matt Birkholz <matt@birkholz.chandler.az.us>
Date: Sun, 18 Sep 2011 23:06:49 +0000 (-0700)
Subject: Fixed resizing to small sizes.  Added parse-geometry.
X-Git-Tag: mit-scheme-pucked-9.2.12~366^2~91
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=43a90a758de6051f641f9c2800c83e07fdc3d8dc;p=mit-scheme.git

Fixed resizing to small sizes.  Added parse-geometry.

Settled on an init-size! that sets a small (arbitrary) minimum size.
---

diff --git a/src/gtk-screen/gtk-screen.pkg b/src/gtk-screen/gtk-screen.pkg
index f7fb70507..fe9a01aaf 100644
--- a/src/gtk-screen/gtk-screen.pkg
+++ b/src/gtk-screen/gtk-screen.pkg
@@ -136,10 +136,9 @@ USA.
 	  <gtk-vbox> gtk-vbox? gtk-vbox-new
 	  gtk-box-pack-end
 
-	  gtk-window-get-default-size
 	  gtk-window-new
 	  gtk-window-present
-	  gtk-window-set-default-size
+	  gtk-window-set-geometry-hints
 	  gtk-window-set-title
 	  gtk-window-set-opacity
 	  gtk-window-parse-geometry
diff --git a/src/gtk-screen/gtk-screen.scm b/src/gtk-screen/gtk-screen.scm
index db4d711cb..cba1bc9f5 100644
--- a/src/gtk-screen/gtk-screen.scm
+++ b/src/gtk-screen/gtk-screen.scm
@@ -122,67 +122,46 @@ USA.
 	  (set-gtk-screen-font! screen desc))
 	(set-gtk-widget-font! widget font))))
 
-;;; This procedure produces a tiny gtk-window!
-(define (new-init-size! screen)
-  ;; SETS the window default size to -1x-1.  (Leaving it there did not
-  ;; work!)  Does NOT depend on font(!).
-  (%trace ";   init-size! "screen"\n")
-  (let ((toplevel (gtk-screen-toplevel screen))
-	(x-size 80)
-	(y-size 24))
-    (gtk-window-get-default-size
-     toplevel
-     (lambda (w h)
-       (%trace ";     window default: "w"x"h"\n")))
-;;;    (let ((toplevel (gtk-screen-toplevel screen))
-;;;	  (width (x-size->width screen x-size))
-;;;	  (height (y-size->height screen y-size)))
-;;;      (gtk-window-set-default-size toplevel width height))
-    (gtk-window-set-default-size toplevel -1 -1)
-    (set-screen-x-size! screen x-size)
-    (set-screen-y-size! screen y-size)))
-
-(define (old-init-size! screen)
-  ;; Set initial x-size and y-size.  Depends on default font
-  ;; dimensions.  Needs to deal with gtk_window_parse/set_geometry
-  ;; maybe, someday...
-  (%trace ";   init-size! "screen"\n")
-  (let ((toplevel (gtk-screen-toplevel screen))
-	(x-size 83)
-	(y-size 27))
-    (gtk-window-get-default-size
-     toplevel
-     (lambda (w h)
-       (%trace ";     window default: "w"x"h"\n")
-       (let ((w* (if (not (fix:= w -1)) w (x-size->width screen x-size)))
-	     (h* (if (not (fix:= h -1)) h (y-size->height screen y-size))))
-	 (if (or (fix:= w -1) (fix:= h -1))
-	     (begin
-	       (%trace ";     set window default: "w*"x"h*"\n")
-	       (gtk-window-set-default-size toplevel w* h*)))
-	 ;; The widget allocation callback will not do this soon enough!
-	 (let ((x-size (width->x-size screen w*))
-	       (y-size (height->y-size screen h*)))
-	   (%trace ";     setting screen: "x-size"x"y-size"\n")
-	   (set-screen-x-size! screen x-size)
-	   (set-screen-y-size! screen y-size)))))))
-
 (define (init-size! screen geometry)
-  (declare (ignore geometry))
-  (%trace ";   init-size! "screen" 80x24\n")
-  ;; Just set the logical screen size.  This size sets window and
-  ;; widget sizes, which ultimately determine the GtkWindow size
-  ;; request.  Cannot set-screen-size! because there is no root window
-  ;; yet.  Must set screen size anyway; it is soon used by
-  ;; initialize-screen-root-window!.
-  (set-screen-x-size! screen 80)
-  (set-screen-y-size! screen 24)
-  (%trace ";   default size: "
-	 (gtk-window-get-default-size
-	  (gtk-screen-toplevel screen)
-	  (lambda (w h) (string-append
-			 (number->string w)"x"(number->string h))))
-	 "\n"))
+  (%trace ";   init-size! "screen" "geometry"\n")
+  ;; Sets the logical screen size.  This sets Edwin window and thus
+  ;; text-widget sizes, which ultimately determine the GtkWindow size
+  ;; request.  Sets a small (arbitrary) minimum size so that the luser
+  ;; can resize to a size smaller than the logical size.
+  (parse-geometry
+   geometry
+   (lambda (width height x y)
+     ;; Set-screen-size! will not work here.
+     (set-screen-x-size! screen width)
+     (set-screen-y-size! screen height)
+     (let ((toplevel (gtk-screen-toplevel screen)))
+       ;; This allows the luser to resize to smaller than the logical size.
+       (gtk-window-set-geometry-hints toplevel toplevel
+				      'min-width 100 'min-height 100)))))
+
+(define (parse-geometry geometry receiver)
+  (let* ((num "[0-9]+")
+	 (size-patt (string "\\("num"\\)x\\("num"\\)"))
+	 (position-patt (string "\\([-+]"num"\\)\\([-+]"num"\\)"))
+	 (extract (lambda (regs index)
+		    (string->number (re-match-extract geometry regs index)))))
+    (declare (integrate extract))
+    (cond ((re-string-match (string size-patt position-patt) geometry)
+	   => (lambda (regs)
+		(receiver (extract regs 1) (extract regs 2)
+			  (extract regs 3) (extract regs 4))))
+	  ((re-string-match position-patt geometry)
+	   => (lambda (regs)
+		(receiver #f #f
+			  (extract regs 1) (extract regs 2))))
+	  ((re-string-match size-patt geometry)
+	   => (lambda (regs)
+		(receiver (extract regs 1) (extract regs 2)
+			  #f #f)))
+	  (else
+	   (error:wrong-type-argument geometry
+				      "window geometry (e.g. \"80x40-0-0\")"
+				      'parse-geometry)))))
 
 (define (x-size->width screen x-size)
   (fix:* x-size (gtk-screen-char-width screen)))