From 347a440134b4694edf583c118fb400c741386b14 Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Fri, 24 Feb 1995 00:38:28 +0000
Subject: [PATCH] Lots of changes to generalize this code for OS/2 and Windows.
---
v7/src/6001/make.scm | 4 ++--
v7/src/6001/pic-imag.scm | 14 ++++++-----
v7/src/6001/picture.scm | 52 ++++++++++++++++++++++------------------
3 files changed, 39 insertions(+), 31 deletions(-)
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))))))))
--
2.25.1