From eb558cfb35d82761ea07cb1eeeb2ce160a0bd10c Mon Sep 17 00:00:00 2001 From: Matt Birkholz Date: Sun, 28 Apr 2013 13:54:34 -0700 Subject: [PATCH] planetarium: Replace old filenames, redundant code in mit-make.scm. Use load-package-set to load the tellurion. Add graphics.scm and load it before its users, to ensure they all link to the same binding(?). --- src/planetarium/graphics.scm | 42 +++++++++++++++++++++++++++++ src/planetarium/mit-compile.scm | 5 ++-- src/planetarium/mit-make.scm | 22 +++++++--------- src/planetarium/mit-scheme.scm | 45 +++++--------------------------- src/planetarium/mit-snapshot.scm | 29 +++++++++++++------- src/planetarium/mit.pkg | 36 +++++++++++-------------- 6 files changed, 94 insertions(+), 85 deletions(-) create mode 100644 src/planetarium/graphics.scm diff --git a/src/planetarium/graphics.scm b/src/planetarium/graphics.scm new file mode 100644 index 000000000..7f9bf7184 --- /dev/null +++ b/src/planetarium/graphics.scm @@ -0,0 +1,42 @@ +#| -*-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 diff --git a/src/planetarium/mit-compile.scm b/src/planetarium/mit-compile.scm index a60dee726..cb39c1cb2 100644 --- a/src/planetarium/mit-compile.scm +++ b/src/planetarium/mit-compile.scm @@ -22,10 +22,9 @@ USA. |# (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 diff --git a/src/planetarium/mit-make.scm b/src/planetarium/mit-make.scm index a7a7c9425..d7cf58f10 100644 --- a/src/planetarium/mit-make.scm +++ b/src/planetarium/mit-make.scm @@ -2,10 +2,10 @@ 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) @@ -16,13 +16,9 @@ Load the Planetarium. |# (->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 diff --git a/src/planetarium/mit-scheme.scm b/src/planetarium/mit-scheme.scm index d57a495d7..c5ff2dbdc 100644 --- a/src/planetarium/mit-scheme.scm +++ b/src/planetarium/mit-scheme.scm @@ -21,44 +21,11 @@ USA. |# -;;;; 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 diff --git a/src/planetarium/mit-snapshot.scm b/src/planetarium/mit-snapshot.scm index f8f1e6b27..6f06be085 100644 --- a/src/planetarium/mit-snapshot.scm +++ b/src/planetarium/mit-snapshot.scm @@ -23,20 +23,31 @@ USA. ;;;; 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) diff --git a/src/planetarium/mit.pkg b/src/planetarium/mit.pkg index 182667bba..cf435e53f 100644 --- a/src/planetarium/mit.pkg +++ b/src/planetarium/mit.pkg @@ -82,11 +82,11 @@ USA. (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)) @@ -120,6 +120,7 @@ USA. "matrices" "time" "solar" + "graphics" "earth" "tellurion") (export () @@ -127,35 +128,28 @@ USA. (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) -- 2.25.1