(in-package 'obvius)

;;; in x-control-panel.lisp: alphabetize the list
(defun make-misc-menu (&optional owner)
  (make-instance
   'lispview:menu
   :label "Misc" :owner owner :pushpin t :default nil
   :choices
   #'(lambda ()
       (let* ((modules (loop for plist = *obvius-module-plist* then (cddr plist)
			     until (null plist)
			     collect (car plist))))
	 (setq modules (remove-if #'(lambda (m) (member m *obvius-features*))
				  modules))
	 (setq modules (sort modules #'string<))
	 (setq modules (mapcar #'(lambda (m)
				   (make-instance
				    'lv::command-menu-item
				    :label (mk-dlg-name m nil)
				    :command 
				    (let ((expr `(obv-require ,m)))
				      #'(lambda ()
					  (push-onto-eval-queue
					   `(progn 
					     (format t "~S~%" ',expr)
					     (print-top-level-values
					      (multiple-value-list ,expr))))))))
			       modules))
	 (cons (make-instance
		'lv:submenu-item
		:label "Load module:"
		:menu (make-instance 'lv:menu :choices modules))
	       (loop for op in *obvius-misc-functions*
		     collect
		     (make-instance 'lv::command-menu-item
				    :label (mk-dlg-name op)
				    :command
				    (let ((fn op)) ;rebind for lexical closure
				      #'(lambda ()
					  (make-function-dialog fn))))))))))

;;; flipbook.lisp: Took out with-locked-pane, since this is run by the
;;; initial-process and you don't want it to block mouse events!!
(defun display-seq (flipbook &optional (repeat t))
  (when (null repeat) (setq repeat 1))
  (let* ((pane (pane-of flipbook))
	 (frobs (mapcar 'system-dependent-frob (picture-list flipbook)))
	 (test-fn
	  (if (numberp repeat)
	      #'(lambda (i) (and (< i repeat)
				 (slot-value flipbook 'displaying-p)))
	      #'(lambda (i)
		  (declare (ignore i))
		  (slot-value flipbook 'displaying-p)))))
    (when (back-and-forth flipbook)
      (setq frobs (append (cdr frobs) (cdr (reverse frobs)))))
    (set-pane-title-bar pane "showing movie ...")
    (setf (displaying-p flipbook) t)
    (unwind-protect
	 (fast-display-seq
	  (car frobs) pane frobs
	  (x-offset flipbook) (y-offset flipbook) (zoom flipbook)
	  (frame-delay flipbook) (seq-delay flipbook) test-fn)
      (draw-pane pane :clear nil))))

;;;; In filter.lisp: Rewrote this.  If user specifies
;;;; edge-handler/vectors/display-type, they are used by the
;;;; sub-filters, EVEN if user passes existing filters.
(defun make-separable-filter (kernel-1 kernel-2 &rest initargs
			      &key 
			      (display-type nil display-specified-p)
			      (edge-handler nil edge-handler-specified-p)
			      (start-vector nil start-vector-specified-p)
			      (step-vector nil step-vector-specified-p)
			      name ->)
  (declare (ignore name))
  (when -> (setf (getf initargs :name) ->))
  (let (filter-1 filter-2 kernel)
    (cond ((filter-p kernel-2)
	   (setq filter-2 (copy kernel-2))
	   (if edge-handler-specified-p
	       (setf (edge-handler filter-2) edge-handler)
	       (setq edge-handler (edge-handler filter-2)))
	   (if display-specified-p
	       (setf (display-type filter-2) display-type)
	       (setq display-type (display-type filter-2)))
	   (setf (start-vector filter-2)
		 (sublist-of-length (rank filter-2)
				    (if start-vector-specified-p
					(subseq start-vector (rank filter-1))
					(start-vector filter-2))
				    0))
	   (setf (step-vector filter-2)
		 (sublist-of-length (rank filter-2)
				    (if step-vector-specified-p
					(subseq step-vector (rank filter-1))
					(step-vector filter-2))
				    1)))
	  (t (setq filter-2
		   (apply 'make-filter kernel-2
			  :start-vector
			  (sublist-of-length
			   (rank kernel-2) (subseq start-vector (rank filter-1)) 0)
			  :step-vector
			  (sublist-of-length
			   (rank kernel-1) (subseq step-vector (rank filter-1)) 1)
			  initargs))))
    (cond ((filter-p kernel-1)
	   (setq filter-1 (copy kernel-1))
	   (if edge-handler-specified-p
	       (setf (edge-handler filter-1) edge-handler)
	       (setq edge-handler (edge-handler filter-1)))
	   (if display-specified-p
	       (setf (display-type filter-1) display-type)
	       (setq display-type (display-type filter-1)))
	   (setf (start-vector filter-1)
		 (sublist-of-length (rank filter-1)
				    (if start-vector-specified-p
					start-vector
					(start-vector filter-1))
				    0))
	   (setf (step-vector filter-1)
		 (sublist-of-length (rank filter-1)
				    (if step-vector-specified-p
					step-vector
					(step-vector filter-1))
				    1)))
	  (t (setq filter-1
		   (apply 'make-filter kernel-1
			  :start-vector
			  (sublist-of-length (rank kernel-1) start-vector 0)
			  :step-vector
			  (sublist-of-length (rank kernel-1) step-vector 1)
			  initargs))))
    (setq start-vector (append (start-vector filter-1) (start-vector filter-2)))
    (setq step-vector (append (step-vector filter-1) (step-vector filter-2)))
    (setq kernel (array-cross-product (kernel filter-1) (kernel filter-2)))
    (with-result ((result nil)
		  `(:class separable-filter
		    :kernel ,kernel :filter-2 ,filter-2 :filter-1 ,filter-1
		    :start-vector ,start-vector :step-vector ,step-vector
		    ,@initargs)
		  'apply 'make-separable-filter 
		  (list-from-array (kernel filter-1))
		  (list-from-array (kernel filter-2))
		  :start-vector (cons 'list start-vector)
		  :step-vector (cons 'list step-vector)
		  initargs)
      result)))

;;;; in fft.lisp: call set-not-current on im if it is eq to the
;;;; real-part of the result.  
(defmethod fft ((im image) &key inverse center
		(pre-center center) (post-center center)
		dimensions ->)
  (with-result ((result ->) 
		(list :class 'complex-image
		      :dimensions (cond (dimensions dimensions)
					((complex-image-p ->) (dimensions ->))
					(t (padded-dimensions im))))
		'fft im :inverse inverse
		:pre-center pre-center :post-center post-center)
    (cond ((eq im (imaginary-part result))
	   (error "input image cannot be eq to imaginary part of result."))
	  ((eq im (real-part result))
	   (warn "input image is eq to real-part of result: it will be modified.")
	   (zero! (imaginary-part result))
	   (set-not-current (real-part result)))
	  (t
	   (zero! result)
	   (paste im (real-part result) :-> (real-part result))))
    (when pre-center
      (circular-shift (real-part result)
		      :x (truncate (x-dim im) -2)
		      :y (truncate (y-dim im) -2)
		      :-> (real-part result)))
    (array-fft (data (real-part result)) (data (imaginary-part result)) :inverse inverse)
    (when post-center
      (circular-shift result
		      :x (floor (x-dim result) 2)
		      :y (floor (y-dim result) 2)
		      :-> result))
    result))

;;;; fft.lisp: Allow result and im to be eq (and call set-not-current
;;;; if they are.) 
(defmethod fft ((im complex-image) &key
		inverse center dimensions
		(pre-center center) (post-center center)
		->)
  (with-result ((result ->)
		(list :class (clos::class-of im)
		      :dimensions (cond (dimensions dimensions)
					((complex-image-p ->) (dimensions ->))
					(t (padded-dimensions im))))
		'fft im :inverse inverse
		:pre-center pre-center :post-center post-center)
    (cond ((eq result im)
	   (set-not-current (real-part result))
	   (set-not-current (imaginary-part result)))
	  (t (zero! result)
	     (paste im result :-> result)))
    (when pre-center
      (circular-shift result
		      :x (truncate (x-dim im) -2)
		      :y (truncate (y-dim im) -2)
		      :-> result))
    (array-fft (data (real-part result)) (data (imaginary-part result)) :inverse inverse)
    (when post-center
      (circular-shift result
		      :x (floor (x-dim result) 2)
		      :y (floor (y-dim result) 2)
		      :-> result))
    result))

;;;; In fileio.lisp: Used to be busted for loading sub-sequences:
;;;; loaded into (frame i result)
(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 (1- data-files)))
    (with-result ((result ->) (list :class class
				    :dimensions dimensions
				    :length (1+ (- end-index start-index)))
		  'load-image-sequence path
		  :start-index start-index :end-index end-index)
      (loop for i from start-index to end-index
	    for n from 0 do
	    (image-from-datfile path :data-filename (format nil "data~a" i)
				:-> (frame n result)))
      result)))

;;;; image-pair.lisp: Replaced with-local-viewables with a let, since
;; complex-phase and magnitude are just accessors for polar images.
(defmethod polar-to-complex ((im polar-image) &key ->)
  (with-result ((result ->)
		(list :class 'complex-image :dimensions (dimensions im))
		'complex-to-polar im)
    (let ((phase (complex-phase im))
	  (mag (magnitude im)))
      (cos. phase :-> (real-part result))
      (sin. phase :-> (imaginary-part result))
      (mul (real-part result) mag :-> (real-part result))
      (mul (imaginary-part result) mag :-> (imaginary-part result)))
    result))

;;;; viewable-sequence.lisp: this had a typo
(defun make-viewable-sequence (vbl-list &rest initargs
					&key length sub-viewable-spec display-type name ->)
  (declare (ignore length sub-viewable-spec display-type name))
  (when -> (setf (getf initargs :name) ->))
  (unless (or (null vbl-list)
	      (and (listp vbl-list)
		   (every #'(lambda (x) (viewable-p x)) vbl-list)))
    (error "Bad vbl-list ~a: must be nil or a list of viewables" vbl-list))
  (with-result ((result nil)
		`(:class viewable-sequence
		  :viewable-list ,vbl-list
		  ,@initargs)
		'apply 'make-viewable-sequence vbl-list initargs)
    result))

;;;; viewable-sequence.lisp: the next three methods used to call
;;;; with-result, which set the sub-viewables not-current.
(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))
	  ((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 'viewable-sequence
			  :viewable-list appended-seq
			  :display-type (display-type seq1) :-> ->))
	  (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 'viewable-sequence
			  :viewable-list sub-seq
			  :display-type (display-type seq) :-> ->))
	  (t (error "bad result argument")))))

;;; New function: modeled on common Lisp reduce
(defmethod reduce. ((func function) (seq viewable-sequence)
		    &rest keys &key start end from-end initial-value ->)
  (declare (ignore start end from-end initial-value))
  (remf keys :->)
  (with-result ((res ->)
		(aref (data seq) 0 0)
		'apply 'reduce. seq keys)
    (let ((vect (subseq (vectorize (data seq)) start end)))
      (apply #'reduce
	     #'(lambda (v1 v2) (funcall func v1 v2 :-> res))
	     vect
	     keys))
    res))

(defmethod reduce. ((seq viewable-sequence) (func function) &rest keys)
  (apply 'reduce. func seq keys))

;;; new function, modeled on common lisp map.  rgs can be more
;;; sequences, and a :-> argument.
(defmethod map. ((func function) (seq viewable-sequence) &rest args)
  (let* ((key-pos (position :-> args))
	 (res-arg (when key-pos (nth (1+ key-pos) args)))
	 (other-seqs (if key-pos (subseq args 0 key-pos) args))
	 (len (loop for s in (cons seq other-seqs) minimize (length. s)))
	 results)
    (when (and (viewable-sequence-p res-arg)
    	       (/= (length. res-arg) len))
      (error "Result sequence should be of length ~A" len))
    (setq results
	  (loop for i from 0 below len
		for res-vbl = (when (viewable-sequence-p res-arg) (frame res-arg i))
		for other-vbls = (mapcar #'frame (circular-list i) other-seqs)
		collect
		(apply func (frame seq i)
		       (append other-vbls (when res-vbl (list :-> res-vbl))))))
    (cond ((viewable-sequence-p res-arg)
	   res-arg)
	  ((every #'(lambda (x) (viewable-p x)) results)
	   (make-viewable-sequence results :-> res-arg))
	  ((notany #'(lambda (x) (viewable-p x)) results)
	   results)
	  (t (mapc #'(lambda (x) (when (viewable-p x) (destroy x))) results)
	     (error "Results are a mixture of viewables and non-viewables!")))))

;;; generic-ops.lisp: Add these (if user passes function first as in
;;; mapcar or apply).
(defmethod point-operation ((func function) thing &rest keys)
  (apply 'point-operation thing func keys))

(defmethod point-operation ((func discrete-function) thing &rest keys)
  (apply 'point-operation thing func keys))

;;;; misc.lisp (new): make a circular list containg thing as all of its elements
;;; CAREFUL USING THESE: YOU MIGHT END UP IN INFINITE LOOPS!!
(defun circular-list (thing)
  (let ((res (list thing)))
    (setf (cdr res) res)
    res))

;;;; Array-ops.lisp: current version makes no sense (checks that
;;;; vector is square???).  This breaks on non-numerical vectors!
(defmethod symmetric-p ((v vector) &rest args)
  (declare (ignore args))
  (loop with symm = t
	for i from 0 below (floor (length v) 2)
	for N-i = (- (length v) 1) then (- N-i 1)
	while (setq symm (almost-equal (aref v i) (aref v N-i)))
	finally (return (and symm t))))

(defmethod symmetric-p ((l cons) &rest args)
  (declare (ignore args))
  (every 'almost-equal l (reverse (nthcdr (floor (length l) 2) l))))

(export '(anti-symmetric-p))
(defmethod anti-symmetric-p ((v vector) &rest args)
  (declare (ignore args))
  (loop with asymm = t
	for i from 0 below (floor (length v) 2)
	for N-i = (- (length v) 1) then (- N-i 1)
	while (setq asymm (almost-equal (- (aref v i)) (aref v N-i)))
	finally (return (and asymm t))))

(defmethod anti-symmetric-p ((l cons) &rest args)
  (declare (ignore args))
  (every #'(lambda (a b) (almost-equal a (- b))) l (reverse (nthcdr (floor (length l) 2) l))))

;;;; matrix.lisp: new functions
(export '(constant-vector vector-length2 weighted-vector-length2))

;;; To match identity-matrix
(defun constant-vector (size value &key ((:-> res)))
  (cond ((null res)
	 (make-array size :element-type 'single-float
		     :initial-element (coerce value 'single-float)))
	((and (typep res '(array single-float (*)))
	      (= (length res) size))
	 (fill! res value)
	 res)
	(t (error "result argument is not a single-float vector of length ~A"
		  size))))

(defmethod vector-length2 ((arr array))
  (dot-product arr arr))

(defmethod weighted-vector-length2 ((vect vector) (mat array))
  (dot-product (matrix-mul vect mat) vect))

;;;; In  TODO:

;;; modify viewable-matrix ops so that they have the same default
;;; keywords as the ops on the sub-viewables.  These keep becoming
;;; inconsistent!!  We probably want to write apply-unary-vm-ops that
;;; can operate on the keyword list.

;;; Write circular-shift on general arrays/lists.

;;; list-ops are inefficient: should loop over list, instead of using nth.

;;; Normalize on vectors (in matrix.lisp) should call C code.

;;; outer-product on viewable-sequences should check if the sequences
;;; are eq (a common case) and then only do half as many computations.

;;; fileio: raw-files.lisp containing  data writers/readers (with skip-bytes)
;;;         dat-files.lisp containing datfile stuff
;;;         generic-files.lisp for reading general CLOS objects.

;;;; In doc:

;;; Document compile-if-necessary, especially :compiler-optimizations and
;;; :umask.