home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / mitsch75.zip / scheme-7_5_17-src.zip / scheme-7.5.17 / src / 6001 / pic-reco.scm < prev    next >
Text File  |  1999-01-02  |  7KB  |  208 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: pic-reco.scm,v 1.7 1999/01/02 06:06:43 cph Exp $
  4.  
  5. Copyright (c) 1993, 1999 Massachusetts Institute of Technology
  6.  
  7. This program is free software; you can redistribute it and/or modify
  8. it under the terms of the GNU General Public License as published by
  9. the Free Software Foundation; either version 2 of the License, or (at
  10. your option) any later version.
  11.  
  12. This program is distributed in the hope that it will be useful, but
  13. WITHOUT ANY WARRANTY; without even the implied warranty of
  14. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15. General Public License for more details.
  16.  
  17. 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., 675 Mass Ave, Cambridge, MA 02139, USA.
  20. |#
  21.  
  22. ;;; Representation of pictures using records
  23.  
  24. (declare (usual-integrations))
  25.  
  26. (define picture-type (make-record-type 
  27.               'picture 
  28.               '(width
  29.             height
  30.             data
  31.             min
  32.             max 
  33.             image)))
  34.  
  35. (define %make-picture (record-constructor picture-type '(width height)))
  36.  
  37. (define %picture-min (record-accessor picture-type 'min))
  38. (define %picture-max (record-accessor picture-type 'max))
  39. (define %picture-set-data! (record-updater picture-type 'data))
  40. (define %picture-set-image! (record-updater picture-type 'image))
  41. (define %picture-set-min! (record-updater picture-type 'min))
  42. (define %picture-set-max! (record-updater picture-type 'max))
  43.  
  44. (define (make-picture width height #!optional initial-val)
  45.   (let ((pic (%make-picture width height))
  46.     (initial-val (if (default-object? initial-val)
  47.              0.
  48.              (exact->inexact initial-val))))
  49.     (%picture-set-min! pic initial-val)
  50.     (%picture-set-max! pic initial-val)
  51.     (%picture-set-data! pic 
  52.             (make-initialized-vector
  53.              height
  54.              (lambda (n)
  55.                n    ; ignored
  56.                (make-floating-vector width initial-val))))
  57.     (%picture-set-image! pic #f)
  58.     pic))
  59.  
  60. (define picture? (record-predicate picture-type))
  61.  
  62. (define picture-width
  63.   (record-accessor picture-type 'width))
  64.  
  65. (define picture-height
  66.   (record-accessor picture-type 'height))
  67.  
  68. (define picture-data
  69.   (record-accessor picture-type 'data))
  70.  
  71. (define picture-image
  72.   (record-accessor picture-type 'image))
  73.  
  74. (define (picture-set-image! picture image)
  75.   (let ((img (picture-image picture)))
  76.     (if (image? img)
  77.     (image/destroy img))
  78.     (%picture-set-image! picture image)))
  79.  
  80. (define (picture-min picture)
  81.   (let ((pic-min (%picture-min picture)))
  82.     (if (not pic-min) 
  83.     (begin (find-min-max picture)
  84.            (%picture-min picture))
  85.     pic-min)))
  86.  
  87. (define (picture-max picture)
  88.   (let ((pic-max (%picture-max picture)))
  89.     (if (not pic-max) 
  90.     (begin (find-min-max picture)
  91.            (%picture-max picture))
  92.     pic-max)))
  93.  
  94. (define (make-picture-referencer bad-type-predicate bad-range-signal)
  95.   (lambda (picture x y)
  96.     (cond ((bad-type-predicate x)
  97.        (error:wrong-type-argument x "picture X coordinate" 'PICTURE-REF))
  98.       ((bad-type-predicate y)
  99.        (error:wrong-type-argument y "picture Y coordinate" 'PICTURE-REF))
  100.       ((not (and (fix:>= x 0)
  101.              (fix:< x (picture-width picture))))
  102.        (bad-range-signal x 'PICTURE-REF))
  103.       ((not (and (fix:>= y 0)
  104.              (fix:< y (picture-height picture))))
  105.        (bad-range-signal y 'PICTURE-REF))
  106.       (else
  107.        (floating-vector-ref
  108.         (vector-ref (picture-data picture) y) x)))))
  109.  
  110. (define (make-picture-setter bad-type-predicate bad-range-signal)
  111.   (lambda (picture x y value)
  112.     (cond ((bad-type-predicate x)
  113.        (error:wrong-type-argument x "picture X coordinate" 'PICTURE-SET!))
  114.       ((bad-type-predicate y)
  115.        (error:wrong-type-argument y "picture Y coordinate" 'PICTURE-SET!))
  116.       ((not (and (fix:>= x 0)
  117.              (fix:< x (picture-width picture))))
  118.        (bad-range-signal x 'PICTURE-SET!))
  119.       ((not (and (fix:>= y 0)
  120.              (fix:< y (picture-height picture))))
  121.        (bad-range-signal y 'PICTURE-SET!))
  122.       (else
  123.        (floating-vector-set! (vector-ref (picture-data picture) y)
  124.             x (exact->inexact value))
  125.        (invalidate-cached-values picture)))))
  126.  
  127. (define picture-ref (make-picture-referencer
  128.              (lambda (var)
  129.                (declare (integrate var))
  130.                (not (fix:fixnum? var)))
  131.              error:bad-range-argument))
  132.  
  133. (define no-error-picture-ref (make-picture-referencer
  134.               (lambda (var)
  135.                 (declare (integrate var))
  136.                 var  ;ignored
  137.                 false)
  138.               (lambda (var proc-name)
  139.                 var proc-name   ;ignored
  140.                 false)))
  141.  
  142. (define picture-set! (make-picture-setter
  143.               (lambda (var)
  144.             (declare (integrate var))
  145.             (not (fix:fixnum? var)))
  146.               error:bad-range-argument))
  147.  
  148. (define no-error-picture-set! (make-picture-setter
  149.                (lambda (var)
  150.                  (declare (integrate var))
  151.                  var  ;ignored
  152.                  false)
  153.                (lambda (var proc-name)
  154.                  var proc-name  ;ignored 
  155.                  false)))
  156.  
  157. (define (picture-map! picture fn)
  158.   (let ((picdata (picture-data picture))
  159.     (width (picture-width picture))
  160.     (height (picture-height picture)))
  161.     (let y-loop ((y 0))
  162.       (if (< y height)
  163.       (let ((yth-row (vector-ref picdata y)))
  164.         (let x-loop ((x 0))
  165.           (if (< x width)
  166.           (begin (floating-vector-set! yth-row x 
  167.                       (exact->inexact 
  168.                        (fn x y)))
  169.              (x-loop (1+ x)))
  170.           (y-loop (1+ y))))))
  171.       (invalidate-cached-values picture))))
  172.  
  173. (define (picture-set-data! picture data)
  174.   (%picture-set-data! picture data)
  175.   (invalidate-cached-values picture))
  176.  
  177. ;;; Note that picture-data and picture-set-data! are both unsafe operations
  178. ;;; in the sense that both of them do not ensure that only floating point 
  179. ;;; numbers are ever stored in the picture array.
  180.  
  181.  
  182. (define (invalidate-cached-values picture)
  183.   (%picture-set-min! picture #f)
  184.   (%picture-set-max! picture #f)
  185.   (let ((img (picture-image picture)))
  186.     (if (image? img)
  187.     (image/destroy img))
  188.     (%picture-set-image! picture '())))
  189.  
  190. (define (find-min-max picture)
  191.   (let* ((picdata (picture-data picture))
  192.      (width (picture-width picture))
  193.      (height (picture-height picture))
  194.      (current-min (floating-vector-ref (vector-ref picdata 0) 0))
  195.      (current-max current-min))
  196.     (let y-loop ((y 0))
  197.       (if (< y height)
  198.       (let ((yth-row (vector-ref picdata y)))
  199.         (let x-loop ((x 0))
  200.           (if (< x width)
  201.           (let ((v (floating-vector-ref yth-row x)))
  202.             (set! current-min (min current-min v))
  203.             (set! current-max (max current-max v))
  204.             (x-loop (1+ x)))
  205.           (y-loop (1+ y)))))))
  206.     (%picture-set-min! picture current-min)
  207.     (%picture-set-max! picture current-max)))
  208.