;;;
;;; Demo code for reading standard image file formats
;;;
;;; Margaret M. Fleck and Daniel E. Stevenson
;;; Copyright 1997
;;;

;;; This file contains only the scheme functions.  See
;;;   foreign-image-utils.scm for the coprocessor functions,
;;;   which should be loaded before this file.

;;; Currently, this code can read the following formats:
;;;     -- MIT grey-scale and RGB (8-bit only)
;;;     -- Iowa calibrated images (only radial projections
;;;           only intensity and color data)
;;;     -- packed/rawbits version of PPM and PGM (formats P5 and P6)
;;;
;;; It also correctly identifies, but cannot read, files in 
;;;     JPEG and GIF, as well as files in the other PNM formats.
;;;
;;; This code is not pretty, general, or bullet-proof.  It is intended
;;;     to help you move data from crufty old formats, into the nicer
;;;     new tagged format.  

;;; ================================================================
;;; Top-level function
;;; ================================================================

;;; The function read-foreign-image returns a list of images.  
;;;    (Some formats allow more than one image per file.)  
;;;
;;; Each image is a list containing (in order)
;;;    1) a string indicating how many sheets will follow, and what 
;;;       sort of values they contain.  Options include: 
;;;            "linear intensity image"
;;;            "linear RGB color image"
;;;            "log intensity image"
;;;            "log opponent color image"
;;;    2) a string label identifying the image.  This defaults to the
;;;       filename if nothing better was found in the file.
;;;    3) one or more sheets (one if this is an intensity image, three
;;;       if it is a color image).  Each sheet contains a human-readable
;;;       label describing its contents.
;;;    4) zero or more human-readable objects describing the data.
;;;       The format of these depends on the input file format.

;;; Example:  (read-foreign-image "/group/images/mfleck/corel2/212015.mit")

