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-imag.scm < prev    next >
Text File  |  1999-01-02  |  6KB  |  167 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: pic-imag.scm,v 1.10 1999/01/02 06:06:43 cph Exp $
  4.  
  5. Copyright (c) 1991-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. ;;;; 6.001 Images
  23.  
  24. (declare (usual-integrations))
  25.  
  26. ;;; Procedure to build an image given a picture and the magnification factors
  27.  
  28. (define (build-image pic window h-sf v-sf pic-min pic-max)
  29.   (let* ((gray-map (n-gray-map window))
  30.      (pic-height (picture-height pic))    ;py
  31.      (pic-width (picture-width pic))    ;x
  32.      (pic-data (picture-data pic))
  33.      (image-width (fix:* h-sf pic-width)) ;x
  34.      (image-height (fix:* v-sf pic-height)) ;iy
  35.      (use-string?
  36.       (for-all? (vector->list gray-map)
  37.         (lambda (n)
  38.           (<= 0 n 255))))
  39.      (image (image/create window image-width image-height))
  40.      (pixels
  41.       (if use-string?
  42.           (make-string (fix:* image-width image-height))
  43.           (make-vector (fix:* image-width image-height))))
  44.      (write-pixel (if use-string? vector-8b-set! vector-set!))
  45.      (py-max (- pic-height 1))
  46.      (rect-index-height (fix:* v-sf image-width))
  47.      (binner
  48.       (cutoff-binner .01 pic-min pic-max (vector-length gray-map)))
  49.      (gray-pixel
  50.       (lambda (pixel-value)
  51.         (vector-ref gray-map (binner pixel-value)))))
  52.  
  53.     (cond ((and (fix:= 1 h-sf) (fix:= 1 v-sf))
  54.        (let y-loop ((py py-max) (iy-index 0))
  55.          (if (fix:<= 0 py)
  56.          (begin
  57.            (let ((pic-row (vector-ref pic-data py)))
  58.              (let x-loop ((px 0))
  59.                (if (fix:< px pic-width)
  60.                (begin
  61.                  (write-pixel
  62.                   pixels
  63.                   (fix:+ px iy-index)
  64.                   (gray-pixel (flo:vector-ref pic-row px)))
  65.                  (x-loop (fix:+ px 1))))))
  66.            (y-loop (fix:- py 1) (fix:+ iy-index rect-index-height))))))
  67.  
  68.       ((and (fix:= 2 h-sf) (fix:= 2 v-sf))
  69.        (let y-loop ((py py-max) (iy-index 0))
  70.          (if (fix:<= 0 py)
  71.          (let ((pic-row (vector-ref pic-data py)))
  72.            (let x-loop ((px 0) (ix 0))
  73.              (if (fix:< px pic-width)
  74.              (let* ((n-is-0 (fix:+ ix iy-index))
  75.                 (n-is-1 (fix:+ n-is-0 image-width))
  76.                 (v (gray-pixel (flo:vector-ref pic-row px))))
  77.                (write-pixel pixels n-is-0 v)
  78.                (write-pixel pixels (fix:+ n-is-0 1) v)
  79.                (write-pixel pixels n-is-1 v)
  80.                (write-pixel pixels (fix:+ n-is-1 1) v)
  81.                (x-loop (fix:+ px 1) (fix:+ ix h-sf)))
  82.              (y-loop (fix:- py 1) 
  83.                  (fix:+ iy-index rect-index-height))))))))
  84.  
  85.       ((and (fix:= 3 h-sf) (fix:= 3 v-sf))
  86.        (let y-loop ((py py-max) (iy-index 0))
  87.          (if (fix:<= 0 py)
  88.          (let ((pic-row (vector-ref pic-data py)))
  89.            (let x-loop ((px 0) (ix 0))
  90.              (if (fix:< px pic-width)
  91.              (let* ((row0 (fix:+ ix iy-index))
  92.                 (row1 (fix:+ row0 image-width))
  93.                 (row2 (fix:+ row1 image-width))
  94.                 (v (gray-pixel (flo:vector-ref pic-row px))))
  95.                (write-pixel pixels row0 v)
  96.                (write-pixel pixels (fix:+ row0 1) v)
  97.                (write-pixel pixels (fix:+ row0 2) v)
  98.                (write-pixel pixels row1 v)
  99.                (write-pixel pixels (fix:+ row1 1) v)
  100.                (write-pixel pixels (fix:+ row1 2) v)
  101.                (write-pixel pixels row2 v)
  102.                (write-pixel pixels (fix:+ row2 1) v)
  103.                (write-pixel pixels (fix:+ row2 2) v)
  104.                (x-loop (fix:+ px 1) (fix:+ ix h-sf)))
  105.              (y-loop (fix:- py 1) 
  106.                  (fix:+ iy-index rect-index-height))))))))
  107.  
  108.       ((and (fix:= 4 h-sf) (fix:= 4 v-sf))
  109.        (let y-loop ((py py-max) (iy-index 0))
  110.          (if (fix:<= 0 py)
  111.          (let ((pic-row (vector-ref pic-data py)))
  112.            (let x-loop ((px 0) (ix 0))
  113.              (if (fix:< px pic-width)
  114.              (let* ((row0 (fix:+ ix iy-index))
  115.                 (row1 (fix:+ row0 image-width))
  116.                 (row2 (fix:+ row1 image-width))
  117.                 (row3 (fix:+ row2 image-width))
  118.                 (v (gray-pixel (flo:vector-ref pic-row px))))
  119.                (write-pixel pixels row0 v)
  120.                (write-pixel pixels (fix:+ row0 1) v)
  121.                (write-pixel pixels (fix:+ row0 2) v)
  122.                (write-pixel pixels (fix:+ row0 3) v)
  123.                (write-pixel pixels row1 v)
  124.                (write-pixel pixels (fix:+ row1 1) v)
  125.                (write-pixel pixels (fix:+ row1 2) v)
  126.                (write-pixel pixels (fix:+ row1 3) v)
  127.                (write-pixel pixels row2 v)
  128.                (write-pixel pixels (fix:+ row2 1) v)
  129.                (write-pixel pixels (fix:+ row2 2) v)
  130.                (write-pixel pixels (fix:+ row2 3) v)
  131.                (write-pixel pixels row3 v)
  132.                (write-pixel pixels (fix:+ row3 1) v)
  133.                (write-pixel pixels (fix:+ row3 2) v)
  134.                (write-pixel pixels (fix:+ row3 3) v)
  135.                (x-loop (fix:+ px 1) (fix:+ ix h-sf)))
  136.              (y-loop (fix:- py 1) 
  137.                  (fix:+ iy-index rect-index-height))))))))
  138.  
  139.       (else 
  140.        (let y-loop ((py py-max) (iy-index 0))
  141.          (if (fix:<= 0 py)
  142.          (let ((pic-row (vector-ref pic-data py)))
  143.            (let x-loop ((px 0) (ix 0))
  144.              (if (fix:< px pic-width)
  145.              (let* ((v (gray-pixel (flo:vector-ref pic-row px)))
  146.                 (n-start (fix:+ ix iy-index))
  147.                 (n-end (fix:+ n-start rect-index-height)))
  148.                (let n-loop ((n n-start))
  149.                  (if (fix:< n n-end)
  150.                  (let ((m-end (fix:+ n h-sf)))
  151.                    (let m-loop ((m n))
  152.                      (if (fix:< m m-end)
  153.                      (begin
  154.                        (write-pixel pixels m v)
  155.                        (m-loop (fix:+ m 1)))
  156.                      (n-loop (fix:+ n image-width)))))
  157.                  (x-loop (fix:+ px 1) (fix:+ ix h-sf)))))
  158.              (y-loop (fix:- py 1) 
  159.                  (fix:+ iy-index rect-index-height)))))))))
  160.     ;; Kludge: IMAGE/FILL-FROM-BYTE-VECTOR should take an argument
  161.     ;; that specifies what color a given byte in PIXELS maps to.
  162.     ;; OS/2 requires this information, so we supply it here.
  163.     (if (eq? 'OS/2 microcode-id/operating-system)
  164.     (os2-image/set-colormap image (os2-image-colormap)))
  165.     (image/fill-from-byte-vector image pixels)
  166.     (1d-table/put! (graphics-device/properties window) image (cons h-sf v-sf))
  167.     image))