planetarium/terrain.scm: Accept real arguments to commands.

diff --git a/src/planetarium/mit-3d.pkg b/src/planetarium/mit-3d.pkg
index f4f79e51e2fbed7e089b478fea552ee782b38834..5e51d9b1f5fd04aebd3fc3949108d102972689fa 100644 (file)
--- a/src/planetarium/mit-3d.pkg
+++ b/src/planetarium/mit-3d.pkg
@@ -37,13 +37,13 @@ USA.
   (files "terrain")
   (import ()
          burst-string read-line write-string ->namestring
-         error:wrong-type-argument flo:= flo:>= flo:flonum? symbol-name
-         guarantee-list-of-type->length guarantee-symbol guarantee-string
+         error:wrong-type-argument real? ->flonum symbol-name
+         guarantee-list-of-type->length
          universal-time->local-time-string
-         sleep-current-thread
          define-class define-method initialize-instance
          system-global-environment
          define-syntax syntax-rules outf-error ill-formed-syntax
+         flo:abs flo:round->exact
          fix:+ fix:* fix:- fix:-1+ fix:1+ fix:=)
   (import (gtk)
          gtk-widget-set-hexpand

diff --git a/src/planetarium/terrain.scm b/src/planetarium/terrain.scm
index e624e4f67d0132f5726b29b5114a32b99145ed97..5c6205b108eabfef930ef5af0294a0bea2407b49 100644 (file)
--- a/src/planetarium/terrain.scm
+++ b/src/planetarium/terrain.scm
@@ -33,7 +33,7 @@ USA.
 
       (define (check-flonum-args num description)
        (if (not (= num (guarantee-list-of-type->length
-                        args flo:flonum? "a flonum" 'TERRAIN)))
+                        args real? "a real number" 'TERRAIN)))
            (error (string-append
                    "The "(symbol-name command)" command requires"
                    (number->string num '(int))" arguments: "description"."))))
@@ -41,9 +41,9 @@ USA.
       (cond
        ((eq? 'POSITION command)
        (check-flonum-args 3 "LATITUDE, LONGITUDE and ALTITUDE")
-       (let ((lat (car args))
-             (lng (cadr args))
-             (alt (caddr args)))
+       (let ((lat (->flonum (car args)))
+             (lng (->flonum (cadr args)))
+             (alt (->flonum (caddr args))))
          (if (not (flo:<= (flo:abs lat) 80.))
              (error "Requested latitude is greater than 80°:" lat))
          (let ((pos (glx-viewport-position widget))
@@ -57,12 +57,13 @@ USA.
 
        ((eq? 'HEADING command)
        (check-flonum-args 1 "AZIMUTH")
-       (set-glx-viewport-heading! widget (degrees->radians (car args)))
+       (set-glx-viewport-heading! widget
+                                  (degrees->radians (->flonum (car args))))
        (gtk-widget-queue-draw widget))
 
        ((eq? 'TILT command)
        (check-flonum-args 1 "INCLINATION in degrees")
-       (if (not (flo:<= (flo:abs (car args)) 80.))
+       (if (not (flo:<= (flo:abs (->flonum (car args))) 80.))
            (error "Requested inclination greater than 80°.")
            (set-glx-viewport-tilt! widget (degrees->radians (car args))))
        (gtk-widget-queue-draw widget))