;;;
;;; Demo code for displaying images
;;;
;;; Margaret M. Fleck and Daniel E. Stevenson
;;; Copyright 1997
;;;

;;; ==> WARNING:  still being debugged!!!

;;;   Depends on coprocessor functions defined in 
;;;   image-display-utils.scm, which should be loaded before 
;;;   this file.

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

;;; If the second input (show-color?) is set to #t (or omitted), displays 
;;;     color images as color.  If it is #f or missing, it displays them 
;;;     as grayscale.
(define (show-image image . options)
  (let ((show-color? (cond ((null? options) #t)
			  (#t #f))))
    (cond ((sheet? image)
	   (make-gray-display image (sheet-label image)))
	  ((list? image)
	   (let ((mystring (car image)))
	     (cond ((not (string? mystring))
		    (error "show-image needs a string tag on lists")))
	     (cond ((or (string=? mystring  "linear intensity image") 
			(string=? mystring  "log intensity image")) 
		    (cond ((< (length image) 3)
			   (error "bad grayscale input to show-image")))
		    (make-gray-display (list-ref image 2)    ;; intensities
				       (list-ref image 1)))  ;; label
		   ((or (string=? mystring  "linear RGB color image") 
			(string=? mystring  "log opponent color image"))
		    (cond ((< (length image) 5)
			   (error "bad color input to show-image")))
		    (make-color-display (list-ref image 2)   ;; red
					(list-ref image 3)   ;; green
					(list-ref image 4)   ;; blue
					(list-ref image 1) ;; label
					show-color?))
		   (#t (error "show-image: bad tag"))))))))

;;; ================================================================
;;; Set up a more useful colormap than the default one.
;;; ================================================================

(define (image-colormap)
  (let* ((new-cm (make-real-grid "cm" '(flat 1 (0 255)) 
				'(flat 0.001 (0 1) (0 1) (0 1)) #f 0 0 0)))
    (fill-image-colormap! new-cm)
    new-cm))

;(define (image-colormap)
;  (let* ((new-cm (make-real-grid "cm" '(flat 1 (0 255)) 
;				'(flat 1 (0 1) (0 1) (0 1)) #f 0 0 0)))
;    (fill-image-colormap! new-cm)
;    new-cm))

;(define *image-color-map* (image-colormap 255))

;(define new-cm (make-real-grid "cm" '(flat 1 (0 255)) 
;      '(flat 1 (0 1) (0 1) (0 1)) #f 0 0 0))

;(green-colormap new-cm 50.0)
;(install-colormap w new-cm)

;;; ================================================================
;;; Coprocessor functions, defined in image-display-utils.scm
;;; ================================================================

(bulk-import fill-image-colormap!)
(bulk-import gray-quantize)
(bulk-import color-quantize)
(bulk-import color-quantize-gray)

;;; ================================================================
;;; Convert input manifold (gray) or manifolds (color)
;;;     to an integer-grid of colormap values.
;;; ================================================================

;;; Takes a manifold as input and returns two values
;;;    -- an integer grid to contain its colormap values
;;;    -- a window the right size to display it
(define (make-display-output input label)
  (let* ((input-type (car (sheet-domain input)))
	 (input-size (sample-offset (focus-max-sample input)
				    (focus-min-sample input)))
	 (xrange (list 0 (point-coordinate input-size 0)))
	 (yrange (list 0 (point-coordinate input-size 1)))
	 (grid
	  (make-integer-grid 
	   label
	   (list input-type 1 xrange yrange)
	   '(flat 1 (0 255))
	   #f 0))
	 (window (open-window
		  (crop-label label (floor (/ (cadr xrange) 14)))
		  xrange yrange)))
    (values grid window)))

(define (make-gray-display input label)
  (cond ((not (manifold? input))
	 (error "input to make-gray-display must be a manifold")))
  (receive (mygrid mywindow)
	   (make-display-output input label)
    (gray-quantize input mygrid)
    (draw mygrid mywindow (make-point 0 0))
    mygrid))

(define (make-color-display inred ingreen inblue label show-color?)
  (cond ((or (not (manifold? inred))
	     (not (manifold? ingreen))
	     (not (manifold? inblue)))
	 (error "inputs to make-color-display must be manifolds")))
  (receive (mygrid mywindow)
	   (make-display-output inred label)
    (if show-color?
	(begin (color-quantize inred ingreen inblue mygrid)
	       (install-colormap mywindow (image-colormap)))
	(color-quantize-gray inred ingreen inblue mygrid))
    (draw mygrid mywindow (make-point 0 0))
    mygrid))


(define (crop-label label maxwidth)
  (let ((mylength (string-length label)))
    (if (<= mylength maxwidth)
	label
	(substring label (- mylength maxwidth) mylength))))