From c2ce851626eb1364230693b08771bd508a801b29 Mon Sep 17 00:00:00 2001
From: Arthur Gleckler <edu/mit/csail/zurich/arthur>
Date: Thu, 22 Aug 1991 17:44:50 +0000
Subject: [PATCH] Initial revision

---
 v7/src/6001/6001.cbf     |  35 ++++
 v7/src/6001/6001.sf      |  48 +++++
 v7/src/6001/arith.scm    | 390 +++++++++++++++++++++++++++++++++++++++
 v7/src/6001/make.scm     |  45 +++++
 v7/src/6001/nodefs.scm   | 171 +++++++++++++++++
 v7/src/6001/pic-imag.scm | 156 ++++++++++++++++
 v7/src/6001/pic-ops.scm  | 300 ++++++++++++++++++++++++++++++
 v7/src/6001/pic-read.scm |  96 ++++++++++
 v7/src/6001/pic-reco.scm | 186 +++++++++++++++++++
 v7/src/6001/picture.scm  |   0
 10 files changed, 1427 insertions(+)
 create mode 100644 v7/src/6001/6001.cbf
 create mode 100644 v7/src/6001/6001.sf
 create mode 100644 v7/src/6001/arith.scm
 create mode 100644 v7/src/6001/make.scm
 create mode 100644 v7/src/6001/nodefs.scm
 create mode 100644 v7/src/6001/pic-imag.scm
 create mode 100644 v7/src/6001/pic-ops.scm
 create mode 100644 v7/src/6001/pic-read.scm
 create mode 100644 v7/src/6001/pic-reco.scm
 create mode 100644 v7/src/6001/picture.scm

