(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")
(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.)))
((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
;;;; 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"))
(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
(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
--- /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.
+
+|#
+
+;;;; 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
`(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
(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))
(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
;;;; 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 ())
(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"
(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
(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
(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
projects / mit-scheme.git / commitdiff