;;; NOTE: These were incorporated into obvius-3.0 on 3/23/93. - EPS

(in-package 'obvius)

;;; in viewable.lisp
(export 'name)

;;; In Viewable-matrix.lisp
(export 'matrix)

(defmethod matrix ((mtx viewable-matrix))
  (slot-value mtx 'data))

(defmethod (setf matrix) (arr (mtx viewable-matrix))
  (unless (and (typep arr '(array t (* *)))
	       (every #'(lambda (x) (viewable-p x)) (vectorize arr)))
    (error "Arg must be a 2D array containing viewables"))
  (setf (slot-value mtx 'data) arr))

;;; Don't include steerable-pyramid (this is in lucid-defsys)
(setf (getf *obvius-module-plist* :steerable)
      '("steer" "steer-orient"))

#|
;;; Fixes: didn't used to pass the U,V,S matrices, minimization code
;;; consed and was slow.
(defun solve-eigenvalue (matrix
			 &key
			 (S (make-array (x-dim matrix) :element-type 'single-float))
			 (U (make-array (dimensions matrix) :element-type 'single-float))
			 (V (make-array (dimensions matrix) :element-type 'single-float))
			 ((:-> e-vector) (make-array (x-dim matrix) :element-type 'single-float)))
  (multiple-value-setq (S U V)
    (singular-value-decomposition matrix :u U :v V :s S))
  (multiple-value-bind (min-ev min-ev-pos) (minimize S)
    ;;Fill the e-vector with elements from the pos-of-min column of U.
    (dotimes (i (array-total-size e-vector))
      (setf (aref e-vector i) (aref U i min-ev-pos))))
  (values e-vector S))

;;; Return minimum-value item and its position in the sequence.
(defun minimize (seq &key key)
  (if (consp seq)
      (if key
	  (loop with min-pos = 0
		with min-val = (funcall key (car seq))
		for item in (cdr seq)
		for val = (funcall key item)
		for pos from 1
		do (when (< val min-val) (setq min-pos pos  min-val val))
		finally (return (values min-val min-pos )))
	  (loop with min-pos = 0
		with min-val = (car seq)
		for val in (cdr seq)
		for pos from 1
		do (when (< val min-val) (setq min-pos pos  min-val val))
		finally (return (values min-val min-pos ))))
      (if key
	  (loop with min-pos = 0
		with min-val = (funcall key (aref seq 0))
		for pos from 1 below (array-total-size seq)
		for val = (funcall key (aref seq pos))
		do (when (< val min-val) (setq min-pos pos  min-val val))
		finally (return (values min-val min-pos )))
	  (loop with min-pos = 0
		with min-val = (aref seq 0)
		for pos from 1 below (array-total-size seq)
		for val = (aref seq pos)
		do (when (< val min-val) (setq min-pos pos  min-val val))
		finally (return (values min-val min-pos ))))))

;;; Implemented with dummy q and r keywords to avoid breaking code
;;; that relies on teh qr decomposition.
;;; *** need a better way to handle SVD arguments, here and other places
;;; *** note that SVD ignores sign of determinant!!
(defmethod determinant ((matrix array) &key (ignore-zeros nil) q r u v
                        suppress-warning)
  (declare-matrices (matrix) nil)
  (when (and (or q r) (not suppress-warning))
    (warn "QR decomposition not used now, using SVD and ignoring q,r keywords. "))
  (let ((case (cond ((not (square-p matrix)) 0)
                    ((not ignore-zeros) (row-dim matrix))
                    (t t))))
    (case case
      (0 0.0)
      (1 (aref matrix 0 0))
      (2 (- (* (aref matrix 0 0) (aref matrix 1 1))
            (* (aref matrix 1 0) (aref matrix 0 1))))
      (3 (- (+ (* (aref matrix 0 0) (aref matrix 1 1) (aref matrix 2 2))
               (* (aref matrix 1 0) (aref matrix 2 1) (aref matrix 0 2))
               (* (aref matrix 2 0) (aref matrix 0 1) (aref matrix 1 2)))
            (+ (* (aref matrix 0 2) (aref matrix 1 1) (aref matrix 2 0))
               (* (aref matrix 1 2) (aref matrix 2 1) (aref matrix 0 0))
               (* (aref matrix 2 2) (aref matrix 0 1) (aref matrix 1 0)))))
      (t (unless suppress-warning
           (warn "Bug in determinant: absolute value of determinant returned"))
         (let* ((s (svd matrix :u u :v v))
                (val 1.0)
                elt)
           (dotimes (i (length s))
             (setq elt (aref s i))
             (when (or (> (abs elt) short-float-epsilon) (not ignore-zeros))
               (setq val (* val elt))))
           val)))))

|#

;;; Skip the status-message for z-dim = 1
(defmethod apply-filter ((filter filter) (seq image-sequence)
			 &key -> 
			 (start-frame 0)
			 (end-frame (sequence-length seq))
			 (direction (if (= (rank filter) 1) 2 0)))
  (with-local-viewables ((filt (directionalize filter direction)))
    (when (> (rank filt) (rank seq))
      (error "Rank of ~A is too large to be applied to ~A in direction ~A"
	     filter seq direction))
    (with-result ((result ->)
		  (list :class (class-of seq)
			:dimensions (subsampled-dimensions
				     (cons (- end-frame start-frame) (dimensions seq))
				     (start-vector filt) (step-vector filt)))
		  'apply-filter filter seq
		  :start-frame start-frame :end-frame end-frame)
      (if (< (rank filt) 3)		;a spatial filter
	  (loop for res-frame from 0 below (z-dim result)
		for frame from (+ (z-start filter) start-frame) by (z-step filter)
		for arg-im = (frame frame seq)
		for res-im = (frame res-frame result)
		do (apply-filter filter arg-im :-> res-im :direction direction
				 :start-frame start-frame :end-frame end-frame))
	  (loop for res-frame from 0 below (z-dim result)
		for ctr-frame from (+ (z-start filt) start-frame) by (z-step filt)
		do
		(when (> (z-dim result) 1)
		  (status-message "Apply-filter: frame ~A" res-frame))
		(single-frame-correlate filt seq 
					:center-frame ctr-frame
					:-> (frame res-frame result))
		finally (status-message "")))
      result)))

;;; viewable.lisp: loop is MUCH faster than useing mapl.  SHOULD ALSO
;;; GET RID OF CONSING &REST arg!
(defun set-history (vbl &rest hist-list)
  (loop for l on hist-list
	for car = (car l)
	do (when (viewable-p car) (rplaca l (history car))))
  (setf (slot-value vbl 'history)
	(make-instance 'history 
		       :viewable vbl
		       :creation-function (car hist-list)
		       :creation-args (cdr hist-list))))

;;; memory.lisp: right-justify.
(defun heap-status ()
  "Print out information about the static array allocator.  For each type of
static heap, prints the number of used elements, the number of free elements,
the number of contiguous blocks (i.e. fragmentation), and the size of the
largest block."
  (format t "~%Static Heap Status:~%")
  (format t "  ~22A~11@A~11@A~11@A~10@A~%" "Type" "Used" "Free" "Max Block" "# Blocks")
  (format t "  ~65,,,'-<~>~%")
  (loop for heap in *static-heaps*
	for type = (static-heap-type heap)
	for free = (static-heap-free-size heap)
	for used = (- (static-heap-total-size heap) free)
	for largest = (static-heap-largest-block-size heap)
	for num = (static-heap-number-of-blocks heap)
	do
	(format t "  ~22A~11@A~11@A~11@A~10@A~%" type used free largest num))
  (format t "  ~65,,,'-<~>~%~%")
  (values))

;;; synth.lisp: Don't do atan if x-freq and y-freq are zero
(defun make-sin-grating (dims &key (period 8.0) (orientation 0.0) 
			      (phase 0.0) (amplitude 1.0) (dc 0.0)
			      frequency x-freq y-freq ->)
  (with-result ((result ->)
		(list :class 'image :dimensions dims)
		'make-sin-grating dims :period period :orientation orientation
		:dc dc :amplitude amplitude :phase phase)
    (cond (frequency t)
	  ((and x-freq y-freq)
	   (setq frequency (sqrt (+ (sqr x-freq) (sqr y-freq))))
	   (setq orientation (if (and (zerop x-freq) (zerop y-freq))
				 0.0 (atan y-freq x-freq))))
	  (t (setq frequency (/-0 2-pi period))))
    (make-ramp dims :orientation orientation :slope frequency
	       :pedestal phase :-> result)
    (periodic-point-operation
     result #'(lambda (x) (+ dc (* amplitude (sin x)))) 2-pi
     :binsize (/-0 2-pi (get-default 'discrete-function :size) 1)
     :-> result)))

(setq *obvius-debugger-hook*
  #'(lambda ()
      (declare (special *status-reporter*))
      (when *status-reporter* (status-message " in debugger ..."))))