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

;;; Copyright (c) 1987, Massachusetts Institute of Technology
;;; Authors: Mike Drumheller, Walter E. Gillett

(in-package :mu)

;;#+(OR CM-5.0 CM-5-1)
;;(compiler:make-obsolete *defunc "*DEFUN does the package right, finally.")

(eval-when (compile load eval)
(setf (macro-function '*defunc) (macro-function '*lisp-i::*defunc))
)
;;; indent in the same way as the real *defun
#+lispm
(zwei::defindentation (*defunc 2 1))

;;; use the variable cmv::any-border!!
(defmacro BORDERP!! ()
  `(or!! (=!! (self-address-grid!! (!! 0)) (!! 0))
	 (=!! (self-address-grid!! (!! 0)) (!! (1- (dimension-size 0))))
	 (=!! (self-address-grid!! (!! 1)) (!! 0))
	 (=!! (self-address-grid!! (!! 1)) (!! (1- (dimension-size 1))))))

(defmacro BOOLEAN-TO-BIT!! (pvar!!) `(if!! ,pvar!! (!! 1) (!! 0)))

(proclaim '(inline bits-per-element))
(defun bits-per-element (array) (vu:array-element-size array))

;;;****************************************************************************************
;;; allocation and deallocation

;;; make a temporary copy of a boolean pvar
(defmacro ALLOCATE-TEMP-COPY-OF-BOOLEAN!! (boolean!!)
  `(*lx:allocate-boolean-pvar :initial-value ,boolean!!))

;;; make a temporary copy of a field pvar
(defmacro ALLOCATE-TEMP-COPY-OF-FIELD!! (field!!)
  `(*lx:allocate-field-pvar (pvar-length ,field!!) :initial-value ,field!!))

;;; Like *deallocate, but doesn't complain if the argument is not a pvar or hasn't been
;;; allocated.
(defun *DEALLOCATE-TOLERANT (pvar)
  (if (and (pvarp pvar)
	   (member pvar *lisp-i::*all-allocate!!-pvars*))
      (*deallocate pvar)))

(defun X!! () (self-address-grid!! (!! 0)))
(defun Y!! () (self-address-grid!! (!! 1)))

(defun XSIZE () (dimension-size 0))
(defun YSIZE () (dimension-size 1))

(*defunc CLAMP!! (pvar lower-bound-pvar upper-bound-pvar)
  (cond!! ((<!! pvar lower-bound-pvar)
	   lower-bound-pvar)
	  ((>!! pvar upper-bound-pvar)
	   upper-bound-pvar)
	  (t!! pvar)))

(defmacro CLAMP-X!! (x!!)
  "Clamp x!! so that it is guaranteed to be on the grid."
  `(clamp!! ,x!! (!! 0) (!! (1- (xsize)))))

(defmacro CLAMP-Y!! (y!!)
  "Clamp y!! so that it is guaranteed to be on the grid."
  `(clamp!! ,y!! (!! 0) (!! (1- (ysize)))))

(*defunc NZEROP!! (pvar)
  (not!! (zerop!! pvar)))

(*defunc SQUARE!! (pvar)
  (*!! pvar pvar))

(*defunc *SUM-BOOLEAN (boolean-pvar)
  (*sum (if!! boolean-pvar (!! 1) (!! 0))))

(*defunc PG (pvar) (ppp pvar :mode :grid))

;;; Neighbors are numbered in the following way:
;;;       x->
;;;     5 6 7
;;;  y  4   0
;;;  |  3 2 1
(*defunc NEAREST-NEIGHBOR!! (pvar num &optional (border-pvar (!! 0)))
  (let (x y)
    (case num
      (0 (setq x  1 y  0))
      (1 (setq x  1 y  1))
      (2 (setq x  0 y  1))
      (3 (setq x -1 y  1))
      (4 (setq x -1 y  0))
      (5 (setq x -1 y -1))
      (6 (setq x 0  y -1))
      (7 (setq x  1 y -1)))
    (news-border!! pvar border-pvar x y)))

(*defunc MY-NORTH!! (pvar &optional border-pvar) (news-border!! pvar border-pvar 0 1))
(*defunc MY-SOUTH!! (pvar &optional border-pvar) (news-border!! pvar border-pvar 0 -1))
(*defunc MY-EAST!!  (pvar &optional border-pvar) (news-border!! pvar border-pvar 1 0))
(*defunc MY-WEST!!  (pvar &optional border-pvar) (news-border!! pvar border-pvar -1 0))
(*defunc NORTHEAST!! (pvar &optional border-pvar) (news-border!! pvar border-pvar 1 1))
(*defunc NORTHWEST!! (pvar &optional border-pvar) (news-border!! pvar border-pvar -1 1))
(*defunc SOUTHEAST!! (pvar &optional border-pvar) (news-border!! pvar border-pvar 1 -1))
(*defunc SOUTHWEST!! (pvar &optional border-pvar) (news-border!! pvar border-pvar -1 -1))

(*defunc NUMBER-OF-NEIGHBORS!! (boolean-pvar)
  (*let ((no-of-neighbors (!! 0)))
    (declare (type (field-pvar 4) no-of-neighbors))
    (loop for i from 0 to 7 do
      (*if (nearest-neighbor!! boolean-pvar i nil!!)
	   (*incf no-of-neighbors)))
    no-of-neighbors))

#+*lisp-hardware
(*defunc GET-GRID!!
	 (pvar rel-x rel-y &optional (border-pvar (!! (if (eq (pvar-type pvar) :boolean)
							  nil
							  0))))
  (news-border!! pvar border-pvar rel-x rel-y))

#+*lisp-simulator
(*defunc GET-GRID!! (pvar rel-x rel-y &optional (border-pvar (!! 0)))
   (news-border!! pvar border-pvar rel-x rel-y))

(*defunc VALID-GRID-ADDRESS?!! (x!! y!!)
  (and!! (>=!! x!! (!! 0)) (<!! x!! (!! (xsize)))
	 (>=!! y!! (!! 0)) (<!! y!! (!! (ysize)))))

;;; Like *pset-grid-relative except that messages to invalid addresses are ignored.
(*defunc *PSET-GRID-RELATIVE-CLIPPED (combiner value-pvar dest-pvar rel-x-pvar rel-y-pvar)
  (*when (valid-grid-address?!! (+!! (self-address-grid!! (!! 0)) rel-x-pvar)
				(+!! (self-address-grid!! (!! 1)) rel-y-pvar))
     (*pset combiner value-pvar dest-pvar (cube-from-grid-address!! rel-x-pvar rel-y-pvar))))

(*defunc PREF-GRID-RELATIVE-CLAMPED!! (pvar delta-x!! delta-y!!)
  "Like pref-grid-relative!!, but all off-border references are clamped to within the border."
  (*let ((x!! (clamp-x!! (+!! (x!!) delta-x!!)))
	 (y!! (clamp-y!! (+!! (y!!) delta-y!!))))
     (pref!! pvar (cube-from-grid-address!! x!! y!!))))

#+*lisp-hardware
(*defunc *SLIDE-PVAR
	 (pvar rel-x rel-y &optional (border-pvar (!! (if (eq (pvar-type pvar) :boolean)
								      nil
								      0))))
  "Destructively slides the pvar in the direction (rel-x, rel-y)."
  (*set pvar (get-grid!! pvar (- rel-x) (- rel-y) border-pvar)))

#+*lisp-simulator
(*defunc *SLIDE-PVAR (pvar rel-x rel-y &optional (border-pvar (!! 0)))
  "Destructively slides the pvar in the direction (rel-x, rel-y)."
  (*set pvar (get-grid!! pvar (- rel-x) (- rel-y) border-pvar)))

(defmacro *SLIDE-PVARS (pvars &rest rest)
  `(loop for pvar in ,pvars do (*slide-pvar pvar ,@rest)))
	
#+*lisp-hardware
(*defunc *SLIDE-PVAR-FROM
	(pvar rel-x rel-y &optional (border-pvar (!! (if (eq (pvar-type pvar) :boolean)
							 nil
							 0))))
  "Destructively slides the pvar in the direction ((- rel-x), (- rel-y))."
  (*set pvar (get-grid!! pvar rel-x rel-y border-pvar)))

#+*lisp-simulator
(*defunc *SLIDE-PVAR-FROM (pvar rel-x rel-y &optional (border-pvar (!! 0)))
  "Destructively slides the pvar in the direction ((- rel-x), (- rel-y))."
  (*set pvar (get-grid!! pvar rel-x rel-y border-pvar)))

(defmacro *SLIDE-PVARS-FROM (pvars &rest rest)
  `(loop for pvar in ,pvars do (*slide-pvar-from pvar ,@rest)))

(*defunc CONTEXT-RECTANGLE!! (top-border left-border right-border bottom-border)
  (*let ((rect (!! nil))
	 (xaddr (x!!))
	 (yaddr (y!!)))
    (*when (and!! (>=!! xaddr (!! left-border))
		  (>=!! yaddr (!! top-border))
		  (<!! xaddr (!! (- (xsize) right-border)))
 		  (<!! yaddr (!! (- (ysize) bottom-border))))
      (*set rect (!! t)))
      rect))

(defmacro CONTEXT-SQUARE!! (border)
  `(context-rectangle!! ,border ,border ,border ,border))

(*defunc DRAW-RECTANGLE!! (width height &optional clip-corners &aux
				 (border-x (floor (- (dimension-size 0) width) 2))
				 (far-border-x (- (dimension-size 0) border-x 1))
				 (border-y (floor (- (dimension-size 1) height) 2))
				 (far-border-y (- (dimension-size 1) border-y 1)))
  (*let ((x!! (x!!))
	 (y!! (y!!))
	 (rect!! nil!!))
    (declare (type boolean-pvar rect!!))
    (*set rect!!
	  (and!! (context-rectangle!! border-y border-x border-x border-y)
		 (or!! (=!! x!! (!! border-x)) (=!! x!! (!! far-border-x))
		       (=!! y!! (!! border-y)) (=!! y!! (!! far-border-y)))))
    (cond (clip-corners
	   (*setf (pref rect!! (cube-from-grid-address border-x border-y)) nil)
	   (*setf (pref rect!! (cube-from-grid-address border-x far-border-y)) nil)
	   (*setf (pref rect!! (cube-from-grid-address far-border-x far-border-y)) nil)
	   (*setf (pref rect!! (cube-from-grid-address far-border-x border-y)) nil)))
    rect!!))

(defmacro DRAW-SQUARE!! (width &optional clip-corners)
  `(draw-rectangle!! ,width ,width ,clip-corners))

(*defunc DFDX!! (image)
  (+!! (-!! (get-grid!! image 1 0) image)))

(*defunc DFDY!! (image)
  (+!! (-!! (get-grid!! image 0 1) image)))


(defun ARRAY-ELEMENT-LENGTH (array)
  (let* ((type (array-element-type array))
	 (size (if (listp type)
		   (car (third type))
		   type)))
    (if (numberp size)
	(ceiling (log size 2))
	size)))

;;; *** The following i/o functions are obsolete.  Use the functions in the fastio module
;;;     or the standard TMC block i/o routines.  (WEG 3/2/88) ***
;;; If SIGNED? is T, then the returned pvar will be a signed-pvar, i.e., the 8-bit elements
;;; of the 8-bit-array will be sign-extended.
;#+*lisp-simulator
;(*defunc ARRAY-PVAR!! (array &optional signed? imposed-length (boolean-if-one-bit-long? t))
;  (let ((arr-el-len (array-element-length array)))
;    (if (equal arr-el-len t)
;	(error "Sorry, array elements must be of type integer: ~a" array)
;	(if (not (or (= 1. arr-el-len)
;		     (= 2. arr-el-len)
;		     (= 4. arr-el-len)
;		     (= 8. arr-el-len)
;		     (= 16. arr-el-len)))
;	    (error "Sorry, array elements must be integers of 1, 2, 4, 8 or 16 bits.  Length was instead: ~a"
;		   arr-el-len))
;	(cond (signed?
;	       (*let ((result (!! 0)))
;		 (declare (type (signed-pvar (or imposed-length arr-el-len)) result))
;		 (loop for x from 0 below (dimension-size 0) do
;		   (loop for y from 0 below (dimension-size 1) do
;		     (pset (cl-user::sign-extend
;			     (aref array x y) (1- arr-el-len))
;			   result (cube-from-grid-address x y))))
;		 result))
;	      ((and (= 1 arr-el-len) boolean-if-one-bit-long?)
;	       (*let ((result (!! nil)))
;		 (declare (type boolean-pvar result))
;		 (loop for x from 0 below (dimension-size 0) do
;		   (loop for y from 0 below (dimension-size 1) do
;		     (pset (if (= 1 (aref array x y)) t nil)
;			   result (cube-from-grid-address x y))))
;		 result))
;	      (t
;	       (*let ((result (!! 0)))
;		 (declare (type (field-pvar (or imposed-length arr-el-len)) result))
;		 (loop for x from 0 below (dimension-size 0) do
;		   (loop for y from 0 below (dimension-size 1) do
;		     (pset (aref array x y) result (cube-from-grid-address x y))))
;		 result))))))

;;; If SIGNED? is T, then the returned pvar will be a signed-pvar, i.e., the 8-bit elements
;;; of the 8-bit-array will be sign-extended.
;#+*lisp-hardware
;(*defunc ARRAY-PVAR!! (array &optional signed? imposed-length (boolean-if-one-bit-long? t))
;  (let ((arr-el-len (array-element-length array)))
;    (if (equal arr-el-len t)
;	(error "Sorry, array elements must be of type integer: ~a" array)
;	(if (not (or (= 1. arr-el-len)
;		     (= 2. arr-el-len)
;		     (= 4. arr-el-len)
;		     (= 8. arr-el-len)
;		     (= 16. arr-el-len)))
;	    (error "Sorry, array elements must be integers of 1, 2, 4, 8 or 16 bits.  Length was instead: ~a"
;		   arr-el-len))
;	(cond (signed?
;	       (*let ((result (!! 0)))
;		 (declare (type (field-pvar (or imposed-length arr-el-len)) result))
;		 (cmv::*write-array-grid array result)
;		 (*let ((real-result (!! 0)))
;		   (declare (type (signed-pvar (pvar-length result)) real-result))
;		   (cm:move (pvar-location real-result)
;			    (pvar-location result) (pvar-length result))
;		   real-result)))
;	      ((and (= 1 arr-el-len) boolean-if-one-bit-long?)
;	       (*let ((result (!! nil)))
;		 (declare (type boolean-pvar result))
;		 (cmv::*write-array-grid array result)
;		 result))
;	      (t
;	       (*let ((result (!! 0)))
;		 (declare (type (field-pvar (or imposed-length arr-el-len)) result))
;		 (cmv::*write-array-grid array result)
;		 result))))))

;#+*lisp-hardware
;(*defunc *ARRAY-INTO-PVAR (array pvar)
;  (let ((arr-el-len (array-element-length array)))
;    (cond ((equal arr-el-len t)
;	   (error "Sorry, array elements must be of type integer: ~a" array))
;	  ((not (or (equal 1. arr-el-len)
;		    (equal 2. arr-el-len)
;		    (equal 4. arr-el-len)
;		    (equal 8. arr-el-len)
;		    (equal 16. arr-el-len)))
;	   (error "Sorry, array elements must be integers of 1, 2, 4, 8 or 16 bits.  Length was instead: ~a"
;		  arr-el-len))
;	  ((not (= arr-el-len (pvar-length pvar)))
;	   (error "Sorry, array-element-length (~a) must be same length as pvar-length (~a)." arr-el-len (pvar-length pvar)))
;	  (t
;	   (cmv::*write-array-grid array pvar)
;;	   (cm:write-array-by-news-addresses
;;	   array 0 0 0 0
;	   ;						(min (dimension-size 0) (array-dimension array 0))
;	   ;						(min (dimension-size 1) (array-dimension array 1))
;	   ;						(pvar-location pvar) arr-el-len)
;	   ))))

(defun PPP-GRID (pvar &optional 
		      (x 0)
		      (y 0)
		      (w (dimension-size 0))
		      (h (dimension-size 1))
		      (forced-width 3)
		      (sample-rate 1)
		      &aux 
		      (xdim (dimension-size 0))
		      (ydim (dimension-size 1)))
  (if (not (= 1 sample-rate))
      (format t "~%Printing ~a with a sub-sampling rate of ~a..." pvar sample-rate))
  (let ((finish-i (+ w x))
	(finish-j (+ h y)))
    (loop for j from y below (min ydim finish-j) by sample-rate do
      (format t "~%")
      (loop for i from x below (min xdim finish-i) by sample-rate do
	(format t "~va " forced-width (pref-grid pvar i j))))))

(defun PG-MESSAGE (pvar &optional (message "~%")
		      (x 0)
		      (y 0)
		      (w (dimension-size 0))
		      (h (dimension-size 1))
		      (forced-width 3)
		      (sample-rate 1))
  (format t message)
  (ppp-grid pvar x y w h forced-width sample-rate))

(*defunc THRESHOLD!! (pvar number)
  (>=!! pvar (!! number)))

;;; Returns a pvar that is T for each of the top N ranked elements of VALUE!!.
;;; For example, if you wanted to know the top 10 brightest pixels in an image, you would
;;; do:  (n-highest!! <image> 10)
;;;
;;;  Note that if some large number are tied for first place, it gives you a random
;;;  sampling of them, i.e. the first N in the sort.
(*defunc N-HIGHEST!! (value!! n)
  (*let ((rank!! (rank!! value!! '<=!!)))
    (declare (type (field-pvar *log-number-of-processors-limit*) rank!!))
    (>=!! rank!! (!! (- (*sum (if t!! (!! 1) (!! 0))) n)))))
	
;;; Returns a pvar that is 1 (or T) for each of the top PERCENT ranked elements of pvar.
;;; For example, if you wanted to know the top 1/5 brightest pixels in an image, you would
;;; do:  (top-percentile!! <image> 20)
(*defunc TOP-PERCENTILE!! (pvar percent &optional (boolean-or-number :number))
  (if (not (and (>= percent 0) (<= percent 100.)))
      (error "Percent must be a number between 0 and 100 (inclusive)")
      (*let ((rank!! (rank!! pvar '<=!!))
	     (number!! (!! (floor (* (/ (- 100. percent) 100.0)
				   (*sum (if!! t!! (!! 1) (!! 0))))))))
	(declare (type (field-pvar *log-number-of-processors-limit*)
		        rank!! number!!))
	(cond ((equal boolean-or-number :boolean)
	       (*let ((result (>=!! rank!! number!!)))
		 (declare (type boolean-pvar result))
		 result))
	      ((equal boolean-or-number :number)
	       (*let ((result (if!! (>=!! rank!! number!!) (!! 1) (!! 0))))
		 (declare (type field-pvar result))
		 result))
	      (t
	       (error "Unknown type ~a" boolean-or-number))))))

(*defunc TOP-PERCENTILE-IGNORING-A-VALUE!! (pvar percent value-to-ignore)
  (if!! (=!! pvar (!! value-to-ignore))
	(!! nil)
	(top-percentile!! pvar percent :boolean)))

#+*lisp-simulator
;(*defunc *LOAD-PVAR-INTO-2D-ARRAY
;	(pvar &optional (array (make-array (list (dimension-size 0) (dimension-size 1)))))
;  (cl-user::clear-array array)
;  (loop for y from 0 below (dimension-size 1) do
;    (loop for x from 0 below (dimension-size 0) do
;      (setf (aref array x y) (pref-grid pvar x y)))))

(defun ARRAY-TYPE-FOR-PVAR (pvar)
  (let ((type (pvar-type pvar)))
    (if (equal :boolean type)
	'(mod 1.)
	(if (not (or (equal :signed type)
		     (equal :field type)))
	    t
	    (let ((length (pvar-length pvar)))
	      (case length
		(1. '(mod 1.))
		(2. '(mod 4.))
		(4. '(mod 16.))
		(8. '(mod 256.))
		(16. '(mod 65536.))
		(otherwise
		  (error "Oops.  I can answer this question only if the length of the pvar (~a) is 1, 2, 4, 8 or 16"))))))))

#+*lisp-hardware 
;(*defunc *LOAD-PVAR-INTO-2D-ARRAY (pvar &optional array)
;  (if (not (and (= (array-dimension array 0) (dimension-size 0))
;		(= (array-dimension array 1) (dimension-size 1))))
;      (error "The 2-D array is not the same size as the CM grid: ~a, cmx = ~a, cmy = ~a"
;	     array (dimension-size 0) (dimension-size 1)))
;  (let ((array-type (array-type-for-pvar pvar)))
;    (or array (setq array (make-array (list (dimension-size 0) (dimension-size 1)) :element-type array-type)))
;    (if (listp array-type)
;	(cmv::*read-array-grid array pvar)
;	(loop for y from 0 below (dimension-size 1) do
;	  (loop for x from 0 below (dimension-size 0) do
;	    (setf (aref array x y) (pref-grid pvar x y)))))))
	

;;; Jim Little's function cmv::*sum-nbhd is defined in b:>vision>cm>cmv>scansum.  It uses grid
;;; scans whereas Mike's function unsigned-square-sum!! uses NEWS.  For 23x23 neighborhoods,
;;; Jim's function is about 3 times faster, but uses more stack space.

;;; Returns the number of bits required to hold the sum of a square neighborhood of field!!.
(defmacro SUM-FIELD-NBHD-LENGTH (field!! width)
  `(+ (pvar-length ,field!!) (integer-length (square ,width))))

;;; add up a square neighborhood of a field pvar
(*defunc SUM-FIELD-NBHD!! (field!! width)
  (declare (*defun unsigned-square-sum-1d!! unsigned-square-sum!!))
  (*let ((sum!! (!! 0)))
    ;; We are adding up width^2 elements of support-plane, where width = xdim is the
    ;; width of the square neighborhood to sum.
    (declare (type (field-pvar (sum-field-nbhd-length field!! width))
		   sum!!))
    (cond (*fast-square-sum?*
	   (cmv::*sum-nbhd field!! sum!! (floor width 2)))
	  (*use-1d-neighborhoods?*
	   (*set sum!! (unsigned-square-sum-1d!! field!! width)))
	  (t (*set sum!! (unsigned-square-sum!! field!! width))))
    sum!!))

(*defunc UNSIGNED-SQUARE-SUM-1D!! (pvar diameter)
  "This is just like UNSIGNED-SQUARE-SUM!! in mike-starlisp7, but is constrained to X"
  (assert (oddp diameter))
  (let* ((half-diam (floor (/ (1- diameter) 2))))
    (*let* ((copy pvar)
	    (x-accumulator-pvar copy)
	    ;;(temp (!! 0))
	    )
      (declare (type (field-pvar (pvar-length pvar)) copy)
	       (type (field-pvar (+ 1 (floor (+ (log diameter 2) (pvar-length pvar)))))
		     x-accumulator-pvar ;; temp
		     ))
      (do ((x (- half-diam) (1+ x)))
	  ((> x -1))
	(*set copy (news-border!! copy (!! 0) -1 0))
	(*incf x-accumulator-pvar copy))
      (*set copy pvar)
      (do ((x 1 (1+ x)))
	  ((> x half-diam))
	(*set copy (news-border!! copy (!! 0) 1 0))
	(*incf x-accumulator-pvar copy))
      x-accumulator-pvar)))

;;;******************************************************************************************
;;; Some obscure stuff...

(*defunc AVERAGE-PVAR (pvar)
  (/ (float (*sum pvar)) (*sum (!! 1))))

(*defunc AVERAGE (image)
  (cond ((pvarp image)
	 (average-pvar image))
	((arrayp image)
	 (average-pvar (cmv::write-raster-to-cm-grid!! image)))
	(t (format t "~%Error: argument ~S to image-average!! is neither an array nor a pvar." image))))

(*defunc AVERAGE-PVAR!! (pvar width &key (result-type :integer))
  "Return a patchwise average of pvar, where the average is taken over a <width> by <width>
square neighborhood centered at each point.  The width must be odd.   By default, the
result-type is :integer since floating point is expensive."
  (assert (oddp width) (width))
  (with-temp-pvars
    (cond ((eq (pvar-type pvar) :field)
	   (let ((sum!! (*lx::allocate-field-pvar (sum-field-nbhd-length pvar width)
						  :initial-value (sum-field-nbhd!! pvar width))))
	     (if (eq result-type :integer)
		 (floor!! sum!! (!! (square width)))
		 (/!! sum!! (!! (square width))))))
	  (t (*let ((sum!! (sum-field-nbhd!! pvar width)))
	       (if (eq result-type :integer)
		   (floor!! sum!!  (!! (square width)))
		   (/!! sum!! (!! (square width)))))))))

(*defunc AVERAGE!! (image width &key (result-type :integer))
  "Return a patchwise average of the image, where the average is taken over a <width> by
<width> square neighborhood centered at each point.  The width must be odd.   By default, the
result-type is :integer since floating point is expensive."
  (cond ((pvarp image)
	 (average-pvar!! image width :result-type result-type))
	((arrayp image)
	 (average-pvar!! (cmv::write-raster-to-cm-grid!! image) width :result-type result-type))
	(t (format t "~%Error: argument ~S to image-average!! is neither an array nor a pvar." image))))

(defmacro REPETITIVE-TEST (form &optional verbose? (print-every 100))
  `(let (last next)
     (setq last ,form)
     (loop for i from 0 
	   until (check-keyboard-quit) do
       (setq next ,form)
       (if (not (equal next last))
	   (fsignal "Losing at i = ~a.  Next (~a) not equal to Last (~a)"
		   i next last)
	   (if ,verbose?
	       (format t "~%OK, i = ~a (next: ~a = last: ~a)" i next last)
	       (if (zerop (mod i ,print-every))
		   (format t " ~a " i)
		   (format t "."))))
       (setq last next))))
    
(defun OVERLAP-CHECK (dest source dlen slen scratch scratchlen)
  (cond ((and (<= scratch source) (<= (+ source slen) (+ scratch scratchlen)))
	 (error "Scratch overlaps source"))
	((and (<= scratch dest) (<= (+ dest dlen) (+ scratch scratchlen)))
	 (error "Scratch overlaps dest"))))

(*defunc STRICT-LOCAL-MAXIMA!! (pvar &optional (8-neighbors? t))
  (if 8-neighbors?
      (if!! (and!! (>!! pvar (news-border!! pvar (!! 0) 1 0))
		   (>!! pvar (news-border!! pvar (!! 0) 0 1))
		   (>!! pvar (news-border!! pvar (!! 0) -1 0))
		   (>!! pvar (news-border!! pvar (!! 0) 0 -1))
		   (>!! pvar (news-border!! pvar (!! 0) 1 1))
		   (>!! pvar (news-border!! pvar (!! 0) -1 1))
		   (>!! pvar (news-border!! pvar (!! 0) -1 -1))
		   (>!! pvar (news-border!! pvar (!! 0) 1 -1)))
	    t!!
	    nil!!)
      (if!! (and!! (>!! pvar (news-border!! pvar (!! 0) 1 0))
		   (>!! pvar (news-border!! pvar (!! 0) 0 1))
		   (>!! pvar (news-border!! pvar (!! 0) -1 0))
		   (>!! pvar (news-border!! pvar (!! 0) 0 -1)))
	    t!!
	    nil!!)))

(*defunc LOCAL-MAXIMA!! (pvar &optional (8-neighbors? t))
  (if 8-neighbors?
      (if!! (and!! (>=!! pvar (news-border!! pvar (!! 0) 1 0))
		   (>=!! pvar (news-border!! pvar (!! 0) 0 1))
		   (>=!! pvar (news-border!! pvar (!! 0) -1 0))
		   (>=!! pvar (news-border!! pvar (!! 0) 0 -1))
		   (>=!! pvar (news-border!! pvar (!! 0) 1 1))
		   (>=!! pvar (news-border!! pvar (!! 0) -1 1))
		   (>=!! pvar (news-border!! pvar (!! 0) -1 -1))
		   (>=!! pvar (news-border!! pvar (!! 0) 1 -1)))
	    t!!
	    nil!!)
      (if!! (and!! (>=!! pvar (news-border!! pvar (!! 0) 1 0))
		   (>=!! pvar (news-border!! pvar (!! 0) 0 1))
		   (>=!! pvar (news-border!! pvar (!! 0) -1 0))
		   (>=!! pvar (news-border!! pvar (!! 0) 0 -1)))
	    t!!
	    nil!!)))

(*defunc STRICT-LOCAL-MAXIMA-OVER-AREA!! (pvar diameter)
  (let ((w2 (floor diameter 2)))
    (*let ((max (!! (*min pvar))))
      ;; Top line
      (loop for rel-x from (- w2) to w2 do
	(*set max (max!! max (news-border!! pvar (!! 0) rel-x (- w2)))))
      ;; Bottom line
      (loop for rel-x from (- w2) to w2 do
	(*set max (max!! max (news-border!! pvar (!! 0) rel-x w2))))
      ;; Left side
      (loop for rel-y from (- (1- w2)) to (1- w2) do
	(*set max (max!! max (news-border!! pvar (!! 0) (- w2) rel-y))))
      ;; Right side
      (loop for rel-y from (- (1- w2)) to (1- w2) do
	(*set max (max!! max (news-border!! pvar (!! 0) rel-y w2))))
      (if!! (>!! pvar max)
	    t!!
	    nil!!))))
  
(*defunc RECTANGULAR-BORDER-BOOLEAN!! (border-width)
  (or!! (<!! (x!!) (!! border-width))
	(<!! (y!!) (!! border-width))
	(>=!! (x!!) (!! (- (dimension-size 0) border-width)))
	(>=!! (y!!) (!! (- (dimension-size 1) border-width)))))

(*defunc SQUARE-OF-GRADIENT-MAGNITUDE!! (image)
  (*let ((x-grad (-!! (get-grid!! image 1 0) image))
	 (y-grad (-!! (get-grid!! image 0 1) image)))
    (+!! (*!! x-grad x-grad) (*!! y-grad y-grad))))

;;; Transpose the pvar: all processors (x y) such that start-x  x < end-x and
;;; start-y  y < end-y send their value to (y x).  (WEG - 10/6/87)
(*defunc *TRANSPOSE (pvar &optional (transposed-pvar pvar)
			  &key (start-x 0) (start-y 0)
			  (end-x (dimension-size 0)) (end-y (dimension-size 1)))
  ;; make sure that transposed pvar will fit within CM
  (setq end-x (min end-x (dimension-size 1)))
  (setq end-y (min end-y (dimension-size 0)))
  ;; transpose the pvar
  (*when (and!! (>=!! (self-address-grid!! (!! 0)) (!! start-x))
		(<!! (self-address-grid!! (!! 0)) (!! end-x))
		(>=!! (self-address-grid!! (!! 1)) (!! start-y))
		(<!! (self-address-grid!! (!! 1)) (!! end-y)))
    (*pset :default pvar transposed-pvar
	   (cube-from-grid-address!! (self-address-grid!! (!! 1)) (self-address-grid!! (!! 0)))
	   :collision-mode :no-collisions)))

;;; Same as *transpose-pvar except that it creates and returns a result pvar.
(*defunc TRANSPOSE!! (pvar &key (start-x 0) (start-y 0)
			  (end-x (dimension-size 0)) (end-y (dimension-size 1)))
  (*let ((transposed-pvar (!! 0)))
    (*transpose pvar transposed-pvar :start-x start-x
		:start-y start-y :end-x end-x :end-y end-y)
    transposed-pvar))

;;; From Todd Cass: count how many processors hold the value t.
(*defunc *COUNT (pvar!!)
  (*sum (if!! pvar!! (!! 1) (!! 0))))

;;; Fill pvar2!! with a shifted version of pvar1!!, where pvar1!! is shifted so that
;;; its MSB is in the right position to be the MSB of pvar2!!.
(*defunc *RESIZE (pvar1!! pvar2!!)
  (*set pvar2!! (ash!! pvar1!! (!! (- (pvar-length pvar2!!)
				      (pvar-length pvar1!!))))))

;;; like lognot!! except that it returns a field pvar instead of a signed pvar
#+*lisp-hardware
(*defunc LOGNOT-FIELD!! (field!!)
  (*let ((not-field!!))
    (declare (type (field-pvar (pvar-length field!!)) not-field!!))
    (progn
      (CM:lognot-2-1L
       (pvar-location not-field!!) (pvar-location field!!) (pvar-length not-field!!)))
    not-field!!))

;;;*****************************************************************************
;;; check the state of the CM

(defun SQUARE-CM-GRID? () (= (dimension-size 0) (dimension-size 1)))

(defun BOOT-256 ()
  (format t "~%Cold-booting to 256x256 grid...")
  (*cold-boot :initial-dimensions '(256 256)))

(defun REQUIRE-256X256-CM-GRID ()
  (if (not (*lx::*lisp-runnable-p))
      (format t "~%The CM is not attached or has not been *cold-booted."))
  (if (not (and (= 256. (dimension-size 0))
		(= 256. (dimension-size 1))))
      (error
	"The CM grid must have dimensions 256x256 (currently ~ax~a).  Fix by doing (*cold-boot :initial-dimensions (256. 256.))."
	(dimension-size 0) (dimension-size 1))))

;;;*****************************************************************************