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