(in-package 'obvius)

;;;; Viewable-sequence.lisp: re-patch: if res is nil, don't set name
(defmethod frame ((n number) (seq viewable-sequence) &key ((:-> res)))
  (unless (<= 0 n (- (sequence-length seq) 1))
    (error "Frame number out of bounds: ~A" n))
  (let ((sub-viewable (aref (data seq) 0 n)))
    (cond ((viewable-p res)
	   (copy sub-viewable :-> res))
	  ((null res) sub-viewable)
	  ((typep res 'viewable-name)	;string, symbol, or nil
	   (set-name sub-viewable res)
	   sub-viewable)
	  (t (error "bad result argument")))))

(defmethod append-sequence ((seq1 viewable-sequence) (seq2 viewable-sequence) &key ->)
  (let ((appended-seq (append (viewable-list seq1) (viewable-list seq2))))
    (cond ((viewable-p ->)
	   (unless (eq (length appended-seq) (length. ->))
	     (error "result sequence has incorrect length"))
	   (mapcar #'(lambda (im res) (copy im :-> res))
		   appended-seq (viewable-list ->))
	   ->)
	  ((typep -> 'viewable-name)
	   (make-instance (class-of seq1)
			  :viewable-list appended-seq
			  :display-type (display-type seq1) :name ->))
	  (t (error "bad result argument")))))

(defmethod sub-sequence ((seq viewable-sequence) start-frame &optional end-frame &key ->)
  (let ((sub-seq (subseq (viewable-list seq) start-frame end-frame)))
    (cond ((viewable-p ->)
	   (unless (eq (length sub-seq) (length. ->))
	     (error "result sequence has incorrect length"))
	   (mapcar #'(lambda (im res) (copy im :-> res))
		   sub-seq (viewable-list ->))
	   ->)
	  ((typep -> 'viewable-name)
	   (make-instance (class-of seq)
			  :viewable-list sub-seq
			  :display-type (display-type seq) :name ->))
	  (t (error "bad result argument")))))


;;; Viewable.lisp.  Execute body, and at the end, destroy viewables
;;; bound in vbl-list.  The following exceptions are NOT destroyed: 1)
;;; any local viewable that is RETURNED from the body, 2) a local
;;; viewable that has a NON-LOCAL superior, 3) local viewables with
;;; global symbol names, and 4) local viewables displayed in pictures.
(defmacro with-local-viewables (vbl-list &body body)
  (let* ((vars (loop for item in vbl-list
		     for var = (if (symbolp item) item (car item))
		     collect var))
	 (res (gensym)))
    `(let* (,@vars ,res)
      (unwind-protect
	   (progn ,@(loop for item in vbl-list
			  when (listp item) collect `(setq ,@item))
		  (setq ,res (multiple-value-list (progn ,@body)))
		  ;;(when (intersection (remove-if-not 'viewable-p ,res) (list ,@vars))
		  ;;  (error "Attempting to return a local viewable"))
		  (values-list ,res))
	(let ((*protected-viewables* (append ,res *protected-viewables*)))
	  (declare (special *protected-viewables*))
	  (destroy-viewables ,@vars))))))

