3
$Id: pic-reco.scm,v 1.8 2001/12/20 03:24:33 cph Exp $
5
Copyright (c) 1993, 1999, 2001 Massachusetts Institute of Technology
7
This program is free software; you can redistribute it and/or modify
3
$Id: pic-reco.scm,v 1.11 2003/03/07 19:19:24 cph Exp $
5
Copyright 1991,1992,1993,2001,2003 Massachusetts Institute of Technology
7
This file is part of MIT/GNU Scheme.
9
MIT/GNU Scheme is free software; you can redistribute it and/or modify
8
10
it under the terms of the GNU General Public License as published by
9
11
the Free Software Foundation; either version 2 of the License, or (at
10
12
your option) any later version.
12
This program is distributed in the hope that it will be useful, but
14
MIT/GNU Scheme is distributed in the hope that it will be useful, but
13
15
WITHOUT ANY WARRANTY; without even the implied warranty of
14
16
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
15
17
General Public License for more details.
17
19
You should have received a copy of the GNU General Public License
18
along with this program; if not, write to the Free Software
19
Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
20
along with MIT/GNU Scheme; if not, write to the Free Software
21
Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
23
26
;;; Representation of pictures using records
25
28
(declare (usual-integrations))
27
(define picture-type (make-record-type
36
(define %make-picture (record-constructor picture-type '(width height)))
38
(define %picture-min (record-accessor picture-type 'min))
39
(define %picture-max (record-accessor picture-type 'max))
40
(define %picture-set-data! (record-updater picture-type 'data))
41
(define %picture-set-image! (record-updater picture-type 'image))
42
(define %picture-set-min! (record-updater picture-type 'min))
43
(define %picture-set-max! (record-updater picture-type 'max))
30
(define-record-type <picture>
31
(%make-picture width height)
34
(height picture-height)
35
(data picture-data %picture-set-data!)
36
(min %picture-min %picture-set-min!)
37
(max %picture-max %picture-set-max!)
38
(image picture-image %picture-set-image!))
45
40
(define (make-picture width height #!optional initial-val)
46
41
(let ((pic (%make-picture width height))
47
(initial-val (if (default-object? initial-val)
49
(exact->inexact initial-val))))
43
(if (default-object? initial-val)
45
(exact->inexact initial-val))))
50
46
(%picture-set-min! pic initial-val)
51
47
(%picture-set-max! pic initial-val)
52
48
(%picture-set-data! pic
53
(make-initialized-vector
57
(flo:make-vector width initial-val))))
49
(make-initialized-vector height
52
(flo:make-vector width initial-val))))
58
53
(%picture-set-image! pic #f)
61
(define picture? (record-predicate picture-type))
64
(record-accessor picture-type 'width))
66
(define picture-height
67
(record-accessor picture-type 'height))
70
(record-accessor picture-type 'data))
73
(record-accessor picture-type 'image))
56
(define (picture-set-data! picture data)
57
(%picture-set-data! picture data)
58
(invalidate-cached-values picture))
60
(define (picture-min picture)
61
(or (%picture-min picture)
63
(find-min-max picture)
64
(%picture-min picture))))
66
(define (picture-max picture)
67
(or (%picture-max picture)
69
(find-min-max picture)
70
(%picture-max picture))))
75
72
(define (picture-set-image! picture image)
76
73
(let ((img (picture-image picture)))
78
75
(image/destroy img))
79
76
(%picture-set-image! picture image)))
81
(define (picture-min picture)
82
(let ((pic-min (%picture-min picture)))
84
(begin (find-min-max picture)
85
(%picture-min picture))
88
(define (picture-max picture)
89
(let ((pic-max (%picture-max picture)))
91
(begin (find-min-max picture)
92
(%picture-max picture))
95
78
(define (make-picture-referencer bad-type-predicate bad-range-signal)
96
79
(lambda (picture x y)
97
80
(cond ((bad-type-predicate x)
122
105
(bad-range-signal y 'PICTURE-SET!))
124
107
(flo:vector-set! (vector-ref (picture-data picture) y)
125
x (exact->inexact value))
108
x (exact->inexact value))
126
109
(invalidate-cached-values picture)))))
128
(define picture-ref (make-picture-referencer
130
(declare (integrate var))
131
(not (fix:fixnum? var)))
132
error:bad-range-argument))
134
(define no-error-picture-ref (make-picture-referencer
136
(declare (integrate var))
139
(lambda (var proc-name)
140
var proc-name ;ignored
143
(define picture-set! (make-picture-setter
145
(declare (integrate var))
146
(not (fix:fixnum? var)))
147
error:bad-range-argument))
149
(define no-error-picture-set! (make-picture-setter
151
(declare (integrate var))
154
(lambda (var proc-name)
155
var proc-name ;ignored
112
(make-picture-referencer (lambda (var) (not (fix:fixnum? var)))
113
error:bad-range-argument))
115
(define no-error-picture-ref
116
(make-picture-referencer (lambda (var) var #f)
117
(lambda (var caller) var caller #f)))
120
(make-picture-setter (lambda (var) (not (fix:fixnum? var)))
121
error:bad-range-argument))
123
(define no-error-picture-set!
124
(make-picture-setter (lambda (var) var #f)
125
(lambda (var caller) var caller #f)))
158
127
(define (picture-map! picture fn)
159
128
(let ((picdata (picture-data picture))
160
129
(width (picture-width picture))
added
removed
src/6001/pic-reco.scm
