planetarium: tellurions: Accept a decoded-time. Animate any time.

Do not snap to the current time if a different time is set.  Punt the
HOUR-TO message; instead, send (MAKE-DECODED-TIME 0 0 hour...) in a
TIME-TO message.

diff --git a/src/planetarium/mit.pkg b/src/planetarium/mit.pkg
index 62e6fc59a834db80ae38ef7d71e1ddb6e582e34f..a3c8d91a4843e6f1eeece9976e1d20017c9a6e72 100644 (file)
--- a/src/planetarium/mit.pkg
+++ b/src/planetarium/mit.pkg
@@ -110,7 +110,7 @@ USA.
          thread-queue/dequeue! thread-queue/dequeue-no-hang!
 
          get-universal-time universal-time->global-decoded-time
-         make-decoded-time decoded-time->universal-time
+         decoded-time? make-decoded-time decoded-time->universal-time
          decoded-time/hour decoded-time/minute decoded-time/second
          decoded-time/year decoded-time/month decoded-time/day 
          universal-time->string

diff --git a/src/planetarium/tellurion.scm b/src/planetarium/tellurion.scm
index a7f6e664adb5f7c446576fb19a7f3bcfb307b830..cf3567d66c89713bb72709ef5bb1f4d4d324f7f3 100644 (file)
--- a/src/planetarium/tellurion.scm
+++ b/src/planetarium/tellurion.scm
@@ -35,13 +35,10 @@ USA.
               (if (or (< lat -90) (< 90 lat))
                   (error "Invalid latitude:" lat))
               (if (or (< long -180) (< 180 long))
-                  (error "INvalid longitude:" long))
+                  (error "Invalid longitude:" long))
               (queue! 'turn-to lat long)))
            ((eq? keyword 'TIME-TO)
-            (let ((time (car args)))
-              (if (not (eq? time 'current))
-                  (guarantee-integer time 'time-to))
-              (queue! 'time-to time)))
+            (queue! 'time-to (->time (car args))))
            ((eq? keyword 'HOUR-TO)
             (let ((hour (car args)))
               (guarantee-integer hour 'hour-to)
@@ -54,55 +51,58 @@ USA.
             (queue! queue 'go))
            (else (error "unknown command:" keyword args))))))
 
+(define (->time object)
+  (cond ((eq? object 'current)
+        'current)
+       ((decoded-time? object)
+        (decoded-time->universal-time object))
+       ((integer? object)
+        object)
+       (else
+        (error "Not a time (universal, decoded or 'CURRENT):" object))))
+
 (define (run-tellurion queue)
   (let ((device (make-suitable-graphics-device))
        ;; Latitude and longitude per GPS -- positive degrees long. to the east.
        (lat/lng (make-latitude/longitude 23.271 0.))
-       (time (get-universal-time))
+       (time 'current)
        (stopped? #f))
-    (define-integrable (draw)
-      (draw-tellurion device time lat/lng))
+    (define (draw)
+      (draw-tellurion device
+                     (if (eq? time 'current)
+                         (get-universal-time)
+                         time)
+                     lat/lng))
     (draw)
     (let loop ()
       (let ((command (if stopped?
                         (thread-queue/dequeue! queue)
                         (thread-queue/dequeue-no-hang!
                          queue
-                         (let* ((time (get-universal-time))
-                                (next (* 15 60
-                                         (1+ (quotient time (* 15 60)))))
-                                (sec (- next time)))
-                           (* sec 1000))))))
+                         (if (eq? time 'current)
+                             (let* ((time (get-universal-time))
+                                    (next (* 15 60
+                                             (1+ (quotient time (* 15 60)))))
+                                    (sec (- next time)))
+                               (* sec 1000))
+                             (* 15 60 1000))))))
        (cond ((eq? command #f) ;timeout
-              (set! time (get-universal-time))
+              (if (not (eq? time 'current))
+                  (set! time (+ time (* 15 60))))
               (draw))
              ((eq? (car command) 'TURN-TO)
               (set-latitude! lat/lng (cadr command))
               (set-longitude! lat/lng (caddr command))
               (draw))
              ((eq? (car command) 'TIME-TO)
-              (if (eq? (cadr command) 'current)
-                  (set! time (get-universal-time))
-                  (set! time (cadr command)))
-              (draw))
-             ((eq? (car command) 'HOUR-TO)
-              (set! time (decoded-time->universal-time
-                          (let ((decoded
-                                 (universal-time->global-decoded-time time)))
-                            (make-decoded-time
-                             0 0 (cadr command)
-                             (decoded-time/day decoded)
-                             (decoded-time/month decoded)
-                             (decoded-time/year decoded)))))
+              (set! time (cadr command))
               (draw))
              ((eq? (car command) 'STOP)
-              (display ";stopped\n")
               (set! stopped? #t))
              ((eq? (car command) 'GO)
               (set! stopped? #f)
-              (display ";going\n")
-              (set! time (get-universal-time))
-              (draw))))
+              (if (eq? time 'current)
+                  (draw)))))
       (loop))))
 
 (define draw-tellurion