From 1096816f71d307dc63c699bf305798431bb45f77 Mon Sep 17 00:00:00 2001
From: Matt Birkholz <puck@birchwood-abbey.net>
Date: Tue, 29 Mar 2016 15:25:06 -0700
Subject: [PATCH] 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.
---
 src/planetarium/mit.pkg       |  2 +-
 src/planetarium/tellurion.scm | 62 +++++++++++++++++------------------
 2 files changed, 32 insertions(+), 32 deletions(-)

diff --git a/src/planetarium/mit.pkg b/src/planetarium/mit.pkg
index 62e6fc59a..a3c8d91a4 100644
--- 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 a7f6e664a..cf3567d66 100644
--- 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
-- 
2.25.1