From: Matt Birkholz <puck@birchwood-abbey.net>
Date: Sat, 30 Apr 2016 20:00:24 +0000 (-0700)
Subject: planetarium/terrain.scm (make-terrain): Take all args with keywords.
X-Git-Tag: mit-scheme-pucked-9.2.12~332
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=abc5c1a39367cf8fbabf5d99f27fa12fb971c802;p=mit-scheme.git

planetarium/terrain.scm (make-terrain): Take all args with keywords.
---

diff --git a/src/planetarium/mit-3d.pkg b/src/planetarium/mit-3d.pkg
index 5e51d9b1f..795563f7b 100644
--- a/src/planetarium/mit-3d.pkg
+++ b/src/planetarium/mit-3d.pkg
@@ -39,6 +39,7 @@ USA.
 	  burst-string read-line write-string ->namestring
 	  error:wrong-type-argument real? ->flonum symbol-name
 	  guarantee-list-of-type->length
+	  guarantee-procedure-of-arity guarantee-real
 	  universal-time->local-time-string
 	  define-class define-method initialize-instance
 	  system-global-environment
diff --git a/src/planetarium/mit-check.sh b/src/planetarium/mit-check.sh
index 22afb68f7..1c7b4b061 100755
--- a/src/planetarium/mit-check.sh
+++ b/src/planetarium/mit-check.sh
@@ -50,8 +50,10 @@ ${MIT_SCHEME_EXE} --prepend-library . <<\EOF
 		(if (not (file-exists? "sample-terrain.txt"))
 		    ((access write-sample-terrain env)
 		     "sample-terrain.txt" 20 20))
-		(let ((view (make-terrain "sample-terrain.txt"
-					  20 20 0. 0. .001)))
+		(let ((view (make-terrain 'filename "sample-terrain.txt"
+					  'rows 20 'columns 20
+					  'latitude 0. 'longitude 0.
+					  'step .001)))
 		  (view 'position -.01 0. 2000.)
 		  (view 'heading 25.)
 		  (view 'tilt -45.)))))
diff --git a/src/planetarium/terrain.scm b/src/planetarium/terrain.scm
index 5c6205b10..4d974d677 100644
--- a/src/planetarium/terrain.scm
+++ b/src/planetarium/terrain.scm
@@ -26,16 +26,15 @@ USA.
 
 (declare (integrate-external "geometry"))
 
-(define (make-terrain filename rows columns lat lng step color-function)
-  (let ((widget (%make-terrain filename rows columns
-			       lat lng step color-function)))
+(define (make-terrain . options)
+  (let ((widget (%make-terrain options)))
     (named-lambda (terrain command . args)
 
       (define (check-flonum-args num description)
 	(if (not (= num (guarantee-list-of-type->length
 			 args real? "a real number" 'TERRAIN)))
 	    (error (string-append
-		    "The "(symbol-name command)" command requires"
+		    "The "(symbol-name command)" command requires "
 		    (number->string num '(int))" arguments: "description"."))))
 
       (cond
@@ -71,27 +70,68 @@ USA.
        (else
 	(error:wrong-type-argument command "a command name" 'TERRAIN))))))
 
-(define (%make-terrain filename rows columns lat lng step color-function)
-  (let ((window (gtk-window-new 'toplevel))
-	(grid (gtk-grid-new))
-	(label (gtk-label-new ""))
-	(matrix (make-heightmap-matrix filename rows columns)))
-    (gtk-window-set-title window (string-append "Terrain: "
-						(->namestring filename)))
-    (gtk-container-set-border-width window 5)
-    (gtk-widget-set-hexpand label #t)
-    (let* ((min.max (matrix-min.max matrix rows columns))
-	   (widget (make-terrain-viewport
-		    matrix rows columns (car min.max) (cdr min.max)
-		    (make-latitude/longitude lat lng) step color-function
-		    label 300 300)))
-      (gtk-widget-set-vexpand widget #t)
-      (gtk-widget-set-hexpand widget #t)
-      (gtk-grid-attach grid widget 0 0 1 1)
-      (gtk-grid-attach grid label 0 1 1 1)
-      (gtk-container-add window grid)
-      (gtk-widget-show-all window)
-      widget)))
+(define (%make-terrain options)
+
+  (define (get-keyword-value klist key default)
+    (let loop ((klist klist))
+      (if (pair? klist)
+	  (if (eq? (car klist) key)
+	      (car (cdr klist))
+	      (loop (cdr (cdr klist))))
+	  default)))
+
+  (define no-value "<none>")
+
+  (define (get-flonum-option name)
+    (let ((v (get-keyword-value options name no-value)))
+      (guarantee-real v name)
+      (->flonum v)))
+
+  (define (get-integer-option name default)
+    (let ((v (get-keyword-value options name no-value)))
+      (if (eq? v no-value)
+	  default
+	  (begin
+	    (guarantee-integer v name)
+	    v))))
+
+  (let ((filename (get-keyword-value options 'filename #f))
+	(rows (get-integer-option 'rows #f))
+	(columns (get-integer-option 'columns #f))
+	(latitude (get-flonum-option 'latitude))
+	(longitude (get-flonum-option 'longitude))
+	(step (get-flonum-option 'step))
+	(color-function
+	 (let ((v (get-keyword-value options 'color-function #f)))
+	   (and v (begin
+		    (guarantee-procedure-of-arity
+		     v 3 'make-terrain:color-function)
+		    v))))
+	(width (get-integer-option 'width 300))
+	(height (get-integer-option 'height 300)))
+    (let ((matrix (make-heightmap-matrix filename rows columns))
+	  (origin (make-latitude/longitude latitude longitude))
+	  (title (if filename
+		     (string-append "Terrain: "(->namestring filename))
+		     "Terrain")))
+      (let ((window (gtk-window-new 'toplevel))
+	    (grid (gtk-grid-new))
+	    (label (gtk-label-new "")))
+	(gtk-window-set-title window title)
+	(gtk-container-set-border-width window 5)
+	(gtk-widget-set-hexpand label #t)
+	(let* ((min.max (matrix-min.max matrix rows columns))
+	       (widget (make-terrain-viewport
+			matrix rows columns (car min.max) (cdr min.max)
+			origin step color-function
+			label width height)))
+	  (gtk-widget-set-vexpand widget #t)
+	  (gtk-widget-set-hexpand widget #t)
+	  (gtk-grid-attach grid widget 0 0 1 1)
+	  (gtk-grid-attach grid label 0 1 1 1)
+	  (gtk-container-add window grid)
+	  (gtk-widget-show-all window)
+	  widget)))))
 
 (define-class (<terrain-viewport>
 	       (constructor make-terrain-viewport