From: Matt Birkholz Date: Sun, 7 Apr 2013 17:43:13 +0000 (-0700) Subject: Add src/planetarium/snapshot, tweaks, TODO list. X-Git-Tag: mit-scheme-pucked-9.2.12~520 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=8e2521f6edb9222a407c4f4411bc579c08bd490b;p=mit-scheme.git Add src/planetarium/snapshot, tweaks, TODO list. Factor draw-tellurian out of run-tellurian for snapshot.scm. Tweak position of lat/long text. Use default fore/background. --- diff --git a/src/planetarium/TODO b/src/planetarium/TODO new file mode 100644 index 000000000..ea4ba2303 --- /dev/null +++ b/src/planetarium/TODO @@ -0,0 +1,24 @@ +-*-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. diff --git a/src/planetarium/mit-scheme-gtk.scm b/src/planetarium/mit-scheme-gtk.scm index 5741abf04..f3c971701 100644 --- a/src/planetarium/mit-scheme-gtk.scm +++ b/src/planetarium/mit-scheme-gtk.scm @@ -26,8 +26,6 @@ USA. (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)) diff --git a/src/planetarium/snapshot.scm b/src/planetarium/snapshot.scm new file mode 100644 index 000000000..c57be34fa --- /dev/null +++ b/src/planetarium/snapshot.scm @@ -0,0 +1,47 @@ +#| -*-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 diff --git a/src/planetarium/tellurian.scm b/src/planetarium/tellurian.scm index 1f52b3e38..23d83b64b 100644 --- a/src/planetarium/tellurian.scm +++ b/src/planetarium/tellurian.scm @@ -63,27 +63,10 @@ USA. (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? @@ -127,6 +110,25 @@ USA. (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))))