From 1b8eb2d963d4d35353c4b1a8d93e5d49bd295b26 Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Tue, 21 Feb 1995 23:22:24 +0000
Subject: [PATCH] Major cleanup of this file.  Generalization of graphics code
 to support OS/2.

---
 v7/src/6001/picture.scm | 304 +++++++++++++++++++++-------------------
 1 file changed, 157 insertions(+), 147 deletions(-)

diff --git a/v7/src/6001/picture.scm b/v7/src/6001/picture.scm
index f9c7da137..5668e9bca 100644
--- a/v7/src/6001/picture.scm
+++ b/v7/src/6001/picture.scm
@@ -1,8 +1,8 @@
 #| -*-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
@@ -35,54 +35,70 @@ MIT in each case. |#
 ;;;; 6.001 Images
 
 (declare (usual-integrations))
+
+;;;; 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)))))
+
+;;;; 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
@@ -90,7 +106,6 @@ MIT in each case. |#
 			       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
@@ -99,59 +114,65 @@ MIT in each case. |#
     ;; 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))))))
+
 (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)
@@ -178,10 +199,7 @@ MIT in each case. |#
 		    (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)
@@ -192,19 +210,30 @@ MIT in each case. |#
 	    (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-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)
+
+;;;; Pictures
 
 (define (procedure->picture width height fn)
   (let ((new-pic (make-picture width height)))
@@ -216,7 +245,7 @@ MIT in each case. |#
 	   (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"))
@@ -225,13 +254,13 @@ MIT in each case. |#
 		 (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)))))))))
@@ -245,34 +274,32 @@ MIT in each case. |#
 			     (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))))))))))
@@ -285,13 +312,13 @@ MIT in each case. |#
     (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)
@@ -308,7 +335,7 @@ MIT in each case. |#
 	     (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))
@@ -318,11 +345,11 @@ MIT in each case. |#
 	    (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)
@@ -339,7 +366,7 @@ MIT in each case. |#
 
 (define *last-picture-displayed*
   false)
-
+
 (define (picture-write picture filename)
   (let ((path-name  (->pathname filename)))
     (if (picture? picture)
@@ -358,11 +385,11 @@ MIT in each case. |#
 	 (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)
@@ -386,23 +413,6 @@ MIT in each case. |#
 		(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
-- 
2.25.1