(define (read-foreign-image filename)
  (let* ((type (image-type filename)))
    (cond ((member type '(mit-gray mit-color iowa))
	   (read-mit filename))
	  ((eq? type 'pgm-packed)
	   (read-pgm-packed filename))
	  ((eq? type 'ppm-packed)
	   (read-ppm-packed filename))
	  ((eqv? type #f)
	   (error "Unknown image format.~%"))
	  (#t 
	   (error (format #f "Reader for format ~s not yet implemented.~%" type))))))

;;; ================================================================
;;; Coprocessor functions (defined in foreign-image-utils.scm)
;;; ================================================================

(bulk-import mit-transfer-bytes)
(bulk-import ppm-transfer-bytes)

;;; ================================================================
;;; File header utilities
;;; ================================================================

;;; Returns type of image, as a symbol: 
;;;    'mit-gray, 'mit-color, 'jpeg, 'gif, 'iowa, 
;;;    'pbm, 'pgm, 'ppm, 'pgm-packed, 'ppm-packed, 'pbm-packed 
;;; Returns #f if it can't identify format.
(define (image-type filename)
  (let* ((fp (open-binary-input-file filename))
	 (byte1 (read-byte fp))
	 (byte2 (read-byte fp))
	 (byte3 (read-byte fp)))
    (close-binary-port fp)
    (cond ((and (= byte1 255) (= byte2 216)) 'jpeg)
	  ((and (= byte1 1) (= byte2 0)) 'mit-gray)
	  ((and (= byte1 2) (= byte2 0)) 'mit-color)
	  ((and (= byte1 200) (= byte2 0)) 'iowa)
	  ((and (= byte1 71) (= byte2 73) (= byte3 70)) 'gif)
	  ((= byte1 80)
	   (cond ((= byte2 49) 'pbm)
		 ((= byte2 50) 'pgm)
		 ((= byte2 51) 'ppm)
		 ((= byte2 52) 'pbm-packed)
		 ((= byte2 53) 'pgm-packed)
		 ((= byte2 54) 'ppm-packed)
		 (#t #f)))
	  (#t #f))))


;;; Print first n bytes, for checking image header by hand.
;;; For debugging purposes only
;;; Must open the module ascii before using
;(define (test-header filename n)
;  (let* ((fp (open-binary-input-file filename))
;	 (next-byte 0))
;    (format #t "First ~d bytes:" n)
;    (do ((i 0 (+ 1 i)))
;	((> i n))
;      (cond ((= 0 (modulo i 5)) (format #t "~%")))
;      (set! next-byte (read-byte fp))
;      (format #t " ~d=~s" next-byte (ascii->char next-byte)))
;    (format #t "~%")  
;    (close-binary-port fp)))
  

;;; ================================================================
;;; Code for reading PPM images
;;; ================================================================

;;; grayscale image
(define (read-pgm-packed filename)
  (let* ((fp (open-binary-input-file filename))
	 (width #f)
	 (height #f)
	 (intensities #f))
    ;; read past the magic number since we already know it is P5
    (read-byte fp)
    (read-byte fp)
    (set! width (read-ppm-number fp))
    (set! height (read-ppm-number fp))
    (format #t "Reading packed PGM format intensity image, ~d by ~d pixels.~%"
	    width height)	     
    ;; read past max value, since we know it's <= 255.
    (read-ppm-number fp)
    (set! intensities 
	  (read-mit-8-sheet fp width height "intensity data" 0))
    (close-binary-port fp)
    (list (list "linear intensity image" filename intensities))))

(define (read-ppm-packed filename)
  (let* ((fp (open-binary-input-file filename))
	 (width #f)
	 (height #f)
	 (planes #f))
    ;; read past the magic number since we already know it is P6
    (read-byte fp)
    (read-byte fp)
    (set! width (read-ppm-number fp))
    (set! height (read-ppm-number fp))
    (format #t "Reading packed PPM format color image, ~d by ~d pixels.~%"
	    width height)	     
    ;; read past max value, since we know it's <= 255.
    (read-ppm-number fp)
    (set! planes (read-ppm-sheets fp width height))
    (close-binary-port fp)
    (list (cons "linear RGB color image" (cons filename planes)))))


;;; ================================================================
;;; Utility for PPM images
;;; ================================================================

;;; Gobbles next number, as well as any preceding whitespace and
;;;   first character of any following whitespace.
(define (read-ppm-number fp)
  (let ((status 0)   
	(next-char 0)
	(output 0))
    ;; status 0 = haven't started number (eating preceding whitespace)
    ;;        1 = reading number
    ;;        2 = finished reading number
    (do ()
	((= status 2))
      (set! next-char (read-byte fp))
      (cond ((member next-char '(9 10 32 12 13))  ;; whitespace
	     (cond ((= status 1) (set! status 2))))
	    ((eq? next-char 35)  
	     ;; i.e. a #, which indicates the start of a comment
	     ;; So walk to end of comment (end of line)
	     (do ((temp (read-byte fp) (read-byte fp)))
		 ((or (binary-eof-object? temp)
		      (member temp '(13 10)))))  
	     ;; be nice:  count this also as whitespace
	     (cond ((= status 1) (set! status 2)))) 
	    ((and (>= next-char 48)
		  (<= next-char 57))
	     ;; found more digits for our number
	     (cond ((= status 0) (set! status 1)))
	     (set! output (+ (- next-char 48) (* output 10))))
	    (#t
	     (format #t "Illegal character ~s in ppm file" next-char)
	     (set! status 2)
	     (set! output #f))))
    output))
	     

;;; ascii codes for special characters
;;;    9 = tab
;;;    10 = newline
;;;    32 = space
;;;    12 = page
;;;    13 = carriage return 
;;;    35 = #
;;; numbers 0-9 are ascii codes 48-57

;;; Reads ppm's interleaved format and returns three sheets
(define (read-ppm-sheets file-pointer width height)
  (let ((outred (make-manifold "red data"
				   `(flat 1 (0 ,(- width 1)) (0 ,(- height 1)))
				   '(flat 1 (0 255))
				   #f 0))
	(outgreen (make-manifold "green data"
				     `(flat 1 (0 ,(- width 1)) (0 ,(- height 1)))
				     '(flat 1 (0 255))
				     #f 0))
	(outblue (make-manifold "blue data"
				    `(flat 1 (0 ,(- width 1)) (0 ,(- height 1)))
				    '(flat 1 (0 255))
				    #f 0)))
    (receive (data k) (read-bytes file-pointer (* 3 width height))
	     (ppm-transfer-bytes data outred 0)
	     (ppm-transfer-bytes data outgreen 1)
	     (ppm-transfer-bytes data outblue 2)
	     (remove-sheet data)
	     (list outred outgreen outblue))))

;;; ================================================================
;;; Code for reading MIT and Iowa format images
;;; ================================================================

;;; These formats allow multiple images in the same file.
(define (read-mit filename)
  (let* ((fp (open-binary-input-file filename))
	 (outlist '())
	 (number 0)
	 (label filename)
	 (current-image #t))
    (do ((format-number (read-reverse-16 fp) (read-reverse-16 fp)))
	((or (binary-eof-object? format-number) 
	     (not current-image)
	     (not (member format-number '(1 2 200))))
	 (close-binary-port fp)
	 outlist)
      (set! number (+ 1 number))
      (set! label (format #f "~a(~d)" filename number))
      (cond ((member format-number '(1 2))
	     (set! current-image (read-mit-raw fp format-number))
	     (cond (current-image
		    (set! outlist 
			  (cons (mit-add-label current-image label) outlist)))))
	    ((= format-number 200)
	     (set! current-image (read-mit-calibrated fp))
	     (cond (current-image
		    (set! outlist 
			  (cons (mit-add-label current-image label) outlist)))))
	    (#t 
	     (error "internal error in read-mit")
	     (set! current-image #f))))))

(define (mit-add-label raw-image label)
  (cons (car raw-image) 
	(cons label
	      (cdr raw-image))))

(define (read-mit-raw fp format-number)
  (let* ((bits-per-pixel (read-reverse-16 fp))
	 (width (read-reverse-16 fp))
	 (height (read-reverse-16 fp))
	 (sheet-reader #f))
    (cond ((= bits-per-pixel 8)
	   (set! sheet-reader read-mit-8-sheet))
	  (#t 
	   (format #t "~d bits per pixel is not supported.~%" bits-per-pixel)))
    (cond ((not sheet-reader)
	   #f)
	  ((= format-number 1)
	   (format #t "Reading MIT format ~d-bit intensity image, ~d by ~d pixels.~%"
		   bits-per-pixel width height)	     
	   (list "linear intensity image" 
		 (sheet-reader fp width height "intensity data" 0)))
	  ((= format-number 2)
	   (format #t "Reading MIT format ~d-bit color image, ~d by ~d pixels.~%"
		   bits-per-pixel width height)	     
	   (list "linear RGB color image" 
		 (sheet-reader fp width height "red data" 0)
		 (sheet-reader fp width height "green data" 0)
		 (sheet-reader fp width height "blue data" 0)))
	  (#t (error "internal error in read-mit-raw")))))
  

(define (read-mit-calibrated fp)
  (let* ((geometry-type (read-reverse-16 fp))
	 (data-type (read-reverse-16 fp)))
    (cond ((not (= geometry-type 0))
	   (format #t "Geometry type ~d is not supported.~%" geometry-type)
	   #f)
	  ((not (member data-type '(0 1)))
	   (format #t "Data type ~d is not supported.~%" data-type)
	   #f)
	  (#t
	   (let* ((geometry (read-radial-geometry fp))
		  (data (if (= 0 data-type)
			    (read-calib-intensity fp)
			    (read-calib-color fp))))
	     (and geometry data 
		  (append (car data) 
			  (list geometry (cadr data)))))))))

(define (read-radial-geometry fp)
  (let* ((center (list (read-float-16 fp) (read-float-16 fp)))
	 (center-error (read-float-16 fp))
	 (radial-scale (list (read-true-float fp) (read-true-float fp)))
	 (projection-type (cadr (assoc (read-reverse-16 fp)
				       '((0 "perspective")
					 (1 "stereographic")
					 (2 "equidistant")
					 (3 "equisolid")
					 (4 "sine-law"))))))
    (list "radial projection parameters"
	  (list "projection type" projection-type)
	  (list "estimated projection center" center)
	  (list "error in projection center" center-error)
	  (list "high and low estimates of radial scale" radial-scale))))

(define (read-calib-color fp)
  (let* ((width (read-reverse-16 fp))
	 (height (read-reverse-16 fp))
	 (colorwidth (read-reverse-16 fp))
	 (colorheight (read-reverse-16 fp))
	 (intensity-is (cadr (assoc (read-reverse-16 fp)
				    '((0 "y channel") 
				      (1 "grayscale camera")
				      (2 "green channel") 
				      (3 "average of red, green, and blue channels")))))
	 (log-multiplier (read-float-16 fp)))
    (format #t "Reading Iowa calibrated color image, ~s by ~s pixels~%"
	    width height)
    (list (list "log opponent color image"
		(read-mit-8-sheet fp width height "intensity data" 0)
		(read-mit-8-sheet fp colorwidth colorheight "red green data" -128)
		(read-mit-8-sheet fp colorwidth colorheight "blue yellow data" -128))
	  (list "opponent value parameters"
		(list "intensity values come from" intensity-is)
		(list "log multiplier" log-multiplier)))))

(define (read-calib-intensity fp)
  (let* ((width (read-reverse-16 fp))
	 (height (read-reverse-16 fp))
	 (intensity-is (cadr (assoc (read-byte fp)
				    '((0 y) (1 bw)
					    (2 green) (3 rgb)))))
	 (log-multiplier (read-float-16 fp)))
    (format #t "Reading Iowa calibrated intensity image, ~s by ~s pixels~%"
	    width height)
    (list (list "log intensity image"
		(read-mit-8-sheet fp width height "intensity data" 0))
	  (list "intensity value parameters"
		(list "intensity values come from" intensity-is)
		(list "log multiplier" log-multiplier)))))
	  

;;; ================================================================
;;; MIT reader utilities
;;; ================================================================

;;; Reads raw 1D input into 2D sheet, in appropriate order.
;;; Output is currently a grid for convenience:  will become a manifold
;;;    once the display utilities exist.
;;; Also eventually needs to handle missing values used in the
;;;    calibrated format.
(define (read-mit-8-sheet file-pointer width height label offset)
  (let ((outsheet (make-manifold label
				     `(flat 1 (0 ,(- width 1)) (0 ,(- height 1)))
				     '(flat 1 (0 255))
				     #f 0)))
    (receive (data k) (read-bytes file-pointer (* width height))
	     (mit-transfer-bytes data outsheet offset)
	     (remove-sheet data)
	     outsheet)))
  
;;; reads two bytes from file, in swapped order
(define (read-reverse-16 file-pointer)	
  (let* ((first (read-byte file-pointer))
	 (second (read-byte file-pointer)))
    (cond ((binary-eof-object? first) first)
	  ((binary-eof-object? second) second)
	  (#t (+ first (* second 256))))))

(define (read-float-16 file-pointer)
  (let ((raw (read-reverse-16 file-pointer)))
    (cond ((= raw 0) "unavailable")
	  ((= raw 65535) "infinity")
	  (#t (* 0.1 (- raw 32768))))))

(define (read-true-float file-pointer)
  (let ((first (read-byte file-pointer))
	(second (read-byte file-pointer))
	(third (read-reverse-16 file-pointer)))
    (cond ((binary-eof-object? first) first)
	  ((binary-eof-object? second) second)
	  ((binary-eof-object? third) third)
	  (#t 
	   (cond ((= second 255) "infinity")
		 ((= second 0) "negative infinity")
		 (#t
		  (* (if (= 0 first) -1.0 1.0)
		     (* third (expt 10 (- second 128))))))))))