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

(in-package :mu)

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

;;;*****************************************************************************
;;; CHANGE HISTORY
;;;
;;; 10/12/87  WEG  Changed the package to mu.  Recompiled for Release 7.
;;;                Merged Mike's new image utilities, formerly in image-util,
;;;                into this file.
;;;  3/ 3/92  PAO  Ported to Lucid.
;;;*****************************************************************************

;;; constants ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; dimensions of an image captured by the frame grabber
;;; These are defined in CMV, use them.
;(defvar *FRAME-WIDTH* 576)
;(defvar *FRAME-HEIGHT* 454)

;;; variables ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; This is a little bogus...
(defvar *MIKE-DISPLAY-PANE* *standard-output*)	;for image display (WEG)

#+symbolics
(compiler:make-obsolete *mike-display-pane* "Figure out something else" defvar)

;;; macros ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; Isn't there something in VU that does this?
(defmacro MAKE-SIMILAR-ARRAY (array)
  `(make-array (array-dimensions ,array) :element-type (array-element-type ,array)))

(defun PAUSE (&optional (string "Hit space to go on:"))
  (clear-input *query-io*)			;get rid of prior user input
  #+symbolics
  (scl:prompt-and-read :character string)
  #-symbolics
  (progn
    (fresh-line *query-io*)
    (write-string string *query-io*)
    (read-char *query-io*)
    (clear-input *query-io*)))

(defmacro XDIM (array)
  `(array-dimension ,array 1))

