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 fill-source alpha-fun)
  60   "From http://www.teamten.com/lawrence/graphics/premultiplication/"
  61   (declare (ignore height))
  62   (lambda (x y alpha)
  63     (multiple-value-bind (r.fg g.fg b.fg a.fg)
  64         (funcall fill-source x y)
  65       (setf alpha (funcall alpha-fun alpha))
  66       (when (plusp alpha)
  67         (let* ((i (* +png-channels+ (+ x (* y width))))
  68                (r.bg (aref data (+ i 0)))
  69                (g.bg (aref data (+ i 1)))
  70                (b.bg (aref data (+ i 2)))
  71                (a.bg (aref data (+ i 3)))
  72                (a.fg (imult alpha a.fg))
  73                (gamma (prelerp a.fg a.bg a.bg)))
  74           (flet ((blend (fg bg)
  75                    (let ((value (lerp (imult bg a.bg) fg a.fg)))
  76                      (float-octet (/ value gamma)))))
  77             (unless (zerop gamma)
  78               (setf (aref data (+ i 0)) (blend r.fg r.bg)
  79                     (aref data (+ i 1)) (blend g.fg g.bg)
  80                     (aref data (+ i 2)) (blend b.fg b.bg)))
  81             (setf (aref data (+ i 3)) gamma)))))))
  82
  83 (defun draw-function/clipped (data clip-data
  84                               width height
  85                               fill-source
  86                               alpha-fun)
  87   "Like DRAW-FUNCTION, but uses uses the clipping channel."
  88   (declare (ignore height))
  89   (lambda (x y alpha)
  90     (let* ((clip-index (+ x (* y width)))
  91            (clip (aref clip-data clip-index)))
  92       (setf alpha (imult clip (funcall alpha-fun alpha)))
  93       (when (plusp alpha)
  94         (multiple-value-bind (r.fg g.fg b.fg a.fg)
  95             (funcall fill-source x y)
  96           (let* ((i (* clip-index +png-channels+))
  97                  (r.bg (aref data (+ i 0)))
  98                  (g.bg (aref data (+ i 1)))
  99                  (b.bg (aref data (+ i 2)))
 100                  (a.bg (aref data (+ i 3)))
 101                  (a.fg (imult alpha a.fg))
 102                  (gamma (prelerp a.fg a.bg a.bg)))
 103             (flet ((blend (fg bg)
 104                      (let ((value (lerp (imult bg a.bg) fg a.fg)))
 105                        (float-octet (/ value gamma)))))
 106               (unless (zerop gamma)
 107                 (setf (aref data (+ i 0)) (blend r.fg r.bg)
 108                       (aref data (+ i 1)) (blend g.fg g.bg)
 109                       (aref data (+ i 2)) (blend b.fg b.bg)))
 110               (setf (aref data (+ i 3)) gamma))))))))
 111
 112 (defun make-draw-function (data clipping-path
 113                            width height
 114                            fill-source
 115                            alpha-fun)
 116   (if (emptyp clipping-path)
 117       (draw-function data width height fill-source alpha-fun)
 118       (draw-function/clipped data (clipping-data clipping-path)
 119                              width height
 120                              fill-source
 121                              alpha-fun)))
 122
 123 (defun intersect-clipping-paths (data temp)
 124   (declare (type (simple-array (unsigned-byte 8) (*)) data temp))
 125   (map-into data #'imult temp data))
 126
 127 (defun draw-clipping-path-function (data width height alpha-fun)
 128   (declare (ignore height)
 129            (type (simple-array (unsigned-byte 8) (*)) data))
 130   (lambda (x y alpha)
 131     (let ((i (+ x (* width y))))
 132       (let ((alpha (funcall alpha-fun alpha)))
 133         (setf (aref data i) alpha)))))
 134
 135 (defun draw-paths (&key width height paths
 136                    transform-function
 137                    draw-function)
 138   "Use DRAW-FUNCTION as a callback for the cells sweep function
 139 for the set of paths PATHS."
 140   (let ((state (aa:make-state))
 141         (paths (mapcar (lambda (path)
 142                          ;; FIXME: previous versions lacked
 143                          ;; paths:path-clone, and this broke fill &
 144                          ;; stroke because transform-path damages the
 145                          ;; paths. It would be nicer if transform-path
 146                          ;; wasn't destructive, since I didn't expect
 147                          ;; it to be.
 148                          (transform-path (paths:path-clone path)
 149                                          transform-function))
 150                        paths)))
 151     (vectors:update-state state paths)
 152     (aa:cells-sweep/rectangle state 0 0 width height draw-function)))
 153
 154 ;;; FIXME: this was added for drawing text paths, but the text
 155 ;;; rendering mode could be changed in the future, making it a little
 156 ;;; silly to have a fixed draw-function.
 157
 158 (defun draw-paths/state (paths state)
 159   (draw-paths :paths paths
 160               :width (width state)
 161               :height (height state)
 162               :transform-function (transform-function state)
 163               :draw-function (fill-draw-function state)))
 164
 165 (defun fill-image (image-data red green blue alpha)
 166   "Completely fill IMAGE with the given colors."
 167   (let ((r (float-octet red))
 168         (g (float-octet green))
 169         (b (float-octet blue))
 170         (a (float-octet alpha)))
 171     (do ((h 0 (+ h 4))
 172          (i 1 (+ i 4))
 173          (j 2 (+ j 4))
 174          (k 3 (+ k 4)))
 175         ((<= (length image-data) k))
 176       (setf (aref image-data h) r
 177             (aref image-data i) g
 178             (aref image-data j) b
 179             (aref image-data k) a))))
 180
 181 (defun color-source-function (color)
 182   (let ((red (float-octet (red color)))
 183         (green (float-octet (green color)))
 184         (blue (float-octet (blue color)))
 185         (alpha (float-octet (alpha color))))
 186     (lambda (x y)
 187       (declare (ignore x y))
 188       (values red green blue alpha))))
 189
 190 (defun fill-source-function (state)
 191   (or (fill-source state)
 192       (color-source-function (fill-color state))))
 193
 194 (defun stroke-source-function (state)
 195   (color-source-function (stroke-color state)))
 196
 197 (defun state-draw-function (state fill-source fill-style)
 198   "Create a draw function for the graphics state STATE."
 199   (make-draw-function (image-data state)
 200                       (clipping-path state)
 201                       (width state)
 202                       (height state)
 203                       fill-source
 204                       (ecase fill-style
 205                         (:even-odd #'even-odd-alpha)
 206                         (:nonzero-winding #'nonzero-winding-alpha))))
 207
 208 (defun stroke-draw-function (state)
 209   (state-draw-function state
 210                        (stroke-source-function state)
 211                        :nonzero-winding))
 212
 213 (defun fill-draw-function (state)
 214   (state-draw-function state
 215                        (fill-source-function state)
 216                        :nonzero-winding))
 217
 218 (defun even-odd-fill-draw-function (state)
 219   (state-draw-function state
 220                        (fill-source-function state)
 221                        :even-odd))
 222
 223 (defun tolerance-scale (state)
 224   (let ((matrix (transform-matrix state)))
 225     (abs (/ 1.0 (min (transform-matrix-x-scale matrix)
 226                      (transform-matrix-y-scale matrix))))))
 227
 228 (defun state-stroke-paths (state)
 229   "Compute the outline paths of the strokes for the current paths of STATE."
 230   (let ((paths (dash-paths (paths state)
 231                            (dash-vector state)
 232                            (dash-phase state)))
 233         (paths:*bezier-distance-tolerance*
 234          (* paths:*bezier-distance-tolerance* (tolerance-scale state))))
 235     (stroke-paths paths
 236                   :line-width (line-width state)
 237                   :join-style (join-style state)
 238                   :cap-style (cap-style state))))
 239
 240 (defun draw-stroked-paths (state)
 241   "Create a set of paths representing a stroking of the current
 242 paths of STATE, and draw them to the image."
 243   (draw-paths :paths (state-stroke-paths state)
 244               :width (width state)
 245               :height (height state)
 246               :transform-function (transform-function state)
 247               :draw-function (stroke-draw-function state)))
 248
 249 (defun close-paths (paths)
 250   (dolist (path paths)
 251     (setf (paths::path-type path) :closed-polyline)))
 252
 253 (defun draw-filled-paths (state)
 254   "Fill the paths of STATE into the image."
 255   (close-paths (paths state))
 256   (draw-paths :paths (paths state)
 257               :width (width state)
 258               :height (height state)
 259               :transform-function (transform-function state)
 260               :draw-function (fill-draw-function state)))
 261
 262 (defun draw-even-odd-filled-paths (state)
 263   "Fill the paths of STATE into the image."
 264   (close-paths (paths state))
 265   (draw-paths :paths (paths state)
 266               :width (width state)
 267               :height (height state)
 268               :transform-function (transform-function state)
 269               :draw-function (even-odd-fill-draw-function state)))
 270
 271 (defun draw-clipping-path (state alpha-fun)
 272   (let ((data (writable-clipping-data (clipping-path state)))
 273         (scratch (scratch (clipping-path state)))
 274         (width (width state))
 275         (height (height state)))
 276     (declare (type octet-vector data scratch))
 277     (fill scratch 0)
 278     (draw-paths :paths (paths state)
 279                 :width (width state)
 280                 :height (height state)
 281                 :transform-function (transform-function state)
 282                 :draw-function (draw-clipping-path-function scratch
 283                                                             width
 284                                                             height
 285                                                             alpha-fun))
 286     (intersect-clipping-paths data scratch)))
 287
 288 (defun make-clipping-path-function (state type)
 289   (ecase type
 290     (:nonzero-winding
 291      (lambda ()
 292        (draw-clipping-path state #'nonzero-winding-alpha)))
 293     (:even-odd
 294      (lambda ()
 295        (draw-clipping-path state #'even-odd-alpha)))))
 296