paths-annotation.lisp

   1 ;;;; cl-vectors -- Rasterizer and paths manipulation library
   2 ;;;; Copyright (C) 2007  Frédéric Jolliton <frederic@jolliton.com>
   3 ;;;;
   4 ;;;; This library is free software; you can redistribute it and/or
   5 ;;;; modify it under the terms of the Lisp Lesser GNU Public License
   6 ;;;; (http://opensource.franz.com/preamble.html), known as the LLGPL.
   7 ;;;;
   8 ;;;; This library is distributed in the hope that it will be useful, but
   9 ;;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  10 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the Lisp
  11 ;;;; Lesser GNU Public License for more details.
  12
  13 (in-package #:net.tuxee.paths)
  14
  15 ;;;--[ Path annotation ]-----------------------------------------------------
  16
  17 (defun path-annotated (paths &key (include-tangents nil) (decimate-knots t) (assume-type nil))
  18   "Annotate the path with visual effect (like color for each type
  19 of interpolation, circle to represent knots,..)
  20
  21 path -- a path or a list of path
  22
  23 Return a list of (color . paths)."
  24   (let (layer-surface
  25         layer-lines
  26         layer-arcs
  27         layer-bezier
  28         layer-bezier-cpl
  29         layer-bezier-cp
  30         layer-catmull-rom
  31         layer-catmull-rom-cp
  32         layer-knots
  33         layer-implicit
  34         layer-tangents)
  35     (dolist (path (if (listp paths) paths (list paths)))
  36       (let ((path-type (or assume-type (path-type path))))
  37         (when (plusp (path-size path))
  38           ;;
  39           ;; Surfaces
  40           ;;
  41           (unless (eq path-type :open-polyline)
  42             (push path layer-surface))
  43           ;;
  44           ;; Interpolations
  45           ;;
  46           (loop with iterator = (path-iterator path)
  47              for stop-p = nil then end-p
  48              for k1 = nil then k2
  49              for (interpolation k2 end-p) = (multiple-value-list (path-iterator-next iterator))
  50              until stop-p
  51              when k1
  52              do
  53              ;;
  54              ;; Tangents
  55              ;;
  56              (when include-tangents
  57                (let ((t1 (interpolation-normal interpolation k1 k2 nil))
  58                      (t2 (interpolation-normal interpolation k1 k2 t)))
  59                  (when t1
  60                    (setf layer-tangents
  61                          (nconc (stroke-path
  62                                  (make-simple-path
  63                                   (list k1 (p+ k1 (p* t1 25.0)))) 1.0)
  64                                 layer-tangents)))
  65                  (when t2
  66                    (setf layer-tangents
  67                          (nconc (stroke-path
  68                                  (make-simple-path
  69                                   (list k2 (p+ k2 (p* t2 25.0)))) 1.0)
  70                                 layer-tangents)))))
  71              ;;
  72              ;; Interpolation
  73              ;;
  74              (etypecase interpolation
  75                ((eql :straight-line)
  76                 (setf layer-lines
  77                       (nconc (stroke-path (make-simple-path (list k1 k2)) 1.0)
  78                              layer-lines)))
  79                (bezier
  80                 (let ((control (create-path :open-polyline)))
  81                   (path-reset control k1)
  82                   (loop for cp across (slot-value interpolation 'control-points)
  83                      do (path-extend control (make-straight-line) cp)
  84                      (push (make-circle-path (point-x cp) (point-y cp) 5.0)
  85                            layer-bezier-cp)
  86                      (push (path-reversed (make-circle-path (point-x cp) (point-y cp) 3.5))
  87                            layer-bezier-cp))
  88                   (path-extend control (make-straight-line) k2)
  89                   (push (first (stroke-path control 1.0))
  90                         layer-bezier-cpl))
  91                 (let ((arc (create-path :open-polyline)))
  92                   (path-reset arc k1)
  93                   (path-extend arc interpolation k2)
  94                   (push (first (stroke-path (make-discrete-path arc) 1.0))
  95                         layer-bezier)))
  96                (arc
  97                 (let ((arc (create-path :open-polyline)))
  98                   (path-reset arc k1)
  99                   (path-extend arc interpolation k2)
 100                   (setf layer-arcs
 101                         (nconc (stroke-path (make-discrete-path arc) 1.0)
 102                                layer-arcs))))
 103                (catmull-rom
 104                 (loop for cp in (list* (slot-value interpolation 'head)
 105                                        (slot-value interpolation 'queue)
 106                                        (coerce (slot-value interpolation 'control-points)
 107                                                'list))
 108                    do
 109                    (push (make-circle-path (point-x cp) (point-y cp) 5.0)
 110                          layer-catmull-rom-cp)
 111                    (push (path-reversed (make-circle-path (point-x cp) (point-y cp) 3.5))
 112                          layer-catmull-rom-cp))
 113                 (let ((spline (create-path :open-polyline)))
 114                   (path-reset spline k1)
 115                   (path-extend spline interpolation k2)
 116                   (push (first (stroke-path (make-discrete-path spline) 1.0))
 117                         layer-catmull-rom)))))
 118           ;;
 119           ;; Implicit straight line
 120           ;;
 121           (unless (eq path-type :open-polyline)
 122             (let ((k1 (aref (path-knots path) (1- (length (path-knots path)))))
 123                   (i2 (aref (path-interpolations path) 0))
 124                   (k2 (aref (path-knots path) 0))
 125                   (path (create-path :open-polyline)))
 126               (path-reset path k1)
 127               (path-extend path i2 k2)
 128               (setf layer-implicit
 129                     (nconc (stroke-path (dash-path path #(5 5)) 1.0)
 130                            layer-implicit))))
 131           ;;
 132           ;; Knots (decimated)
 133           ;;
 134           (loop with knots = (path-knots path)
 135              with last-added-knot = nil
 136              with first-knot = t
 137              with second-knot = nil
 138              for i below (length knots)
 139              for knot = (aref knots i)
 140              for last-knot = (= i (- (length knots) 1))
 141              do (when (or (not decimate-knots)
 142                           last-knot
 143                           (null last-added-knot)
 144                           (> (point-distance last-added-knot knot) 10))
 145                   (when first-knot
 146                     (push (make-circle-path (point-x knot) (point-y knot) 8.0)
 147                           layer-knots)
 148                     (push (path-reversed (make-circle-path (point-x knot) (point-y knot) 6.5))
 149                           layer-knots))
 150                   (push (make-circle-path (point-x knot) (point-y knot) 5.0)
 151                         layer-knots)
 152                   (unless second-knot
 153                     (push (path-reversed (make-circle-path (point-x knot) (point-y knot) 3.5))
 154                           layer-knots))
 155                   (setf last-added-knot knot
 156                         second-knot first-knot
 157                         first-knot nil))))))
 158     ;; Put everything together
 159     (list (cons #(230 245 255) (nreverse layer-surface))
 160           (cons #(90 120 180) (nreverse layer-implicit))
 161           (cons #(90 120 180) (nreverse layer-lines))
 162           (cons #(255 0 0) (nreverse layer-tangents))
 163           (cons #(255 0 255) (nreverse layer-arcs))
 164           (cons #(255 0 0) (nreverse layer-bezier))
 165           (cons #(0 255 0) (nreverse layer-catmull-rom))
 166           (cons #(255 128 0) (nreverse layer-bezier-cpl))
 167           (cons #(0 0 255) (nreverse layer-knots))
 168           (cons #(100 100 100) (nreverse layer-catmull-rom-cp))
 169           (cons #(255 0 0) (nreverse layer-bezier-cp)))))