(defmacro YDIM (array)
  `(array-dimension ,array 0))

;;; functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; This is my so-called "VSETQ SOFTWARE".  It is useful for times when you are
;;; hand-modifying data structures--usually images-- and you're doing a lot of setq-ing
;;; (making up names as you go along).  If you're involoved in a long session of such work,
;;; for example, when you're experimenting different operators on images, then it's very
;;; easy to lose track of what you've setq-ed.  
;;;
;;; This software solves the problem in the following way:  If you use VSETQ, then whatever
;;; name you just created (should be something mnemonic to you) gets pushed onto the "vsetq
;;; list" of variable names (*vsetq-list*).  (Note that *vsetq-list* contains the symbols,
;;; not the objects themselves.)  Then when you call the function V (no args), a little
;;; window pops up with everything that you've VSETQed.  Then you just click left on the name
;;; that you want, and whatever it is bound to gets returned.
;;;
;;; Example session: (at a Lisp Listener)
;;; (vsetq bla (g-convolve <some-image> 4. 128.))
;;; (g-convolve (v) 8. 128.) ; as soon as you type <close-parentheses> here, a window
;;; pops ups up, and you click on "bla".

(defvar *VSETQ-LIST* nil)  ; List of things that you have VSETQed.

;;; Main function.
(defmacro VSETQ (&rest symbols-and-values)  
  (do ((s&v symbols-and-values (cddr s&v)))
      ((null s&v))
    (set (car s&v) (eval (cadr s&v)))
    (if (not (member (car s&v) *vsetq-list*))
	(push (car s&v) *vsetq-list*))))

#|| ;; this looks useful, but I'm not going to convert it to clx or clim right now.
;; -- PAO 3/03/92 13:36:41

;;; Pop-up menu of items in *vsetq-list*.
(defun V ()
  (symbol-value (tv:menu-choose *vsetq-list*)))

;;; Same as (v), but returns the symbol instead of the value in the value-cell of the symbol.
;;; It is very useful when you have a funciton that requires quoted args.  It's pretty easy
;;; to write other things, like VSAVE below, that do something besides just return the things
;;; you click on.
(defun VSYM ()
  (tv:menu-choose *vsetq-list*))

;;; Removes the items from *vsetq-list*.
(defun VREM ()
  (let ((list-to-remove nil)
	(name nil))
    (catch 'quit 
      (loop do
	    (setq name (tv:menu-choose *vsetq-list*))
	    (if (not name)
		(throw 'quit (dolist (name list-to-remove)
			       (delete name *vsetq-list*)))
		(push name list-to-remove))))))

;;;  Loads object (that was saved using SAVE-OB) and puts its name in the *vsetq-list*.
(defun VLOAD-OB (quoted-ob-name &optional (dir "b:>mike>data>"))
  (let ((file-name (string-append dir (string-downcase (string quoted-ob-name)) ".bin")))
    (push quoted-ob-name *vsetq-list*)
    (load file-name)))

(defvar *LOAD-LIST* nil)

||#

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Math stuff.

;;; may already be defined by cmv:cmv;cmgrok
(defun MIKE-UTILS-SQUARE (x) (* x x))

(unless (fboundp 'square)
  (setf (symbol-function 'square) #'mike-utils-square))

(defun AVERAGE-OF-RAD-ANGLES (&rest rad-angles
			      &aux (x-comps 0.0) (y-comps 0.0) (n 0)
			      len)
  (dolist (rad-angle rad-angles)
    (incf n)
    (incf x-comps (cos rad-angle))
    (incf y-comps (sin rad-angle)))
  (setq x-comps (/ x-comps n) y-comps (/ y-comps n)
	len (sqrt (+ (* x-comps x-comps) (* y-comps y-comps)))
	x-comps (/ x-comps len))
  (if (and (zerop x-comps) (zerop y-comps))
      (error "You left the stove on at home.  Better go check it.")
      (if (minusp y-comps)
	  (- 6.2831855 (acos x-comps))  ; 2pi = 6.2831855
	  (acos x-comps))))

(defun ON-RANGE-P (number lower-bound upper-bound
		   &optional (lower-inclusive? t) (upper-inclusive? t))
  (if (and lower-inclusive? upper-inclusive?)
      (and (>= number lower-bound) (<= number upper-bound))
      (if (and (not lower-inclusive?) upper-inclusive?)
	  (and (> number lower-bound) (<= number upper-bound))
	  (if (and lower-inclusive? (not upper-inclusive?))
	      (and (>= number lower-bound) (< number upper-bound))
	      (if (and (not lower-inclusive?) (not upper-inclusive?))
		  (and (> number lower-bound) (< number upper-bound)))))))

;;; Returns a random number on the range [lower-inclusive, upper-inclusive].
(defun RANDOM-ON-RANGE (lower-inclusive upper-inclusive
			&aux (ran (random (1+ (- upper-inclusive lower-inclusive)))))
  (+ lower-inclusive ran))

;;; Returns a random number on the range [(- from-pos-to-neg-num), from-pos-to-neg-num].
;;; I sure hope that successive returns from the random number generator are
;;; sufficiently independent.  -- PAO 88DEC29
(defun RANDOM-POS-OR-NEG (from-pos-to-neg-num
			  &aux (r (random (1+ from-pos-to-neg-num)))
			  (pos (random 2)))
  (if (zerop pos)
      (- r)
      r))

;;; Recursive?  -- PAO 6/04/92 15:24:37
(defun FACT (n)
  (if (or (= n 1) (= n 0))
      1
      (* n (fact (1- n)))))

;;; a.k.a PERMUTE
(defun CHOOSE-WHEN-ORDER-MATTERS (n k)
  (round (fact n)
	 (* (fact (- n k)))))

(defun CHOOSE (n k)
  (round (fact n)
	 (* (fact k) (fact (- n k)))))

(defun ORDER-OF-MAGNITUDE (n)
  (setq n (abs n))
  (if (>= n 1)
      (loop for i from 0
	    when (< (/ n (expt 10 i)) 10)
	      return (expt 10 i))
      (if (and (>= n 0) (< n 1))
	  (loop for i from 1
		when (>= (* n (expt 10 i)) 1)
		  return (/ 1.0 (expt 10 i))))))

(defun SIGN-EXTEND (x sign-bit) ; Ripped off from karl
  (if (= 1 (ldb (byte 1 sign-bit) x))
      (- x (expt 2 (1+ sign-bit)))
      x))

(defun DIST (x1 y1 x2 y2)
  (let ((xd (- x1 x2))
	(yd (- y1 y2)))
    (sqrt (+ (* xd xd) (* yd yd)))))

(defun SLOPE (x1 y1 x2 y2 &optional (max-slope 100000.0))
  (if (= x1 x2)
      max-slope
      (let ((tentative-slope (/ (- y2 y1) (float (- x2 x1)))))
	(if (> tentative-slope max-slope)
	    max-slope
	    (if (< tentative-slope (- max-slope))
		(- max-slope)		; This avoids undefined slope blow-ups and outrageously
					; large slopes
		tentative-slope)))))

(defun DIST-FROM-PT-TO-LINE-HAVING-SLOPE (ptx pty slope &optional (abs? t))
  (if abs?
      (abs (/ (+ (* (- slope) ptx) pty)
	       (sqrt (1+ (* slope slope)))))
      (/ (+ (* (- slope) ptx) pty)
	  (sqrt (1+ (* slope slope))))))

(defun Y-INTERCEPT (slope point)
  "point is list: (x y)"
  (- (cdr point) (* slope (car point)))) ; y = m*x +b, therefore b = y - m*x.

(defun DIST-FROM-POINT-TO-LINE (point seg-end-1 seg-end-2
				&aux (slp (slope (car seg-end-1) (cdr seg-end-1)
						 (car seg-end-2) (cdr seg-end-2)))
				(y-int (y-intercept slp seg-end-1)))
  (/ (+ (* (- slp) (car point))
	 (cdr point)
	 (- y-int))
      (sqrt (+ 1.0 (* slp slp)))))

(defun DEG (radian-angle) (* radian-angle 57.295776))

(defun RAD (degrees-angle) (* degrees-angle 0.017453292))

(defun ANGLE-BETWEEN-SEGMENTS (seg1-e1 seg1-e2 seg2-e1 seg2-e2)
  (let* ((seg1-x-comp (- (car seg1-e2) (car seg1-e1)))
	 (seg1-y-comp (- (cdr seg1-e2) (cdr seg1-e1)))
	 (seg2-x-comp (- (car seg2-e2) (car seg2-e1)))
	 (seg2-y-comp (- (cdr seg2-e2) (cdr seg2-e1)))
	 (seg1-len (sqrt (+ (* seg1-x-comp seg1-x-comp) (* seg1-y-comp seg1-y-comp))))
	 (seg2-len (sqrt (+ (* seg2-x-comp seg2-x-comp) (* seg2-y-comp seg2-y-comp))))
	 (dot-product (+ (* (/ seg1-x-comp seg1-len) (/ seg2-x-comp seg2-len))
			 (* (/ seg1-y-comp seg1-len) (/ seg2-y-comp seg2-len)))))
    (acos dot-product)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Array stuff

(defun PRINT-1D-ARRAY (array &optional 
		       sign-extend-bit-or-nil
		       (limit (length array)))
  (format t "~%")
  (dotimes (i limit)
    (format t "~a " (if sign-extend-bit-or-nil
			       (sign-extend (aref array i) sign-extend-bit-or-nil)
			       (aref array i)))))

;;;  This also works if you pass it a 1-dimensional array, but I couldn't figure out
;;;  an easy way to say that in the function name.
(defun PRINT-RASTER (raster &optional sign-extend-bit-or-nil (x 0) (y 0)
		     (w (array-dimension raster 1)) (h (array-dimension raster 0))
		     (sample-rate 1))
  (let* ((dims (array-dimensions raster))
	 (xsize (car dims))
	 (ysize (cadr dims)))
    (cond ((= 1 (length dims))
	   (format t "~%")
	   (dotimes (i xsize)
	     (format t "~a "
		     (if sign-extend-bit-or-nil
			 (sign-extend (aref raster i) sign-extend-bit-or-nil)
			 (aref raster i)))))
	  ((= 2 (length dims))
	   (if (not (= 1 sample-rate))
	       (format t
		       "~%Printing ~a with a sub-sampling rate of ~a..." raster sample-rate))
	   (let ((finish-i (+ w x))
		 (finish-j (+ h y)))
	     (loop for j from y below (min ysize finish-j) by sample-rate do
	       (format t "~%")
	       (loop for i from x below (min xsize finish-i) by sample-rate do
		 (format t "~a " (if sign-extend-bit-or-nil
				     (sign-extend (vu:raster-aref raster i j)
						  sign-extend-bit-or-nil)
				     (vu:raster-aref raster i j)))))))
	  (t (error "Can't use PRINT-RASTER here because ~a is not a raster, i.e.,
                     it has ~a > 2 dimensions."
		    raster (length dims))))))

(defun WITHIN-RASTER-BOUNDS (x y raster-xsize raster-ysize)
  (and (plusp x) (plusp y)
       (< x raster-xsize) (< y raster-ysize)))

;;; not portable - use vu:bits-per-element instead (WEG)
;(defun BITS-PER-ELEMENT (array)
;  (round (log (caaddr (array-element-type array)) 2)))

#-symbolics
(defun SET-BASE (base)
  (setq *print-base* base
	*read-base* base))

#+symbolics
(defun SET-BASE (base)
  (zl:setq-standard-value *print-base* base)
  (zl:setq-standard-value *read-base* base))

#+symbolics
(defun TIME-STRING ()
  (with-output-to-string (foo) (time:print-universal-time (time:get-universal-time) foo)))

#-symbolics
(defun TIME-STRING () "Sometime")

(defun PRINT-LIST (list)
  (dolist (i list) (format t "~%~%~a" i)))

(defun SAFE-AREF (2d-array subscr-1 subscr-2
		  &optional (xdim (array-dimension 2d-array 0))
		  (ydim (array-dimension 2d-array 1)))
  "Returns nil if out of bounds"
  (unless (or (minusp subscr-1) (minusp subscr-2) (>= subscr-1 xdim) (>= subscr-2 ydim))
    (aref 2d-array subscr-1 subscr-2)))

(defun SAFE-ASET (value 2d-array subscr-1 subscr-2
			 &optional (xdim (array-dimension 2d-array 0))
			 (ydim (array-dimension 2d-array 1)))
  "Returns nil if out of bounds"
  (unless (or (minusp subscr-1) (minusp subscr-2) (>= subscr-1 xdim) (>= subscr-2 ydim))
    (setf (aref 2d-array subscr-1 subscr-2) value)))

(defun SET-1B-ARRAY (1b-array)
  (dotimes (x (array-dimension 1b-array 0))
    (dotimes (y (array-dimension 1b-array 1))
      (setf (aref 1b-array x y) 1))))

(defun CLEAR-RASTER (raster)
  (multiple-value-bind (xsize ysize) (vu:decode-raster-array raster)
    (let ((arr (make-array (* xsize ysize)
			   :element-type (array-element-type raster)
			   :displaced-to raster)))
      (fill arr
	    (cond ((subtypep (array-element-type raster) 'integer) 0)
		  ((subtypep (array-element-type raster) 'float) 0.0)
		  ((not (subtypep (array-element-type raster) 'number)) nil)
		  (t (error "Foo")))))))

#+symbolics
(defun MOVE-ARRAY (source-array dest-array)
  (let ((sxdim (array-dimension source-array 0))
	(sydim (array-dimension source-array 1))
	(dxdim (array-dimension source-array 0))
	(dydim (array-dimension source-array 1)))
  (if (not (and (= sxdim dxdim)
		(= sydim dydim)))
      (error "For MOVE-ARRAY, SOURCE-ARRAY and DEST-ARRAY must have identical
              dimensions: (~a,~a), (~a,~a)"
	     sxdim sydim dxdim dydim))
  (zl-user:bitblt tv:alu-seta sxdim sydim source-array 0 0 dest-array 0 0)))

#+symbolics
(defun MOVE-RASTER (source-raster dest-raster)
  (let ((sxsize (array-dimension source-raster 0))
	(sysize (array-dimension source-raster 1))
	(dxsize (array-dimension source-raster 0))
	(dysize (array-dimension source-raster 1)))
  (if (not (and (= sxsize dxsize)
		(= sysize dysize)))
      (error "For MOVE-RASTER, SOURCE-RASTER and DEST-RASTER must have identical
              dimensions: (~a,~a), (~a,~a)"
	     sxsize sysize dxsize dysize))
  (zl-user:bitblt tv:alu-seta sxsize sysize source-raster 0 0 dest-raster 0 0)))

(defun CLEAR-1B-ARRAY (1b-array)
  (dotimes (x (array-dimension 1b-array 0))
    (dotimes (y (array-dimension 1b-array 1))
      (setf (aref 1b-array x y) 0))))

#+symbolics
(defun CLEAR-SECTION-OF-SCREEN (x y w h &optional (static-window *mike-display-pane*))
  (scl:send static-window :draw-rectangle w h x y tv:alu-setz)
  )
;; The above is a cleaner implementation.  - PAO 88DEC29
;; Unfortunately, it's ancient history...  - PAO 92MAR03
;  (bitblt tv:alu-xor
;	  w h
;	  (scl:send static-window :screen-array)
;	  (+ x (scl:send static-window :left-margin-size))
;	  (+ y (scl:send static-window :top-margin-size))
;	  (scl:send static-window :screen-array)
;	  (+ x (scl:send static-window :left-margin-size))
;	  (+ y (scl:send static-window :top-margin-size))))

#+symbolics
(defun MOVE-CURSOR-IF-NEC (y &optional (static-window *mike-display-pane*))
  (if (<= (scl:send static-window :cursor-y) y)
      (scl:send static-window :set-cursorpos 0 y)))

#+symbolics
(defun DRAW-BOX (x y w &optional (h w) (static-window *mike-display-pane*)
		 (alu tv:alu-seta))
  (scl:send static-window :draw-lines alu x y (+ x w) y (+ x w) (+ y h) x (+ y h) x y))

#+symbolics
(defun SHOW-1B-RASTER				;modified 10/9/87 WEG
       (raster
	 &optional (x 0) (y 0) (static-window *mike-display-pane*)
	 (draw-box? t) (move-cursor-if-nec? t)
	 (alu tv:alu-seta))
  (setq static-window (si:follow-syn-stream static-window))
  (multiple-value-bind (xdim ydim nil) (vu:decode-raster-array raster)
    (if move-cursor-if-nec?
	(move-cursor-if-nec (+ y ydim 8)))
    (tv:prepare-sheet (static-window)		; Added by PAO 88DEC29
      (scl:bitblt alu xdim ydim raster 0 0
		      (scl:send static-window :screen-array)
		      (+ x (scl:send static-window :top-margin-size))
		      (+ y (scl:send static-window :left-margin-size))))
    (if draw-box?
	(draw-box x y xdim ydim static-window))))

;;; This shows you the x-y coordinates of the point that the tip of the mouse-arrow is on.
;;; Remember that when you display an array using show-1b-array, (0,0) is at the upper
;;; left.
#+symbolics
(defun MOUSE-POINT-IN-1B-ARRAY
       (array &optional (show-x 0) (show-y 0) (static-window *mike-display-pane*))
  (show-1b-raster array show-x show-y static-window t t)
  (let ((old-x sys:mouse-x) (old-y sys:mouse-y)
	(ydim (array-dimension array 1))
	(left-marg (scl:send static-window :left-margin-size))
	(top-marg (scl:send static-window :top-margin-size)))
    (loop do
      (sleep 10.)
      (cond ((or (plusp (abs (- old-x sys:mouse-x)))
		 (plusp (abs (- old-y sys:mouse-y))))
	     (setq old-x (+ left-marg sys:mouse-x) old-y (+ top-marg sys:mouse-y))
	     (scl:send *mike-display-pane* :set-cursorpos show-x (+ ydim show-y 10))
	     (scl:send *mike-display-pane* :clear-rest-of-line)
	     (format t "~d  ~d ~d"
		     (- sys:mouse-x show-x left-marg) (- sys:mouse-y show-y top-marg)
		     (safe-aref array
				(- sys:mouse-x show-x left-marg)
				(- sys:mouse-y show-y top-marg)))))
      (cond ((= tv:mouse-buttons 1)
	     (return
	       (progn
		 (values (- sys:mouse-x show-x left-marg) (- sys:mouse-y show-y top-marg)
			 (safe-aref array
				    (- sys:mouse-x show-x left-marg)
				    (- sys:mouse-y show-y top-marg))))))))))

#||
#+symbolics
(defun DRAW-INTO-1B-ARRAY
       (1b-array &optional (show-x 0) (show-y 0) (static-window *mike-display-pane*))
  (show-1b-raster 1b-array show-x show-y static-window t t)
  (format t "~%~%Type Q to quit.")
  (let ((xdim (array-dimension 1b-array 0))
	(ydim (array-dimension 1b-array 1)))
    (loop until (tv:key-state (char-code #\q)) do
      (if (= tv:mouse-buttons 1)
	  (let ((i (- sys:mouse-x show-x))
		(j (- sys:mouse-y show-y)))
	    (cond ((not (or (minusp i) (minusp j) (>= i xdim) (>= j ydim)))
		   (setf (aref 1b-array (- sys:mouse-x show-x) (- sys:mouse-y show-y)) 1)
		   (zl-user::send static-window :draw-point (+ show-x i) (+ show-y j))
		   )))))
    (zl-user::send static-window :clear-input)))
||#

;(defun SHOW-AND-NAME-1B-ARRAY
;       (1b-array-name &optional (x 0) (y 0)
;		      (static-window *mike-display-pane*)
;		      (move-cursor-if-nec? t)
;		      surround-with-box?
;		      (font fonts:cptfontb)
;		      char-at-which-to-divide-name
;		      (nth-occurence-of-char 1))
;  (let ((xdim (array-dimension (symbol-value 1b-array-name) 0))
;	(ydim (array-dimension (symbol-value 1b-array-name) 1))
;	(left-margin (scl:send static-window :left-margin-size))
;	(top-margin (scl:send static-window :top-margin-size))
;	(screen-array (scl:send static-window :screen-array)))
;    (show-1b-array
;      (symbol-value 1b-array-name) x y static-window move-cursor-if-nec? surround-with-box?)
;    (if char-at-which-to-divide-name
;	(let* ((string (string 1b-array-name))
;	       (string1 (substr
;			  string nil char-at-which-to-divide-name 1 nth-occurence-of-char))
;	       (string2 (substr
;			  string char-at-which-to-divide-name nil nth-occurence-of-char))
;	       (string-height (zl:font-char-height font))
;	       (string-width
;		 (max (scl:send static-window :string-length (zl:string string1) 0 nil nil font)
;		      (scl:send static-window :string-length (zl:string string2) 0 nil nil font)))
;	     (real-show-x (+ x left-margin)) (real-show-y (+ y top-margin)))
;	(loop for sx from (+ 1 real-show-x) to (+ 3 real-show-x string-width) do
;	  (loop for sy from (+ real-show-y ydim (- (* 2 string-height)) -1) to
;		    (+ real-show-y xdim -1)
;		do
;	    (setf (aref screen-array sx sy) 0)))
;	(draw-string string1 x (+ y ydim (- string-height)) t nil font static-window 2 0 tv:alu-seta)
;	(draw-string string2 x (+ y ydim) t nil font static-window 2 0 tv:alu-seta))
;      (let* ((string (string 1b-array-name))
;	     (string-height (zl:font-char-height font))
;	     (string-width (scl:send static-window :string-length (zl:string string) 0 nil nil font))
;	     (real-show-x (+ x left-margin)) (real-show-y (+ y top-margin)))
;	(loop for sx from (+ 1 real-show-x) to (+ 3 real-show-x string-width)
;	      do
;	  (loop for sy from (+ real-show-y ydim (- string-height) -1)
;		       to (+ real-show-y xdim -1)
;		do
;	    (setf (aref screen-array sx sy) 0)))
;	(draw-string string x (+ y ydim) t nil font static-window 2 0 tv:alu-seta)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; String code and other random code.

;;; This function provides a good example of a depth first search program.  If you call it
;;; (with a couple of reasonble numbers like 3 and 4), it prints out every node that it
;;; visits.  It is included in this file just in case you need a model piece of code.   It
;;; was written by Karl, of course.
;(defun EXAMPLE-OF-DEPTH-FIRST-SEARCH (depth breadth &optional (current-node '()))
;  (print current-node)
;  (cond ((> depth 0)
;	 (loop for i from 1 to breadth do
;	   (if (node-legal? i current-node)
;	       (example-of-depth-first-search (1- depth) breadth (cons i current-node)))))))


;;; Returns the position of the Nth occurrence of KEY in STRING.  Returns NIL if there are not
;;; at least N occurrences of KEY in STRING.
#+symbolics
(defun NTH-KEY-OCCURRENCE (key string n &optional (start-pos 0) &aux (pos 0))
  (let ((substr (scl:substring string start-pos)))
    (if (< n 1)
	(error "The argument N to NTH-KEY-OCCURENCE must be greater than or equal to 1.")
	(if (= n 1)
	    (scl:string-search key string) 
	    (dotimes (i n)
	      (declare (ignore i))
	      (if pos
		  (if (scl:string-search key substr :start2 (1+ pos))
		      (setq pos (scl:string-search key substr :start2 (1+ pos)))
		      (setq pos nil))
		  (setq pos nil)))
	    pos))))

;;; Returns the substring in STRING between the N1th occurrence of CHAR1 and the N2th
;;; occurrence of CHAR2.  For example, (substr "asdf.jkl;.qwer" "." ".") => "jkl;".  If CHAR1
;;; is nil, then it returns the substring consisting of all the characters preceeding the
;;; first occurence of CHAR2.  If CHAR2 is nil, then it returns the substring consisting of
;;; all the characters after CHAR1.
#+symbolics
(defun SUBSTR (string &optional char1 char2 (n1 1) (n2 1))
  (let* ((pos1 (if (null char1)
		   0
		   (let ((nth-occ-1 (nth-key-occurrence char1 string n1)))
		     (if nth-occ-1
			 (1+ (nth-key-occurrence char1 string n1))
			 nil))))
	 (pos2 (if (null char2)
		   (scl:string-length string)
		   (nth-key-occurrence char2 string n2))))
    (if pos1
	(scl:substring string pos1 pos2)
	nil)))

;;; Returns the number of times CHAR appears in STRING.
#+symbolics
(defun NUMBER-OF-OCCURENCES-OF-CHARACTER (char string &optional (times 0))
  (if (scl:string-search char string)
      (number-of-occurences-of-character char (substr string char) (1+ times))
      times))

#+symbolics
(defun COLLECT-MOUSE-POINTS (&optional (connect? t) (static-window *mike-display-pane*)
			     (point-radius 2) (point-list ()))
  (do () ((= tv:mouse-buttons 0)))
  (do () ((> tv:mouse-buttons 0)))
  (cond ((= tv:mouse-buttons 1)
	 (let ((x (- sys:mouse-x 66))   ;<-- why the subtraction?
	       (y (- sys:mouse-y 44)))  ;<-- why the subtraction?
	   (if (and connect? (not (null point-list)))
	       (scl:send static-window :draw-line (car (car point-list)) (cadr (car point-list))
		     x y))
	   (scl:send static-window :draw-filled-in-circle x y point-radius)
	   (collect-mouse-points
	     connect? static-window point-radius (cons (list x y) point-list))))
	(t (reverse point-list))))

(defun WRITE-STRING-INTO-FILE (string filename)
  (with-open-file (stream filename :direction :output :if-exists :append)
    (format stream string)))

;;; ROTATEF does this.  PAO 88DEC29
(defmacro SWAP (symbol1 symbol2)
  `(let ((temp))
     (setq temp ,symbol1
	   ,symbol1 ,symbol2
	   ,symbol2 temp)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun MAKE-8B-RASTER (xsize ysize &optional (init-val 0))
  (vu:make-raster-array xsize ysize :element-type '(mod 256) :initial-element init-val))

(defun SET-RASTER (raster value)
  (let ((arr (make-array (array-total-size raster)
			 :element-type (array-element-type raster)
			 :displaced-to raster)))
    (fill arr value)))

;  (let* ((xsize (array-dimension raster 1))
;	 (ysize (array-dimension raster 0))
;	 (arr (make-array (* xsize ysize)
;			  :element-type (array-element-type raster)
;			  :displaced-to raster)))
;    (loop for i from 0 below (* xsize ysize) do
;      (setf (aref arr i) value))))

(defun FILL-RASTER-RANDOM (raster &optional (from 0) (to 255.) (square-patch-size 1))
  (let ((range (1+ (- to from)))
	(value 0)
	(xsize (array-dimension raster 1))
	(ysize (array-dimension raster 0)))
  (do ((x 0 (+ square-patch-size x)))
      ((>= x xsize))
    (do ((y 0 (+ square-patch-size y)))
	((>= y ysize))
      (setq value (+ from (random range)))
      (dotimes (i square-patch-size)
	(dotimes (j square-patch-size)
	  (if (not (or (> (+ x i) (1- xsize)) (> (+ y j) (1- ysize))))
	      (setf (vu:raster-aref raster (+ x i) (+ y j)) value))))))))

(defun CLAMP (value min max)
  (cond ((> value max)
	 max)
	((< value min)
	 min)
	(t value)))

(defun RESCALE (value from-min from-max to-min to-max)
  (let* ((old-range (- from-max from-min))
	 (new-range (float (- to-max to-min)))
	 (ratio (/ new-range old-range)))
    (+ to-min (* ratio (- value from-min)))))

(defun MIN-IN-ARRAY (array-of-numbers)
  (let* ((n (array-total-size array-of-numbers))
	 (displaced-array (make-array n
				      :element-type (array-element-type array-of-numbers)
				      :displaced-to array-of-numbers)))
    (loop for i from 0 below n
	  minimize (aref displaced-array i))))

(defun MAX-IN-ARRAY (array-of-numbers)
  (let* ((n (array-total-size array-of-numbers))
	 (displaced-array (make-array n
				      :element-type (array-element-type array-of-numbers)
				      :displaced-to array-of-numbers)))
    (loop for i from 0 below n
	  maximize (aref displaced-array i))))
  
(defun RESCALE-RASTER (from-raster &key
				  to-raster
				  from-min
				  from-max
				  (to-min 0)
				  (to-max 255.) 
				  (fix-p t))
  (let ((val nil)
	(xsize (array-dimension from-raster 1))
	(ysize (array-dimension from-raster 0)))
    (if (not to-raster)
	(setq to-raster (vu:make-raster-array xsize ysize :element-type '(mod 256))))
    (if (not from-min)
	(setq from-min (min-in-array from-raster)))
    (if (not from-max)
	(setq from-max (max-in-array from-raster)))
    (loop for x from 0 below xsize do
      (loop for y from 0 below ysize do
	(setq val
	      (clamp (rescale (vu:raster-aref from-raster x y) from-min from-max to-min to-max)
		     to-min to-max))
	(setf (vu:raster-aref to-raster x y) (if fix-p (floor val) val)))))
  to-raster)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Image Sampling Code

;;; Tries to center the sampled section as best it can in the new raster.  For example, if
;;; you try to sample a 576x454 frame-grabbed raster into a 256x256 raster, you must start
;;; at old-x = 32 , old-y = zero, new-x = 0, new-y = 15.  This function calculates all
;;; that for you.
(defun SAMPLE-RASTER (raster &key (linear-factor 2) average? sampled-raster)
  (let ((xsize (array-dimension raster 1))
	(ysize (array-dimension raster 0))
	(shift-amount (- (round (log (* linear-factor linear-factor) 2)))))
    (if sampled-raster (clear-raster sampled-raster))
    (let* ((new-xsize (if sampled-raster (array-dimension sampled-raster 1) (floor xsize linear-factor)))
	   (new-ysize (if sampled-raster (array-dimension sampled-raster 0) (floor ysize linear-factor)))
	   (sampled-raster
	     (or sampled-raster
		 (vu:make-raster-array new-xsize new-ysize :element-type (array-element-type raster))))
	   (old-start-x (if (> xsize (* linear-factor new-xsize))
			    (floor (- xsize (* linear-factor new-xsize)) 2)
			    0))
	   (old-start-y (if (> ysize (* linear-factor new-ysize))
			    (floor (- ysize (* linear-factor new-ysize)) 2)
			    0))
	   (new-start-x (if (> xsize (* linear-factor new-xsize))
			    0
			    (floor (- new-xsize (floor xsize linear-factor)) 2)))
	   (new-start-y (if (> ysize (* linear-factor new-ysize))
			    0
			    (floor (- new-ysize (floor ysize linear-factor)) 2)))
	   (read-from-width (min xsize (* linear-factor new-xsize)))
	   (read-from-height (min ysize (* linear-factor new-ysize)))
	   (linear-factor=2 (= linear-factor 2)))
      (if (= 1 linear-factor) ; <--A simple case.
	  (loop for x from old-start-x
		for new-x from new-start-x
		repeat read-from-width do
	    (loop for y from old-start-y
		  for new-y from new-start-y 
		  repeat read-from-height do
	      (setf (vu:raster-aref sampled-raster new-x new-y) (vu:raster-aref raster x y))))
	  (loop for x from old-start-x by linear-factor
		for new-x from new-start-x
		repeat (/ read-from-width linear-factor) do
	    (loop for y from old-start-y by linear-factor
		  for new-y from new-start-y 
		  repeat (/ read-from-height linear-factor) do
	      (setf (vu:raster-aref sampled-raster new-x new-y)
		    (if average?
			(if linear-factor=2
			    (ash (+ (vu:raster-aref raster x y)
				    (vu:raster-aref raster (1+ x) y)
				    (vu:raster-aref raster x (1+ y))
				    (vu:raster-aref raster (1+ x) (1+ y)))
				 shift-amount)
			    (ash (loop for i from 0 below linear-factor
				       summing
					 (loop for j from 0 below linear-factor
					       summing (vu:raster-aref raster (+ x i) (+ y j))))
				 shift-amount))
			(vu:raster-aref raster x y))))))
      sampled-raster)))

;;; Does arbitrary shrinking of images.
(defun SUB-SAMPLE-RASTER (raster
			  &key
			  sampled-raster
			  (xsize (array-dimension raster 1))
			  (ysize (array-dimension raster 0))
			  (from-x 0) (from-y 0) (from-w xsize) (from-h ysize)
			  (to-w (floor xsize 2)) (to-h (floor ysize 2)))
  (or sampled-raster
      (setq sampled-raster (vu:make-raster-array to-w to-h :element-type '(mod 256))))
  (let* ((x-ratio (/ from-w (float to-w)))
	 (y-ratio (/ from-h (float to-h)))
	 (patch-start-x 0)
	 (patch-start-y 0))
    (loop for x from 0 below (- to-w x-ratio) do
      (loop for y from 0 below (- to-h y-ratio) do
	(setq patch-start-x (+ from-x (* x-ratio x))
	      patch-start-y (+ from-y (* y-ratio y)))
	(setf (vu:raster-aref sampled-raster x y)
	      (patch-average raster patch-start-x patch-start-y x-ratio y-ratio)))))
  sampled-raster)

;;;  PATCH-AVERAGE is strictly for use as a subroutine to SUB-SAMPLE, above.
;;;
;;;  In this diagram, p's are pixels.  The brightness value of a pixel is regarded as
;;;  filling up the imaginary square below and to the right of the pixel, as the x's do
;;;  for the upper-left pixel in the diagram.  Therefore, in order to determine the
;;;  average brightness of the patch starting at START-X, START-Y, (which will in
;;;  general be floating-point numbers) and having width W, height H (also floats) we
;;;  must carefully calculate the integral of the intensities in the rectangle, then
;;;  normalize.  All the pixels labelled P (capital "p") contribute at least SOME of
;;;  their intensity to the average.  Exactly how much they contribute is a little
;;;  tricky to figure out.
;;;
;;;    pxxxxp    p    p    p    p
;;;    xxxxxx
;;;    pxxxxp    p    p    p    p
;;;
;;;    p    P    P    P    P    p
;;;           ______W________
;;;    p    P |a_P    P    P |  p
;;;           |              |H
;;;    p    P |  P    P    P |  p
;;;           |______________|
;;;    p    p    p    p    p    p
;;;   
;;;    p    p    p    p    p    p
(defun PATCH-AVERAGE (raster start-x start-y w h)
  (let* ((sx (floor start-x)) ;<--The integer closest to and less than start-x.
	 (sy (floor start-y))
	 (fx (floor (+ start-x w)))
	 (fy (floor (+ start-y h)))
	 (ul-weight (* (- start-x sx 1) (- start-y sy 1))); <-The area of the
						; upper-left pixel that gets contributed.
	 (ul-contribution (* ul-weight (vu:raster-aref raster sx sy))); i.e., the small patch
						; labelled "a" above.
	 (ll-weight (* (- start-x sx 1) (- fy (+ start-y h)))) ;<-The "caught-area"
						;of lower-left.
	 (ll-contribution (* ll-weight (vu:raster-aref raster sx fy)))
	 (ur-weight (* (- (+ start-x w) fx) (- (- start-y sy 1))))
	 (ur-contribution (* ur-weight (vu:raster-aref raster fx sy)))
	 (lr-weight (* (- (+ start-x w) fx) (- (+ start-y h) fy)))
	 (lr-contribution (* lr-weight (vu:raster-aref raster fx fy)))
	 ;; That does it for the corner pixels.
	 ;; Now the left-edge:
	 (left-edge-contribution
	   (loop for y from (1+ sy) to (1- fy)
		 summing
		   (* (- (- start-x sx 1)) (vu:raster-aref raster sx y))))
	 ;; Right edge:
	 (right-edge-contribution
	   (loop for y from (1+ sy) to (1- fy)
		 summing
		   (* (- (+ start-x w) fx) (vu:raster-aref raster fx y))))
	 ;; Top edge:
	 (top-edge-contribution
	   (loop for x from (1+ sx) to (1- fx)
		 summing
		   (* (- (- start-y sy 1)) (vu:raster-aref raster x sy))))
	 ;; Bottom edge:
	 (bottom-edge-contibution
	   (loop for x from (1+ sx) to (1- fx)
		 summing
		   (* (- (+ start-y h) fy) (vu:raster-aref raster x fy))))
	 ;; That does it for the edges, now the middle:
	 (middle-contribution (loop for x from (1+ sx) to (1- fx) summing
				    (loop for y from (1+ sy) to (1- fy) summing
					  (vu:raster-aref raster x y)))))
;    (format t "~%ul-contribution = ~a~%ll-contribution = ~a~%ur-contribution = ~a~%lr-contribution = ~a~%left-edge-contribution = ~a~%right-edge-contribution = ~a~%top-edge-contribution = ~a~%bottom-edge-contibution = ~a~%middle-contribution = ~a"
;	    ul-contribution ll-contribution ur-contribution lr-contribution left-edge-contribution right-edge-contribution
;	    top-edge-contribution bottom-edge-contibution middle-contribution)
    (round (/ (+ ul-contribution ll-contribution ur-contribution lr-contribution
		 left-edge-contribution right-edge-contribution top-edge-contribution bottom-edge-contibution
		 middle-contribution)
	      (float (* w h))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Here's some more obscure raster code.

;;; Rotates the image 180 degrees.
(defun TURN-IMAGE-UPSIDE-DOWN (image &optional (out-arr (make-similar-array image)))
  (let ((1-xsize (1- (array-dimension image 0)))
	(1-ysize (1- (array-dimension image 1))))
    (dotimes (x (array-dimension image 0))
      (dotimes (y (array-dimension image 1))
	(setf (aref out-arr (- 1-xsize x) (- 1-ysize y)) (aref image x y))))
    out-arr))
 
;;; Reflects the image about a horizontal axis throught the center.
(defun TURN-IMAGE-UPSIDE-DOWN-BY-REFLECTION
       (image &optional (out-arr (make-similar-array image)))
  (let ((1-ysize (1- (array-dimension image 1))))
    (dotimes (x (array-dimension image 0))
      (dotimes (y (array-dimension image 1))
	(setf (aref out-arr x (- 1-ysize y)) (aref image x y))))
    out-arr))
  
(defun PAINT-SQUARE-PATCH-IN-IMAGE
       (8b-array value width
		 &optional (x-start (- (array-dimension 8b-array 0) width))
		 (y-start (- (array-dimension 8b-array 0) width)))
  (loop for x from x-start to (1- (+ x-start width)) do
    (loop for y from y-start to (1- (+ y-start width)) do
      (setf (aref 8b-array x y) value))))

(defun NTH-BIT-OF-IMAGE (image position
			 &optional (out-arr (make-array (array-dimensions image)
							:element-type '(mod 2))))
  (dotimes (x (array-dimension image 0))
    (dotimes (y (array-dimension image 1))
      (setf (aref out-arr x y) (ldb (byte 1 position) (aref image x y)))))
  out-arr)

(defvar *PI-OVER-180* (/ (float pi 0.0) 180.0))

(defun ROTATE-POINT (x y counterclockwise-n-degrees about-x about-y
		       &optional sin cos)
  (let ((xo (- x about-x))
	(yo (- y about-y)))
    (if (and sin cos)
	(values (+ about-x (- (* xo cos) (* yo sin)))
		(+ about-y (* xo sin) (* yo cos)))
	(let* ((radians (* counterclockwise-n-degrees *pi-over-180*))
	       (sin (sin radians))
	       (cos (cos radians)))
	  (values (+ about-x (- (* xo cos) (* yo sin)))
		  (+ about-y (* xo sin) (* yo cos)))))))
  
;;;  This is actually used by ROTATE-ARRAY
(defun RASTER-DEFAULT-ELEMENT-TYPE (raster)
  (if (listp (array-element-type raster))
      0
      nil))

;;;  Note that "counterclockwise" turns out to be clockwise because of the screen
;;;  coordinate system.
(defun ROTATE-RASTER (raster
		      counterclockwise-n-degrees
		      &optional
		      (about-x (floor (array-dimension raster 1) 2))
		      (about-y (floor (array-dimension raster 0) 2))
		      rotated-raster
		      (do-not-bother-rotating-this-value--can-be-keyword-none
			(raster-default-element-type raster)))
  (let ((xsize (array-dimension raster 1))
	(ysize (array-dimension raster 0)))
    (or rotated-raster
	(setq rotated-raster (vu:make-raster-array
			       (array-dimension raster 1) (array-dimension raster 0)
			       :element-type (array-element-type raster))))
    (let* ((radians (* counterclockwise-n-degrees (/ 3.1415927 180.0)))
	   (cos (cos radians))
	   (sin (sin radians))
	   (ignore-any-values?
	     (not (equal do-not-bother-rotating-this-value--can-be-keyword-none :none))))
      (dotimes (v ysize)
	(dotimes (u xsize)
	  (let ((value (vu:raster-aref raster u v)))
	    (if (and ignore-any-values?
		     (equal value do-not-bother-rotating-this-value--can-be-keyword-none))
		nil
		(let* ((x (- u about-x))
		       (y (- v about-y))
		       (new-x (round (- (* x cos) (* y sin))))
		       (new-y (round (+ (* x sin) (* y cos))))
		       (new-u (+ about-x new-x))
		       (new-v (+ about-y new-y)))
		  (if (and (>= new-u 0)
			   (>= new-v 0)
			   (< new-u xsize)
			   (< new-v ysize))
		      (setf (vu:raster-aref rotated-raster new-u new-v)
			    (vu:raster-aref raster u v))))))))))
  rotated-raster)