diff --git a/v7/src/6001/6001.cbf b/v7/src/6001/6001.cbf
new file mode 100644
index 000000000..cde7138b3
--- /dev/null
+++ b/v7/src/6001/6001.cbf
@@ -0,0 +1,35 @@
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/6001/6001.cbf,v 1.1 1991/08/22 17:44:50 arthur Exp $
+
+Copyright (c) 1991 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. |#
+
+(compile-directory ".")
\ No newline at end of file
diff --git a/v7/src/6001/6001.sf b/v7/src/6001/6001.sf
new file mode 100644
index 000000000..400c5db75
--- /dev/null
+++ b/v7/src/6001/6001.sf
@@ -0,0 +1,48 @@
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/6001/6001.sf,v 1.1 1991/08/22 17:42:15 arthur Exp $
+
+Copyright (c) 1991 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. |#
+
+(fluid-let ((sf/default-syntax-table syntax-table/system-internal))
+  (for-each sf-conditionally
+	    '("arith" "nodefs" "picture" "pic-record" "pic-image" "pic-read"
+		      "pic-ops")))
+
+;; Guarantee that the package modeller is loaded.
+(if (not (name->package '(CROSS-REFERENCE)))
+    (with-working-directory-pathname "/scheme/800/cref"
+      (lambda ()
+	(load "make"))))
+
+(cref/generate-all "6001")
+(sf "6001.con")
+(sf "6001.ldr")
\ No newline at end of file
diff --git a/v7/src/6001/arith.scm b/v7/src/6001/arith.scm
new file mode 100644
index 000000000..d56b7b109
--- /dev/null
+++ b/v7/src/6001/arith.scm
@@ -0,0 +1,390 @@
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/6001/arith.scm,v 1.1 1991/08/22 17:42:25 arthur Exp $
+
+Copyright (c) 1989-91 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. |#
+
+;;;; Scheme Arithmetic for 6.001
+;;; package: (student number)
+
+(declare (usual-integrations))
+
+(define-integrable (int:->flonum n)
+  ((ucode-primitive integer->flonum 2) n #b10))
+
+(define-integrable (flonum? object)
+  (object-type? (ucode-type big-flonum) object))
+
+(declare (integrate flo:integer?))
+(define (flo:integer? x)
+  (flo:= x (flo:round x)))
+
+(define (flo:->integer x)
+  (if (not (flo:integer? x))
+      (error:wrong-type-argument x "integer" 'FLONUM->INTEGER))
+  (flo:truncate->exact x))
+
+(define-integrable (guarantee-integer object procedure)
+  (if (not (int:integer? object))
+      (error:wrong-type-argument object "number" procedure)))
+
+(let-syntax
+    ((define-standard-unary
+       (macro (name flo:op int:op)
+	 `(DEFINE (,name X)
+	    (IF (FLONUM? X)
+		(,flo:op X)
+		(,int:op X))))))
+  (define-standard-unary rational? (lambda (x) x true) int:integer?)
+  (define-standard-unary integer? flo:integer? int:integer?)
+  (define-standard-unary exact? (lambda (x) x false)
+    (lambda (x)
+      (guarantee-integer x 'EXACT?)
+      true))
+  (define-standard-unary zero? flo:zero? int:zero?)
+  (define-standard-unary negative? flo:negative? int:negative?)
+  (define-standard-unary positive? flo:positive? int:positive?)
+  (define-standard-unary abs flo:abs int:abs)
+  (define-standard-unary floor flo:floor (lambda (x) x))
+  (define-standard-unary ceiling flo:ceiling (lambda (x) x))
+  (define-standard-unary truncate flo:truncate (lambda (x) x))
+  (define-standard-unary round flo:round (lambda (x) x))
+  (define-standard-unary exact->inexact (lambda (x) x) int:->flonum)
+  (define-standard-unary inexact->exact
+    (lambda (x)
+      (if (not (flo:integer? x))
+	  (error:bad-range-argument x 'INEXACT->EXACT))
+      (flo:truncate->exact x))
+    (lambda (x)
+      (guarantee-integer x 'INEXACT->EXACT)
+      x)))
+
+(let-syntax
+    ((define-standard-binary
+       (macro (name flo:op int:op)
+	 `(DEFINE (,name X Y)
+	    (IF (FLONUM? X)
+		(IF (FLONUM? Y)
+		    (,flo:op X Y)
+		    (,flo:op X (INT:->FLONUM Y)))
+		(IF (FLONUM? Y)
+		    (,flo:op (INT:->FLONUM X) Y)
+		    (,int:op X Y)))))))
+  (define-standard-binary real:+ flo:+ int:+)
+  (define-standard-binary real:- flo:- int:-)
+  (define-standard-binary rationalize
+    flo:rationalize
+    int:rationalize))
+
+(define (int:rationalize q e)
+  (int:simplest-rational (int:- q e) (int:+ q e)))
+
+(define (int:simplest-rational x y)
+  (let ((x<y
+	 (lambda (x y)
+	   (cond ((int:positive? x) x)
+		 ((int:negative? y) y)
+		 (else 0)))))
+    (cond ((int:< x y) (x<y x y))
+	  ((int:< y x) (x<y y x))
+	  (else x))))
+
+(define (real:* x y)
+  (cond ((flonum? x)
+	 (cond ((flonum? y) (flo:* x y))
+	       ((int:zero? y) y)
+	       (else (flo:* x (int:->flonum y)))))
+	((int:zero? x) x)
+	((flonum? y) (flo:* (int:->flonum x) y))
+	(else (int:* x y))))
+
+(define (real:/ x y)
+  (let ((y (if (flonum? y) y (int:->flonum y))))
+    (cond ((flonum? x) (flo:/ x y))
+	  ((int:zero? x) x)
+	  (else (flo:/ (int:->flonum x) y)))))
+
+(define (real:= x y)
+  (if (flonum? x)
+      (if (flonum? y)
+	  (flo:= x y)
+	  (begin
+	    (guarantee-integer y '=)
+	    (and (flo:= x (flo:truncate x))
+		 (int:= (flo:truncate->exact x) y))))
+      (if (flonum? y)
+	  (begin
+	    (guarantee-integer x '=)
+	    (and (flo:= y (flo:truncate y))
+		 (int:= x (flo:truncate->exact y))))
+	  (int:= x y))))
+
+(define (real:< x y)
+  (if (flonum? x)
+      (if (flonum? y)
+	  (flo:< x y)
+	  (flo/int:< x y))
+      (if (flonum? y)
+	  (int/flo:< x y)
+	  (int:< x y))))
+
+(define (real:max x y)
+  (if (flonum? x)
+      (if (flonum? y)
+	  (if (flo:< x y) y x)
+	  (if (flo/int:< x y) (int:->flonum y) x))
+      (if (flonum? y)
+	  (if (int/flo:< x y) y (int:->flonum x))
+	  (if (int:< x y) y x))))
+
+(define (real:min x y)
+  (if (flonum? x)
+      (if (flonum? y)
+	  (if (flo:< x y) x y)
+	  (if (flo/int:< x y) x (int:->flonum y)))
+      (if (flonum? y)
+	  (if (int/flo:< x y) (int:->flonum x) y)
+	  (if (int:< x y) x y))))
+
+(define-integrable (flo/int:< x y)
+  (let ((ix (flo:truncate->exact x)))
+    (cond ((int:< ix y) true)
+	  ((int:< y ix) false)
+	  (else (flo:< x (flo:truncate x))))))
+
+(define-integrable (int/flo:< x y)
+  (let ((iy (flo:truncate->exact y)))
+    (cond ((int:< x iy) true)
+	  ((int:< iy x) false)
+	  (else (flo:< (flo:truncate y) y)))))
+
+(define (even? n)
+  (int:even? (if (flonum? n) (flo:->integer n) n)))
+
+(let-syntax
+    ((define-integer-binary
+       (macro (name operator)
+	 `(DEFINE (,name N M)
+	    (IF (FLONUM? N)
+		(INT:->FLONUM
+		 (,operator (FLO:->INTEGER N)
+			    (IF (FLONUM? M) (FLO:->INTEGER M) M)))
+		(IF (FLONUM? M)
+		    (INT:->FLONUM (,operator N (FLO:->INTEGER M)))
+		    (,operator N M)))))))
+  (define-integer-binary quotient int:quotient)
+  (define-integer-binary remainder int:remainder)
+  (define-integer-binary modulo int:modulo)
+  (define-integer-binary real:gcd int:gcd)
+  (define-integer-binary real:lcm int:lcm))
+
+(define (numerator q)
+  (if (flonum? q)
+      (int:->flonum (rat:numerator (flo:->rational q)))
+      (begin
+	(guarantee-integer q 'NUMERATOR)
+	q)))
+
+(define (denominator q)
+  (if (flonum? q)
+      (int:->flonum (rat:denominator (flo:->rational q)))
+      (begin
+	(guarantee-integer q 'DENOMINATOR)
+	1)))
+
+(let-syntax
+    ((define-transcendental-unary
+       (macro (name hole? hole-value function)
+	 `(DEFINE (,name X)
+	    (IF (,hole? X)
+		,hole-value
+		(,function (REAL:->FLONUM X)))))))
+  (define-transcendental-unary exp real:exact0= 1 flo:exp)
+  (define-transcendental-unary log real:exact1= 0 flo:log)
+  (define-transcendental-unary sin real:exact0= 0 flo:sin)
+  (define-transcendental-unary cos real:exact0= 1 flo:cos)
+  (define-transcendental-unary tan real:exact0= 0 flo:tan)
+  (define-transcendental-unary asin real:exact0= 0 flo:asin)
+  (define-transcendental-unary acos real:exact1= 0 flo:acos)
+  (define-transcendental-unary real:atan real:exact0= 0 flo:atan))
+
+(define (real:atan2 y x)
+  (if (and (real:exact0= y) (exact? x))
+      0
+      (flo:atan2 (real:->flonum y) (real:->flonum x))))
+
+(define-integrable (real:exact0= x)
+  (if (flonum? x) false (int:zero? x)))
+
+(define-integrable (real:exact1= x)
+  (if (flonum? x) false (int:= 1 x)))
+
+(define (real:->flonum x)
+  (if (flonum? x)
+      x
+      (int:->flonum x)))
+
+(define (sqrt x)
+  (if (flonum? x)
+      (begin
+	(if (flo:negative? x)
+	    (error:bad-range-argument x 'SQRT))
+	(flo:sqrt x))
+      (int:sqrt x)))
+
+(define (int:sqrt x)
+  (if (int:negative? x)
+      (error:bad-range-argument x 'SQRT))
+  (let ((guess (flo:sqrt (int:->flonum x))))
+    (let ((n (flo:round->exact guess)))
+      (if (int:= x (int:* n n))
+	  n
+	  guess))))
+
+(define (expt x y)
+  (let ((general-case
+	 (lambda (x y)
+	   (cond ((flo:zero? y) 1.)
+		 ((flo:zero? x)
+		  (if (not (flo:positive? y))
+		      (error:divide-by-zero 'EXPT (list x y)))
+		  x)
+		 (else
+		  (if (and (flo:negative? x)
+			   (not (flo:integer? y)))
+		      (error:bad-range-argument x 'EXPT))
+		  (flo:expt x y))))))
+    (if (flonum? x)
+	(if (flonum? y)
+	    (general-case x y)
+	    (let ((exact-method
+		   (lambda (y)
+		     (if (int:= 1 y)
+			 x
+			 (let loop ((x x) (y y) (answer 1.))
+			   (let ((qr (int:divide y 2)))
+			     (let ((x (flo:* x x))
+				   (y (integer-divide-quotient qr))
+				   (answer
+				    (if (int:zero?
+					 (integer-divide-remainder qr))
+					answer
+					(flo:* answer x))))
+			       (if (int:= 1 y)
+				   (flo:* answer x)
+				   (loop x y answer)))))))))
+	      (cond ((int:positive? y) (exact-method y))
+		    ((int:negative? y)
+		     (flo:/ 1. (exact-method (int:negate y))))
+		    (else 1.))))
+	(if (flonum? y)
+	    (general-case (int:->flonum x) y)
+	    (int:expt x y)))))
+
+(define number? rational?)
+(define complex? rational?)
+(define real? rational?)
+
+(define (inexact? z)
+  (not (exact? z)))
+
+(define (odd? n)
+  (not (even? n)))
+
+(define (= . zs)
+  (reduce-comparator real:= zs))
+
+(define (< . xs)
+  (reduce-comparator real:< xs))
+
+(define (> . xs)
+  (reduce-comparator (lambda (x y) (real:< y x)) xs))
+
+(define (<= . xs)
+  (reduce-comparator (lambda (x y) (not (real:< y x))) xs))
+
+(define (>= . xs)
+  (reduce-comparator (lambda (x y) (not (real:< x y))) xs))
+
+(define (max x . xs)
+  (reduce-max/min real:max x xs))
+
+(define (min x . xs)
+  (reduce-max/min real:min x xs))
+
+(define (+ . zs)
+  (cond ((null? zs) 0)
+	((null? (cdr zs)) (car zs))
+	((null? (cddr zs)) (real:+ (car zs) (cadr zs)))
+	(else
+	 (real:+ (car zs)
+		 (real:+ (cadr zs)
+			 (reduce real:+ 0 (cddr zs)))))))
+
+(define (* . zs)
+  (cond ((null? zs) 1)
+	((null? (cdr zs)) (car zs))
+	((null? (cddr zs)) (real:* (car zs) (cadr zs)))
+	(else
+	 (real:* (car zs)
+		 (real:* (cadr zs)
+			 (reduce real:* 1 (cddr zs)))))))
+
+(define (- z1 . zs)
+  (cond ((null? zs)
+	 (if (flonum? z1) (flo:negate z1) (int:negate z1)))
+	((null? (cdr zs))
+	 (real:- z1 (car zs)))
+	(else
+	 (real:- z1
+		 (real:+ (car zs)
+			 (real:+ (cadr zs)
+				 (reduce real:+ 0 (cddr zs))))))))
+
+(define (/ z1 . zs)
+  (cond ((null? zs)
+	 (flo:/ 1. (if (flonum? z1) z1 (int:->flonum z1))))
+	((null? (cdr zs))
+	 (real:/ z1 (car zs)))
+	(else
+	 (real:/ z1
+		 (real:* (car zs)
+			 (real:* (cadr zs)
+				 (reduce real:* 1 (cddr zs))))))))
+
+(define (gcd . integers)
+  (reduce real:gcd 0 integers))
+
+(define (lcm . integers)
+  (reduce real:lcm 1 integers))
+
+(define (atan z #!optional x)
+  (if (default-object? x) (real:atan z) (real:atan2 z x)))
\ No newline at end of file
diff --git a/v7/src/6001/make.scm b/v7/src/6001/make.scm
new file mode 100644
index 000000000..080705c1e
--- /dev/null
+++ b/v7/src/6001/make.scm
@@ -0,0 +1,45 @@
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/6001/make.scm,v 1.1 1991/08/22 17:42:30 arthur Exp $
+
+Copyright (c) 1991 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: System Construction
+
+(declare (usual-integrations))
+
+(package/system-loader "6001" '() 'QUERY)
+((access initialize-package! (->environment '(student scode-rewriting))))
+(add-system! (make-system "6.001" 15 0 '()))
+(in-package (->environment '(edwin))
+  (using-syntax (access edwin-syntax-table (->environment '(edwin)))
+    (set-variable! enable-transcript-buffer true)))
+(ge '(student))
\ No newline at end of file
diff --git a/v7/src/6001/nodefs.scm b/v7/src/6001/nodefs.scm
new file mode 100644
index 000000000..115139d61
--- /dev/null
+++ b/v7/src/6001/nodefs.scm
@@ -0,0 +1,171 @@
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/6001/nodefs.scm,v 1.1 1991/08/22 17:42:36 arthur Exp $
+
+Copyright (c) 1991 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. |#
+
+;;;; SCode rewriting for 6.001
+;;; package: (student scode-rewriting)
+
+(declare (usual-integrations))
+
+(define (initialize-package!)
+  (set! hook/repl-eval student/repl-eval)
+  unspecific)
+
+(define (student/repl-eval repl s-expression environment syntax-table)
+  (let ((scode (rewrite-scode (syntax s-expression syntax-table) repl)))
+    (with-new-history (lambda () (extended-scode-eval scode environment)))))
+
+(define (rewrite-scode expression repl)
+  (let ((expression
+	 (if (open-block? expression)
+	     (open-block-components expression unscan-defines)
+	     expression)))
+    (check-for-illegal-definitions expression)
+    (make-sequence
+     (map (lambda (expression)
+	    (if (definition? expression)
+		(let ((name (definition-name expression))
+		      (value (definition-value expression)))
+		  (make-sequence
+		   (list expression
+			 (make-combination write-definition-value
+					   (list name
+						 (make-variable name))))))
+		expression))
+	  (sequence-actions expression)))))
+
+(define (write-definition-value name value)
+  (let ((port (nearest-cmdl/output-port)))
+    (fresh-line port)
+    (write-string ";" port)
+    (write name port)
+    (write-string ": " port)
+    (write value port)))
+
+(define (check-for-illegal-definitions expression)
+  (walk/expression (if (open-block? expression)
+		       (open-block-components expression unscan-defines)
+		       expression)
+		   'LEGAL))
+
+(define (walk/expression expression context)
+  ((scode-walk walker expression) expression context))
+
+(define-integrable (walk/no-definitions expression)
+  (walk/expression expression 'ILLEGAL))
+
+(define (walk/lambda expression context)
+  context
+  (let loop
+      ((expressions
+	(sequence-actions
+	 (lambda-components expression
+	   (lambda (name required optional rest auxiliary declarations body)
+	     name required optional rest
+	     (unscan-defines auxiliary declarations body))))))
+    (if (definition? (car expressions))
+	(begin
+	  (walk/no-definitions (definition-value (car expressions)))
+	  (if (not (null? (cdr expressions)))
+	      (loop (cdr expressions))))
+	(for-each walk/no-definitions expressions))))
+
+(define (walk/definition expression context)
+  (case context
+    ((ILLEGAL)
+     (error "Definition appears in illegal context:"
+	    (unsyntax expression)))
+    ((UNUSUAL)
+     (warn "Definition appears in unusual context:"
+	   (unsyntax expression))))
+  (walk/no-definitions (definition-value expression)))
+
+(define (walk/sequence expression context)
+  (for-each (lambda (expression)
+	      (walk/expression expression context))
+	    (sequence-actions expression)))
+
+(define (walk/constant expression context)
+  expression context
+  unspecific)
+
+(define (walk/access expression context)
+  context
+  (walk/no-definitions (access-environment expression)))
+
+(define (walk/assignment expression context)
+  context
+  (walk/no-definitions (assignment-value expression)))
+
+(define (walk/combination expression context)
+  context
+  (walk/no-definitions (combination-operator expression))
+  (for-each walk/no-definitions (combination-operands expression)))
+
+(define (walk/comment expression context)
+  (walk/expression (comment-expression expression) context))
+
+(define (walk/conditional expression context)
+  (walk/no-definitions (conditional-predicate expression))
+  (let ((context (if (eq? 'LEGAL context) 'UNUSUAL context)))
+    (walk/expression (conditional-consequent expression) context)
+    (walk/expression (conditional-alternative expression) context)))
+
+(define (walk/delay expression context)
+  context
+  (walk/no-definitions (delay-expression expression)))
+
+(define (walk/disjunction expression context)
+  (walk/no-definitions (disjunction-predicate expression))
+  (walk/expression (disjunction-alternative expression)
+		   (if (eq? 'LEGAL context) 'UNUSUAL context)))
+
+(define (walk/in-package expression context)
+  context
+  (walk/no-definitions (in-package-environment expression))
+  (check-for-illegal-definitions (in-package-expression expression)))
+
+(define walker
+  (make-scode-walker
+   walk/constant
+   `((ACCESS ,walk/access)
+     (ASSIGNMENT ,walk/assignment)
+     (COMBINATION ,walk/combination)
+     (COMMENT ,walk/comment)
+     (CONDITIONAL ,walk/conditional)
+     (DEFINITION ,walk/definition)
+     (DELAY ,walk/delay)
+     (DISJUNCTION ,walk/disjunction)
+     (IN-PACKAGE ,walk/in-package)
+     (LAMBDA ,walk/lambda)
+     (SEQUENCE ,walk/sequence))))
\ No newline at end of file
diff --git a/v7/src/6001/pic-imag.scm b/v7/src/6001/pic-imag.scm
new file mode 100644
index 000000000..6920ac561
--- /dev/null
+++ b/v7/src/6001/pic-imag.scm
@@ -0,0 +1,156 @@
+;;; Procedure to build an image given a picture and the magnification factors
+
+(declare (usual-integrations))
+
+(define (build-image pic window h-sf v-sf pic-min pic-max)
+  (let* ((colormap-size (colormap-size (get-visual-info window)))
+	 (pic-height (picture-height pic))	;py
+	 (pic-width (picture-width pic))	;x
+	 (pic-data (picture-data pic))
+	 (image-width (fix:* h-sf pic-width)) ;x
+	 (image-height (fix:* v-sf pic-height)) ;iy
+	 (image (graphics-operation window 'create-image
+				    image-width image-height))
+	 (byte-string (make-string (fix:* image-width image-height)))
+	 (py-max (- pic-height 1))
+	 (rect-index-height (fix:* v-sf image-width))
+	 (range (flo:- pic-max pic-min))
+	 (mul (if (flo:< range 1e-12)
+		  0.
+		  (/ colormap-size (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
+    ;; of 2^24. In general, choose epsilon such that:
+    ;;            colormap-size < (/ (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)
+		 (begin
+		   (let ((pic-row (floating-vector-ref pic-data py)))
+		     (let x-loop ((px 0))
+		       (if (fix:< px pic-width)
+			   (begin
+			     (vector-8b-set!
+			      byte-string
+			      (fix:+ px iy-index)
+			      (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))))))
+
+	  ((and (fix:= 2 h-sf) (fix:= 2 v-sf))
+	   (let y-loop ((py py-max) (iy-index 0))
+	     (if (fix:<= 0 py)
+		 (let ((pic-row (floating-vector-ref pic-data py)))
+		   (let x-loop ((px 0) (ix 0))
+		     (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)))))
+			   (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)
+			   (vector-8b-set! byte-string (fix:+ n-is-1 1) v)
+			   (x-loop (fix:+ px 1) (fix:+ ix h-sf)))
+			 (y-loop (fix:- py 1) 
+				 (fix:+ iy-index rect-index-height))))))))
+
+	  ((and (fix:= 3 h-sf) (fix:= 3 v-sf))
+	   (let y-loop ((py py-max) (iy-index 0))
+	     (if (fix:<= 0 py)
+		 (let ((pic-row (floating-vector-ref pic-data py)))
+		   (let x-loop ((px 0) (ix 0))
+		     (if (fix:< px pic-width)
+			 (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)))))
+			   (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)
+			   (vector-8b-set! byte-string row1 v)
+			   (vector-8b-set! byte-string (fix:+ row1 1) v)
+			   (vector-8b-set! byte-string (fix:+ row1 2) v)
+			   (vector-8b-set! byte-string row2 v)
+			   (vector-8b-set! byte-string (fix:+ row2 1) v)
+			   (vector-8b-set! byte-string (fix:+ row2 2) v)
+			   (x-loop (fix:+ px 1) (fix:+ ix h-sf)))
+			 (y-loop (fix:- py 1) 
+				 (fix:+ iy-index rect-index-height))))))))
+
+	  ((and (fix:= 4 h-sf) (fix:= 4 v-sf))
+	   (let y-loop ((py py-max) (iy-index 0))
+	     (if (fix:<= 0 py)
+		 (let ((pic-row (floating-vector-ref pic-data py)))
+		   (let x-loop ((px 0) (ix 0))
+		     (if (fix:< px pic-width)
+			 (let* ((row0 (fix:+ ix iy-index))
+				(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)))))
+			   (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)
+			   (vector-8b-set! byte-string (fix:+ row0 3) v)
+			   (vector-8b-set! byte-string row1 v)
+			   (vector-8b-set! byte-string (fix:+ row1 1) v)
+			   (vector-8b-set! byte-string (fix:+ row1 2) v)
+			   (vector-8b-set! byte-string (fix:+ row1 3) v)
+			   (vector-8b-set! byte-string row2 v)
+			   (vector-8b-set! byte-string (fix:+ row2 1) v)
+			   (vector-8b-set! byte-string (fix:+ row2 2) v)
+			   (vector-8b-set! byte-string (fix:+ row2 3) v)
+			   (vector-8b-set! byte-string row3 v)
+			   (vector-8b-set! byte-string (fix:+ row3 1) v)
+			   (vector-8b-set! byte-string (fix:+ row3 2) v)
+			   (vector-8b-set! byte-string (fix:+ row3 3) v)
+			   (x-loop (fix:+ px 1) (fix:+ ix h-sf)))
+			 (y-loop (fix:- py 1) 
+				 (fix:+ iy-index rect-index-height))))))))
+
+	  (else 
+	   (let y-loop ((py py-max) (iy-index 0))
+	     (if (fix:<= 0 py)
+		 (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))))
+				(n-start (fix:+ ix iy-index))
+				(n-end (fix:+ n-start rect-index-height)))
+			   (let n-loop ((n n-start))
+			     (if (fix:< n n-end)
+				 (let ((m-end (fix:+ n h-sf)))
+				   (let m-loop ((m n))
+				     (if (fix:< m m-end)
+					 (begin
+					   (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)))))))))
+    
+    (x-image/fill-from-byte-vector image byte-string)
+    (1d-table/put! (graphics-device/properties window) image #t)
+    image))
+
diff --git a/v7/src/6001/pic-ops.scm b/v7/src/6001/pic-ops.scm
new file mode 100644
index 000000000..b589d73b0
--- /dev/null
+++ b/v7/src/6001/pic-ops.scm
@@ -0,0 +1,300 @@
+
+;;; Operations for manipulating pictures
+(declare (usual-integrations))
+
+(define-integrable (in-rect? x y width height)
+  (and (fix:< -1 x) (fix:< x width) (fix:< -1 y) (fix:< y height)))
+
+(define make-pt cons)
+(define xcor car)
+(define ycor cdr)
+
+(define (picture-overlap pic1 pic2 u v)
+  (let* ((wid1 (picture-width pic1))
+	 (hgt1 (picture-height pic1))
+	 (p1-data (picture-data pic1))
+	 (wid2 (picture-width pic2))
+	 (hgt2 (picture-height pic2))
+	 (p2-data (picture-data pic2))
+	 (u (floor->exact u))
+	 (v (floor->exact v))
+	 (lf (min 0 u)) 
+	 (dn (min 0 v))
+	 (rt (max wid2 (fix:+ wid1 u))) 
+	 (up (max hgt2 (fix:+ hgt1 v)))
+	 (p1x-offset (fix:- u lf))
+	 (p1y-offset (fix:- v dn))
+	 (new-min (min (picture-min pic1) (picture-min pic2)))
+	 (new-pic (make-picture (fix:- rt lf) (fix:- up dn) new-min))
+	 (new-data (picture-data new-pic)))
+
+;; place pic2 in its proper place on the resulting picture
+    (let y-loop ((y 0))
+      (if (fix:< y hgt2)
+	  (let* ((p2-yth-row (floating-vector-ref p2-data y))
+		 (new-yth-row (floating-vector-ref new-data (fix:- y dn)))) 
+	    (let x-loop ((x 0))
+	      (if (fix:< x wid2)
+		  (begin  
+		    (floating-vector-set! new-yth-row (fix:- x lf) 
+				 (floating-vector-ref p2-yth-row x))
+		    (x-loop (fix:+ x 1)))
+		  (y-loop (fix:+ y 1)))))))
+
+    ;; overlay pic1 in its proper location in the result
+    (let y-loop ((y 0))
+      (if (fix:< y hgt1)
+	  (let* ((p1-yth-row (floating-vector-ref p1-data y))
+		 (new-yth-row (floating-vector-ref new-data
+						   (fix:+ y p1y-offset)))) 
+	    (let x-loop ((x 0))
+	      (if (fix:< x wid1)
+		  (begin  
+		    (floating-vector-set! new-yth-row (fix:+ x p1x-offset) 
+				 (floating-vector-ref p1-yth-row x))
+		    (x-loop (fix:+ x 1)))
+		  (y-loop (fix:+ y 1)))))))
+    (picture-set-data! new-pic new-data)
+    new-pic))
+
+(define (picture-paste! pic1 pic2 u v)
+  (let ((wid1 (picture-width pic1))
+	(hgt1 (picture-height pic1))
+	(p1-data (picture-data pic1))
+	(wid2 (picture-width pic2))
+	(hgt2 (picture-height pic2))
+	(p2-data (picture-data pic2))
+	(u (floor->exact u))
+	(v (floor->exact v)))
+  (if (in-rect? u v wid2 hgt2)
+      (if (and (fix:<= (fix:+ u wid1) wid2) (fix:<= (fix:+ v hgt1) hgt2))
+	  (let y-loop ((y 0))
+	    (if (fix:< y hgt1)
+		(let ((p1-yth-row (floating-vector-ref p1-data y))
+		      (p2-yth-row (floating-vector-ref p2-data (fix:+ y v))))
+		  (let x-loop ((x 0))
+		    (if (fix:< x wid1)
+			(begin
+			  (floating-vector-set! p2-yth-row (fix:+ x u)
+				       (floating-vector-ref p1-yth-row x))
+			  (x-loop (fix:+ x 1)))
+			(y-loop (fix:+ y 1))))))
+	    (picture-set-data! pic2 p2-data))
+	  (error "Picture too large -- PICTURE-PASTE!"))
+      (error "Coordinates out of bounds -- PICTURE-PASTE!"))))
+
+(define (picture-cut pic u v cut-wid cut-hgt)
+  (let* ((wid (picture-width pic))
+	 (hgt (picture-height pic))
+	 (data (picture-data pic))
+	 (u (floor->exact u))
+	 (v (floor->exact v))
+	 (cut-wid (floor->exact cut-wid))
+	 (cut-hgt (floor->exact cut-hgt))
+	 (new-pic (make-picture cut-wid cut-hgt))
+	 (new-data (picture-data new-pic)))
+    (if (not (in-rect? u v wid hgt))
+	(error "Coordinates out of bounds -- PICTURE-CUT")) 
+    (if (not (fix:<= (fix:+ u cut-wid) wid)) 
+	(error:bad-range-argument cut-wid 'PICTURE-CUT))
+    (if (not (fix:<= (fix:+ v cut-hgt) hgt)) 
+	(error:bad-range-argument cut-hgt 'PICTURE-CUT))
+    (let y-loop ((y 0))
+      (if (fix:< y cut-hgt)
+	  (let ((new-yth-row (floating-vector-ref new-data y))
+		(old-yth-row (floating-vector-ref data (fix:+ v y))))
+	    (let x-loop ((x 0))
+	      (if (fix:< x cut-wid)
+		  (begin
+		    (floating-vector-set! new-yth-row x
+				 (floating-vector-ref old-yth-row (fix:+ u x)))
+		    (x-loop (fix:+ x 1)))
+		  (y-loop (fix:+ y 1))))))
+      (picture-set-data! new-pic new-data)
+      new-pic)))
+
+(define (picture-scale pic xsf ysf)
+  (let* ((wid (floor->exact (* xsf (picture-width pic))))
+	 (hgt (floor->exact (* ysf (picture-height pic))))
+	 (data (picture-data pic))
+	 (new-pic (make-picture wid hgt))
+	 (new-data (picture-data new-pic))
+	 (->discrete-y (if (flo:> ysf 1.)
+			   floor->exact
+			   ceiling->exact))
+	 (->discrete-x (if (flo:> xsf 1.)
+			   floor->exact
+			   ceiling->exact)))
+    (let y-loop ((ny 0) (old-y-index -1))
+      (if (fix:< ny hgt)
+	  (let ((y-index (->discrete-y (/ ny ysf))))
+	    (if (fix:= y-index old-y-index)  ; don't recompute the row
+		(floating-vector-set! new-data ny
+			     (floating-vector-copy
+			      (floating-vector-ref new-data (fix:- ny 1))))
+		(let ((yth-row (floating-vector-ref data y-index))
+		      (new-yth-row (floating-vector-ref new-data ny)))
+		  (let x-loop ((nx 0))
+		    (if (fix:< nx wid)
+			(begin
+			  (floating-vector-set! new-yth-row nx
+				       (floating-vector-ref yth-row 
+						   (->discrete-x (/ nx xsf))))
+			  (x-loop (fix:+ nx 1)))))))
+	    (y-loop (fix:+ ny 1) y-index))))
+    (picture-set-data! new-pic new-data)
+    new-pic))
+
+(define (picture-rotate pic angle)
+  (define (rotate-pt-by theta)
+    (lambda (x y)
+      (let ((c (cos theta)) (s (sin theta)))
+	(make-pt (- (* c x) (* s y))
+		 (+ (* s x) (* c y))))))
+
+  (define (close-enough? a b)
+    (fix:= (round->exact a) (round->exact b)))
+
+  (let* ((wid (picture-width pic))
+	 (hgt (picture-height pic))
+	 (data (picture-data pic))
+	 (pic-min (picture-min pic))
+	 (lf (lo-bound wid))
+	 (rt (fix:- (up-bound wid) 1))
+	 (dn (lo-bound hgt))
+	 (up (fix:- (up-bound hgt) 1))
+	 (rotate-by-angle (rotate-pt-by angle))
+	 (rotate-by-neg-angle (rotate-pt-by (- angle)))
+	 (ll (rotate-by-angle lf dn))        ;rotate each
+	 (lr (rotate-by-angle rt dn))        ;corner
+	 (ul (rotate-by-angle lf up))        ;of the
+	 (ur (rotate-by-angle rt up))        ;picture
+	 (lx (min (xcor ll) (xcor lr) (xcor ul) (xcor ur)))   ;compute
+	 (ly (min (ycor ll) (ycor lr) (ycor ul) (ycor ur)))   ;extreme
+	 (ux (max (xcor ll) (xcor lr) (xcor ul) (xcor ur)))   ;coordinate
+	 (uy (max (ycor ll) (ycor lr) (ycor ul) (ycor ur)))   ;values
+	 (new-wid (round->exact (1+ (- ux lx))))
+	 (new-hgt (round->exact (1+ (- uy ly))))
+	 (nx-max (fix:- new-wid 1))
+	 (ny-max (fix:- new-hgt 1))
+	 (new-lf (lo-bound new-wid))
+	 (new-dn (lo-bound new-hgt))
+	 (new-pic (make-picture new-wid new-hgt))
+	 (new-data (picture-data new-pic)))
+    ;; Special cases are rotations of 90 degrees (both directions) and 180
+    ;; degrees.
+
+    (cond ((and (close-enough? (xcor ur) ux)    ; check for 
+		(close-enough? (ycor ur) uy))   ; 0 degrees
+	   (set! new-data (make-initialized-vector
+			   new-hgt
+			   (lambda (n)
+			     (floating-vector-copy
+			      (floating-vector-ref data n))))))
+
+	  ((and (close-enough? (xcor ur) lx)   ; check for 
+		(close-enough? (ycor ur) uy))  ; 90 degrees anti-clockwise
+	   (let y-loop ((ny 0))
+	     (if (fix:< ny new-hgt)
+		 (let ((yth-row (floating-vector-ref new-data ny)))
+		   (let x-loop ((nx 0))
+		     (if (fix:< nx new-wid)
+			 (begin
+			   (floating-vector-set! yth-row nx
+					(floating-vector-ref 
+					 (floating-vector-ref
+					  data (fix:- nx-max nx))
+					 ny))
+			   (x-loop (fix:+ nx 1)))
+			 (y-loop (fix:+ ny 1))))))))
+
+	  ((and (close-enough? (xcor ur) ux)   ; check for
+		(close-enough? (ycor ur) ly))  ; 90 degrees clockwise
+	   (let y-loop ((ny 0))
+	     (if (fix:< ny new-hgt)
+		 (let ((yth-row (floating-vector-ref new-data ny)))
+		   (let x-loop ((nx 0))
+		     (if (fix:< nx new-wid)
+			 (begin
+			   (floating-vector-set! yth-row nx
+					(floating-vector-ref 
+					 (floating-vector-ref data nx) 
+					 (fix:- ny-max ny)))
+			   (x-loop (fix:+ nx 1)))
+			 (y-loop (fix:+ ny 1))))))))
+
+	  ((and (close-enough? (xcor ur) lx)  ; check for
+		(close-enough? (ycor ur) ly)) ; 180 degrees
+	   (let y-loop ((ny 0))
+	     (if (fix:< ny new-hgt)
+		 (begin
+		   (floating-vector-set! new-data ny 
+				(list->vector
+				 (reverse 
+				  (vector->list 
+				   (floating-vector-ref data
+							(fix:- ny-max ny))))))
+		   (y-loop (fix:+ ny 1))))))
+
+	  (else
+	   (let* ((rot-bot-lef (rotate-by-neg-angle new-lf new-dn))
+		  (x-start (exact->inexact 
+			    (- (xcor rot-bot-lef) lf)))  ; in "vector 
+		  (y-start (exact->inexact
+			    (- (ycor rot-bot-lef) dn)))  ; coordinates"
+		  (c (cos angle))
+		  (s (sin angle))) 
+	     (let y-loop ((ny 0) (outer-x x-start) (outer-y y-start))
+	       (if (fix:< ny new-hgt)
+		   (let ((nyth-row (floating-vector-ref new-data ny)))
+		     (let x-loop ((nx 0) (inner-x outer-x) (inner-y outer-y))
+		       (if (fix:< nx new-wid)
+			   (let ((x (round->exact inner-x))
+				 (y (round->exact inner-y)))
+			     (floating-vector-set! nyth-row nx
+					  (if (in-rect? x y wid hgt)
+					      (floating-vector-ref
+					       (floating-vector-ref data y) x)
+					      pic-min))
+			     (x-loop (fix:+ nx 1) 
+				     (flo:+ inner-x c) (flo:- inner-y s)))
+			   (y-loop (fix:+ ny 1) 
+				   (flo:+ outer-x s) 
+				   (flo:+ outer-y c))))))))))
+    (picture-set-data! new-pic new-data)
+    new-pic))
+
+(define (picture-v-reflect pic)
+  (let* ((wid (picture-width pic))
+	 (hgt (picture-height pic))
+	 (data (picture-data pic))
+	 (new-pic (make-picture wid hgt))
+	 (new-data (picture-data new-pic))
+	 (y-max (fix:- hgt 1)))
+    (let y-loop ((y 0))
+      (if (fix:< y hgt)
+	  (begin
+	    (floating-vector-set! new-data y 
+			 (floating-vector-copy
+			  (floating-vector-ref data (fix:- y-max y))))
+	    (y-loop (fix:+ y 1)))))
+    (picture-set-data! new-pic new-data)
+    new-pic))
+	  
+(define (picture-h-reflect pic)
+  (let* ((wid (picture-width pic))
+	 (hgt (picture-height pic))
+	 (data (picture-data pic))
+	 (new-pic (make-picture wid hgt))
+	 (new-data (picture-data new-pic)))
+    (let y-loop ((y 0))
+      (if (fix:< y hgt)
+	  (begin
+	    (floating-vector-set! new-data y
+			 (list->vector 
+			  (reverse 
+			   (vector->list (floating-vector-ref data y)))))
+	    (y-loop (fix:+ y 1)))))
+    (picture-set-data! new-pic new-data)
+    new-pic))
+
diff --git a/v7/src/6001/pic-read.scm b/v7/src/6001/pic-read.scm
new file mode 100644
index 000000000..4fc551183
--- /dev/null
+++ b/v7/src/6001/pic-read.scm
@@ -0,0 +1,96 @@
+;; Procedures to read a file in raw pgm format into a picture
+
+(declare (usual-integrations))
+
+(define (pgm-file->picture filename)
+  (let* ((path-name (->pathname filename))
+	 (file-name (if (pathname-type path-name)
+			path-name
+			(if (file-exists? path-name)
+			    path-name
+			    (pathname-new-type path-name "pgm")))))
+    
+  (call-with-input-file file-name (lambda (port)
+				   (get-body port (get-header port))))))
+
+(define (get-line port result)   ; read a line of data
+  (let ((c (read-char port)))
+    (cond ((eof-object? c) (reverse result))
+	  ((eq? c #\Linefeed) 
+	   (let ((res (reverse result)))
+	     (if (eq? (car res) #\#)  ; ignore comments
+		 (get-line port '())
+		 res)))
+	  (else (get-line port (cons c result))))))
+
+(define (get-header port)
+  (let* ((type (list->string (get-line port '())))
+	 (dims (list->string (get-line port '())))
+	 (no-of-greys (string->number 
+		       (list->string (get-line port '()))))
+	 (spc-index (string-find-next-char dims #\space))
+	 (length (string->number 
+		  (string-head dims spc-index)))
+	 (width (string->number
+		 (string-tail dims (1+ spc-index)))))
+    (if (not (equal? type "P5"))  ; P5 is the magic number for raw PGM format
+	(error "Unrecognized format. (Convert to raw PGM) -- PICTURE-READ")
+	(vector type length width no-of-greys))))
+
+(define (get-body port attributes)
+  (let* ((length (vector-ref attributes 1))
+	 (width (vector-ref attributes 2))
+	 (max-grey (vector-ref attributes 3))
+	 (pic (make-picture length width))
+	 (data (make-initialized-vector 
+		width
+		(lambda (index)
+		  index		; ignored
+		  (make-floating-vector length 0.)))))     ;initialize to blank
+
+    (side-effecting-iter
+     width
+     (lambda (n)
+       (let ((nth-row (floating-vector-ref data (- width n 1))))
+	 (side-effecting-iter
+	  length
+	  (lambda (m)
+	    (floating-vector-set! nth-row m 
+			 (exact->inexact (char->ascii (read-char port)))))))))
+    (picture-set-data! pic data)
+;;    (%picture-set-min! pic 0.)    ; set min, max of picture according to
+;;    (%picture-set-max! pic (exact->inexact max-grey))  ; information in file
+    pic))
+
+;;; Procedure to read in a picture that was previously saved using 
+;;; picture-write.
+
+(define (picture-read filename)
+  (let* ((path-name (->pathname filename))
+	 (pic-mimic (fasload (if (pathname-type path-name)
+				 path-name
+				 (if (file-exists? path-name)
+				     path-name
+				     (pathname-new-type path-name "pic"))))))
+    (if (not (record? pic-mimic))
+	(error "Object loaded is not a picture -- PICTURE-READ"))
+
+    (define mimic-type (record-type-descriptor pic-mimic))
+
+    (if (not (equal? (record-type-field-names mimic-type)
+		     (record-type-field-names picture-type)))
+	(error "Object loaded is not a picture -- PICTURE-READ"))
+	 
+    (define mimic-width (record-accessor mimic-type 'width))
+    (define mimic-height (record-accessor mimic-type 'height))
+    (define mimic-data (record-accessor mimic-type 'data))
+    (define mimic-min (record-accessor mimic-type 'min))
+    (define mimic-max (record-accessor mimic-type 'max))
+
+    (define new-pic (make-picture (mimic-width pic-mimic) 
+				  (mimic-height pic-mimic)))
+    (picture-set-data! new-pic (mimic-data pic-mimic))
+    (%picture-set-min! new-pic (mimic-min pic-mimic))
+    (%picture-set-max! new-pic (mimic-max pic-mimic))
+    new-pic))
+
diff --git a/v7/src/6001/pic-reco.scm b/v7/src/6001/pic-reco.scm
new file mode 100644
index 000000000..6f71451dc
--- /dev/null
+++ b/v7/src/6001/pic-reco.scm
@@ -0,0 +1,186 @@
+;;; Representation of pictures using records
+
+(declare (usual-integrations))
+
+(define picture-type (make-record-type 
+		      'picture 
+		      '(width
+			height
+			data
+			min
+			max 
+			image)))
+
+(define %make-picture (record-constructor picture-type '(width height)))
+
+(define %picture-min (record-accessor picture-type 'min))
+(define %picture-max (record-accessor picture-type 'max))
+(define %picture-set-data! (record-updater picture-type 'data))
+(define %picture-set-image! (record-updater picture-type 'image))
+(define %picture-set-min! (record-updater picture-type 'min))
+(define %picture-set-max! (record-updater picture-type 'max))
+
+(define (make-picture width height #!optional initial-val)
+  (let ((pic (%make-picture width height))
+	(initial-val (if (default-object? initial-val)
+			 0.
+			 (exact->inexact initial-val))))
+    (%picture-set-min! pic initial-val)
+    (%picture-set-max! pic initial-val)
+    (%picture-set-data! pic 
+			(make-initialized-vector
+			 height
+			 (lambda (n)
+			   n	; ignored
+			   (make-floating-vector width initial-val))))
+    (%picture-set-image! pic #f)
+    pic))
+
+(define picture? (record-predicate picture-type))
+
+(define picture-width
+  (record-accessor picture-type 'width))
+
+(define picture-height
+  (record-accessor picture-type 'height))
+
+(define picture-data
+  (record-accessor picture-type 'data))
+
+(define picture-image
+  (record-accessor picture-type 'image))
+
+(define (picture-set-image! picture image)
+  (let ((img (picture-image picture)))
+    (if (x-image? img)
+	(x-image/destroy img))
+    (%picture-set-image! picture image)))
+
+(define (picture-min picture)
+  (let ((pic-min (%picture-min picture)))
+    (if (not pic-min) 
+	(begin (find-min-max picture)
+	       (%picture-min picture))
+	pic-min)))
+
+(define (picture-max picture)
+  (let ((pic-max (%picture-max picture)))
+    (if (not pic-max) 
+	(begin (find-min-max picture)
+	       (%picture-max picture))
+	pic-max)))
+
+(define (make-picture-referencer bad-type-predicate bad-range-signal)
+  (lambda (picture x y)
+    (cond ((bad-type-predicate x)
+	   (error:wrong-type-argument x "picture X coordinate" 'PICTURE-REF))
+	  ((bad-type-predicate y)
+	   (error:wrong-type-argument y "picture Y coordinate" 'PICTURE-REF))
+	  ((not (and (fix:>= x 0)
+		     (fix:< x (picture-width picture))))
+	   (bad-range-signal x 'PICTURE-REF))
+	  ((not (and (fix:>= y 0)
+		     (fix:< y (picture-height picture))))
+	   (bad-range-signal y 'PICTURE-REF))
+	  (else
+	   (floating-vector-ref
+	    (floating-vector-ref (picture-data picture) y) x)))))
+
+(define (make-picture-setter bad-type-predicate bad-range-signal)
+  (lambda (picture x y value)
+    (cond ((bad-type-predicate x)
+	   (error:wrong-type-argument x "picture X coordinate" 'PICTURE-SET!))
+	  ((bad-type-predicate y)
+	   (error:wrong-type-argument y "picture Y coordinate" 'PICTURE-SET!))
+	  ((not (and (fix:>= x 0)
+		     (fix:< x (picture-width picture))))
+	   (bad-range-signal x 'PICTURE-SET!))
+	  ((not (and (fix:>= y 0)
+		     (fix:< y (picture-height picture))))
+	   (bad-range-signal y 'PICTURE-SET!))
+	  (else
+	   (floating-vector-set! (floating-vector-ref (picture-data picture) y)
+			x (exact->inexact value))
+	   (invalidate-cached-values picture)))))
+
+(define picture-ref (make-picture-referencer
+		     (lambda (var)
+		       (declare (integrate var))
+		       (not (fix:fixnum? var)))
+		     error:bad-range-argument))
+
+(define no-error-picture-ref (make-picture-referencer
+			  (lambda (var)
+			    (declare (integrate var))
+			    var  ;ignored
+			    false)
+			  (lambda (var proc-name)
+			    var proc-name   ;ignored
+			    false)))
+
+(define picture-set! (make-picture-setter
+		      (lambda (var)
+			(declare (integrate var))
+			(not (fix:fixnum? var)))
+		      error:bad-range-argument))
+
+(define no-error-picture-set! (make-picture-setter
+			   (lambda (var)
+			     (declare (integrate var))
+			     var  ;ignored
+			     false)
+			   (lambda (var proc-name)
+			     var proc-name  ;ignored 
+			     false)))
+
+(define (picture-map! picture fn)
+  (let ((picdata (picture-data picture))
+	(width (picture-width picture))
+	(height (picture-height picture)))
+    (let y-loop ((y 0))
+      (if (< y height)
+	  (let ((yth-row (floating-vector-ref picdata y)))
+	    (let x-loop ((x 0))
+	      (if (< x width)
+		  (begin (floating-vector-set! yth-row x 
+				      (exact->inexact 
+				       (fn x y)))
+			 (x-loop (1+ x)))
+		  (y-loop (1+ y))))))
+      (invalidate-cached-values picture))))
+
+(define (picture-set-data! picture data)
+  (%picture-set-data! picture data)
+  (invalidate-cached-values picture))
+
+;;; Note that picture-data and picture-set-data! are both unsafe operations
+;;; in the sense that both of them do not ensure that only floating point 
+;;; numbers are ever stored in the picture array.
+
+
+(define (invalidate-cached-values picture)
+  (%picture-set-min! picture #f)
+  (%picture-set-max! picture #f)
+  (let ((img (picture-image picture)))
+    (if (x-image? img)
+	(x-image/destroy img))
+    (%picture-set-image! picture '())))
+
+(define (find-min-max picture)
+  (let* ((picdata (picture-data picture))
+	 (width (picture-width picture))
+	 (height (picture-height picture))
+	 (current-min (floating-vector-ref (floating-vector-ref picdata 0) 0))
+	 (current-max current-min))
+    (let y-loop ((y 0))
+      (if (< y height)
+	  (let ((yth-row (floating-vector-ref picdata y)))
+	    (let x-loop ((x 0))
+	      (if (< x width)
+		  (let ((v (floating-vector-ref yth-row x)))
+		    (set! current-min (min current-min v))
+		    (set! current-max (max current-max v))
+		    (x-loop (1+ x)))
+		  (y-loop (1+ y)))))))
+    (%picture-set-min! picture current-min)
+    (%picture-set-max! picture current-max)))
diff --git a/v7/src/6001/picture.scm b/v7/src/6001/picture.scm
new file mode 100644
index 000000000..e69de29bb
-- 
2.25.1