;;; dat/xml/svg.lisp --- SVG data encoders

 ;; based on https://github.com/orthecreedence/cl-svg-polygon

 ;;; Code:

 (in-package :dat/svg)

 ;;; MATRIX

 (defun id-matrix (dims)

   "Return a square identity matrix with the specified "

   (let ((array (make-array (* dims dims) :initial-element 0.0 :element-type 'single-float)))

     (dotimes (d dims)

       (setf (aref array (* d (1+ dims))) 1.0))

     array))

 (defun mat* (m1 m2)

   "Multiply 3x3 matrices m1 by m2."

   (let ((new (make-array 9 :initial-element 0.0 :element-type 'single-float)))

     (dotimes (x 3)

       (dotimes (y 3)

         (let ((prod (+ (* (aref m1 (* x 3)) (aref m2 y))

                        (* (aref m1 (+ (* x 3) 1)) (aref m2 (+ y 3)))

                        (* (aref m1 (+ (* x 3) 2)) (aref m2 (+ y 6))))))

           (setf (aref new (+ y (* x 3))) (coerce prod 'single-float)))))

     new))

 (defun matv* (m v)

   "Multiple a matrix by a vector, return the resulting vector."

   (let ((new (make-list 3))

         (vx (car v))

         (vy (cadr v))

         (vz 1))

     (dotimes (i 3)

       (setf (nth i new) (+ (* vx (aref m (* i 3)))

                            (* vy (aref m (+ (* i 3) 1)))

                            (* vz (aref m (+ (* i 3) 2))))))

     new))

 (defun m-rotate (degrees &key reverse)

   "Generate a rotation matrix."

   (let* ((matrix (id-matrix 3))

          (angle-rad (* (mod degrees 360) (/ PI 180)))

          (cos (coerce (cos angle-rad) 'single-float))

          (sin (coerce (sin angle-rad) 'single-float)))

     (setf (aref matrix 0) cos

           (aref matrix 1) (if reverse sin (- sin))

           (aref matrix 3) (if reverse (- sin) sin)

           (aref matrix 4) cos)

     matrix))

 (defun m-scale (x y)

   "Generate a scaling matrix."

   (let ((matrix (id-matrix 3)))

     (setf (aref matrix 0)  (coerce x 'single-float)

           (aref matrix 4)  (coerce y 'single-float))

     matrix))

 (defun m-translate (x y)

   "Generate a translation matrix."

   (let ((translatrix (id-matrix 3)))

     (setf (aref translatrix 2) (coerce x 'single-float)

           (aref translatrix 5) (coerce y 'single-float))

     translatrix))

 (defun m-skew (degrees &key (axis :x))

   "Generate a skew matrix along the :axis axis (:x or :y)."

   (let ((matrix (id-matrix 3))

         (angle-rad (* (mod degrees 360) (/ PI 180)))

         (idx (if (equal axis :x) 1 3)))

     (setf (aref matrix idx) (coerce (tan angle-rad) 'single-float))

     matrix))

 ;;; VECTOR

 (defun norm (v)

   "Calculate a vector norm."

   (expt (loop for x in v sum (expt x 2)) .5))

 (defun normalize (v)

   "Normalize a 2D vector"

   (let ((x (car v))

         (y (cadr v)))

     (let ((norm (norm v)))

       (list (/ x norm) (/ y norm)))))

 (defun dot-prod (v1 v2)

   "Give the dot product of two 2D vectors."

   (+ (* (car v1) (car v2))

      (* (cadr v1) (cadr v2))))

 ;;; TRANSFORMATIONS

 (defun parse-transform (transform)

   "Turn a transform(...) into an easily-parsable list structure."

   ;; convert "translate(-10,-20) scale(2) rotate(45) translate(5,10)" into

   ;; "(translate -10 -20) (scale 2) (rotate 45) (translate 5 10)"

   ;; (ie read-from-string'able)

   (let* ((transform (cl-ppcre::regex-replace-all "([a-z]+)\\(" transform "(\\1 "))

          (transform (cl-ppcre::regex-replace-all "," transform " ")))

     (read-from-string (format nil "( ~a )" transform))))

 (defun get-transformations (object groups)

   "Given an SVG object and a tree of groups, grab all transformations, starting

    from the top down, into a flat list so they can be applied sequentially."

   (let ((object-transform (getf object :transform))

         (object-group (getf object :group))

         (transformations nil))

     (labels ((traverse-groups (path groups)

                (dolist (group groups)

                  (when (eql (car (getf group :group)) (car path))

                    (let* ((groups (getf group :groups))

                           (transform (getf group :transform))

                           (transform (if (listp transform) (car transform) transform)))

                      (when transform

                        (push transform transformations))

                      (when groups

                        (traverse-groups (cdr path) groups)))))))

       (traverse-groups object-group groups))

     (when object-transform

       (push object-transform transformations))

     transformations))

 (defun get-matrix-from-transformation (transformation)

   "Given a transformation in list form (FN ARG1 ARG2 ...), turn it into a matrix

   which can be multipled to give the overall transformation for an object."

   (macrolet ((idx (var idx default)

                (let ((name (gensym)))

                  `(let ((,name (nth ,idx ,var)))

                     (if ,name ,name ,default)))))

     (let ((transformation (if (listp (car transformation))

                               (car transformation)

                               transformation)))

       (case (intern (write-to-string (car transformation)) :dat/svg)

         (matrix (vector (nth 1 transformation) (nth 3 transformation) (nth 5 transformation)

                         (nth 2 transformation) (nth 4 transformation) (nth 6 transformation)

                         0 0 1))

         (translate (m-translate (nth 1 transformation) (idx transformation 2 0)))

         (scale (m-scale (nth 1 transformation) (idx transformation 2 0)))

         (rotate (let ((angle (nth 1 transformation))

                       (center-x (idx transformation 2 0))

                       (center-y (idx transformation 3 0)))

                   (if (and (eq 0 center-x) (eq 0 center-y))

                       ;; just rotate, no offset funny business

                       (m-rotate angle)

                       (mat* (mat* (m-translate center-x center-y) (m-rotate angle)) (m-translate (- center-x) (- center-y))))))

         (skewx (m-skew (nth 1 transformation) :axis :x))

         (skewy (m-skew (nth 1 transformation) :axis :y))))))

 (defun apply-transformations (points object groups &key scale)

   "Apply all transformations for an object, starting from its top-level group

   and working down to the object itself."

   (let ((transformations (get-transformations object groups))

         (matrix (id-matrix 3))

         (trans-points nil))

     (dolist (transform transformations)

       (setf matrix (mat* (get-matrix-from-transformation transform) matrix)))

     (when scale

       (setf matrix (mat* (m-scale (car scale) (cadr scale)) matrix)))

     (loop for p across points do

       (push (butlast (matv* matrix (append p '(1)))) trans-points))

     (values (reverse trans-points)

             matrix)))

 ;;; PATHS

 (define-condition unsupported-path-command (error)

   ((text :initarg :text :reader text))

   (:documentation "Thrown when an unsupported action/feature is parsed in a path."))

 (defun points-close-equal-p (point1 point2 &key (precision 10))

   "Determine if two points are (about) the same. Yes, this is open to

    interpretation, which is why it takes a precision argument =]."

   (flet ((round-point (point)

            (mapcar (lambda (x) (/ (floor (* x precision)) precision)) point)))

     (equal (round-point point1) (round-point point2))))

 (defun replace-char (char rep str)

   "Replace all instances of char with rep in str (non-destructive)."

   (let ((new-str (make-string (length str))))

     (loop for i from 0

           for c across str do

       (setf (aref new-str i) (if (eq c char)

                                  rep

                                  c)))

     new-str))

 (defmacro cmd-repeat (args-and-count &body body)

   "Some commands can repeat values with the command, namely the curve commands:

        c,1,2,4,4,5,5 c,8,8,3,4,3,1

     can be written as

        c,1,2,4,4,5,5,8,8,3,4,3,1

   yay. This macro helps alleviate some of the issues caused by this wonderful

   feature in the get-points-from-path function."

   (let ((i (gensym))

         (a (gensym))

         (args (car args-and-count))

         (count (cadr args-and-count)))

     `(dotimes (,i (floor (/ (length ,args) ,count)))

        ,@body

        (setf cur-x (car cur-point)

              cur-y (cadr cur-point))

        (dotimes (,a ,count)

          (setf ,args (cdr ,args))))))

 (defun get-points-from-path (str-data &key (curve-resolution 10))

   "Given a string describing an SVG path, do our best to retrieve points along

   that path. Bezier curves are approximated as accurately as needed (defined by

   :curve-resolution).

   If the path generates an arc between x1,y1 and x2,y2, we just ignore the whole

   arc thing and set x2,y2 as the next point in the path.

   If Z/z ends the path in the middle, we silently return the current set of 

   points without continuing the path. The idea here is we are generating

   polygons so breaks or cutouts are not acceptable."

     (let ((commands (print (split "(?=[a-zA-Z])" str-data)))

           (scanner-empty-p (cl-ppcre:create-scanner (concatenate 'string "[" *whitespaces* "]") :multi-line-mode t))

           (points nil)

         (parts nil)

         (first-point nil)

         (cur-point '(0 0))

         (last-anchor nil)

         (disconnected nil))

     (dolist (cmd-str commands)

       ;; this (let) splits the command from "M-113-20" to

       ;; ("M" "-113" "-20")

       (let* ((cmd-parts (cl-ppcre:split "( |,|(?<=[A-Za-z])|(?=\-))" cmd-str))

              (cmd (aref (car cmd-parts) 0))

              ;(forget (format t "cmd: ~s~%" cmd-parts))

              (args (remove-if #'null (mapcar (lambda (a)

                                                (if (cl-ppcre:scan scanner-empty-p a)

                                                    nil

                                                    (read-from-string a)))

                                              (cdr cmd-parts))))

              (cur-x (car cur-point))

              (cur-y (cadr cur-point)))

         ;; process the commands (http://www.w3.org/TR/SVG/paths.html)

         (case (if (eq cmd #\z)

                   (aref (string-upcase cmd) 0)

                   cmd)

           (#\M

            (cmd-repeat (args 2)

              (setf cur-point args)

              (push cur-point points)))

           (#\m

            (cmd-repeat (args 2)

              (setf cur-point (list (+ cur-x (car args))

                                    (+ cur-y (cadr args))))

              (push cur-point points)))

           (#\L

            (cmd-repeat (args 2)

              (setf cur-point args)

              (push cur-point points)))

           (#\l

            (cmd-repeat (args 2)

              (setf cur-point (list (+ cur-x (car args))

                                    (+ cur-y (cadr args))))

              (push cur-point points)))

           (#\H

            (cmd-repeat (args 1)

              (setf (car cur-point) (car args))

              (push cur-point points)))

           (#\h

            (cmd-repeat (args 1)

              (setf (car cur-point) (+ cur-x (car args)))

              (push cur-point points)))

           (#\V

            (cmd-repeat (args 1)

              (setf (cadr cur-point) (car args))

              (push cur-point points)))

           (#\v

            (cmd-repeat (args 1)

              (setf (cadr cur-point) (+ cur-y (car args)))

              (push cur-point points)))

           (#\C

            (cmd-repeat (args 6)

              (let ((x1 (car args))

                    (y1 (cadr args))

                    (x2 (nth 2 args))

                    (y2 (nth 3 args))

                    (x (nth 4 args))

                    (y (nth 5 args)))

                (setf points (append (bezier-cubic cur-x cur-y x y x1 y1 x2 y2 :resolution curve-resolution) points)

                      last-anchor (list x2 y2)

                      cur-point (list x y)))))

           (#\c

            (cmd-repeat (args 6)

              (let ((x1 (+ (car args) cur-x))

                    (y1 (+ (cadr args) cur-y))

                    (x2 (+ (nth 2 args) cur-x))

                    (y2 (+ (nth 3 args) cur-y))

                    (x (+ (nth 4 args) cur-x))

                    (y (+ (nth 5 args) cur-y)))

                (setf points (append (bezier-cubic cur-x cur-y x y x1 y1 x2 y2 :resolution curve-resolution) points)

                      last-anchor (list x2 y2)

                      cur-point (list x y)))))

           (#\S

            (cmd-repeat (args 4)

              (let ((x1 (+ cur-x (- cur-x (car last-anchor))))

                    (y1 (+ cur-y (- cur-y (cadr last-anchor))))

                    (x2 (car args))

                    (y2 (cadr args))

                    (x (nth 2 args))

                    (y (nth 3 args)))

                (setf points (append (bezier-cubic cur-x cur-y x y x1 y1 x2 y2 :resolution curve-resolution) points)

                      last-anchor (list x2 y2)

                      cur-point (list x y)))))

           (#\s

            (cmd-repeat (args 4)

              (let ((x1 (+ cur-x (- cur-x (car last-anchor))))

                    (y1 (+ cur-y (- cur-y (cadr last-anchor))))

                    (x2 (+ (car args) cur-x))

                    (y2 (+ (cadr args) cur-y))

                    (x (+ (nth 2 args) cur-x))

                    (y (+ (nth 3 args) cur-y)))

                (setf points (append (bezier-cubic cur-x cur-y x y x1 y1 x2 y2 :resolution curve-resolution) points)

                      last-anchor (list x2 y2)

                      cur-point (list x y)))))

           (#\Q

            (cmd-repeat (args 4)

              (let ((x1 (car args))

                    (y1 (cadr args))

                    (x (nth 2 args))

                    (y (nth 3 args)))

                (setf points (append (bezier-quadratic cur-x cur-y x y x1 y1 :resolution curve-resolution) points)

                      last-anchor (list x1 y1)

                      cur-point (list x y)))))

           (#\q

            (cmd-repeat (args 4)

              (let ((x1 (+ (car args) cur-x))

                    (y1 (+ (cadr args) cur-y))

                    (x (+ (nth 2 args) cur-x))

                    (y (+ (nth 3 args) cur-y)))

                (setf points (append (bezier-quadratic cur-x cur-y x y x1 y1 :resolution curve-resolution) points)