#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/6001/picture.scm,v 1.21 1993/11/10 21:15:04 adams Exp $
+$Id: picture.scm,v 1.22 1995/02/21 23:22:24 cph Exp $
-Copyright (c) 1991-92 Massachusetts Institute of Technology
+Copyright (c) 1991-95 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
;;;; 6.001 Images
(declare (usual-integrations))
+\f
+;;;; Miscellaneous Utilities
-(define-primitives floating-vector-ref)
-(define-primitives floating-vector-set!)
-(define-primitives floating-vector-cons)
-(define-primitives floating-vector-length)
-
-(define %win32-prim (make-primitive-procedure 'get-handle 1))
-(define %X11-prim (make-primitive-procedure 'x-get-visual-info 10))
-(define-integrable (for-win32?) (implemented-primitive-procedure? %win32-prim))
-(define-integrable (for-X11?) (implemented-primitive-procedure? %X11-prim))
-
-(define (dispatch-on-window-system win32-item x11-item)
- (cond ((for-win32?) win32-item)
- ((for-X11?) x11-item)
- (else (error "Neither X11 nor Win32 supported"))))
-
+(define-primitives
+ floating-vector-ref
+ floating-vector-set!
+ floating-vector-cons
+ floating-vector-length)
(define (make-floating-vector length init)
(let ((result (floating-vector-cons length)))
(if (not (= init 0.))
- (do
- ((i 0 (+ i 1)))
- ((= i length))
+ (do ((i 0 (fix:+ i 1)))
+ ((fix:= i length))
(floating-vector-set! result i init)))
result))
(define (floating-vector-copy vector)
(let* ((length (floating-vector-length vector))
(result (floating-vector-cons length)))
- (do
- ((i 0 (+ i 1)))
- (( = i length))
+ (do ((i 0 (fix:+ i 1)))
+ ((fix:= i length))
(floating-vector-set! result i (floating-vector-ref vector i)))
result))
-(define (get-visual-info window)
- ((ucode-primitive x-get-visual-info 10) (x-graphics-device/xw window)
- #f #f #f #f #f #f #f #f #f))
+(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 (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 (lo-bound interval-length)
+ (fix:- 1 (quotient (fix:+ 1 interval-length) 2)))
-(define (resize-window window width height)
- (graphics-operation window 'resize-window width height))
+(define (up-bound interval-length)
+ (floor->exact (1+ (/ interval-length 2))))
+
+(define (floating-vector->list vector)
+ (generate-list (floating-vector-length vector)
+ (lambda (i)
+ (floating-vector-ref vector i))))
+
+(define (generate-list n proc) ; ==> ( (proc 0) (proc 1) ... (proc n-1) )
+ (let loop ((i (- n 1)) (list '()))
+ (if (< i 0)
+ list
+ (loop (- i 1) (cons (proc i) list)))))
+\f
+;;;; Graphics Windows
+
+(define (make-window width height x y)
+ (let ((window
+ (let ((name (graphics-type-name (graphics-type #f))))
+ (case name
+ ((X) (make-window/X11 width height x y))
+ ((WIN32) (make-window/win32 width height x y))
+ ((OS/2) (make-window/OS2 width height x y))
+ (else (error "Unsupported graphics type:" name))))))
+ (graphics-set-coordinate-limits window 0 (- (- height 1)) (- width 1) 0)
+ (restore-focus-to-editor)
+ window))
(define (make-window/X11 width height x y)
(let ((window
false
(x-geometry-string x y width height)
true)))
- (graphics-set-coordinate-limits window 0 (- (- height 1)) (- width 1) 0)
;; Prevent this window from receiving the keyboard focus.
(x-graphics/disable-keyboard-focus window)
;; Inform the window manager that this window does not do any
;; OK, now map the window onto the screen.
(x-graphics/map-window window)
(x-graphics/flush window)
- (if (not (n-gray-map window))
- (allocate-grays window))
- (restore-focus-to-editor)
window))
(define (make-window/win32 width height x y)
- (let ((window
- (make-graphics-device 'win32
- width height
- 'grayscale-128)))
- (graphics-operation window 'move-window x y)
- (graphics-set-coordinate-limits window 0 (- (- height 1)) (- width 1) 0)
- (restore-focus-to-editor)
+ (let ((window (make-graphics-device 'WIN32 width height 'GRAYSCALE-128)))
+ (graphics-operation window 'MOVE-WINDOW x y)
window))
-(define (make-window width height x y)
- ((dispatch-on-window-system make-window/win32 make-window/X11)
- width height x y))
-
-(define (n-gray-map/X11 window)
- (1d-table/get (x-display/properties (x-graphics/display window))
- '6001-GRAY-MAP
- false))
-
-(define 128->128-gray-map #f)
+(define (make-window/OS2 width height x y)
+ (let ((window (make-graphics-device 'OS/2 width height)))
+ ;; X, Y specify the position of the upper-left corner of the
+ ;; window, in coordinates relative to the upper-left corner of the
+ ;; display with Y growing down; the OS/2 SET-WINDOW-POSITION
+ ;; operation specifies the position of the lower-left corner of
+ ;; the window, in coordinates relative to the lower left corner of
+ ;; the display, with Y growing up.
+ (call-with-values (lambda () (graphics-operation window 'DESKTOP-SIZE))
+ (lambda (dx dy)
+ dx
+ (call-with-values
+ (lambda () (graphics-operation window 'WINDOW-FRAME-SIZE))
+ (lambda (fx fy)
+ fx
+ (graphics-operation window 'SET-WINDOW-POSITION
+ x
+ (- dy (+ y fy)))))))
+ window))
-(define (n-gray-map/win32 window)
- window
- (if (not 128->128-gray-map)
- (set! 128->128-gray-map
- (let ((s (make-string 128)))
- (let loop ((i 0))
- (if (< i 128)
- (begin
- (vector-8b-set! s i i)
- (loop (1+ i)))))
- s)
- ))
- 128->128-gray-map)
+(define (resize-window window width height)
+ (let ((name (graphics-type-name (graphics-type window))))
+ (case name
+ ((X WIN32) (graphics-operation window 'RESIZE-WINDOW width height))
+ ((OS/2) (graphics-operation window 'SET-WINDOW-SIZE width height))
+ (else (error "Unsupported graphics type:" name)))))
+(define (show-window-size window)
+ (call-with-values (lambda () (graphics-device-coordinate-limits window))
+ (lambda (x1 y1 x2 y2)
+ (newline)
+ (display `("width:" ,(+ (- x2 x1) 1) " height:" ,(+ (- y1 y2) 1))))))
+\f
(define (n-gray-map window)
- ((dispatch-on-window-system n-gray-map/win32 n-gray-map/X11) window))
+ (let ((name (graphics-type-name (graphics-type window))))
+ (case name
+ ((X) (n-gray-map/X11 window))
+ ((WIN32 OS/2) (n-gray-map/win32 window))
+ (else (error "Unsupported graphics type:" name)))))
-(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 (n-gray-map/X11 window)
+ (let ((properties (x-display/properties (x-graphics/display window))))
+ (or (1d-table/get properties '6001-GRAY-MAP #f)
+ (let ((gm (allocate-grays window)))
+ (1d-table/put! properties '6001-GRAY-MAP gm)
+ gm))))
(define (allocate-grays window)
(let ((w-cm (graphics-operation window 'get-colormap))
- (visual-info (get-visual-info window)))
+ (visual-info
+ ((ucode-primitive x-get-visual-info 10) (x-graphics-device/xw window)
+ #f #f #f #f #f #f #f #f #f)))
(let ((find-info
(let ((length (vector-length visual-info)))
(if (= length 0)
(x-colormap/allocate-color
w-cm
intensity intensity intensity))))
- (1d-table/put! (x-display/properties
- (x-graphics/display window))
- '6001-GRAY-MAP
- gm)))))
+ gm))))
(cond ((find-info visual-class:static-gray 256 256)
(make-gray-map 256))
((or (find-info visual-class:gray-scale 256 256)
(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-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 (up-bound interval-length)
- (floor->exact (1+ (/ interval-length 2))))
+(define (n-gray-map/win32 window)
+ window
+ (if (not 128->128-gray-map)
+ (set! 128->128-gray-map
+ (let ((s (make-string 128)))
+ (let loop ((i 0))
+ (if (fix:< i 128)
+ (begin
+ (vector-8b-set! s i i)
+ (loop (fix:+ i 1)))))
+ s)))
+ 128->128-gray-map)
+
+(define 128->128-gray-map
+ #f)
+\f
+;;;; Pictures
(define (procedure->picture width height fn)
(let ((new-pic (make-picture width height)))
(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))
+ (new-pic (make-picture width height))
(picdata (picture-data new-pic)))
(cond ((null? pic-list)
(error "no pictures -- PICTURE-MAP"))
(let y-loop ((y 0))
(if (fix:< y height)
(let ((out-yth-row (vector-ref picdata y))
- (in-yth-row (vector-ref p1-data y)))
+ (in-yth-row (vector-ref p1-data y)))
(let x-loop ((x 0))
(if (fix:< x width)
(begin
- (floating-vector-set!
- out-yth-row x
- (exact->inexact
+ (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)))))))))
(in-yth-row2 (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)))
+ (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))
+ (let ((data-list
+ (map (lambda (pic) (picture-data pic)) pic-list)))
+ (let y-loop ((y 0))
(if (fix:< y height)
(let ((out-yth-row (vector-ref picdata y))
- (in-yth-rows (map (lambda (data)
- (vector-ref
- data y))
+ (in-yth-rows (map (lambda (data)
+ (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))
+ (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))))))))))
(if (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)
+ (fix:= (fix:* (picture-width pic) brick-wid)
(image/width image))
- (fix:= (fix:* (picture-height pic) brick-hgt)
+ (fix:= (fix:* (picture-height pic) brick-hgt)
(image/height image))))
#f))
- (with-values
+ (call-with-values
(lambda ()
(graphics-device-coordinate-limits window))
(lambda (x1 y1 x2 y2)
(pic-min (if (default-object? pic-min)
(picture-min pic)
(exact->inexact pic-min)))
- (pic-max (if (default-object? pic-max)
+ (pic-max (if (default-object? pic-max)
(picture-max pic)
(exact->inexact pic-max)))
(true-min-max? (and (= pic-min (picture-min pic))
(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
+ (build-image pic window
brick-wid brick-hgt
pic-min pic-max))))
(graphics-clear window)
- (graphics-operation window 'draw-image
+ (graphics-operation window 'draw-image
(quotient h-margin 2)
(- (quotient v-margin 2))
image)
(define *last-picture-displayed*
false)
-
+\f
(define (picture-write picture filename)
(let ((path-name (->pathname filename)))
(if (picture? picture)
(pmin (picture-min pic))
(pmax (picture-max pic))
(char-function
- (cond ((= pmin pmax)
+ (cond ((= pmin pmax)
(lambda (x) x (ascii->char 0)))
(else
(let ((scale (/ 255. (- pmax pmin))))
- (lambda (x)
+ (lambda (x)
(ascii->char (round->exact (* (- x pmin) scale)))))))))
(call-with-output-file file
(lambda (port)
(let ((rowvals
(map char-function
(floating-vector->list (vector-ref data row)))))
- (begin (write-string (list->string rowvals) port)
- (rowloop (- row 1)))))))))))
-
-
-(define (floating-vector->list vector)
- (generate-list (floating-vector-length vector)
- (lambda (i)
- (floating-vector-ref vector i))))
-
-
-(define (generate-list n proc) ; ==> ( (proc 0) (proc 1) ... (proc n-1) )
- (let loop ((i (- n 1)) (list '()))
- (if (< i 0)
- list
- (loop (- i 1) (cons (proc i) list)))))
-
-
-
-
-
+ (begin
+ (write-string (list->string rowvals) port)
+ (rowloop (- row 1)))))))))))
\ No newline at end of file
projects / mit-scheme.git / commitdiff