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 5e51d9b1f5fd04aebd3fc3949108d102972689fa..795563f7b61a5c57326b26eaf29f74b7f7f3a2a3 100644 (file)
--- 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 22afb68f7227959f7257facbc609bc30873d80ae..1c7b4b06100126ecb99397789fd7bbe818a17a2f 100755 (executable)
--- 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 5c6205b108eabfef930ef5af0294a0bea2407b49..4d974d677b31b431094e38c91c6b025cc6de3c17 100644 (file)
--- 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