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-read.scm < prev    next >
Text File  |  1999-01-02  |  4KB  |  108 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: pic-read.scm,v 1.5 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. ;;;; Procedures to read a file in raw pgm format into a picture
  23.  
  24. (declare (usual-integrations))
  25.  
  26. (define (pgm-file->picture filename)
  27.   (call-with-input-file (standard-pathname filename "pgm")
  28.     (lambda (port)
  29.       (get-body port (get-header port)))))
  30.  
  31. (define (standard-pathname filename type)
  32.   (let ((pathname (->pathname filename)))
  33.     (if (or (pathname-type pathname)
  34.         (file-exists? pathname))
  35.     pathname
  36.     (pathname-new-type pathname type))))
  37.  
  38. (define (get-header port)
  39.   (let* ((type (get-line port))
  40.      (dims (get-line port))
  41.      (no-of-greys (string->number (get-line port)))
  42.      (spc-index (string-find-next-char dims #\space)))
  43.     (if (not (equal? type "P5"))  ; P5 is the magic number for raw PGM format
  44.     (error "Unrecognized format (Convert to raw PGM)."))
  45.     (vector type
  46.         (string->number (string-head dims spc-index))
  47.         (string->number (string-tail dims (+ spc-index 1)))
  48.         no-of-greys)))
  49.  
  50. (define get-line
  51.   (let ((delimiters (char-set #\newline)))
  52.     (lambda (port)
  53.       (let loop ()
  54.     (let ((line (read-string delimiters port)))
  55.       (if (eof-object? line)
  56.           (error "EOF encountered when parsing line."))
  57.       (read-char port)
  58.       ;; ignore comments
  59.       (if (and (not (string-null? line))
  60.            (char=? #\# (string-ref line 0)))
  61.           (loop)
  62.           line))))))
  63.  
  64. (define (get-body port attributes)
  65.   (let* ((length (vector-ref attributes 1))
  66.      (width (vector-ref attributes 2))
  67.      (pic (make-picture length width))
  68.      (data
  69.       (make-initialized-vector
  70.        width
  71.        (lambda (index)
  72.          index            ; ignored
  73.          (make-floating-vector length 0.))))) ;initialize to blank
  74.     (side-effecting-iter
  75.      width
  76.      (lambda (n)
  77.        (let ((nth-row (vector-ref data (- width n 1))))
  78.      (side-effecting-iter
  79.       length
  80.       (lambda (m)
  81.         (floating-vector-set!
  82.          nth-row
  83.          m
  84.          (exact->inexact (char->ascii (read-char port)))))))))
  85.     (picture-set-data! pic data)
  86.     pic))
  87.  
  88. ;;; Procedure to read in a picture that was previously saved using
  89. ;;; picture-write.
  90.  
  91. (define (picture-read filename)
  92.   (let ((pic-mimic (fasload (standard-pathname filename "pic"))))
  93.     (if (not (record? pic-mimic))
  94.     (error "Object loaded is not a record:" pic-mimic))
  95.     (let ((mimic-type (record-type-descriptor pic-mimic)))
  96.       (if (not (equal? (record-type-field-names mimic-type)
  97.                (record-type-field-names picture-type)))
  98.       (error "Object loaded is not a picture:" pic-mimic))
  99.       (let ((new-pic
  100.          (make-picture ((record-accessor mimic-type 'width) pic-mimic)
  101.                ((record-accessor mimic-type 'height) pic-mimic))))
  102.     (picture-set-data! new-pic
  103.                ((record-accessor mimic-type 'data) pic-mimic))
  104.     (%picture-set-min! new-pic
  105.                ((record-accessor mimic-type 'min) pic-mimic))
  106.     (%picture-set-max! new-pic
  107.                ((record-accessor mimic-type 'max) pic-mimic))
  108.     new-pic))))