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