From e4e203e916b18d5dedebbe7dac2654508bb73309 Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Fri, 7 Mar 2003 19:19:24 +0000
Subject: [PATCH] Use DEFINE-RECORD-TYPE to make record descriptions more
succinct.
---
v7/src/6001/pic-reco.scm | 143 ++++++++++++++-------------------------
1 file changed, 52 insertions(+), 91 deletions(-)
diff --git a/v7/src/6001/pic-reco.scm b/v7/src/6001/pic-reco.scm
index 9458b8ed4..d6fefb78d 100644
--- a/v7/src/6001/pic-reco.scm
+++ b/v7/src/6001/pic-reco.scm
@@ -1,8 +1,8 @@
#| -*-Scheme-*-
-$Id: pic-reco.scm,v 1.10 2003/02/14 18:28:00 cph Exp $
+$Id: pic-reco.scm,v 1.11 2003/03/07 19:19:24 cph Exp $
-Copyright (c) 1993, 1999, 2001 Massachusetts Institute of Technology
+Copyright 1991,1992,1993,2001,2003 Massachusetts Institute of Technology
This file is part of MIT/GNU Scheme.
@@ -22,79 +22,59 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
USA.
|#
-
+
;;; 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-record-type <picture>
+ (%make-picture width height)
+ picture?
+ (width picture-width)
+ (height picture-height)
+ (data picture-data %picture-set-data!)
+ (min %picture-min %picture-set-min!)
+ (max %picture-max %picture-set-max!)
+ (image picture-image %picture-set-image!))
(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))))
+ (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
- (flo:make-vector width initial-val))))
+ (make-initialized-vector height
+ (lambda (n)
+ n
+ (flo:make-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-set-data! picture data)
+ (%picture-set-data! picture data)
+ (invalidate-cached-values picture))
-(define picture-data
- (record-accessor picture-type 'data))
+(define (picture-min picture)
+ (or (%picture-min picture)
+ (begin
+ (find-min-max picture)
+ (%picture-min picture))))
-(define picture-image
- (record-accessor picture-type 'image))
+(define (picture-max picture)
+ (or (%picture-max picture)
+ (begin
+ (find-min-max picture)
+ (%picture-max picture))))
(define (picture-set-image! picture image)
(let ((img (picture-image picture)))
(if (image? img)
(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)
@@ -125,39 +105,25 @@ USA.
(bad-range-signal y 'PICTURE-SET!))
(else
(flo:vector-set! (vector-ref (picture-data picture) y)
- x (exact->inexact value))
+ 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-ref
+ (make-picture-referencer (lambda (var) (not (fix:fixnum? var)))
+ error:bad-range-argument))
+
+(define no-error-picture-ref
+ (make-picture-referencer (lambda (var) var #f)
+ (lambda (var caller) var caller #f)))
+
+(define picture-set!
+ (make-picture-setter (lambda (var) (not (fix:fixnum? var)))
+ error:bad-range-argument))
+(define no-error-picture-set!
+ (make-picture-setter (lambda (var) var #f)
+ (lambda (var caller) var caller #f)))
+
(define (picture-map! picture fn)
(let ((picdata (picture-data picture))
(width (picture-width picture))
@@ -173,15 +139,10 @@ USA.
(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)
@@ -207,4 +168,4 @@ USA.
(x-loop (1+ x)))
(y-loop (1+ y)))))))
(%picture-set-min! picture current-min)
- (%picture-set-max! picture current-max)))
+ (%picture-set-max! picture current-max)))
\ No newline at end of file
--
2.25.1