;;; Beta quality code - use at own risk

;;; Copyright (C) 2010 Anders Waldenborg
;;; I'll add a GPL header or something like that here later...

; We handle the tranformation matrix (but let svg do the actual projection).
; So we need some stuff to handle matrices...

(defconst vrend-2pi (* 8.0 (atan 1.0)))

(defun vrend--mtx-col (mtx col)
  "Get column col in matrix mtx"
  (mapcar '(lambda (v) (aref v col)) mtx))

(defun vrend--mtx-row (mtx row)
  "Get row row in matrix mtx"
  (mapcar 'identity (aref mtx row)))

(defun vrend--mtx-ref (i j)
  (aref (aref vrend--curr-mtx i) j))

(defun vrend--dotprod (l r)
  "dot product of l and r"
  (if (or l r)
      (+ (* (car l) (car r)) (vrend--dotprod (cdr l) (cdr r)))
    0))

(defun vrend--mtx-mul3x3 (l r)
  `[[,(vrend--dotprod (vrend--mtx-row l 0) (vrend--mtx-col r 0)) ,(vrend--dotprod (vrend--mtx-row l 0) (vrend--mtx-col r 1)) ,(vrend--dotprod (vrend--mtx-row l 0) (vrend--mtx-col r 2))]
    [,(vrend--dotprod (vrend--mtx-row l 1) (vrend--mtx-col r 0)) ,(vrend--dotprod (vrend--mtx-row l 1) (vrend--mtx-col r 1)) ,(vrend--dotprod (vrend--mtx-row l 1) (vrend--mtx-col r 2))]
    [,(vrend--dotprod (vrend--mtx-row l 2) (vrend--mtx-col r 0)) ,(vrend--dotprod (vrend--mtx-row l 2) (vrend--mtx-col r 1)) ,(vrend--dotprod (vrend--mtx-row l 2) (vrend--mtx-col r 2))]])

(defun vrend--mtx-translate (dx dy)
  "translationmatrix for dx dy"
  `[[1.0 0.0 ,dx]
    [0.0 1.0 ,dy]
    [0.0 0.0 1.0]])

(defun vrend--mtx-rotate (rot)
  ""
  `[[,(cos rot) ,(- (sin rot)) 0.0]
    [,(sin rot)  ,(cos rot)     0.0]
    [       0.0         0.0    1.0]])

(defun vrend--mtx-scale (sx sy)
  ""
  `[[,sx 0.0 0.0]
    [0.0 ,sy 0.0]
    [0.0 0.0 1.0]])

(defun vrend--mtx-ident ()
  ""
  [[1.0 0.0 0.0]
   [0.0 1.0 0.0]
   [0.0 0.0 1.0]])

(defun vrend-path-start (x y)
  (setq vrend--curr-path nil)
  (vrend-path-moveto x y))

(defun vrend-path-moveto (x y)
  (add-to-list 'vrend--curr-path (list ?M x y)))

(defun vrend-path-lineto (x y)
  (add-to-list 'vrend--curr-path (list ?L x y)))

(defun vrend-path-close ()
  (add-to-list 'vrend--curr-path (list ?Z)))

(defun vrend-rotate (deg)
  (setq vrend--curr-mtx (vrend--mtx-mul3x3 vrend--curr-mtx (vrend--mtx-rotate deg))))

(defun vrend-scale (sx sy)
  (setq vrend--curr-mtx (vrend--mtx-mul3x3 vrend--curr-mtx (vrend--mtx-scale (float sx) (float sy)))))

(defun vrend-translate (dx dy)
  (setq vrend--curr-mtx (vrend--mtx-mul3x3 vrend--curr-mtx (vrend--mtx-translate (float dx) (float dy)))))

(defun vrend--render-path-element (e)
  (format "%c %s" (car e) (mapconcat '(lambda (x) (format "%f" x)) (cdr e) " ")))

(defun vrend--render-path ()
  (insert " d=\"" (mapconcat 'vrend--render-path-element (reverse vrend--curr-path) " ") "\""))

(defun vrend--render-transform ()
  (insert (format " transform=\"matrix(%f %f %f %f %f %f)\"" (vrend--mtx-ref 0 0) (vrend--mtx-ref 1 0) (vrend--mtx-ref 0 1) (vrend--mtx-ref 1 1) (vrend--mtx-ref 0 2) (vrend--mtx-ref 1 2))))

(defun vrend-path-stroke ()
  (insert "  <path")
  (vrend--render-path)
  (vrend--render-transform)
  (insert " fill=\"none\"")
  (insert " stroke=\"" (car vrend--curr-strokestyle) "\"")
  (insert " stroke-width=\"0.04\"")
  (insert " />\n"))

(defmacro vrend-with-saved-matrix (&rest body)
  (declare (indent 0) (debug t))
  `(let ((vrend-with-saved-matrix-saved-matrix vrend--curr-mtx))
     (progn
       ,@body
       (setq vrend--curr-mtx vrend-with-saved-matrix-saved-matrix))))

(defmacro vrend (width height coordinatetype &rest body)
  (declare (indent 3) (debug t))
  (let ((width (eval width))
	(height (eval height)))
  `(with-temp-buffer
      (set (make-local-variable 'vrend--curr-mtx) (vrend--mtx-ident))
      (set (make-local-variable 'vrend--curr-path) nil)
      (set (make-local-variable 'vrend--curr-strokestyle) '("black" :width 1))
      (set (make-local-variable 'vrend--curr-fillstyle) nil)

      (insert "<?xml version=\"1.0\" standalone=\"no\"?>\n"
	      "<!DOCTYPE svg PUBLIC \"-//W3C//DTD SVG 1.1//EN\"\n"
	      "  \"http://www.w3.org/Graphics/SVG/1.1/DTD/svg11.dtd\">\n"
	      (format "<svg width=\"%d\" height=\"%d\"\n" ,width ,height)
	      "     xmlns=\"http://www.w3.org/2000/svg\" version=\"1.1\">\n")


      (when ,coordinatetype
	(vrend-translate ,(/ width 2) ,(/ height 2))

	(when (eq ,coordinatetype '1x1fit)
	  (let ((smalldir ,(min width height)))
	    (vrend-scale (/ smalldir 2.0) (/ smalldir 2.0))))

	(when (eq ,coordinatetype '1x1square)
	  (vrend-scale ,(/ width 2.0) ,(/ height 2.0)))

	(vrend-scale -1.0 -1.0))

      (progn
	,@body)

      (insert "</svg>\n")
      (create-image (buffer-string) nil t)
      )))

(provide 'vrend)