;;;---	HSIGGR >  -*- Mode:LISP; Package:USER; Base:10.; readtable: CL -*-

; Signal Processing and Graphical Display functions.


; DISPLAY TEST FUNCTIONS:

(defun size-test (fcn samples &aux temp (maximum -1.0s16) (minimum 1.0s16))
  (do ((x 0 (1+ x)))
      ((>= x samples))
    (do ((y 0. (1+ y)))
	((>= y samples))
      (setq temp (funcall fcn x y samples)
	    maximum (max maximum temp)
	    minimum (min minimum temp))))
  (terpri) (princ-rest "Function:  " fcn)
  (terpri) (princ-rest "Minimum:   " minimum)
  (terpri) (princ-rest "Maximum:   " maximum)
  t)

(defun dgf1 (x y samples &aux middle)
  (cond ((or (< x 0.) (< y 0.) (>= x samples) (>= y samples))
	 (cerror t nil nil "DGF1 wrong args.")))
  (setq middle (floor samples 2.)
	x (- (/ (* x ONEPI 4.0s0 *CYCLES*) samples) (* TWOPI *CYCLES*))
	y (- (/ (* y ONEPI 4.0s0 *CYCLES*) samples) (* TWOPI *CYCLES*)))
  (* (cond ((zerop x) 1.0s0)
	   (t (/ (sine x) x)))
     (cond ((zerop y) 1.0s0)
	   (t (/ (sine y) y)))))

(defun dgf2 (x y samples &aux middle)
  (cond ((or (< x 0.) (< y 0.) (>= x samples) (>= y samples))
	 (cerror t nil nil "DGF2 wrong args.")))
  (setq middle (floor samples 2.)
	x (- (/ (* x ONEPI 4.0s0 *CYCLES*) samples) (* TWOPI *CYCLES*))
	y (- (/ (* y ONEPI 4.0s0 *CYCLES*) samples) (* TWOPI *CYCLES*)))
  (* (cond ((zerop x) 1.0s0)
	   ((> x 0.0s0) (/ (sine x) x))
	   (t (- (/ (sine x) x))))
     (cond ((zerop y) 1.0s0)
	   ((> y 0.0s0) (/ (sine y) y))
	   (t (- (/ (sine y) y))))))

(defun dgf3 (x y samples)
  (cond ((or (< x 0.) (< y 0.) (>= x samples) (>= y samples))
	 (cerror t nil nil "DGF3 wrong args.")))
  (setq x (- x (floor samples 2.))
	y (- y (floor samples 2.)))
  (+ (cond ((> (abs x) 10.) 0.0s0)
	   (t (- 10.0s0 (abs x))))
     (cond ((> (abs y) 10.) 0.0s0)
	   (t (- 10.0s0 (abs y))))))

(defun dgf4 (x y samples)
  (cond ((or (< x 0.) (< y 0.) (>= x samples) (>= y samples))
	 (cerror t nil nil "DGF4 wrong args.")))
  (setq x (- x (floor samples 2.))
	y (- y (floor samples 2.)))
  (+ (* (cond ((>= y 0.) 2.0s0)
	      (t 0.5s0))
	(cond ((> (abs x) 10.) 0.0s0)
	      (t (- 10.0s0 (abs x)))))
     (* (cond ((>= x 0.) 1.0s0)
	      (t 0.25s0))
	(cond ((> (abs y) 10.) 0.0s0)
	      (t (- 10.0s0 (abs y)))))))

