--- /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.
+
+|#
+
+;;;; Bindings for graphics routines.
+
+;;; These are set! per a graphics "plug-in", e.g. in mit-make.scm.
+
+(define make-suitable-graphics-device)
+
+(define draw-segment)
+
+(define draw-circle)
+
+(define draw-text)
+
+(define fill-polygon-available?)
+
+(define fill-polygon)
+
+(define clear-graphics)
+
+(define flush-graphics)
\ No newline at end of file
|#
(load-option 'CREF)
-(compile-system "planetarium" (directory-pathname (current-load-pathname))
+(compile-system "mit" (directory-pathname (current-load-pathname))
'dependencies
`(("solar" "geometry")
("earth" "geometry")
- ("mit-scheme-cil"
- "mit-scheme-syntax" ,@(directory-read "cil-*.txt"))
+ ("mit-cil" "mit-syntax" ,@(directory-read "cil-*.txt"))
("tellurion" "geometry")))
\ No newline at end of file
Load the Planetarium. |#
-(with-loader-base-uri
- (system-library-uri "planetarium/")
- (lambda ()
- (load-package-set "planetarium")))
+(with-working-directory-pathname
+ (directory-pathname (current-load-pathname))
+ (lambda ()
+ (load-package-set "mit")))
(let ((planet (->environment '(planetarium)))
(graphics (cond ((graphics-type-available? 'gtk)
(->environment '(planetarium simple-graphics)))
(else #f))))
(if graphics
- (begin
- (environment-link-name planet graphics 'make-suitable-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-available?)
- (environment-link-name planet graphics 'fill-polygon)
- (environment-link-name planet graphics 'clear-graphics)
- (environment-link-name planet graphics 'flush-graphics))
+ (for-each (lambda (name) (environment-link-name planet graphics name))
+ '(make-suitable-graphics-device
+ draw-segment draw-circle draw-text
+ fill-polygon-available? fill-polygon
+ clear-graphics flush-graphics))
(error "No graphics available.")))
\ No newline at end of file
|#
-;;;; Load and run the planetarium (just a tellurion at the mo').
+;;;; Load the planetarium (just a tellurion at the mo').
-(package/add-child! (find-package '()) 'planetarium
- (extend-top-level-environment (->environment '())) #t)
-
-(with-working-directory-pathname (directory-pathname (current-load-pathname))
+(load-option 'GTK)
+(with-working-directory-pathname
+ (directory-pathname (current-load-pathname))
(lambda ()
- (let ((env (->environment '(planetarium))))
-
- (define (compile-load file #!optional dependencies)
- (let ((deps (if (default-object? dependencies) '() dependencies)))
- (fluid-let (;;(compile-file:sf-only? #t)
- (compiler:generate-lap-files? #t))
- (compile-file file deps env))
- (load file env)))
-
- (define errors-ignored?
- (let ((ok "ok"))
- (lambda (thunk)
- (let ((v (ignore-errors (lambda () (thunk) ok))))
- (cond ((eq? v ok) #f)
- ((condition? v) #t)
- (else (error "Unexpected value:" v)))))))
-
- (compile-load "mit-scheme-syntax")
- (compile-load "geometry")
- (compile-load "matrices")
- (compile-load "time")
- (compile-load "solar" '("geometry"))
- (compile-load "earth" '("geometry"))
- (compile-load "mit-scheme-cil" (cons "mit-scheme-syntax"
- (directory-read "cil-*.txt")))
- (compile-load "tellurion" '("geometry"))
- (environment-link-name (->environment '()) env 'make-tellurion)
- (cond ((not (errors-ignored? (lambda () (load-option 'gtk))))
- (compile-load "mit-scheme-gtk"))
- ((graphics-type-available? 'x)
- (compile-load "mit-scheme-x"))
- ((not (null? (enumerate-graphics-types)))
- (compile-load "mit-scheme-graphics"))
- (else (error "No graphics available."))))))
\ No newline at end of file
+ (load "mit-compile")
+ (load "mit-make")))
\ No newline at end of file
;;;; Generate snapshots (PNG files).
-(load-option 'gtk #t)
+;; Expect DISPLAY not set.
+(ignore-errors (lambda () (load-option 'gtk)))
+
+(with-working-directory-pathname
+ (directory-pathname (current-load-pathname))
+ (lambda ()
+ (load "mit-compile")
+ (load-package-set "mit")))
+
+(let ((planet (->environment '(planetarium)))
+ (graphics (->environment '(planetarium gtk-graphics))))
+ (for-each (lambda (name) (environment-link-name planet graphics name))
+ '(make-suitable-graphics-device
+ draw-segment draw-circle draw-text
+ fill-polygon-available? fill-polygon
+ clear-graphics flush-graphics)))
(let ((here (the-environment))
+ (planet (->environment '(planetarium)))
(gtk (->environment '(gtk))))
+ (for-each (lambda (name) (environment-link-name here planet name))
+ '(make-latitude/longitude draw-tellurion))
(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 (lambda (file) (compile-file file '() here) (load file))
- '("mit-scheme-syntax"
- "geometry" "matrices" "time" "solar" "earth"
- "mit-scheme-cil" "tellurion" "mit-scheme-gtk")))))
+ cairo-surface-write-to-png cairo-surface-destroy)))
(let ((time (get-universal-time))
(latitude 33.3)
(define-package (r3rs extras)
(parent ())
- (files "mit-scheme-r3rs"))
+ (files "mit-r3rs"))
(define-package (planetarium syntax)
(parent ())
- (files "mit-scheme-syntax"))
+ (files "mit-syntax"))
(define-package (planetarium)
(parent (r3rs))
"matrices"
"time"
"solar"
+ "graphics"
"earth"
"tellurion")
(export ()
(define-package (planetarium gtk-graphics)
(parent ())
- (files "mit-scheme-gtk")
- ;; Exports are actually set up by make.scm per the available graphics.
+ (files "mit-gtk")
(export (planetarium)
- make-suitable-graphics-device
- draw-segment
- draw-circle
- draw-text
- fill-polygon-available?
- fill-polygon
- clear-graphics
- flush-graphics))
+ ;; Exports are actually set up by make.scm per the available 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.
- )
+ (files "mit-x")
+ (export (planetarium)
+ ;; Exports are actually set up by make.scm per the available graphics.
+ ))
(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.
- )
+ (files "mit-graphics")
+ (export (planetarium)
+ ;; Exports are actually set up by make.scm per the available graphics.
+ ))
(define-package (planetarium earth-cil)
(parent ())
- (files "mit-scheme-cil")
+ (files "mit-cil")
(import (planetarium syntax)
cil-file)
(export (planetarium)
projects / mit-scheme.git / commitdiff