--- /dev/null
+-*-Text-*-
+
+Obviously half a tellurian does not a planetarium make.
+
+Finish the tellurian. Draw a little moon icon on the globe at the
+lat/long of the Moon. Draw it in dotted lines when it is hidden.
+Include its phase. Draw a sun icon too. Other views: Earth and
+Moon from celestial North, Earth and Moon and Sun from N inside
+celestial grid showing mean equinox of the date, precession animation,
+etc. etc.
+
+Draw orbits and positions of the planets in the (inner) solar system
+from N (e.g. to answer a question like "Why is Curiosity having
+trouble phoning home?"). Other views: the inner/outer planets from
+Earth, moons of Mars, Jupiter, Saturn...
+
+Zoom. I would like to inspect the CIL data most closely. It is
+surprisingly detailed for the 660K bytes it occupies.
+
+Drawing performance could be vastly improved. Calling cairo_line_to
+a thousand of times instead of scm_cairo_draw_lines once with an array
+of a thousand points (like x-graphics/fill-polygon) can't be cheap.
+Draw-cil will have to be considerably more complex to string the
+points together, not just hit the draw-segment operator for each.
(define (make-suitable-graphics-device)
(let ((device (make-graphics-device 'gtk 512 512)))
(graphics-set-coordinate-limits device -1.1 -1.1 1.1 1.1)
- (gtk-graphics/set-background-color device "white")
- (gtk-graphics/set-foreground-color device "black")
device))
(define-integrable (x p) (flo:vector-ref p 0))
--- /dev/null
+#| -*-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.
+
+|#
+
+;;;; Generate snapshots (PNG files).
+
+(load-option 'gtk #t)
+
+(let ((time (get-universal-time))
+ (latitude 33.3)
+ (longitude -111.9)
+
+ (device (make-graphics-device 'gtk 400 400 #t))
+ (here (the-environment))
+ (gtk (->environment '(gtk))))
+ (for-each (lambda (name) (environment-link-name here gtk name))
+ '(surface-ink-surface
+ cairo-surface-write-to-png cairo-surface-destroy))
+ (with-working-directory-pathname
+ (directory-pathname (current-load-pathname))
+ (lambda ()
+ (for-each load '("geometry" "matrices" "time" "solar" "earth"
+ "mit-scheme-cil" "tellurian" "mit-scheme-gtk"))))
+ (graphics-set-coordinate-limits device -1.1 -1.1 1.1 1.1)
+ (draw-tellurian device time (make-latitude/longitude latitude longitude))
+ (let ((surface (surface-ink-surface (graphics-device/descriptor device))))
+ (cairo-surface-write-to-png surface "tellurian.png")
+ (cairo-surface-destroy surface)))
\ No newline at end of file
(let ((device (make-suitable-graphics-device))
;; Latitude and longitude per GPS -- positive degrees long. to the east.
(lat/long (make-latitude/longitude 23.271 0.))
- (lat/long-pos (make-2d-point -1. -1.))
(time (get-universal-time))
- (time-pos (make-2d-point -1. 1.))
- (cross-hair-left (make-2d-point -.02 0.))
- (cross-hair-right (make-2d-point .02 0.))
- (cross-hair-top (make-2d-point 0. .02))
- (cross-hair-bottom (make-2d-point 0. -.02))
(stopped? #f))
-
- (define (draw)
- (graphics-clear 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
- (orientation-matrix lat/long)
- (solar-latitude/longitude
- (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))
-
+ (define-integrable (draw)
+ (draw-tellurian device time lat/long))
(draw)
(let loop ()
(let ((command (if stopped?
(draw))))
(loop))))
+(define draw-tellurian
+ (let ((lat/long-pos (make-2d-point -1. -1.02))
+ (time-pos (make-2d-point -1. 1.))
+ (cross-hair-left (make-2d-point -.02 0.))
+ (cross-hair-right (make-2d-point .02 0.))
+ (cross-hair-top (make-2d-point 0. .02))
+ (cross-hair-bottom (make-2d-point 0. -.02)))
+ (named-lambda (draw-tellurian device time lat/long)
+ (graphics-clear 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
+ (orientation-matrix lat/long)
+ (solar-latitude/longitude
+ (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))))
+
(define (orientation-matrix lat/long)
(let ((Mx (make-x-rotation-matrix (degrees->radians
(latitude lat/long))))
projects / mit-scheme.git / commitdiff