(setq dgf1 (list #'DGF1 "f(x,y) = [(SIN X)/X]*[(SIN Y)/Y]" -0.21713s0 1.0s0)
      dgf2 (list #'DGF2 "f(x,y) = [(SIN X)/X]*[(SIN Y)/Y], with cliffs." -1.0s0 1.0s0)
      dgf3 (list #'DGF3 "Rooftops." 0.0s0 20.0s0)
      dgf4 (list #'DGF4 "Rooftops of varying heights." 0.0s0 20.0s0))


; CONVOLUTION:

(defun convolve (x y samples)
  (do ((sum 0.0s0)
       (weight *CONVOLVE-PATTERN*)
       (i -1. (1+ i)))
      ((> i 1.) sum)
    (do ((j -1. (1+ j))
	 (jx) (jy))
	((> j 1.))
      (setq jx (+ i x) jy (+ j y))
      (and (>= jx 0.) (< jx samples)
	   (>= jy 0.) (< jy samples)
	   (setq sum (+ sum (* (car weight) (aref *CONVOLVE-ARRAY* jx jy)))))
      (setq weight (cdr weight)))))


(defun ctest ( &optional (*CONVOLVE-ARRAY* *CONVOLVE-ARRAY*)
	      (*CONVOLVE-PATTERN* *CONVOLVE-PATTERN*)
	      (zmin -1.0s0) (zmax 1.0s0) (scale 1.0s0))
  (dgf (list #'CONVOLVE "Convolution" zmin zmax) scale
       (car (array-dimensions *CONVOLVE-ARRAY*))))


; INFORMATION DISPLAY

; In graphing functions, ZMIN > ZMAX inverts Z-axis and negative SCALE rotates
; display 180 degrees about Z-axis.

(defun dgf (graph-fcn &optional (scale 1.0s0) (samples 80.) (label (second graph-fcn)))
  (display-graph (first graph-fcn) (third graph-fcn) (fourth graph-fcn) scale samples label))


(defun display-graph (graph zmin zmax scale samples label &aux xincrement yincrement
		      z0 zscale zcenter min-dimension center)
  (setq min-dimension (min *MAX-SCREEN-X* *MAX-SCREEN-Y*)
	center (floor min-dimension 2.)
	scale (small-float scale)
	zmin (small-float zmin)
	zmax (small-float zmax)
	yincrement (floor (* (abs scale) 215.0s0) samples)
	xincrement (floor (* (abs scale) 372.4s0) samples))
  (when (= zmax zmin)
    (setq zmax (1+ zmin)))
  (setq zscale (/ 215.0s0 (- zmax zmin))
	zcenter (/ (+ zmin zmax) 2.0s0)
	z0 (* (- zcenter) zscale))
  (clear)
  (cursorpoint 0. min-dimension)
  (unless (null label) (princ label))
  (princ-rest "  Z-: " zmin "  Z+: " zmax " ")
  (tv:prepare-sheet (*TERMINAL-IO*)
    (sq center center TV:ALU-IOR center)
    (sq center center TV:ALU-IOR (1- center)))
  (do ((i 0. (1+ i)))
      ((>= i *MAX-SCREEN-X*))
    (aset *MAX-SCREEN-Y* *TOP-LINE-ARRAY* i))
  (do ((ylimit (- (* samples 2.) 2.))
       (ycount 1. (1+ ycount))
       (flag) (x) (y) (z) (xlimit)
       (xpt) (ypt) (xpt0) (ypt0))
      ((>= ycount ylimit) (princ-rest " Cmd: " -) t)
    (setq xlimit (min ycount (- ylimit ycount 1.)))
    (do ((xcount (- xlimit) (1+ xcount))
	 (mark? (< ycount samples) nil)
	 (array-x) (array-y) (old-xpt) (old-ypt))
	((> xcount xlimit))
      (and (< ycount samples) (= xcount xlimit) (setq mark? t))
      (and (= ycount 1.) (= xcount 0.) (setq mark? t))
      (setq flag (oddp (+ xcount ycount))
	    x (* xincrement (- xcount 0.5s0))
	    y (* yincrement (- (cond (flag (1+ ycount))
				     (t (+ ycount 2.)))
			       samples)))
      (multiple-value (array-x array-y)
	(get-adjusted-index xcount ycount samples flag scale))
      (cond ((numberp (setq z (cond ((arrayp graph) (aref graph array-x array-y))
				    (t (funcall graph array-x array-y samples)))))
	     (setq z (* (- z zcenter) zscale)
		   xpt (max 3. (min *MAX-SCREEN-X* (+ center (round x))))
		   ypt (max 3. (min *MAX-SCREEN-X* (- center (round (+ z y))))))
	     (when mark?
	       (setq xpt0 (+ center (round x))
		     ypt0 (- center (round (+ z0 y)))))
	     (tv:prepare-sheet (*TERMINAL-IO*)
	       (when (numberp old-xpt)
		 (top-line old-xpt old-ypt xpt ypt))
	       (when (and mark?
			  (> xpt0 2.)
			  (> ypt0 2.)
			  (< xpt0 *MAX-SCREEN-X*)
			  (< ypt0 *MAX-SCREEN-Y*))
		 (baseline (- xpt 1.) ypt (- xpt0 1.) ypt0 TV:ALU-IOR)
		 (sq (- xpt0 1.) ypt0 TV:ALU-IOR 1.)
		 (sq (- xpt 1.) ypt TV:ALU-IOR 1.)))
	     (setq old-xpt xpt old-ypt ypt)))))
  (values))


(defun get-adjusted-index (x y samples flag scale &aux xaux yaux (subtrahend (1- samples)))
  (when flag (setq y (1- y)))
  (setq xaux (- subtrahend (floor (- y x) 2.))
	yaux (floor (+ x y) 2.))
  (when (< scale 0.0s0)
    (setq xaux (- subtrahend xaux) yaux (- subtrahend yaux)))
  (values xaux yaux))


(defun top-line (ox oy nx ny &aux flag flag2 oox ooy lgx lgy
		 (xsum 2048.) (ysum 2048.) xstep numsteps xinc yinc)
  (cond ((< oy ny) (swap ox nx) (swap oy ny) (setq flag t)))
  (let ((dx (- nx ox)) (dy (- ny oy)))
    (setq xstep (cond ((< dx 0.) -1.) (t 1.))
	  numsteps (max (setq dx (abs dx)) (setq dy (abs dy))))
    (unless (zerop numsteps)
      (setq xinc (floor (* 4096. dx) numsteps)
	    yinc (floor (* 4096. dy) numsteps)))
    (do ( )
	(( ))
      (cond ((<= oy (aref *TOP-LINE-ARRAY* ox))
	     (setq flag2 t lgx ox lgy oy)
	     (when (null oox) (setq oox ox ooy oy))
	     (aset (cond ((eq flag 't) *MAX-SCREEN-Y*)
			 (t oy))
		   *TOP-LINE-ARRAY* ox))
	    (t (unless (null oox)
		 (baseline oox ooy lgx lgy TV:ALU-IOR))
	       (setq flag2 nil oox nil ooy nil)))
      (when (eq flag 't) (setq flag 'OFF))
      (cond ((< (setq numsteps (1- numsteps)) 0.)
	     (and flag2 (null flag) (aset *MAX-SCREEN-Y* *TOP-LINE-ARRAY* ox))
	     (when (numberp oox)
	       (baseline oox ooy lgx lgy TV:ALU-IOR))
	     (return nil)))
      (when (>= (setq xsum (+ xsum xinc)) 4096.)
	(setq ox (+ ox xstep) xsum (- xsum 4096.)))
      (when (>= (setq ysum (+ ysum yinc)) 4096.)
	(setq oy (1- oy) ysum (- ysum 4096.))))))


;;; End.