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

;;; This file contains the coprocessor functions for
;;;    image-display.scm.


;;; ================================================================
;;; Filling colormap
;;; ================================================================

;;; Colormap-shuffle inverts the [1,255] section of the colormap, 
;;;    leaving 0 fixed.  It is its own inverse.
;;; This function is used to convert mathematically simple colormaps
;;;    (i.e. linearly increasing brightness) into colormaps in which 
;;;    windows from random other programs tend to remain readable.
(bulk-define colormap-shuffle integer integer
  (lambda (x) (cond ((= 0 x) 0)  ;; black
                    (#t          
		     (- 256 x)))))


;;; Fills in the display colormap 
(bulk-define fill-image-colormap! ((real-grid 1 3)) unspecified 
  (lambda (newmap)
    (let ((position 0))
      (scan (ptr newmap)
	    (let* ((new-position (colormap-shuffle position))
		   (green (modulo new-position 8))
		  (red (modulo (inexact->exact (floor (/ new-position 8.0))) 8))
		  (blue (inexact->exact (floor (/ new-position 64.0)))))
	      (sample-set! ptr (make-point (* red 0.14) (* green 0.14)
					   (* blue 0.33)))
	      (set! position (+ position 1)))))))

;;; ================================================================
;;; Remapping image values to colormap values
;;; ================================================================

;;; One intensity plane
(bulk-define gray-quantize
       ((manifold 2 1) (integer-grid 2 1)) unspecified
  (lambda (input output)
    (let ((input-start (focus-min-sample input))
	  (output-start (focus-min-sample output)))
      (scan (ss output)
	    (let* ((myshift (sample-offset ss output-start))
		   (value (sample-ref 
			   (shift-sample input-start 
					 (sample-offset ss output-start)))))
	      (if (missing? value) (set! value 0))  ;; my favorite color
              (if (> value 254) (set! value 254))   ;; if no missing values in sheet
	      (sample-set! 	     
	       ss 
	       (- 255 (inexact->exact (round value)))))))))


;;; Three RGB color planes
(bulk-define color-quantize
       ((manifold 2 1) (manifold 2 1) (manifold 2 1) (integer-grid 2 1)) 
       unspecified
  (lambda (inred ingreen inblue output)
    (let ((inred-start (focus-min-sample inred))
	  (ingreen-start (focus-min-sample ingreen))
	  (inblue-start (focus-min-sample inblue))
	  (output-start (focus-min-sample output))
	  (rg-bucket (/ 255 7.0))
	  (b-bucket (/ 255 3.0)))
      (scan (ss output)
	    (let* ((myshift (sample-offset ss output-start))
		   (hpos (modulo (point-coordinate myshift 0) 2))
		   (vpos (modulo (point-coordinate myshift 1) 2))
		   (myoffset (if (= 0 hpos)
				 (if (= 0 vpos) (/ 1 6) (/ -3 6))
				 (if (= 0 vpos) (/ -1 6)  (/ 3 6))))
		   (redval (sample-ref 
			    (shift-sample inred-start myshift)))
		   (greenval (sample-ref 
			      (shift-sample ingreen-start myshift)))
		   (blueval (sample-ref 
			     (shift-sample inblue-start myshift))))
	      (cond ((or (missing? redval) (missing? greenval) (missing? blueval))
		     (set! redval 0)      ;; bright blue for missing values
		     (set! greenval 0)
		     (set! blueval 255)))
	      (let* ((quantred (inexact->exact 
				(round (+ myoffset (/ redval rg-bucket)))))
		     (quantgreen (inexact->exact 
				  (round (+ myoffset (/ greenval rg-bucket)))))
		     (quantblue (inexact->exact 
				 (round (+ myoffset (/ blueval b-bucket))))))
		(set! quantred (min 7 (max 0 quantred)))
		(set! quantgreen (min 7 (max 0 quantgreen)))
		(set! quantblue (min 3 (max 0 quantblue)))
		(sample-set! ss 
			     (colormap-shuffle 
			      (+ quantgreen (* 8 (+ quantred (* 8 quantblue))))))))))))


;;; Average three planes
(bulk-define color-quantize-gray
       ((manifold 2 1) (manifold 2 1) (manifold 2 1) (integer-grid 2 1)) 
       unspecified
   (lambda (inred ingreen inblue output)
     (let ((inred-start (focus-min-sample inred))
	  (ingreen-start (focus-min-sample ingreen))
	  (inblue-start (focus-min-sample inblue))
	  (output-start (focus-min-sample output)))
      (scan (ss output)
	    (let* ((myshift (sample-offset ss output-start))
		   (sum
		    (+
		     (sample-ref 
		      (shift-sample inred-start myshift))
		     (sample-ref 
		      (shift-sample ingreen-start myshift))
		     (sample-ref 
		      (shift-sample inblue-start myshift))))
		   (average (inexact->exact (round (/ sum 3.0)))))
	      (if (missing? average) (set! average 0)) ;; my favorite choice
              (if (> average 254) (set! average 254))  ;; if no missing values in sheet
	      (sample-set! ss (- 255 average)))))))