;;; -*- Mode: Lisp; Syntax: Common-lisp; Package: MU; Base: 10.; -*-

;;; Copyright (c) 1987, Massachusetts Institute of Technology
;;; Author: Mike Drumheller

;;;*****************************************************************************
;;; CHANGE HISTORY
;;;
;;; 9/25/87  WEG  Converted to Release 7.  Changed the package to mu.
;;;
;;; 88DEC89  PAO  Converted to CM-5.0
;;;*****************************************************************************

(in-package :mu)

;;; Display routines.  Most arrays are assumed to be 2D.

(*defun BORDER-PROCESSOR-P!! (top-border-width
			       &optional
			       (left-border-width top-border-width)
			       (bottom-border-width top-border-width)
			       (right-border-width left-border-width))
  (let ((to top-border-width)
	(l left-border-width)
	(b bottom-border-width)
	(r right-border-width)
	(dim0 (dimension-size 0))
	(dim1 (dimension-size 1)))
    (*let ((border-processor-p!!
	     (if (and (zerop to) (zerop l) (zerop b) (zerop r))
		 nil!!
		 (*let ((x!! (self-address-grid!! (!! 0)))
			(y!! (self-address-grid!! (!! 1))))
		   (declare (type (field-pvar (integer-length dim0)) x!!)
			    (type (field-pvar (integer-length dim1)) y!!))
		   (or!! (<!! x!! (!! l))
			 (>!! x!! (!! (- dim0 r 1)))
			 (<!! y!! (!! to))
			 (>!! y!! (!! (- dim1 b 1))))))))
      (declare (type boolean-pvar border-processor-p!!))
      border-processor-p!!)))

(*defun PVAR-WITH-BORDERS-AND-NON-NUMBERS-REMOVED!! 
	(pvar!!
	  value-where-near-border
	  value-where-not-a-number 
	  top-border-width
	  &optional
	  (left-border-width top-border-width)
	  (bottom-border-width top-border-width)
	  (right-border-width left-border-width))
  (*let* ((border-p!! (border-processor-p!!
			top-border-width
			left-border-width
			bottom-border-width
			right-border-width))
	  (nans-and-borders-removed!!
	    (cond!! ((and!! (numberp!! pvar!!) (not!! border-p!!))
		     pvar!!)
		    (border-p!!
		     (!! value-where-near-border))
		    ((not!! (numberp!! pvar!!))
		     (!! value-where-not-a-number)))))
    nans-and-borders-removed!!))

(*defun RESCALE-PVAR!! (pvar!! &optional
			       (new-min 0) (new-max 255.)
			       (ignore-processors-within-this-distance-of-grid-border 0)
			       (value-where-not-a-number 0)
			       (value-where-near-border 0))
  ;;;
  ;;;  Rescales the pvar to INTEGER values.
  ;;;
  (if (<= new-max new-min) (error "NEW-MAX must be greater than NEW-MIN."))
  ;; if the pvar is boolean, convert it to a field pvar for the benefit of *min and *max
  (setq pvar!! (fastio:coerce-boolean-to-bit!! pvar!!))
  (*let ((border-processor-p!!
	   (border-processor-p!! ignore-processors-within-this-distance-of-grid-border)))
    (cond!! ((and!! (numberp!! pvar!!) (not!! border-processor-p!!))
	     (let* ((old-min (*min pvar!!))
		    (old-max (*max pvar!!))
		    (old-range (- old-max old-min))
		    (new-range (- new-max new-min))
		    (new-bits (max (integer-length new-min) (integer-length new-max))))
	       (if (zerop old-range)
		   (cond ((> old-max 255) (!! 255))
			 ((< old-min 0) (!! 0))
			 (t (!! (floor old-max))))
		   (if (not (minusp new-min))
		       (*let ((rescaled-pvar!! (!! 0)))
			 (declare (type (field-pvar new-bits)
					rescaled-pvar!!))
			 (*set rescaled-pvar!!
			       (round!!
				 (+!! (!! new-min)
				      (*!! (-!! pvar!! (!! old-min))
					   (!! (/ new-range (float old-range)))))))
			 rescaled-pvar!!)
		       (*let ((rescaled-pvar!! (!! 0)))
			 (declare (type (signed-pvar (1+ new-bits))
					rescaled-pvar!!))
			 (*set rescaled-pvar!!
			       (round!!
				 (+!! (!! new-min)
				      (*!! (-!! pvar!! (!! old-min))
					   (!! (/ new-range (float old-range)))))))
			 rescaled-pvar!!)))))
	    (border-processor-p!!
	      (!! value-where-near-border))
	    ((not!! (numberp!! pvar!!))
	     (!! value-where-not-a-number)))))

#+symbolics
(progn
(defun LEFT-MARGIN (&optional (window zetalisp:standard-output))
  (zetalisp:send window :left-margin-size))
(defun TOP-MARGIN (&optional (window zetalisp:standard-output))
  (zetalisp:send window :top-margin-size))
(defun WINDOW-WIDTH (&optional (window zetalisp:standard-output))
  (zetalisp:send window :inside-width))
(defun WINDOW-HEIGHT (&optional (window zetalisp:standard-output))
  (zetalisp:send window :inside-height))
) ;;; End #+symbolics

