From ce17b2fabf07bfb3be5eb8b9ace97a02a95f97cf Mon Sep 17 00:00:00 2001 From: Hal Abelson Date: Mon, 13 Apr 1992 19:19:54 +0000 Subject: [PATCH] * Change allocation of grays in colormap so that this works on 8-bit pseudo color displays. * Rename FUNCTION->PICTURE as PROCEDURE->PICTURE. * Don't export PICTURE-READ and PICTURE-WRITE. * Add new procedure PICTURE->PGM-FILE. --- v7/src/6001/6001.pkg | 30 ++-- v7/src/6001/pic-imag.scm | 109 ++++++++++---- v7/src/6001/picture.scm | 310 +++++++++++++++++++++++++++++++++++++++ 3 files changed, 406 insertions(+), 43 deletions(-) diff --git a/v7/src/6001/6001.pkg b/v7/src/6001/6001.pkg index 5028d92f0..73fe5e0ed 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.2 1992/03/25 21:52:36 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/6001/6001.pkg,v 1.3 1992/04/13 19:19:54 hal Exp $ Copyright (c) 1991-92 Massachusetts Institute of Technology @@ -122,26 +122,24 @@ MIT in each case. |# (import (runtime x-graphics) x-graphics-device/xw) (export (student) - make-window - show-window-size make-picture - function->picture + make-window pgm-file->picture - picture-read - picture? - picture-width + picture-cut + picture-display + picture-h-reflect picture-height - picture-min - picture-max - picture-ref - picture-set! picture-map - picture-cut + picture-max + picture-min picture-overlap picture-paste! - picture-h-reflect - picture-v-reflect + picture-ref picture-rotate picture-scale - picture-display - picture-write)) \ No newline at end of file + picture-set! + picture-v-reflect + picture-width + picture? + procedure->picture + show-window-size)) \ No newline at end of file diff --git a/v7/src/6001/pic-imag.scm b/v7/src/6001/pic-imag.scm index 6920ac561..32841d10a 100644 --- a/v7/src/6001/pic-imag.scm +++ b/v7/src/6001/pic-imag.scm @@ -1,9 +1,45 @@ -;;; Procedure to build an image given a picture and the magnification factors +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/6001/pic-imag.scm,v 1.2 1992/04/13 19:19:45 hal Exp $ + +Copyright (c) 1991-92 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; 6.001 Images (declare (usual-integrations)) + +;;; Procedure to build an image given a picture and the magnification factors (define (build-image pic window h-sf v-sf pic-min pic-max) - (let* ((colormap-size (colormap-size (get-visual-info window))) + (let* ((gray-map (n-gray-map window)) (pic-height (picture-height pic)) ;py (pic-width (picture-width pic)) ;x (pic-data (picture-data pic)) @@ -17,15 +53,16 @@ (range (flo:- pic-max pic-min)) (mul (if (flo:< range 1e-12) 0. - (/ colormap-size (flo:* (flo:+ 1. 7.142e-8) ; 1+epsilon - range))))) + (/ (string-length gray-map) + (flo:* (flo:+ 1. 7.142e-8) ; 1+epsilon + range))))) ;; The range was slightly adjusted so that an illegal grey level would ;; never be generated. epsilon was carefully chosen so that no error would - ;; be incurred in transforming to actual grey levels up to a colormap-size + ;; be incurred in transforming to actual grey levels up to a gray-levels ;; of 2^24. In general, choose epsilon such that: - ;; colormap-size < (/ (1+ epsilon) epsilon) - + ;; gray-levels < (/ (1+ epsilon) epsilon) + (cond ((and (fix:= 1 h-sf) (fix:= 1 v-sf)) (let y-loop ((py py-max) (iy-index 0)) (if (fix:<= 0 py) @@ -37,10 +74,12 @@ (vector-8b-set! byte-string (fix:+ px iy-index) - (flo:floor->exact - (flo:* mul - (flo:- (floating-vector-ref pic-row px) - pic-min)))) + (vector-8b-ref + gray-map + (flo:floor->exact + (flo:* mul + (flo:- (floating-vector-ref pic-row px) + pic-min))))) (x-loop (fix:+ px 1)))))) (y-loop (fix:- py 1) (fix:+ iy-index rect-index-height)))))) @@ -52,10 +91,14 @@ (if (fix:< px pic-width) (let* ((n-is-0 (fix:+ ix iy-index)) (n-is-1 (fix:+ n-is-0 image-width)) - (v (flo:floor->exact - (flo:* mul - (flo:- (floating-vector-ref pic-row px) - pic-min))))) + (v + (vector-8b-ref + gray-map + (flo:floor->exact + (flo:* mul + (flo:- (floating-vector-ref pic-row + px) + pic-min)))))) (vector-8b-set! byte-string n-is-0 v) (vector-8b-set! byte-string (fix:+ n-is-0 1) v) (vector-8b-set! byte-string n-is-1 v) @@ -73,10 +116,14 @@ (let* ((row0 (fix:+ ix iy-index)) (row1 (fix:+ row0 image-width)) (row2 (fix:+ row1 image-width)) - (v (flo:floor->exact - (flo:* mul - (flo:- (floating-vector-ref pic-row px) - pic-min))))) + (v + (vector-8b-ref + gray-map + (flo:floor->exact + (flo:* mul + (flo:- (floating-vector-ref pic-row + px) + pic-min)))))) (vector-8b-set! byte-string row0 v) (vector-8b-set! byte-string (fix:+ row0 1) v) (vector-8b-set! byte-string (fix:+ row0 2) v) @@ -100,10 +147,14 @@ (row1 (fix:+ row0 image-width)) (row2 (fix:+ row1 image-width)) (row3 (fix:+ row2 image-width)) - (v (flo:floor->exact - (flo:* mul - (flo:- (floating-vector-ref pic-row px) - pic-min))))) + (v + (vector-8b-ref + gray-map + (flo:floor->exact + (flo:* mul + (flo:- (floating-vector-ref pic-row + px) + pic-min)))))) (vector-8b-set! byte-string row0 v) (vector-8b-set! byte-string (fix:+ row0 1) v) (vector-8b-set! byte-string (fix:+ row0 2) v) @@ -130,10 +181,14 @@ (let ((pic-row (floating-vector-ref pic-data py))) (let x-loop ((px 0) (ix 0)) (if (fix:< px pic-width) - (let* ((v (flo:floor->exact - (flo:* mul - (flo:- (floating-vector-ref pic-row px) - pic-min)))) + (let* ((v + (vector-8b-ref + gray-map + (flo:floor->exact + (flo:* mul + (flo:- (floating-vector-ref pic-row + px) + pic-min))))) (n-start (fix:+ ix iy-index)) (n-end (fix:+ n-start rect-index-height))) (let n-loop ((n n-start)) diff --git a/v7/src/6001/picture.scm b/v7/src/6001/picture.scm index e69de29bb..d2b196858 100644 --- a/v7/src/6001/picture.scm +++ b/v7/src/6001/picture.scm @@ -0,0 +1,310 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/6001/picture.scm,v 1.6 1992/04/13 19:19:13 hal Exp $ + +Copyright (c) 1991-92 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; 6.001 Images + +(declare (usual-integrations)) + +(define-integrable floating-vector-ref vector-ref) +(define-integrable floating-vector-set! vector-set!) +(define-integrable floating-vector-copy vector-copy) +(define-integrable make-floating-vector make-vector) + +(define (get-visual-info window) + ((ucode-primitive x-get-visual-info) (x-graphics-device/xw window) + #f #f #f #f #f #f #f #f #f)) + +(define (show-window-size window) + (with-values + (lambda () (graphics-device-coordinate-limits window)) + (lambda (x1 y1 x2 y2) + (newline) + (display `("width:" ,(1+ (- x2 x1)) " height:" ,(1+ (- y1 y2))))))) + +(define (resize-window window width height) + (graphics-operation window 'resize-window width height)) + +(define (make-window width height x y) + (let ((window (make-graphics-device + x-graphics-device-type + false + (x-geometry-string x y width height)))) + (graphics-set-coordinate-limits window 0 (- height) width 0) + (if (not (n-gray-map window)) + (allocate-grays window)) + window)) + +(define (n-gray-map window) + (1d-table/get (x-display/properties (x-graphics/display window)) + '6001-GRAY-MAP + false)) + +(define-integrable visual-class:static-gray 0) +(define-integrable visual-class:gray-scale 1) +(define-integrable visual-class:static-color 2) +(define-integrable visual-class:pseudo-color 3) +(define-integrable visual-class:true-color 4) +(define-integrable visual-class:direct-color 5) + +(define (allocate-grays window) + (let ((w-cm (graphics-operation window 'get-colormap)) + (visual-info (get-visual-info window))) + (let ((find-info + (let ((length (vector-length visual-info))) + (if (= length 0) + (error "X-GET-VISUAL-INFO: no results")) + (lambda (class depth-min depth-max) + (let loop ((index 0)) + (and (< index length) + (let ((info (vector-ref visual-info index))) + (if (and (= class (vector-ref info 4)) + ;; kludge, but X made us do it. + (<= depth-min (vector-ref info 8) depth-max)) + info + (loop (+ index 1))))))))) + (make-gray-map + (lambda (n-levels) + (let ((gm (make-string n-levels)) + (step (/ 65535 (- n-levels 1)))) + (do ((index 0 (+ index 1))) + ((= index n-levels)) + (vector-8b-set! + gm + index + (let ((intensity (round->exact (* step index)))) + (x-colormap/allocate-color + w-cm + intensity intensity intensity)))) + (1d-table/put! (x-display/properties + (x-graphics/display window)) + '6001-GRAY-MAP + gm))))) + (cond ((find-info visual-class:static-gray 256 256) + (make-gray-map 256)) + ((find-info visual-class:pseudo-color 250 256) + (make-gray-map 128)) + ((find-info visual-class:static-gray 2 2) + (make-gray-map 2)) + (else + (error "ALLOCATE-GRAYS: not known display type" window)))))) + +(define (side-effecting-iter n proc) + (define (reverse-order-iter count) + (if (fix:= count n) + 'done + (begin (proc count) + (reverse-order-iter (fix:+ 1 count))))) + (reverse-order-iter 0)) + +(define (lo-bound interval-length) + (fix:- 1 (quotient (fix:+ 1 interval-length) 2))) + +(define (up-bound interval-length) + (floor->exact (1+ (/ interval-length 2)))) + +(define (procedure->picture width height fn) + (let ((new-pic (make-picture width height))) + (picture-map! new-pic fn) + new-pic)) + +(define (picture-map f . pic-list) + (if (and (apply = (map (lambda (pic) (picture-width pic)) pic-list)) + (apply = (map (lambda (pic) (picture-height pic)) pic-list))) + (let* ((width (picture-width (car pic-list))) + (height (picture-height (car pic-list))) + (new-pic (make-picture width height)) + (picdata (picture-data new-pic))) + (cond ((null? pic-list) + (error "no pictures -- PICTURE-MAP")) + ((null? (cdr pic-list)) + (let ((p1-data (picture-data (car pic-list)))) + (let y-loop ((y 0)) + (if (fix:< y height) + (let ((out-yth-row (floating-vector-ref picdata y)) + (in-yth-row (floating-vector-ref p1-data y))) + (let x-loop ((x 0)) + (if (fix:< x width) + (begin + (floating-vector-set! + out-yth-row x + (exact->inexact + (f (floating-vector-ref in-yth-row x)))) + (x-loop (fix:+ 1 x))) + (y-loop (fix:+ 1 y))))))))) + ((null? (cddr pic-list)) + (let ((p1-data (picture-data (car pic-list))) + (p2-data (picture-data (cadr pic-list)))) + (let y-loop ((y 0)) + (if (fix:< y height) + (let ((out-yth-row (floating-vector-ref picdata y)) + (in-yth-row1 (floating-vector-ref p1-data y)) + (in-yth-row2 (floating-vector-ref p2-data y))) + (let x-loop ((x 0)) + (if (fix:< x width) + (begin (floating-vector-set! + out-yth-row x + (exact->inexact + (f (floating-vector-ref in-yth-row1 x) + (floating-vector-ref + in-yth-row2 x)))) + (x-loop (fix:+ 1 x))) + (y-loop (fix:+ 1 y))))))))) + (else + (let ((data-list (map (lambda (pic) (picture-data pic)) + pic-list))) + (let y-loop ((y 0)) + (if (fix:< y height) + (let ((out-yth-row (floating-vector-ref picdata y)) + (in-yth-rows (map (lambda (data) + (floating-vector-ref + data y)) + data-list))) + (let x-loop ((x 0)) + (if (fix:< x width) + (begin + (floating-vector-set! + out-yth-row x + (exact->inexact + (apply f + (map (lambda (row) + (floating-vector-ref + row x)) + in-yth-rows)))) + (x-loop (fix:+ 1 x))) + (y-loop (fix:+ 1 y)))))))))) + (picture-set-data! new-pic picdata) + new-pic) + (error "picture sizes do not match -- PICTURE-MAP"))) + +(define (picture-display window pic #!optional pic-min pic-max) + (define (check-image pic window brick-wid brick-hgt) + (if (x-image? (picture-image pic)) + (let ((image (picture-image pic))) + (and (1d-table/get (graphics-device/properties window) image #f) + (fix:= (fix:* (picture-width pic) brick-wid) + (x-image/width image)) + (fix:= (fix:* (picture-height pic) brick-hgt) + (x-image/height image)))) + #f)) + + (with-values + (lambda () + (graphics-device-coordinate-limits window)) + (lambda (x1 y1 x2 y2) + (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))) + (len&margin (integer-divide win-wid (picture-width pic))) + (wid&margin (integer-divide win-hgt (picture-height pic))) + (h-margin (integer-divide-remainder len&margin)) + (v-margin (integer-divide-remainder wid&margin)) + (brick-wid (integer-divide-quotient len&margin)) + (brick-hgt (integer-divide-quotient wid&margin)) + (pic-min (if (default-object? pic-min) + (picture-min pic) + (exact->inexact pic-min))) + (pic-max (if (default-object? pic-max) + (picture-max pic) + (exact->inexact pic-max))) + (true-min-max? (and (= pic-min (picture-min pic)) + (= pic-max (picture-max pic)))) + (image-cached? (check-image pic window brick-wid brick-hgt))) + (if (or (fix:< brick-wid 1) (fix:< brick-hgt 1)) + (error "Window is too small to display" pic '--PICTURE-DISPLAY) + (let ((image (if (and image-cached? true-min-max?) + (picture-image pic) + (build-image pic window + brick-wid brick-hgt + pic-min pic-max)))) + (graphics-clear window) + (x-image/draw image + (quotient h-margin 2) + (quotient v-margin 2)) + (if (and true-min-max? (not image-cached?)) + (picture-set-image! pic image)))))))) + +(define (picture-write picture filename) + (let ((path-name (->pathname filename))) + (if (picture? picture) + (begin + (picture-set-image! picture '()) + (picture-min picture) ; ignored - but saves cached min, max values + (if (not (pathname-type path-name)) + (fasdump picture (pathname-new-type path-name "pic")) + (fasdump picture path-name))) + (error:wrong-type-argument picture "picture" 'PICTURE-WRITE)))) + +;;; This writes a picture in raw pgm format. If all values are between +;;; 0 and 255, then the values are written as is. Otherwise they are compressed +;;; to lie in the range 0 to 255. + +(define (picture->pgm-file pic file) + (let* ((width (picture-width pic)) + (height (picture-height pic)) + (data ( picture-data pic)) + (pmin (picture-min pic)) + (pmax (picture-max pic)) + (scale-it? (or (< pmin 0) (> pmax 255))) + (char-function + (cond ((= pmin pmax) + (lambda (x) x (ascii->char 0))) + (scale-it? + (let ((scale (/ 255. (- pmax pmin)))) + (lambda (x) + (ascii->char (round->exact (* (- x pmin) scale)))))) + (else + (lambda (x) (ascii->char (round->exact x))))))) + (call-with-output-file file + (lambda (port) + (let ((write-chars + (lambda (chars port) + (for-each (lambda (char) (write-char char port)) + chars)))) + ;;P5 is the magic type number for pgm. + (write-chars (string->list "P5") port) + (write-char #\Linefeed port) + (write-chars (string->list (number->string width)) port) + (write-char #\Space port) + (write-chars (string->list (number->string height)) port) + (write-char #\Linefeed port) + ;;write the number of gray levels + (write-chars (string->list (number->string 255)) port) + (write-char #\Linefeed port) + (let rowloop ((row (- height 1))) + (if (< row 0) + 'done + (let ((rowvals + (map char-function + (vector->list (vector-ref data row))))) + (begin (write-string (list->string rowvals) port) -- 2.25.1