From: Chris Hanson Date: Tue, 1 Sep 1992 20:12:17 +0000 (+0000) Subject: Add support for M-x print-graphics. X-Git-Tag: 20090517-FFI~9024 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=8f5dd8f47fef8882dad43b9fb9fb3be7dd454aaf;p=mit-scheme.git Add support for M-x print-graphics. --- diff --git a/v7/src/6001/6001.pkg b/v7/src/6001/6001.pkg index 2a4329dda..c1fcba654 100644 --- a/v7/src/6001/6001.pkg +++ b/v7/src/6001/6001.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/6001/6001.pkg,v 1.4 1992/07/18 02:26:55 hal Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/6001/6001.pkg,v 1.5 1992/09/01 20:11:17 cph Exp $ Copyright (c) 1991-92 Massachusetts Institute of Technology @@ -144,4 +144,10 @@ MIT in each case. |# ;picture-scale ;picture-set! ;picture-v-reflect - )) \ No newline at end of file + )) + +(define-package (edwin student) + (files "edextra") + (parent (edwin)) + (export (edwin) + edwin-command$print-graphics)) \ No newline at end of file diff --git a/v7/src/6001/6001.sf b/v7/src/6001/6001.sf index 08f69b0e2..bd2bae819 100644 --- a/v7/src/6001/6001.sf +++ b/v7/src/6001/6001.sf @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/6001/6001.sf,v 1.4 1992/03/25 21:44:49 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/6001/6001.sf,v 1.5 1992/09/01 20:12:08 cph Exp $ Copyright (c) 1991-92 Massachusetts Institute of Technology @@ -37,6 +37,9 @@ MIT in each case. |# '("arith" "make" "nodefs" "picture" "pic-record" "pic-image" "pic-read" "pic-ops"))) +(fluid-let ((sf/default-syntax-table edwin-syntax-table)) + (sf-conditionally "edextra")) + ;; Guarantee that the package modeller is loaded. (if (not (name->package '(CROSS-REFERENCE))) (with-working-directory-pathname "../cref" diff --git a/v7/src/6001/picture.scm b/v7/src/6001/picture.scm index efb32ac16..7a8357c07 100644 --- a/v7/src/6001/picture.scm +++ b/v7/src/6001/picture.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/6001/picture.scm,v 1.12 1992/06/11 17:31:22 u6001 Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/6001/picture.scm,v 1.13 1992/09/01 20:07:09 cph Exp $ Copyright (c) 1991-92 Massachusetts Institute of Technology @@ -250,6 +250,7 @@ MIT in each case. |# (lambda () (graphics-device-coordinate-limits window)) (lambda (x1 y1 x2 y2) + (set! *last-picture-displayed* pic) (graphics-set-coordinate-limits window 0 (- y1 y2) (- x2 x1) 0) (let* ((win-wid (fix:+ 1 (fix:- x2 x1))) (win-hgt (fix:+ 1 (fix:- y1 y2))) @@ -282,6 +283,17 @@ MIT in each case. |# (if (and true-min-max? (not image-cached?)) (picture-set-image! pic image)))))))) +(define (call-with-last-picture-file procedure) + (if *last-picture-displayed* + (call-with-temporary-filename + (lambda (filename) + (picture->pgm-file *last-picture-displayed*) + (procedure filename))) + (procedure false))) + +(define *last-picture-displayed* + false) + (define (picture-write picture filename) (let ((path-name (->pathname filename))) (if (picture? picture) diff --git a/v7/src/edwin/print.scm b/v7/src/edwin/print.scm index cf3416546..adc514de8 100644 --- a/v7/src/edwin/print.scm +++ b/v7/src/edwin/print.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/print.scm,v 1.9 1992/08/28 21:03:19 cph Exp $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/print.scm,v 1.10 1992/09/01 20:12:17 cph Exp $ ;;; ;;; Copyright (c) 1991-92 Massachusetts Institute of Technology ;;; @@ -76,63 +76,38 @@ Variable LPR-SWITCHES is a list of extra switches (strings) to pass to lpr." (define (print-region/internal region print-command?) (let ((switches (print-region-switches region print-command?)) - (source-buffer (mark-buffer (region-start region))) - (temp-buffer (temporary-buffer " *spool temp*"))) + (source-buffer (mark-buffer (region-start region)))) (message "Spooling...") - (insert-region (region-start region) - (region-end region) - (buffer-point temp-buffer)) - (let ((width (ref-variable tab-width source-buffer))) - (if (not (= width 8)) - (begin - (define-variable-local-value! temp-buffer - (ref-variable-object tab-width) - width) - (untabify-region (buffer-start temp-buffer) - (buffer-end temp-buffer))))) - (shell-command region (buffer-end temp-buffer) false false - (apply string-append - (ref-variable lpr-command source-buffer) - (let loop ((switches switches)) - (if (null? switches) - (list "") - (cons* " " - (car switches) - (loop (cdr switches))))))) + (call-with-temporary-buffer " *spool temp*" + (lambda (temp-buffer) + (insert-region (region-start region) + (region-end region) + (buffer-point temp-buffer)) + (let ((width (ref-variable tab-width source-buffer))) + (if (not (= width 8)) + (begin + (define-variable-local-value! temp-buffer + (ref-variable-object tab-width) + width) + (untabify-region (buffer-start temp-buffer) + (buffer-end temp-buffer))))) + (shell-command region (buffer-end temp-buffer) false false + (apply string-append + (ref-variable lpr-command source-buffer) + (let loop ((switches switches)) + (if (null? switches) + (list "") + (cons* " " + (car switches) + (loop (cdr switches))))))))) (append-message "done"))) (define (print-region-switches region print-command?) - (let ((switches (ref-variable lpr-switches)) - (title (print-region-title-string region))) - (append (if (and print-command? (not lpr-print-not-special?)) - '("-p") - '()) - (let ((job-name - (or (and lpr-prompt-for-name? - (not (there-exists? switches - (lambda (switch) - (string-prefix? "-J" switch)))) - (let ((job-name - (prompt-for-string - "Name to print on title page" - lpr-most-recent-name - 'INSERTED-DEFAULT))) - (if (string-null? job-name) - false - (begin - (set! lpr-most-recent-name job-name) - job-name)))) - title))) - (if job-name - (list (string-append "-J \"" job-name "\"")) - '())) - (if (and title - (not (there-exists? switches - (lambda (switch) - (string-prefix? "-T" switch))))) - (list (string-append "-T \"" title "\"")) - '()) - switches))) + (print/assemble-switches + (print-region-title-string region) + (if (and print-command? (not lpr-print-not-special?)) + '("-p") + '()))) (define (print-region-title-string region) (let ((buffer-title @@ -148,4 +123,31 @@ Variable LPR-SWITCHES is a list of extra switches (strings) to pass to lpr." (and (group-start? (region-start region)) (group-end? (region-end region)))) buffer-title - (string-append "region from " buffer-title)))) \ No newline at end of file + (string-append "region from " buffer-title)))) + +(define (print/assemble-switches title additional-switches) + (let ((switches (ref-variable lpr-switches))) + (append additional-switches + (let ((job-name (or (print/job-name) title))) + (if job-name + (list (string-append "-J \"" job-name "\"")) + '())) + (if (and title + (not (there-exists? switches + (lambda (switch) + (string-prefix? "-T" switch))))) + (list (string-append "-T \"" title "\"")) + '()) + switches))) + +(define (print/job-name) + (and lpr-prompt-for-name? + (let ((job-name + (prompt-for-string "Name to print on title page" + lpr-most-recent-name + 'INSERTED-DEFAULT))) + (if (string-null? job-name) + false + (begin + (set! lpr-most-recent-name job-name) + job-name))))) \ No newline at end of file