;;; -*- Mode: LISP; Package: :cl-user; BASE: 10; Syntax: ANSI-Common-Lisp; -*-
;;;
;;;   Touched: Sun Jun 26 15:55:19 2005 +0530
;;;   Time-stamp: <05/09/18 09:14:57 madhu>
;;;
(in-package "WEYLI")


;;; ----------------------------------------------------------------------
;;;
;;;
(defmethod one ((domain free-module))
  (let ((dim (dimension-of domain))
	(one (one (coefficient-domain-of domain))))
    (make-instance (first (domain-element-classes domain))
		   :domain domain
		   :values (make-array dim :initial-element one))))

;;; ----------------------------------------------------------------------
;;; madhu 050626 - patches for matrix.lisp
;;;

;; XXX NOTE: this produces a WRONG RESULT if scalar is actually a
;; vector, TODO CHECK
;;
(defun multiply-matrix-by-scalar (matrix scalar  &optional
				  (target-domain (coefficient-domain-of
						  (domain-of matrix)))
				  ans)
  (let* ((dims (multiple-value-list (matrix-dimensions matrix)))
	 (ans (or ans (make-array dims))))
    (assert (= (length dims) 2))
    (loop for x1 below (car dims) do
	  (loop for x2 below (cadr dims) do
		(setf (aref ans x1 x2)
		      (coerce (* scalar (ref matrix x1 x2)) target-domain))))
    (make-element (get-matrix-space target-domain) ans)))

;; (weyli::multiply-matrix-by-scalar $c $p1)


;; treat vectors as colunm vectors
(defmethod coerce ((v free-module-element) (matrix-space matrix-space))
  "Coerce v to be a column vector"
  (make-element matrix-space
		(loop for x across (tuple-value v)
		      collect (list x))))


(defmethod transpose ((v free-module-element))
  "Treat v as a column vector and produce a matrix"
  (transpose (coerce v (get-matrix-space (coefficient-domain-of
					  (domain-of v))))))

;;;
;;;
;;; The following are modeled on the around methods in vector.lisp.
;;;

(defmethod times :around ((matrix matrix-space-element) scalar)
  (let ((coeff-domain (coefficient-domain-of (domain-of matrix)))
	(coerced-scalar nil))
    (cond ((and *coerce-where-possible*
		;; Don't clobber the arg, the next cluase needs it
		(setq coerced-scalar (coercible? scalar coeff-domain)))
	   (multiply-matrix-by-scalar matrix coerced-scalar))
	  ((typep scalar 'matrix-space-element)	; XXX
	   (call-next-method))
	  ((typep scalar 'free-module-element)
	   ;; madhu: implicitly treat `scalar' as a column-vector! XXX
	   (times matrix (coerce scalar (domain-of matrix)))
	   ;; otherwise we might do:
	   #+ignore(matrix-fme-times matrix scalar))
	  (t (multiply-matrix-by-scalar matrix scalar)))))

(defmethod times :around (scalar (matrix matrix-space-element))
  (let ((coeff-domain (coefficient-domain-of (domain-of matrix)))
	(coerced-scalar nil))
    (cond ((and *coerce-where-possible*
		;; Don't clobber the arg, the next clause needs it
		(setq coerced-scalar (coercible? scalar coeff-domain)))
	   (multiply-matrix-by-scalar matrix coerced-scalar))
	  ((typep scalar 'free-module-element)
	   ;; madhu: implicitly treat scalar as a row vector! XXX
	   (times (transpose (coerce scalar (domain-of matrix))) matrix)
	   ;; or we might do:
	   #+ignore(fme-matrix-times scalar matrix))
	  ((typep scalar 'matrix-space-element)	; XXX
	   (call-next-method))
	  (t (multiply-matrix-by-scalar matrix scalar)))))


;;;  madhu 0506026 these are not enough!
;;;
;;; must patch these functions from vector.lisp. I include RZ's
;;; original comment BECAUSE I dont understand it, or think it is no
;;; longer applicable.


(defmethod times :around (scalar (vector free-module-element))
  (let ((coeff-domain (coefficient-domain-of (domain-of vector)))
	(coerced-scalar nil))
    (cond ((and *coerce-where-possible*
		;; Don't clobber the arg, the next cluase needs it
		(setq coerced-scalar (coercible? scalar coeff-domain)))
	   (multiply-vector-by-scalar vector coerced-scalar))
	  ((typep scalar 'matrix-space-element)	;; madhu
	   (call-next-method))
	  ((typep scalar 'free-module-element)
	   (call-next-method))
	  (t (multiply-vector-by-scalar vector scalar)))))


;; The :around methods for this method and the next are not really
;; needed since they are chosen in preference other similar methods
;; since they have a more specialized first argument.  Nonetheless,
;; I'm leaving the :around's here for symmetry and emphasis.
;;  --RZ 7/12/94
(defmethod times :around ((vector free-module-element) scalar)
  (let ((coeff-domain (coefficient-domain-of (domain-of vector)))
	(coerced-scalar nil))
    (cond ((and *coerce-where-possible*
		;; Don't clobber the arg, the next cluase needs it
		(setq coerced-scalar (coercible? scalar coeff-domain)))
	   (multiply-vector-by-scalar vector coerced-scalar))
	  ((typep scalar 'matrix-space-element)
	   (call-next-method))
	  ((typep scalar 'free-module-element)
	   (call-next-method))
	  (t (multiply-vector-by-scalar vector scalar)))))


;;;
;;;
;;;
;;; madhu 050909 This is not used as it is a bad idea.
(defmacro define-fme-matrix-standard-methods 	        ;; madhu
   (real-op
     &aux (op (find-symbol (format nil "MAKE-GE-~A" real-op))))
  "Allow variables to be multiplied with matrices and vectors"

  `(progn
     (defmethod ,real-op ((x free-module-element) (y symbol))
       (,op *general* (list x (coerce y *general*))))

     (defmethod ,real-op ((x symbol) (y free-module-element))
       (,op *general* (list (coerce x *general*) y)))

     (defmethod ,real-op ((x matrix-space-element) (y symbol))
       (,op *general* (list x (coerce y *general*))))

     (defmethod ,real-op ((x symbol) (y matrix-space-element))
       (,op *general* (list (coerce x *general*) y)))))


#+nil
(define-fme-matrix-standard-methods plus)



;;; ----------------------------------------------------------------------
;;; Sun Sep 11 12:47:11 2005 +0530

;;; only CL:FLOAT arguments are SIMPLIFYied with the cl function
;;; corresponding to known GE-FUNCTION. since SIMPLIFY on a
;;; GE-APPLICATION produces only a GE-APPLICATION, and calls SIMPLIFY
;;; on its ARGS-OF, which in turn simplifies (complicates!) CL:FLOATS
;;; to WEYLI::NUMERICs there is no way the cl function gets called.
;;;
;;; This patches kludges SIMPLIFY in general.lisp to not treat
;;; floating point numbers as general expressions.

(defmethod simplify ((x ge-application))
  (let* ((args (mapcar (lambda (x)
			 (typecase x
			   (floating-point-number (fp-value x))
			   (t  (simplify x))))
		       (args-of x)))
	 (simplifier (getf (funct-of x) 'simplify))
	 (new-x  (apply #'make-ge-funct (domain-of x) (funct-of x) args)))
    (if simplifier
	(apply simplifier (domain-of x) new-x args)
	new-x)))