drawing.lisp

   1 ;;; Copyright (c) 2007 Zachary Beane, All Rights Reserved
   2 ;;;
   3 ;;; Redistribution and use in source and binary forms, with or without
   4 ;;; modification, are permitted provided that the following conditions
   5 ;;; are met:
   6 ;;;
   7 ;;;   * Redistributions of source code must retain the above copyright
   8 ;;;     notice, this list of conditions and the following disclaimer.
   9 ;;;
  10 ;;;   * Redistributions in binary form must reproduce the above
  11 ;;;     copyright notice, this list of conditions and the following
  12 ;;;     disclaimer in the documentation and/or other materials
  13 ;;;     provided with the distribution.
  14 ;;;
  15 ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
  16 ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
  17 ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
  18 ;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
  19 ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
  20 ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
  21 ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
  22 ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
  23 ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
  24 ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
  25 ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  26 ;;;
  27 ;;; $Id: drawing.lisp,v 1.17 2007/10/01 19:05:13 xach Exp $
  28
  29 (in-package #:vecto)
  30
  31 (deftype octet ()
  32   '(unsigned-byte 8))
  33
  34 (deftype vector-index ()
  35   `(mod ,array-dimension-limit))
  36
  37 (deftype octet-vector ()
  38   '(simple-array (unsigned-byte 8) (*)))
  39
  40 (defun nonzero-winding-alpha (alpha)
  41   (min 255 (abs alpha)))
  42
  43 (defun even-odd-alpha (alpha)
  44   (let ((value (mod alpha 512)))
  45     (min 255 (if (< value 256) value (- 512 value)))))
  46
  47 ;; ( (t) = (a) * (b) + 0x80, ( ( ( (t)>>8 ) + (t) )>>8 ) )
  48
  49 (defun imult (a b)
  50   (let ((temp (+ (* a b) #x80)))
  51     (logand #xFF (ash (+ (ash temp -8) temp) -8))))
  52
  53 (defun lerp (p q a)
  54   (logand #xFF (+ p (imult a (- q p)))))
  55
  56 (defun prelerp (p q a)
  57   (logand #xFF (- (+ p q) (imult a p))))
  58
  59 (defun draw-function (data width height r.fg g.fg b.fg a.fg alpha-fun)
  60   "From http://www.teamten.com/lawrence/graphics/premultiplication/"
  61   (declare (ignore height))
  62   (let ((r.fg (float-octet r.fg))
  63         (g.fg (float-octet g.fg))
  64         (b.fg (float-octet b.fg))
  65         (a.fg (float-octet a.fg)))
  66     (lambda (x y alpha)
  67       (setf alpha (funcall alpha-fun alpha))
  68       (when (plusp alpha)
  69         (let* ((i (* +png-channels+ (+ x (* y width))))
  70                (r.bg (aref data (+ i 0)))
  71                (g.bg (aref data (+ i 1)))
  72                (b.bg (aref data (+ i 2)))
  73                (a.bg (aref data (+ i 3)))
  74                (a.fg (imult alpha a.fg))
  75                (gamma (prelerp a.fg a.bg a.bg)))
  76           (flet ((blend (fg bg)
  77                    (let ((value (lerp (imult bg a.bg) fg a.fg)))
  78                      (float-octet (/ value gamma)))))
  79             (unless (zerop gamma)
  80               (setf (aref data (+ i 0)) (blend r.fg r.bg)
  81                     (aref data (+ i 1)) (blend g.fg g.bg)
  82                     (aref data (+ i 2)) (blend b.fg b.bg)))
  83             (setf (aref data (+ i 3)) gamma)))))))
  84
  85 (defun draw-function/clipped (data clip-data
  86                               width height
  87                               r.fg g.fg b.fg a.fg
  88                               alpha-fun)
  89   "Like DRAW-FUNCTION, but uses uses the clipping channel."
  90   (declare (ignore height))
  91   (let ((r.fg (float-octet r.fg))
  92         (g.fg (float-octet g.fg))
  93         (b.fg (float-octet b.fg))
  94         (a.fg (float-octet a.fg)))
  95     (lambda (x y alpha)
  96       (let* ((clip-index (+ x (* y width)))
  97              (clip (aref clip-data clip-index)))
  98         (setf alpha (imult clip (funcall alpha-fun alpha)))
  99         (when (plusp alpha)
 100           (let* ((i (* clip-index +png-channels+))
 101                  (r.bg (aref data (+ i 0)))
 102                  (g.bg (aref data (+ i 1)))
 103                  (b.bg (aref data (+ i 2)))
 104                  (a.bg (aref data (+ i 3)))
 105                  (a.fg (imult alpha a.fg))
 106                  (gamma (prelerp a.fg a.bg a.bg)))
 107             (flet ((blend (fg bg)
 108                      (let ((value (lerp (imult bg a.bg) fg a.fg)))
 109                        (float-octet (/ value gamma)))))
 110               (unless (zerop gamma)
 111                 (setf (aref data (+ i 0)) (blend r.fg r.bg)
 112                       (aref data (+ i 1)) (blend g.fg g.bg)
 113                       (aref data (+ i 2)) (blend b.fg b.bg)))
 114               (setf (aref data (+ i 3)) gamma))))))))
 115
 116 (defun make-draw-function (data clipping-path
 117                            width height
 118                            r g b a
 119                            alpha-fun)
 120   (if (emptyp clipping-path)
 121       (draw-function data width height r g b a alpha-fun)
 122       (draw-function/clipped data (clipping-data clipping-path)
 123                              width height
 124                              r g b a
 125                              alpha-fun)))
 126
 127 (defun intersect-clipping-paths (data temp)
 128   (declare (type (simple-array (unsigned-byte 8) (*)) data temp))
 129   (map-into data #'imult temp data))
 130
 131 (defun draw-clipping-path-function (data width height alpha-fun)
 132   (declare (ignore height)
 133            (type (simple-array (unsigned-byte 8) (*)) data))
 134   (lambda (x y alpha)
 135     (let ((i (+ x (* width y))))
 136       (let ((alpha (funcall alpha-fun alpha)))
 137         (setf (aref data i) alpha)))))
 138
 139 (defun draw-paths (&key width height paths
 140                    transform-function
 141                    draw-function)
 142   "Use DRAW-FUNCTION as a callback for the cells sweep function
 143 for the set of paths PATHS."
 144   (let ((state (aa:make-state))
 145         (paths (mapcar (lambda (path)
 146                          ;; FIXME: previous versions lacked
 147                          ;; paths:path-clone, and this broke fill &
 148                          ;; stroke because transform-path damages the
 149                          ;; paths. It would be nicer if transform-path
 150                          ;; wasn't destructive, since I didn't expect
 151                          ;; it to be.
 152                          (transform-path (paths:path-clone path)
 153                                          transform-function))
 154                        paths)))
 155     (vectors:update-state state paths)
 156     (aa:cells-sweep/rectangle state 0 0 width height draw-function)))
 157
 158 ;;; FIXME: this was added for drawing text paths, but the text
 159 ;;; rendering mode could be changed in the future, making it a little
 160 ;;; silly to have a fixed draw-function.
 161
 162 (defun draw-paths/state (paths state)
 163   (draw-paths :paths paths
 164               :width (width state)
 165               :height (height state)
 166               :transform-function (transform-function state)
 167               :draw-function (fill-draw-function state)))
 168
 169 (defun fill-image (image-data red green blue alpha)
 170   "Completely fill IMAGE with the given colors."
 171   (let ((r (float-octet red))
 172         (g (float-octet green))
 173         (b (float-octet blue))
 174         (a (float-octet alpha)))
 175     (do ((h 0 (+ h 4))
 176          (i 1 (+ i 4))
 177          (j 2 (+ j 4))
 178          (k 3 (+ k 4)))
 179         ((<= (length image-data) k))
 180       (setf (aref image-data h) r
 181             (aref image-data i) g
 182             (aref image-data j) b
 183             (aref image-data k) a))))
 184
 185 (defun state-draw-function (state color fill-style)
 186   "Create a draw function for the graphics state STATE."
 187   (make-draw-function (image-data state)
 188                       (clipping-path state)
 189                       (width state)
 190                       (height state)
 191                       (red color)
 192                       (green color)
 193                       (blue color)
 194                       (alpha color)
 195                       (ecase fill-style
 196                         (:even-odd #'even-odd-alpha)
 197                         (:nonzero-winding #'nonzero-winding-alpha))))
 198
 199 (defun stroke-draw-function (state)
 200   (state-draw-function state (stroke-color state) :nonzero-winding))
 201
 202 (defun fill-draw-function (state)
 203   (state-draw-function state (fill-color state) :nonzero-winding))
 204
 205 (defun even-odd-fill-draw-function (state)
 206   (state-draw-function state (fill-color state) :even-odd))
 207
 208 (defun tolerance-scale (state)
 209   (let ((matrix (transform-matrix state)))
 210     (abs (/ 1.0 (min (transform-matrix-x-scale matrix)
 211                      (transform-matrix-y-scale matrix))))))
 212
 213
 214 (defun draw-stroked-paths (state)
 215   "Create a set of paths representing a stroking of the current
 216 paths of STATE, and draw them to the image."
 217   (let ((paths (dash-paths (paths state)
 218                            (dash-vector state)
 219                            (dash-phase state)))
 220         (paths:*bezier-distance-tolerance*
 221          (* paths:*bezier-distance-tolerance* (tolerance-scale state))))
 222     (setf paths (stroke-paths paths
 223                               :line-width (line-width state)
 224                               :join-style (join-style state)
 225                               :cap-style (cap-style state)))
 226     (draw-paths :paths paths
 227                 :width (width state)
 228                 :height (height state)
 229                 :transform-function (transform-function state)
 230                 :draw-function (stroke-draw-function state))))
 231
 232 (defun close-paths (paths)
 233   (dolist (path paths)
 234     (setf (paths::path-type path) :closed-polyline)))
 235
 236 (defun draw-filled-paths (state)
 237   "Fill the paths of STATE into the image."
 238   (close-paths (paths state))
 239   (draw-paths :paths (paths state)
 240               :width (width state)
 241               :height (height state)
 242               :transform-function (transform-function state)
 243               :draw-function (fill-draw-function state)))
 244
 245 (defun draw-even-odd-filled-paths (state)
 246   "Fill the paths of STATE into the image."
 247   (close-paths (paths state))
 248   (draw-paths :paths (paths state)
 249               :width (width state)
 250               :height (height state)
 251               :transform-function (transform-function state)
 252               :draw-function (even-odd-fill-draw-function state)))
 253
 254 (defun draw-clipping-path (state alpha-fun)
 255   (let ((data (writable-clipping-data (clipping-path state)))
 256         (scratch (scratch (clipping-path state)))
 257         (width (width state))
 258         (height (height state)))
 259     (declare (type octet-vector data scratch))
 260     (fill scratch 0)
 261     (draw-paths :paths (paths state)
 262                 :width (width state)
 263                 :height (height state)
 264                 :transform-function (transform-function state)
 265                 :draw-function (draw-clipping-path-function scratch
 266                                                             width
 267                                                             height
 268                                                             alpha-fun))
 269     (intersect-clipping-paths data scratch)))
 270
 271 (defun make-clipping-path-function (state type)
 272   (ecase type
 273     (:nonzero-winding
 274      (lambda ()
 275        (draw-clipping-path state #'nonzero-winding-alpha)))
 276     (:even-odd
 277      (lambda ()
 278        (draw-clipping-path state #'even-odd-alpha)))))
 279