From: Chris Hanson <org/chris-hanson/cph>
Date: Fri, 24 Feb 1995 00:38:28 +0000 (+0000)
Subject: Lots of changes to generalize this code for OS/2 and Windows.
X-Git-Tag: 20090517-FFI~6598
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=347a440134b4694edf583c118fb400c741386b14;p=mit-scheme.git

Lots of changes to generalize this code for OS/2 and Windows.
---

diff --git a/v7/src/6001/make.scm b/v7/src/6001/make.scm
index 140481688..25b6ee563 100644
--- a/v7/src/6001/make.scm
+++ b/v7/src/6001/make.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: make.scm,v 15.22 1995/02/24 00:37:51 cph Exp $
+$Id: make.scm,v 15.23 1995/02/24 00:38:28 cph Exp $
 
 Copyright (c) 1991-95 Massachusetts Institute of Technology
 
@@ -42,7 +42,7 @@ MIT in each case. |#
   (if (eq? 'UNIX microcode-id/operating-system)
       (load "floppy" edwin)))
 ((access initialize-package! (->environment '(student scode-rewriting))))
-(add-system! (make-system "6.001" 15 21 '()))
+(add-system! (make-system "6.001" 15 23 '()))
 
 ;;; Customize the runtime system:
 (set! repl:allow-restart-notifications? false)
diff --git a/v7/src/6001/pic-imag.scm b/v7/src/6001/pic-imag.scm
index 0bc307fe9..37a0ae482 100644
--- a/v7/src/6001/pic-imag.scm
+++ b/v7/src/6001/pic-imag.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: pic-imag.scm,v 1.6 1995/02/21 23:23:42 cph Exp $
+$Id: pic-imag.scm,v 1.7 1995/02/24 00:37:57 cph Exp $
 
 Copyright (c) 1991-95 Massachusetts Institute of Technology
 
@@ -175,15 +175,17 @@ MIT in each case. |#
 				   (let m-loop ((m n))
 				     (if (fix:< m m-end)
 					 (begin
-					   (vector-8b-set! byte-string
-							   m v)
+					   (vector-8b-set! byte-string m v)
 					   (m-loop (fix:+ m 1)))
 					 (n-loop (fix:+ n image-width)))))
 				 (x-loop (fix:+ px 1) (fix:+ ix h-sf)))))
 			 (y-loop (fix:- py 1) 
 				 (fix:+ iy-index rect-index-height)))))))))
-    
+    ;; Kludge: IMAGE/FILL-FROM-BYTE-VECTOR should take an argument
+    ;; that specifies what color a given byte in BYTE-STRING maps to.
+    ;; OS/2 requires this information, so we supply it here.
+    (if (eq? 'OS/2 microcode-id/operating-system)
+	(os2-image/set-colormap image os2-image-colormap:gray-256))
     (image/fill-from-byte-vector image byte-string)
     (1d-table/put! (graphics-device/properties window) image #t)
-    image))
-
+    image))
\ No newline at end of file
diff --git a/v7/src/6001/picture.scm b/v7/src/6001/picture.scm
index 5668e9bca..d246e179d 100644
--- a/v7/src/6001/picture.scm
+++ b/v7/src/6001/picture.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: picture.scm,v 1.22 1995/02/21 23:22:24 cph Exp $
+$Id: picture.scm,v 1.23 1995/02/24 00:38:06 cph Exp $
 
 Copyright (c) 1991-95 Massachusetts Institute of Technology
 
@@ -141,6 +141,13 @@ MIT in each case. |#
 				(- dy (+ y fy)))))))
     window))
 
+(define os2-image-colormap:gray-256
+  (make-initialized-vector 256
+    (lambda (index)
+      (+ (* index #x10000)
+	 (* index #x100)
+	 index))))
+
 (define (resize-window window width height)
   (let ((name (graphics-type-name (graphics-type window))))
     (case name
@@ -158,7 +165,8 @@ MIT in each case. |#
   (let ((name (graphics-type-name (graphics-type window))))
     (case name
       ((X) (n-gray-map/X11 window))
-      ((WIN32 OS/2) (n-gray-map/win32 window))
+      ((WIN32) (n-gray-map/win32 window))
+      ((OS/2) (n-gray-map/os2 window))
       (else (error "Unsupported graphics type:" name)))))
 
 (define (n-gray-map/X11 window)
@@ -217,21 +225,19 @@ MIT in each case. |#
 (define-integrable visual-class:true-color 4)
 (define-integrable visual-class:direct-color 5)
 
-(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)
+(define n-gray-map/win32
+  (let ((map (make-string 128)))
+    (do ((i 0 (fix:+ i 1)))
+	((fix:= i 128))
+      (vector-8b-set! map i i))
+    (lambda (window) window map)))
+
+(define n-gray-map/os2
+  (let ((map (make-string 256)))
+    (do ((i 0 (fix:+ i 1)))
+	((fix:= i 256))
+      (vector-8b-set! map i i))
+    (lambda (window) window map)))
 
 ;;;; Pictures
 
@@ -324,8 +330,8 @@ MIT in each case. |#
     (lambda (x1 y1 x2 y2)
       (set! *last-picture-displayed* pic)
       (graphics-set-coordinate-limits window 0 (- y2 y1) (- x2 x1) 0)
-      (let* ((win-wid (fix:+ 1 (fix:- x2 x1)))
-	     (win-hgt (fix:+ 1 (fix:- y1 y2)))
+      (let* ((win-wid (+ 1 (abs (- x2 x1))))
+	     (win-hgt (+ 1 (abs (- 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))
@@ -349,10 +355,10 @@ MIT in each case. |#
 					 brick-wid brick-hgt
 					 pic-min pic-max))))
 	      (graphics-clear window)
-	      (graphics-operation window 'draw-image
-			    (quotient h-margin 2)
-			    (- (quotient v-margin 2))
-			    image)
+	      (image/draw window
+			  (quotient h-margin 2)
+			  (- (quotient v-margin 2))
+			  image)
 	      (if (and true-min-max? (not image-cached?))
 		  (picture-set-image! pic image))))))))