;;; viewable.lisp.  Modified to add inferiors to list (this way,
;;; compound viewables are completely cleaned up).  To allow user to
;;; return inferiors, or put external viewables into a local compound
;;; viewable, we only destroy orphans.  We sort the list so that
;;; superiors come before their inferiors.  This prevents local
;;; inferiors from being preserved because of the existence of their
;;; superiors!  In summary, the following will NOT be destroyed. 1)
;;; viewables that have a superior not on the list, 2) viewables on
;;; the *protected-viewables* list, 3) viewables with global symbol
;;; names, and 4) viewables displayed in pictures.
(defun destroy-viewables (&rest vbls)
  (declare (special *protected-viewables*))
  ;; Destructively delete all non-viewables and duplicates:
  (setq vbls (delete-duplicates (delete-if-not #'viewable-p vbls)))
  ;; Destructively add inferiors:
  (loop for sub-list = vbls then (cdr sub-list) until (null sub-list)
	for vbl = (car sub-list)
	do (dolist (inf (inferiors-of vbl))
	     (unless (member inf vbls)
	       (rplacd sub-list (cons inf (cdr sub-list))))))
  ;; Destructively re-order list so superiors come before their inferiors:
  (setq vbls (sort-by-superiors! vbls))
  ;; Silently destroy orphaned viewables in list:
  (dolist (vbl vbls)
    (when (orphaned-viewable-p vbl) (destroy vbl :silent t)))
  t)

;;; viewable.lisp (new). destructively sort a viewable list, ordering
;;; superiors before their inferiors.
(defun sort-by-superiors! (vbls)
  (loop with nthcdr = nil
	with max-count = (* 2 (length vbls))
	with sub-list = vbls
	for count from 0
	until (or (null sub-list) (> count max-count))
	for vbl = (car sub-list)
	for sups = (superiors-of vbl)
	for last-sup-pos = (loop for sup in sups
				 maximize (or (position sup sub-list) 0))
	do (cond ((> last-sup-pos 0)	;if sup in list, put vbl after it.
		  (setq nthcdr (nthcdr last-sup-pos sub-list))
		  (setf (cdr nthcdr) (cons vbl (cdr nthcdr)))
		  (setf (car sub-list) (cadr sub-list))
		  (setf (cdr sub-list) (cddr sub-list)))
		 (t (setq sub-list (cdr sub-list)))))
  vbls)

;;; Memory.lisp: Use destroy-viewables to 1) include all inferiors of
;;; preserved-viewables, 2) avoid destruction-of-inferior errors
(defun purge! (&key preserved-viewables (suppress-warnings preserved-viewables))
  (unless suppress-warnings
    (cerror "Destroy all viewables, reclaiming all memory."
	    "Are you sure you want to destroy all existing viewables?"))
  ;; Destroy all non-protected viewables
  (let* ((*protected-viewables* (append preserved-viewables
					*protected-viewables*))
	 (all-vbls (all-viewables)))
    (declare (special *protected-viewables*))
    (setq all-vbls (sort-by-superiors! all-vbls))
    (dolist (vbl all-vbls) 
      (unless (or (member vbl *protected-viewables*) ;check if vbl is protected
		  (superiors-of vbl))	;or if it has an undestroyed superior
	(destroy vbl :silent t))))
  ;; Rebuild heaps, preserving everything that is left:
  (let* ((vbls (all-viewables))
	 (pics (loop for vbl in vbls append (pictures-of vbl)))
	 array-list)
    (setq array-list
	  (nconc (loop for vbl in vbls append (static-arrays-of vbl))
		 (loop for pic in pics append (static-arrays-of pic))))
    (rebuild-heaps-from-allocated-arrays array-list :verbose t)))


;;; matrix.lisp: More efficient.  Returns the norm as a second value.
(defmethod normalize ((v vector) &key (norm 1.0) ((:-> res) (similar v)))
  (obv::declare-matrices () (v res))
  (obv::checktype-matrices (v res))
  (let ((divisor (/ (sqrt (loop for i from 0 below (length v)
				summing (sqr (aref v i))))
		    norm)))
    (internal-sc-mul v res (array-total-size v) (float (/-0 1.0 divisor)))
    (values res divisor)))


;;; filter.lisp: Do  temporal filtering FIRST.
(defmethod apply-filter ((filter separable-filter) (seq image-sequence)
			 &key -> (direction 0)
			 (start-frame 0)
			 (end-frame (sequence-length seq)))
  (when (> (+ direction (rank filter)) (rank seq))
    (error "Rank of ~A is too large to be applied to ~A in direction ~A"
	   filter seq direction))
  (with-slots (filter-2 filter-1) filter
    (with-result ((result  ->)
		  (list :class (class-of seq)
			:dimensions (obv::subsampled-dimensions
				     (cons (- end-frame start-frame) (dimensions seq))
				     (start-vector filter) (step-vector filter)))
		  'apply-filter filter seq :start-frame start-frame
		  :end-frame end-frame :direction direction)
      (cond ((< (+ direction (rank filter)) 3)
	     (loop for res-frame from 0 below (z-dim result)
		   for frame from (+ (obv::z-start filter) start-frame) by (obv::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)))
	    (t
	     (with-local-viewables
		 ((dfilt (obv::directionalize filter direction)) ;just to get z-dim
		  (tmp (apply-filter filter-1 seq :direction (+ direction (rank filter-2))
				     :start-frame start-frame :end-frame end-frame)))
	       (loop for frame from 0 below (z-dim result)
		     do
		     (apply-filter filter-2 (frame frame tmp)
				   :direction direction
				   :-> (frame frame result))))))
      result)))

;;; in fft.lisp: didn't use dimensions arg
(defmethod power-spectrum ((im image) &key -> center dimensions)
  (with-result ((result ->)
		(list :class (class-of im)
		      :dimensions (cond (dimensions dimensions)
					((image-p ->) (dimensions ->))
					(t (padded-dimensions im))))
		'power-spectrum im :center center)
    (with-local-viewables ((fft (fft im :dimensions dimensions)))
      (square-magnitude fft :-> result))
    (when center
      (circular-shift result
		      :x (floor (x-dim result) 2)
		      :y (floor (y-dim result) 2)
		      :-> result))
    result))

;;; New (in fft.lisp)
(defmethod power-spectrum ((filt filter) &key (center t) (dimensions (dimensions filt)) ->)
  (unless (every #'>= dimensions (dimensions filt))
    (error "Dimensions must be larger than filter dimensions"))
  (with-local-viewables ((im (make-image dimensions)))
    (paste (kernel filt) (data im) :-> (data im))
    (power-spectrum im :center center :-> ->)))

;;; In fileio.lisp: should not include frame number end-index: this is
;;; inconsistent with the rest of OBVIUS and COmmon Lisp!  Also, set
;;; frame names to match file numbers.
(defun load-image-sequence (path 
			    &key 
			    (start-index 0) end-index
			    (->
			     (if *auto-bind-loaded-images* 
				 (intern (string-upcase (extract-filename path)))
				 (extract-filename path))))
  (when (not (directory-p path))
    (error "Bad filename for datfile: ~S" path))
  (setq path (trim-right-delimiter path))
  (let* ((dir-path (namestring (directory-path path)))
	 (descriptor-path (concatenate 'string dir-path "descriptor"))
	 (dimensions (df-getkey descriptor-path "_dimensions"))
	 (data-files (df-getkey descriptor-path "_data_files"))
	 (class (df-getkey descriptor-path "class" 'image-sequence)))
    (setq end-index (or end-index data-files))
    (with-result ((result ->) (list :class class
				    :dimensions dimensions
				    :length (- end-index start-index))
		  'load-image-sequence path
		  :start-index start-index :end-index end-index)
      (loop for i from start-index below end-index
	    for n from 0
	    for res = (frame n result)
	    do
	    (image-from-datfile path :data-filename (format nil "data~a" i) :-> res)
	    (unless (name res)
	      (set-name res (format nil "frame~a" i))))
      result)))

;;; In viewable-sequence:
(export '(map. reduce.))

;;; x-blt.lisp:
(setq obv::*X-bltable-overhang* 1.2)

;;; from x-blt.lisp: better status-message
(defmethod fast-display-seq ((bltable x-bltable) pane frobs
			     x-offset y-offset zoom
			     frame-delay seq-delay test-fn
			     &aux gc)
  ;; Compute frobs if necessary:
  (loop for frob in frobs
	for X-image = (x-image frob)
	for i from 0 
	do
	(status-message "Computing X-image ~A ..." i)
	(when (and X-image
		   (/= (cadr (dimensions frob))
		       (ceiling (* (cadr (base-dimensions frob)) zoom))))
	  (setf (lispview:status X-image) :destroyed)
	  (setf X-image nil))
	(unless X-image (compute-bltable-X-image frob zoom)))
  (status-message "Displaying movie ...")
  (setq gc (lv::graphics-context (lv::display pane)))
  (lv::with-graphics-context (gc :foreground (background bltable)
				 :background (foreground bltable))
    (let* ((lv-display (lv::display pane))
	   (dst-xvo (lv::device pane))
	   (dsp (lv::xview-object-dsp (lv::device lv-display)))
	   (xgc (lv::xview-object-xid (lv::device gc)))
	   (dst-xid (lv::xview-object-xid dst-xvo))
	   (src-xids (mapcar #'(lambda (f) (lv::xview-object-xid (lv::device (x-image f))))
			     frobs))
	   (width  (x-dim bltable))	;assume all frobs the same dimensions
	   (height (y-dim bltable))
	   (to-x (+ (floor (- (x-dim pane) (x-dim bltable)) 2) x-offset))
	   (to-y (+ (floor (- (y-dim pane) (y-dim bltable)) 2) y-offset))
	   (from-depth (lv::xview-drawable-depth (lv::device (x-image bltable))))
	   (to-depth (lv::xview-drawable-depth dst-xvo))
	   copy-plane-p)
      (cond ((= from-depth to-depth) (setq copy-plane-p nil))
	    ((= from-depth 1) (setq copy-plane-p t))
	    (t (error "Copying from drawable of depth ~D not supported"
		      from-depth)))
      (loop for count from 0
	    while (funcall test-fn count) do
	    (loop for src-xid in src-xids do
		  (XView::with-xview-lock
		      (if copy-plane-p
			  (X11:XCopyPlane dsp src-xid dst-xid xgc
					  0 0 width height to-x to-y 1)
			  (X11:XCopyArea dsp src-xid dst-xid xgc
					 0 0 width height to-x to-y))
		    (X11:XFlush dsp)
		    (frame-sleep frame-delay)))
	    (mp:process-allow-schedule)	;check for events!
	    (when (> seq-delay 0) (frame-sleep seq-delay))))))