#-symbolics
(progn
(defun LEFT-MARGIN (&optional (window *standard-output*))
  (declare (ignore window))
   0)
(defun TOP-MARGIN (&optional (window *standard-output*))
  (declare (ignore window))
   0)
(defun WINDOW-WIDTH (&optional (window *standard-output*))
  (declare (ignore window))
  100)
(defun WINDOW-HEIGHT (&optional (window *standard-output*))
  (declare (ignore window))
  100)
) ;;; End #-symbolics

(defun MOVE-CURSOR-IF-NECESSARY (y &optional (window *standard-output*))
  #-symbolics (declare (ignore y window))
  #-symbolics nil
  #+symbolics
  (zetalisp:send window :set-cursorpos 0 (max (zetalisp:send window :cursor-y)
					      (+ (top-margin window) y))))

(defvar *1B-SHOW-ARRAY*
	(make-array '(256 256) :element-type '(mod 2)))

#+*lisp-hardware
(*defun *SHOW-BIT (pvar &optional (x 0) (y 0) (bit 0) (window *standard-output*))
  (multiple-value-bind
    (scratch-array-xdim scratch-array-ydim)
      (vu:decode-raster-array *1b-show-array*)
    (if (not (and (= scratch-array-xdim (dimension-size 1))
		  (= scratch-array-ydim (dimension-size 0))))
	(setq *1b-show-array*
	      (vu:make-raster-array (dimension-size 1)
				 (dimension-size 0)
				 :element-type '(mod 2)))))
  (*let ((pvar-bit (!! 0)))
    (declare (type (field-pvar 1) pvar-bit))
    (cm:u-move-1L (pvar-location pvar-bit)
			   (cm:add-offset-to-field-id (pvar-location pvar) bit)
			   1)
;;;    #+(OR CM-5.0 CM-5-1) (*set pvar-bit (load-byte!! pvar (!! bit) (!! 1)))
    (move-cursor-if-necessary (+ y (dimension-size 1)))
    (fastio::*read-array-from-cm-grid *1b-show-array* pvar-bit))
  (show-1b-raster *1b-show-array* x y
		  #-symbolics window
		  #+symbolics
		  (if (typep window 'tv:minimum-window)
		      window
		      (si:follow-syn-stream window))))

;#+*lisp-simulator
;(*defun *SHOW-BIT (pvar &optional (x 0) (y 0) (bit 0) (window *standard-output*))
;  (clear-section-of-screen x y (dimension-size 0) (dimension-size 1) window)
;  (if (equal (pvar-type pvar) :boolean)
;      (loop for i from 0 below (dimension-size 0)
;	    for drawx from x below (window-width window) do
;	(loop for j from 0 below (dimension-size 1)
;	      for drawy from y below (window-height window) do
;	  (if (pref-grid pvar i j)
;	      (zl-user::send window :draw-point drawx drawy))))
;      (loop for i from 0 below (dimension-size 0)
;	    for drawx from x below (window-width window) do
;	(loop for j from 0 below (dimension-size 1)
;	      for drawy from y below (window-height window) do
;	  (if (= 1 (load-byte (pref-grid pvar i j) bit 1))
;	      (zl-user::send window :draw-point drawx drawy))))))

;;; Allocate the display raster statically so that we don't have to build a new one
;;; each time.  The maximum practical CM grid size is 256x256; when this changes,
;;; the raster will need to be larger.  (WEG 3/4/88)
(defvar *DISPLAY-RASTER-256* (make-array '(256 256) :element-type '(unsigned-byte 8)))

;;; Display a pvar on the color monitor.
#+*lisp-hardware
(*defun *SHOW-PVAR (pvar
		      &key
		      (expose? t)
		      (window spe:*color-window*)
		      (x 0) (y 0)
		      (normalize? t)
		      (max-normalized-brightness-if-normalizing 255.)
		      (ignore-border 0)
		      (display-raster *display-raster-256*)
		      (fast fastio:*fast-array-io?*))
  (*let ((display-ready-pvar
	   (if normalize?
	       (rescale-pvar!! pvar
			       0
			       max-normalized-brightness-if-normalizing
			       ignore-border
			       0
			       0)
	       (*let* ((rounded-pvar-with-nans-and-borders-removed!!
			 (round!! (pvar-with-borders-and-non-numbers-removed!!
				    pvar 0 0 ignore-border))))
		 (declare (type (field-pvar 8.)
				rounded-pvar-with-nans-and-borders-removed!!))
		 rounded-pvar-with-nans-and-borders-removed!!))))
    (fastio:*read-raster-from-cm-grid display-raster display-ready-pvar :fast fast)
    (spe:show-color window display-raster :expose? expose? :to-x x :to-y y)))

;;; compute and display the edges of an image (either array or pvar)
(*defun *SHOW-EDGES (image &key (sigma 1.5) smoothed-pixel!! ddx!! ddy!! grad-mag!! grad-angle!!
			    (boundary-condition ':reflect) (border-constant 128)
			    (low-threshold cmv::*low-threshold-factor*)
			    (high-threshold cmv::*high-threshold-factor*)
			    (noise-percentage cmv::*noise-percentage*)
			    (x 0) (y 0))		;display offsets
  (*show-pvar (cmv::canny-edges!! sigma image
				  smoothed-pixel!! ddx!! ddy!! grad-mag!! grad-angle!!
				  :boundary-condition boundary-condition :border-constant border-constant
				  :low-threshold low-threshold :high-threshold high-threshold
				  :noise-percentage noise-percentage)
	      :x x :y y))