From: Matt Birkholz <matt@birkholz.chandler.az.us>
Date: Wed, 24 Apr 2013 17:41:52 +0000 (-0700)
Subject: planetarium: Create an (r3rs) package and use it.
X-Git-Tag: mit-scheme-pucked-9.2.12~502
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=52df5ef36b2ce223791b1a0ca68d6a71fc30f974;p=mit-scheme.git

planetarium: Create an (r3rs) package and use it.

Fix planetarium.pkg.  Putting files into separate packages requires
some changes.  Move read-cil-file to an MIT-Scheme-specific
package/file; move cil-file to load before mit-scheme-cil.scm.  Add
explicit clear-graphics and flush-graphics exports from the graphics
packages.  Why did geometry.scm have to be changed?
---

diff --git a/src/planetarium/earth.scm b/src/planetarium/earth.scm
index 43dc0fb27..e058cea2c 100644
--- a/src/planetarium/earth.scm
+++ b/src/planetarium/earth.scm
@@ -120,36 +120,6 @@ USA.
 		      (loop end (cdr rest))))))
 	    cil))
 
-(define (read-cil-file name)
-  (let ((in (open-input-file name)))
-    (port/set-line-ending in 'CRLF)
-    (let loop ((points '()) (lines '()))
-      (let ((line (read-line in)))
-	(if (eof-object? line)
-	    (begin
-	      (close-port in)
-	      (reverse! (if (null? points)
-			    lines
-			    (cons points lines))))
-	    (let ((line (string-trim-left line)))
-	      (cond
-	       ((string-null? line)
-		(loop points lines))
-	       ((string=? line "-1")
-		(loop '() (cons points lines)))
-	       (else
-		(let ((sep (string-find-next-char line #\space)))
-		  (let ((latitude (string->number (string-head line sep)))
-			(longitude (string->number (string-tail line (1+ sep)))))
-		    (if (or (not latitude) (not longitude))
-			(error "could not parse:" (input-port/line in) line))
-		    (loop (cons (cons (degrees->radians
-				       (flo:/ (->flonum latitude) 3600.))
-				      (degrees->radians
-				       (flo:/ (->flonum longitude) 3600.)))
-				points)
-			  lines)))))))))))
-
 (define (draw-terminator device sol-orientation)
   ;;(graphics-set-line-width! device 4.0)
   (draw-meridian device pi/2 sol-orientation "black")
diff --git a/src/planetarium/geometry.scm b/src/planetarium/geometry.scm
index 0cfde0422..b7cc02a98 100644
--- a/src/planetarium/geometry.scm
+++ b/src/planetarium/geometry.scm
@@ -47,19 +47,19 @@ USA.
 (define-integrable (flo.3 v) (flo:vector-ref v 2))
 (define-integrable (flo.3! v f) (flo:vector-set! v 2 f))
 
-(define-integrable make-2d-point flo:2d)
-(define-integrable x flo.1)
-(define-integrable set-x! flo.1!)
-(define-integrable y flo.2)
-(define-integrable set-y! flo.2!)
-(define-integrable make-3d-point flo:3d)
-(define-integrable z flo.3)
-(define-integrable set-z! flo.3!)
-(define-integrable make-latitude/longitude flo:2d)
-(define-integrable latitude  flo.1)
-(define-integrable set-latitude!  flo.1!)
-(define-integrable longitude flo.2)
-(define-integrable set-longitude! flo.2!)
+(define-integrable (make-2d-point x y) (flo:2d x y))
+(define-integrable (x p) (flo.1 p))
+(define-integrable (set-x! p x) (flo.1! p x))
+(define-integrable (y p) (flo.2 p))
+(define-integrable (set-y! p y) (flo.2! p y))
+(define-integrable (make-3d-point x y z) (flo:3d x y z))
+(define-integrable (z p) (flo.3 p))
+(define-integrable (set-z! p z) (flo.3! p z))
+(define-integrable (make-latitude/longitude lat long) (flo:2d lat long))
+(define-integrable (latitude p) (flo.1 p))
+(define-integrable (set-latitude! p l) (flo.1! p l))
+(define-integrable (longitude p) (flo.2 p))
+(define-integrable (set-longitude! p l) (flo.2! p l))
 
 (define-integrable (degrees->radians degrees) (flo:* degrees (flo:/ 2pi 360.)))
 
diff --git a/src/planetarium/make.scm b/src/planetarium/make.scm
index 859d3d7bf..a7a7c9425 100644
--- a/src/planetarium/make.scm
+++ b/src/planetarium/make.scm
@@ -13,15 +13,16 @@ Load the Planetarium. |#
 		      ((graphics-type-available? 'x)
 		       (->environment '(planetarium x-graphics)))
 		      ((not (null? (enumerate-graphics-types)))
-		       #t)
+		       (->environment '(planetarium simple-graphics)))
 		      (else #f))))
-  (if (environment? graphics)
+  (if graphics
       (begin
 	(environment-link-name planet graphics 'make-suitable-graphics-device)
-	(environment-link-name planet graphics 'flush-graphics-device)
 	(environment-link-name planet graphics 'draw-segment)
 	(environment-link-name planet graphics 'draw-circle)
 	(environment-link-name planet graphics 'draw-text)
-	(environment-link-name planet graphics 'fill-polygon))
-      (if (eq? graphics #f)
-	  (error "No graphics available."))))
\ No newline at end of file
+	(environment-link-name planet graphics 'fill-polygon-available?)
+	(environment-link-name planet graphics 'fill-polygon)
+	(environment-link-name planet graphics 'clear-graphics)
+	(environment-link-name planet graphics 'flush-graphics))
+      (error "No graphics available.")))
\ No newline at end of file
diff --git a/src/planetarium/mit-scheme-cil.scm b/src/planetarium/mit-scheme-cil.scm
index 041c9d674..584307354 100644
--- a/src/planetarium/mit-scheme-cil.scm
+++ b/src/planetarium/mit-scheme-cil.scm
@@ -23,13 +23,6 @@ USA.
 
 ;;;; MIT Scheme specific code to load CIL data.
 
-(define-syntax cil-file
-  (sc-macro-transformer
-   (lambda (form usage-env)
-     (declare (ignore usage-env))
-     (let ((filename (cadr form)))
-       (list 'quote (read-cil-file filename))))))
-
 (define africa-cil (cil-file "cil-africa.txt"))
 (define asia-cil (cil-file "cil-asia.txt"))
 (define europe-cil (cil-file "cil-europe.txt"))
diff --git a/src/planetarium/mit-scheme-graphics.scm b/src/planetarium/mit-scheme-graphics.scm
index 46d9d6de2..69883f43b 100644
--- a/src/planetarium/mit-scheme-graphics.scm
+++ b/src/planetarium/mit-scheme-graphics.scm
@@ -49,4 +49,11 @@ USA.
 
 (define (fill-polygon-available?) #f)
 
-(define flush-graphics-device graphics-flush)
\ No newline at end of file
+(define (fill-polygon device points color)
+  (error "Unimplemented: fill-polygon:" device points color))
+
+(define (clear-graphics device)
+  (graphics-clear device))
+
+(define (flush-graphics device)
+  (graphics-flush device))
\ No newline at end of file
diff --git a/src/planetarium/mit-scheme-gtk.scm b/src/planetarium/mit-scheme-gtk.scm
index f3c971701..08bde099a 100644
--- a/src/planetarium/mit-scheme-gtk.scm
+++ b/src/planetarium/mit-scheme-gtk.scm
@@ -52,4 +52,8 @@ USA.
   (gtk-graphics/set-foreground-color device color)
   (gtk-graphics/fill-polygon-list device points))
 
-(define flush-graphics-device gtk-graphics/flush)
\ No newline at end of file
+(define (clear-graphics device)
+  (gtk-graphics/clear device))
+
+(define (flush-graphics device)
+  (gtk-graphics/flush device))
\ No newline at end of file
diff --git a/src/planetarium/mit-scheme-r3rs.scm b/src/planetarium/mit-scheme-r3rs.scm
new file mode 100644
index 000000000..0fccd641c
--- /dev/null
+++ b/src/planetarium/mit-scheme-r3rs.scm
@@ -0,0 +1,83 @@
+#| -*-Scheme-*-
+
+Copyright (C) 2013  Matthew Birkholz
+
+This file is part of an extension to MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; Essential R3RS syntax and procedures.
+;;; package: (r3rs essentials)
+
+(define-syntax essential-if
+  (syntax-rules ()
+    ((_ PRED CONS ALT)
+     (IF PRED CONS ALT))))
+
+(define-syntax essential-let
+  (syntax-rules ()
+    ((_ (bindings ...) body ...)
+     (LET (bindings ...) body ...))))
+
+(define-integrable (essential-* a b)
+  (* a b))
+
+(define-integrable (essential-+ a b)
+  (+ a b))
+
+(define-integrable (essential-- a b)
+  (- a b))
+
+(define-integrable (essential-/ a b)
+  (/ a b))
+
+(define (essential-append a b)
+  (append a b))
+
+(define (essential-apply proc args)
+  (apply proc args))
+
+(define (essential-max a b)
+  (max a b))
+
+(define (essential-min a b)
+  (min a b))
+
+(define (essential-string-append a b)
+  (string-append a b))
+
+(define (fancy-number->string number format)
+  (error "Unimplemented: fancy-number->string:" number format))
+
+(define (fancy-string->number string exactness radix)
+  (let ((n (string->number string (case radix
+				    ((B) 2)
+				    ((O) 8)
+				    ((D) 10)
+				    ((X) 16)
+				    (else (error "Not a radix:" radix))))))
+    (if (not n) (error "Not a number:" string))
+    (case exactness
+      ((E) (inexact->exact n))
+      ((I) (exact->inexact n))
+      (else (error "Not an exactness:" exactness)))))
+
+(define-syntax fancy-atan
+  (syntax-rules ()
+    ((_ t) (ATAN t))
+    ((_ y x) (ATAN2 y x))))
\ No newline at end of file
diff --git a/src/planetarium/mit-scheme-syntax.scm b/src/planetarium/mit-scheme-syntax.scm
index b323c319d..b5462c96d 100644
--- a/src/planetarium/mit-scheme-syntax.scm
+++ b/src/planetarium/mit-scheme-syntax.scm
@@ -30,4 +30,44 @@ USA.
 	 `(BEGIN
 	   (DECLARE (INTEGRATE-OPERATOR ,(caadr form)))
 	   (DEFINE ,@(cdr form)))
-	 (ill-formed-syntax form)))))
\ No newline at end of file
+	 (ill-formed-syntax form)))))
+
+(define-syntax cil-file
+  (sc-macro-transformer
+   (lambda (form usage-env)
+     (declare (ignore usage-env))
+     (let ((filename (cadr form)))
+       (list 'quote (read-cil-file filename))))))
+
+(define-integrable 2pi (flo:* 8. (flo:atan2 1. 1.)))
+(define-integrable (degrees->radians degrees) (flo:* degrees (flo:/ 2pi 360.)))
+
+(define (read-cil-file name)
+  (let ((in (open-input-file name)))
+    (port/set-line-ending in 'CRLF)
+    (let loop ((points '()) (lines '()))
+      (let ((line (read-line in)))
+	(if (eof-object? line)
+	    (begin
+	      (close-port in)
+	      (reverse! (if (null? points)
+			    lines
+			    (cons points lines))))
+	    (let ((line (string-trim-left line)))
+	      (cond
+	       ((string-null? line)
+		(loop points lines))
+	       ((string=? line "-1")
+		(loop '() (cons points lines)))
+	       (else
+		(let ((sep (string-find-next-char line #\space)))
+		  (let ((latitude (string->number (string-head line sep)))
+			(longitude (string->number (string-tail line (1+ sep)))))
+		    (if (or (not latitude) (not longitude))
+			(error "could not parse:" (input-port/line in) line))
+		    (loop (cons (cons (degrees->radians
+				       (flo:/ (->flonum latitude) 3600.))
+				      (degrees->radians
+				       (flo:/ (->flonum longitude) 3600.)))
+				points)
+			  lines)))))))))))
\ No newline at end of file
diff --git a/src/planetarium/mit-scheme-x.scm b/src/planetarium/mit-scheme-x.scm
index bb4934758..d7f38788f 100644
--- a/src/planetarium/mit-scheme-x.scm
+++ b/src/planetarium/mit-scheme-x.scm
@@ -53,6 +53,9 @@ USA.
 
 (define (fill-polygon-available?) #f)
 
+(define (fill-polygon device points color)
+  (error "Unimplemented: fill-polygon:" device points color))
+
 #;(define (points->vector points)
   (let ((v (make-vector (* 2 (length points)))))
     (let loop ((i 0) (points points))
@@ -67,4 +70,8 @@ USA.
   (x-graphics/set-foreground-color device color)
   (x-graphics/fill-polygon device (points->vector points)))
 
-(define flush-graphics-device x-graphics/flush)
\ No newline at end of file
+(define (clear-graphics device)
+  (x-graphics/clear device))
+
+(define (flush-graphics device)
+  (x-graphics/flush device))
\ No newline at end of file
diff --git a/src/planetarium/planetarium.pkg b/src/planetarium/planetarium.pkg
index 29168f2f1..226614051 100644
--- a/src/planetarium/planetarium.pkg
+++ b/src/planetarium/planetarium.pkg
@@ -24,26 +24,65 @@ USA.
 ;;;; Planetarium Packaging
 
 (global-definitions "../runtime/runtime")
+(global-definitions "../gtk/gtk")
 
-(define-package (r3rs)
+(define-package (r3rs essential)
+  (parent #f)
   (import ()
-	  ;; R3RS's essential syntactic keywords:
-	  quote quasiquote lambda if set! cond let letrec begin define
-	  ;; R3RS's essential bindings:
-	  * + - / < <= = > >= abs append append apply assoc assq assv boolean?
-	  car cdr call-with-current-continuation call-with-input-file
+	  quote lambda set! cond letrec begin define
+
+	  < <= = > >= abs assoc assq assv boolean?
+	  car cdr caar cadr cdar cddr
+	  caaar caadr cadar caddr cdaar cdadr cddar cdddr
+	  caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
+	  cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr
+          call-with-current-continuation call-with-input-file
 	  call-with-output-file char->integer char<=?
 	  char<?  char=?  char>=?  char>?  char?  complex?  cons
 	  current-input-port current-output-port display eof-object?  eq?
 	  equal?  eqv?  even?  exact?  for-each inexact?  input-port?
 	  integer->char integer?  length list list->string list->vector load
-	  make-vector map max member memq memv min negative?  newline not null?
+	  make-vector map member memq memv negative?  newline not null?
 	  number?  odd?  output-port?  pair?  positive?  procedure?  quotient
 	  rational?  read read read-char read-char real?  remainder set-car!
-	  set-cdr!  string->list string->symbol string-append string-length
+	  set-cdr!  string->list string->symbol string-length
 	  string-ref string<=?  string<?  string=?  string>=?  string>?  string?
 	  substring symbol->string symbol?  vector vector->list vector-length
-	  vector-ref vector-ref vector-set!  vector?  write write-char zero?))
+	  vector-ref vector-set!  vector?  write write-char zero?)
+  (import (r3rs extras)
+	  (if essential-if) (let essential-let)
+	  (* essential-*) (+ essential-+) (- essential--) (/ essential-/)
+	  (append essential-append) (apply essential-apply)
+	  (max essential-max) (min essential-min)
+	  (string-append essential-string-append)))
+
+(define-package (r3rs)
+  (parent (r3rs essential))
+  (import ()
+	  do backquote quasiquote and case delay if let let* or
+
+	  * + - / acos angle append apply asin ceiling
+	  char-alphabetic?  char-ci<=? char-ci<? char-ci=? char-ci>=?
+	  char-ci>?  char-downcase char-lower-case? char-numeric?
+	  char-ready?  char-upcase char-upper-case? char-whitespace?
+	  close-input-port close-output-port cos denominator
+	  exact->inexact exp expt floor for-each force gcd imag-part
+	  inexact->exact last-pair lcm list-ref list-tail log
+	  magnitude make-polar make-rectangular make-string
+	  make-vector map max min modulo numerator open-input-file
+	  open-output-file rationalize real-part reverse round sin
+	  sqrt string-append string-ci<=? string-ci<? string-ci=?
+	  string-ci>=? string-ci>?  string-copy string-fill!
+	  string-set!  tan transcript-off transcript-on truncate
+	  vector-fill! with-input-from-file with-output-to-file)
+  (import (r3rs extras)
+	  (number->string fancy-number->string)
+	  (string->number fancy-string->number)
+	  (atan fancy-atan)))
+
+(define-package (r3rs extras)
+  (parent ())
+  (files "mit-scheme-r3rs"))
 
 (define-package (planetarium syntax)
   (parent ())
@@ -52,9 +91,31 @@ USA.
 (define-package (planetarium)
   (parent (r3rs))
   (import ()
-	  declare define-integrable)
+	  declare define-integrable named-lambda append! reverse!
+	  string-pad-left
+
+	  ;; Many of these are in usual-integrations/expansion-names
+	  ;; and thus do not have to be imported, but are listed here
+	  ;; anyway for completeness (and analysis someday).
+	  guarantee-integer integer-divide round->exact truncate->exact
+	  ->flonum flo:< flo:<= flo:+ flo:- flo:* flo:/
+	  flo:negative? flo:negate flo:truncate
+	  flo:sin flo:cos flo:atan2
+	  flo:vector-cons flo:vector-ref flo:vector-set!
+
+	  create-thread detach-thread
+	  make-thread-queue thread-queue/queue!
+	  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/hour decoded-time/minute decoded-time/second
+	  decoded-time/year decoded-time/month decoded-time/day 
+	  universal-time->string
+
+	  error warn)
   (import (planetarium syntax)
-	  declare-integrable-operator)
+	  define-integrable-operator)
   (files "geometry"
 	 "matrices"
 	 "time"
@@ -67,17 +128,35 @@ USA.
 (define-package (planetarium gtk-graphics)
   (parent ())
   (files "mit-scheme-gtk")
-  #;(files "mit-scheme-x")
-  #;(files "mit-scheme-graphics")
+  ;; Exports are actually set up by make.scm per the available graphics.
   (export (planetarium)
 	  make-suitable-graphics-device
 	  draw-segment
 	  draw-circle
 	  draw-text
-	  fill-polygon))
+	  fill-polygon-available?
+	  fill-polygon
+	  clear-graphics
+	  flush-graphics))
+
+(define-package (planetarium x-graphics)
+  (parent ())
+  (files "mit-scheme-x")
+  ;; Exports are actually set up by make.scm per the available graphics.
+  ;; See (planetarium gtk-graphics)'s exports.
+  )
+
+(define-package (planetarium simple-graphics)
+  (parent ())
+  (files "mit-scheme-graphics")
+  ;; Exports are actually set up by make.scm per the available graphics.
+  ;; See (planetarium gtk-graphics)'s exports.
+  )
 
 (define-package (planetarium earth-cil)
-  (parent (planetarium))
+  (parent ())
   (files "mit-scheme-cil")
+  (import (planetarium syntax)
+	  cil-file)
   (export (planetarium)
 	  africa-cil asia-cil europe-cil namer-cil samer-cil))
\ No newline at end of file
diff --git a/src/planetarium/tellurion.scm b/src/planetarium/tellurion.scm
index b6455eebf..f238dea84 100644
--- a/src/planetarium/tellurion.scm
+++ b/src/planetarium/tellurion.scm
@@ -118,7 +118,7 @@ USA.
 	(cross-hair-top (make-2d-point 0. .02))
 	(cross-hair-bottom (make-2d-point 0. -.02)))
     (named-lambda (draw-tellurion device time lat/long)
-      (graphics-clear device)
+      (clear-graphics device)
       (draw-text device time-pos (universal-time->string time) "black")
       (draw-text device lat/long-pos (latitude/longitude-string lat/long) "black")
       (draw-earth device
@@ -127,7 +127,7 @@ USA.
 		   (universal-time->julian-day time)))
       (draw-segment device cross-hair-left cross-hair-right "black")
       (draw-segment device cross-hair-top cross-hair-bottom "black")
-      (flush-graphics-device device))))
+      (flush-graphics device))))
 
 (define (orientation-matrix lat/long)
   (let ((Mx (make-x-rotation-matrix (degrees->radians