aa.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 ;;;; This file implement the AA algorithm from the AntiGrain project
  14 ;;;; (http://antigrain.com/).
  15 ;;;;
  16 ;;;; Changelogs:
  17 ;;;;
  18 ;;;; 2007-02-25: Released under LLGPL this time. Future changes made
  19 ;;;;             in this file will be thus covered by this license.
  20 ;;;;
  21 ;;;; 2007-01-20: Minors updates to comments and code.
  22 ;;;;
  23 ;;;; 2007-01-11: I chose to release the code in this file in public
  24 ;;;;             domain. You can do whatever you want with the code.
  25 ;;;;
  26 ;;;; 2007-01-07: fixed 2 bugs related to cells reuse. The first bug
  27 ;;;;             was that the cell after the last reused one was kept
  28 ;;;;             in the list. The second bug occured when the latest
  29 ;;;;             cell (the current one) was empty. The code was
  30 ;;;;             failing to correctly eliminate unused cells in such
  31 ;;;;             case.
  32 ;;;;
  33 ;;;; 2007-01-05: +cell-width+ is no longer passed as parameter to let
  34 ;;;;             the CL compiler optimize various computation
  35 ;;;;             involving this value. Added docstrings and
  36 ;;;;             (hopefully) clarified some points.
  37 ;;;;
  38 ;;;; 2006-12-31: moved examples to a separate file
  39 ;;;;
  40 ;;;; 2006-12-30: added animated GIF (using Skippy) example
  41 ;;;;
  42 ;;;; 2006-12-30: cleaned the code, factorized, simplified
  43 ;;;;
  44 ;;;; 2006-12-30: map-grid-spans rewritten in term of map-line-spans
  45 ;;;;
  46 ;;;; 2006-12-30: first release
  47 ;;;;
  48 ;;;; About AntiGrain: "Anti-Grain Geometry (AGG) is an Open Source,
  49 ;;;; free of charge graphic library, written in industrially standard
  50 ;;;; C++." "A High Quality Rendering Engine for C++". Its main author
  51 ;;;; is Maxim Shemanarev. Project home page is at http://antigrain.com/
  52 ;;;;
  53 ;;;; How to use it:
  54 ;;;;
  55 ;;;; 1) create a state with MAKE-STATE, or reuse a previous state by
  56 ;;;;    calling STATE-RESET on it.
  57 ;;;;
  58 ;;;; 2) call LINE-F (or LINE) to draw each line of one or several
  59 ;;;;    closed polygons. It is very important to close them to get a
  60 ;;;;    coherent result. Note that nothing is really drawn at this
  61 ;;;;    stage (not until the call to CELLS-SWEEP.)
  62 ;;;;
  63 ;;;; 3) finally, call CELLS-SWEEP to let it call your own function for
  64 ;;;;    each pixels covered by the polygon(s), where the callback
  65 ;;;;    function take 3 arguments: x, y, alpha. Pixels are scanned on
  66 ;;;;    increasing y, then on increasing x. Optionnaly, CELLS-SWEEP
  67 ;;;;    can take another callback function as parameter. See its
  68 ;;;;    documentation for details.
  69 ;;;;
  70 ;;;;    The alpha value passed to the callback function can be used in
  71 ;;;;    various way. Usually you want:
  72 ;;;;
  73 ;;;;      (defun normalize-alpha (alpha)
  74 ;;;;        (min 255 (abs alpha)))
  75 ;;;;
  76 ;;;;    to get a normalized alpha value between 0 and 255. But you may
  77 ;;;;    also be interested by:
  78 ;;;;
  79 ;;;;      (defun even-odd-alpha (alpha)
  80 ;;;;        (let ((value (mod alpha 512)))
  81 ;;;;          (min 255 (if (< value 256) value (- 512 value)))))
  82 ;;;;
  83 ;;;;    to simulate "even/odd" fill. You can also use the alpha value
  84 ;;;;    to render polygons without anti-aliasing by using:
  85 ;;;;
  86 ;;;;      (defun bool-alpha (value)
  87 ;;;;        (if (>= (abs value) 128) 255 0))
  88 ;;;;
  89 ;;;;    or, for "even/odd" fill:
  90 ;;;;
  91 ;;;;      (defun bool-even-odd-alpha (value)
  92 ;;;;        (if (<= 128 (mod (abs value) 256) 384) 255 0))
  93 ;;;;
  94 ;;;; Note: Drawing direction (clockwise or counter-clockwise) is only
  95 ;;;; important if polygons overlap during a single
  96 ;;;; cells-state. Opposite directions produce hole at the intersection
  97 ;;;; (coverage is canceled), while identical directions does not
  98 ;;;; (coverage overflow.)
  99 ;;;;
 100 ;;;; The latest version can be downloaded from:
 101 ;;;;
 102 ;;;;     http://tuxee.net/cl-aa.lisp
 103 ;;;;     http://tuxee.net/cl-aa-sample.lisp
 104 ;;;;
 105 ;;;; See also:
 106 ;;;;
 107 ;;;;     http://projects.tuxee.net/cl-aa-path/
 108 ;;;;
 109 ;;;; See examples of output at:
 110 ;;;;
 111 ;;;;     http://tuxee.net/cl-aa-1.png
 112 ;;;;     http://tuxee.net/cl-aa-2.png (this one was a bug.)
 113 ;;;;     http://tuxee.net/cl-aa-3.png
 114 ;;;;     http://tuxee.net/cl-aa-4.png
 115 ;;;;     http://tuxee.net/cl-aa-5.png (when testing transparency, but looks bad.)
 116 ;;;;     http://tuxee.net/cl-aa-6.png
 117 ;;;;     http://tuxee.net/cl-aa-7.png
 118 ;;;;     http://tuxee.net/cl-aa-8.png
 119 ;;;;     http://tuxee.net/cl-aa-stroke-0.png (using stroke functions not provided here.)
 120 ;;;;     http://tuxee.net/cl-aa-stroke-1.png
 121 ;;;;     http://tuxee.net/cl-aa-stroke-2.png
 122 ;;;;     http://tuxee.net/cl-aa-skippy-1.gif (animated GIF, thanks to Skippy library)
 123 ;;;;     http://tuxee.net/cl-aa-skippy-2.gif
 124 ;;;;
 125 ;;;; The code is absolutely NOT optimized in any way. It was mainly to
 126 ;;;; figure how the algorithm was working. Also, I don't have tested
 127 ;;;; many corner cases. It is absolutely NOT for production use.
 128 ;;;;
 129 ;;;; About the example, note that the resulting image is exported as a
 130 ;;;; PNM file. Not great, but no need for any external lib. You can
 131 ;;;; use pnmtopng to convert it to PNG afterward.
 132 ;;;;
 133 ;;;; Inspiration come from agg/include/agg_rasterizer_cells_aa.h and
 134 ;;;; agg/include/agg_rasterizer_scanline_aa.h sources files from the
 135 ;;;; AntiGrain project (version 2.5 at this date.)
 136 ;;;;
 137 ;;;; For animated GIF, see Zach Beane's Skippy project at:
 138 ;;;;     http://www.cliki.net/Skippy
 139
 140 ;;;; Naming convention:
 141 ;;;; foo-m for fixed-point mantissa,
 142 ;;;; foo-f for fixed-point fractional part.
 143
 144 #+nil(error "This file assume that #+NIL is never defined.")
 145
 146 (defpackage #:net.tuxee.aa
 147   (:use #:common-lisp)
 148   (:nicknames #:aa)
 149   (:export #:make-state
 150            #:state-reset
 151            #:line
 152            #:line-f
 153            #:cells-sweep))
 154
 155 (in-package #:net.tuxee.aa)
 156
 157 ;;;--[ Utility function ]-----------------------------------------------------
 158
 159 (defconstant +cell-width+ 256
 160   "A cell represent a pixel square, and the width is the
 161 fractional part of the fixed-point coordinate. A large value
 162 increase precision. 256 should be enough though. Note that
 163 smaller value should NOT increase performance.")
 164
 165 ;;; This function is used to split a line at each pixel boundaries
 166 ;;; (when using sub-pixel coordinates.) Since the function only cut
 167 ;;; along one axis, it must be called twice (with the second call with
 168 ;;; coordinates swapped) to split along X and Y axis.
 169 ;;;
 170 ;;; In the comments below, by "main axis" I mean the X axis if A1 and
 171 ;;; A2 are the X coordinates, or the Y axis otherwise.
 172 (declaim (inline map-line-spans))
 173 (defun map-line-spans (function a1 b1 a2 b2)
 174   "Call FUNCTION for each segment of a line with integer
 175 coordinates (A1,B1)-(A2,B2) cut by a grid of spacing
 176 +CELL-WIDTH+."
 177   (multiple-value-bind (b1-m b1-f) (floor b1 +cell-width+)
 178     (multiple-value-bind (b2-m b2-f) (floor b2 +cell-width+)
 179       (cond
 180         ;; The line doesn't cross the grid in the main axis. We have a
 181         ;; single segment. Just call FUNCTION.
 182         ((= b1-m b2-m)
 183          (funcall function b1-m a1 b1-f a2 b2-f))
 184         ;; The line cross the grid in the main axis. We have at least
 185         ;; 2 segments.
 186         (t
 187          (let* ((b-m b1-m)
 188                 (delta-a (- a2 a1))
 189                 (delta-b (abs (- b2 b1)))
 190                 (b-increment (signum (- b2 b1)))
 191                 (from-boundary (if (< b1 b2) 0 +cell-width+))
 192                 (to-boundary (if (< b1 b2) +cell-width+ 0)))
 193            (multiple-value-bind (a ma) (floor (+ (* delta-a (if (< b1 b2)
 194                                                                 (- +cell-width+ b1-f)
 195                                                                 b1-f))
 196                                                  ;; a littre change compared to
 197                                                  ;; AntiGrain AA algorithm. Used
 198                                                  ;; to round to the nearest integer
 199                                                  ;; instead of the "floor" one.
 200                                                  (floor delta-b 2))
 201                                               delta-b)
 202              (incf a a1)
 203              ;; The first segment (to reach the first grid boundary)
 204              (funcall function b1-m a1 b1-f a to-boundary)
 205              (incf b-m b-increment)
 206              (when (/= b-m b2-m)
 207                (multiple-value-bind (step mod) (floor (* +cell-width+ delta-a) delta-b)
 208                  (loop
 209                     do (let ((prev-a a))
 210                          (incf a step)
 211                          (incf ma mod)
 212                          (when (>= ma delta-b)
 213                            (incf a)
 214                            (decf ma delta-b))
 215                          ;; A segment from one grid boundary to the other.
 216                          (funcall function b-m prev-a from-boundary a to-boundary)
 217                          (incf b-m b-increment))
 218                     while (/= b-m b2-m))))
 219              ;; The last segment (from the latest grid boundary up to
 220              ;; the final coordinates.)
 221              (funcall function b-m a from-boundary a2 b2-f))))))))
 222
 223 (defun map-grid-spans (function x1 y1 x2 y2)
 224   "Call FUNCTION for each segments of the line from (X1,Y1)
 225 to (X2,Y2) cut by a grid with spacing +CELL-WIDTH+."
 226   (check-type x1 integer)
 227   (check-type y1 integer)
 228   (check-type x2 integer)
 229   (check-type y2 integer)
 230   (flet ((hline (y-m x1 y1-f x2 y2-f)
 231            (declare (integer y-m x1 y1-f x2 y2-f))
 232            (flet ((pixel (x-m y1-f x1-f y2-f x2-f)
 233                     (declare (integer x-m y1-f x1-f y2-f x2-f))
 234                     (funcall function x-m y-m x1-f y1-f x2-f y2-f)))
 235              ;; further split along Y axis
 236              (map-line-spans #'pixel y1-f x1 y2-f x2))))
 237     ;; first split along X axis
 238     (map-line-spans #'hline x1 y1 x2 y2)))
 239
 240 ;;;--[ cell ]-----------------------------------------------------------------
 241
 242 ;;; Note that cover and area are unbound and could take any value
 243 ;;; while drawing polygons (even negative values), especially when
 244 ;;; drawing multiple overlapping polygons. However, for non
 245 ;;; overlapping polygons, cover is in the range (-width,width) and
 246 ;;; area in the range (-2*width*width,2*width*width), where width is
 247 ;;; +cell-width+ defined above.
 248 (defstruct cell
 249   "A cell used to represent the partial area covered by a line
 250 passing by a corresponding pixel. The cell alone doesn't hold all
 251 the information to calculate the area."
 252   (x 0 :type integer)
 253   (y 0 :type integer)
 254   (cover 0 :type integer)
 255   (area 0 :type integer))
 256
 257 (declaim (inline cell-empty-p))
 258 (defun cell-empty-p (cell)
 259   "Test if the cell is empty. A cell is empty when COVER and AREA
 260 are both zero."
 261   (and (zerop (cell-cover cell))
 262        (zerop (cell-area cell))))
 263
 264 (declaim (inline cell-reset))
 265 (defun cell-reset (cell)
 266   "Reset the cell such that CELL-EMPTY-P is true."
 267   (setf (cell-area cell) 0
 268         (cell-cover cell) 0))
 269
 270 (declaim (inline compare-cells))
 271 (defun compare-cells (a b)
 272   "Compare coordinates between 2 cells. Used to sort cells by Y,
 273 then by X."
 274   (or (< (cell-y a) (cell-y b))
 275       (and (= (cell-y a) (cell-y b))
 276            (< (cell-x a) (cell-x b)))))
 277
 278 (declaim (inline update-cell))
 279 (defun update-cell (cell fx1 fy1 fx2 fy2)
 280   "Update COVER and AREA given a segment inside the corresponding
 281 cell. FX1, FY1, FX2 and FY2 must be subpixel coordinates between
 282 0 and +CELL-WIDTH+ included."
 283   (let ((delta (- fy2 fy1)))
 284     (incf (cell-cover cell) delta)
 285     ;; Note: increase by twice the area, for optimization
 286     ;; purpose. Will be divided by 2 in the final pass.
 287     (incf (cell-area cell) (* (+ fx1 fx2) delta))))
 288
 289 ;;;-------------------------------------------------------------------------
 290
 291 (defconstant +alpha-range+ 256
 292   "For non overlapping polygons, the alpha value will be in the
 293 range (-limit,limit) where limit is +alpha-range+. The value is
 294 negative or positive accordingly to the polygon
 295 orientation (clockwise or counter-clockwise.)")
 296
 297 (defconstant +alpha-divisor+ (floor (* 2 +cell-width+ +cell-width+)
 298                                     +alpha-range+)
 299   "Constant used to translate value computed by AREA and COVER to
 300 an alpha value.")
 301
 302 (defstruct state
 303   "AA state. Hold all the cells generated when drawing lines."
 304   (current-cell (make-cell) :type cell)
 305   (cells nil)
 306   (recycling-cells (cons nil nil)))
 307
 308 (defun state-reset (state)
 309   "Reset the state, losing all accumulated cells. It can be
 310 faster or less memory consuming to reset a state and reuse it,
 311 rather than creating a new state."
 312   (cell-reset (state-current-cell state))
 313   (setf (state-recycling-cells state) (cons nil (state-cells state))))
 314
 315 (declaim (inline state-push-current-cell))
 316 (defun state-push-cell (state cell)
 317   "Store a copy of the current cell into the cells list. If the
 318 state was reset, possibly reuse previous cells."
 319   (unless (cell-empty-p cell)
 320     (let ((recycling-cells (cdr (state-recycling-cells state))))
 321       (cond
 322         (recycling-cells
 323          (let ((target-cell (car recycling-cells)))
 324            (setf (cell-x target-cell) (cell-x cell)
 325                  (cell-y target-cell) (cell-y cell)
 326                  (cell-cover target-cell) (cell-cover cell)
 327                  (cell-area target-cell) (cell-area cell)))
 328          (setf (state-recycling-cells state) recycling-cells))
 329         (t
 330          (push (copy-cell cell) (state-cells state)))))))
 331
 332 (defun state-finalize (state)
 333   "Finalize the state."
 334   ;; Ensure that the current cell is stored with other cells and that
 335   ;; old cells (before the last reset) that were not reused are
 336   ;; correctly removed from the result.
 337   (let ((current-cell (state-current-cell state)))
 338     (unless (cell-empty-p current-cell)
 339       (state-push-cell state current-cell)
 340       (cell-reset current-cell))
 341     (when (cdr (state-recycling-cells state))
 342       (setf (cdr (state-recycling-cells state)) nil)
 343       (unless (car (state-recycling-cells state))
 344         (setf (state-cells state) nil)))))
 345
 346 (defun set-current-cell (state x y)
 347   "Ensure current cell is one at coordinate X and Y. If not,
 348 the current cell is stored, then reset accordingly to new
 349 coordinate.
 350
 351 Returns the current cell."
 352   (let ((current-cell (state-current-cell state)))
 353     (when (or (/= x (cell-x current-cell))
 354               (/= y (cell-y current-cell)))
 355       ;; Store the current cell, then reset it.
 356       (state-push-cell state current-cell)
 357       (setf (cell-x current-cell) x
 358             (cell-y current-cell) y
 359             (cell-cover current-cell) 0
 360             (cell-area current-cell) 0))
 361     current-cell))
 362
 363 (defun state-sort-cells (state)
 364   "Sort the cells by Y, then by X."
 365   (setf (state-cells state)
 366         (sort (state-cells state) #'compare-cells)))
 367
 368 (defun line (state x1 y1 x2 y2)
 369   "Draw a line from (X1,Y1) to (X2,Y2). All coordinates are
 370 integers with subpixel accuracy (a pixel width is given by
 371 +CELL-WIDTH+.) The line must be part of a closed polygons."
 372   (declare (integer x1 y1 x2 y2))
 373   (map-grid-spans (lambda (x y fx1 fy1 fx2 fy2)
 374                          (update-cell (set-current-cell state x y)
 375                                       fx1 fy1 fx2 fy2))
 376                        x1 y1 x2 y2))
 377
 378 (defun line-f (state x1 y1 x2 y2)
 379   "Draw a line, whose coordinates are translated to fixed-point
 380 as expected by function LINE. This is a convenient function to
 381 not depend on +CELL-WIDTH+."
 382   (labels ((float-to-fixed (n)
 383              (values (round (* +cell-width+ n)))))
 384     (line state
 385           (float-to-fixed x1) (float-to-fixed y1)
 386           (float-to-fixed x2) (float-to-fixed y2))))
 387
 388 (declaim (inline compute-alpha))
 389 (defun compute-alpha (cover area)
 390   "Compute the alpha value given the accumulated cover and the
 391 actual area of a cell."
 392   (truncate (- (* 2 +cell-width+ cover) area)
 393             +alpha-divisor+))
 394
 395 (defun cells-sweep (state function &optional (function-span))
 396   "Call FUNCTION for each pixel on the polygon path described by
 397 previous call to LINE or LINE-F. The pixels are scanned in
 398 increasing Y, then on increasing X. For optimization purpose, the
 399 optional FUNCTION-SPAN, if provided, is called for a full span of
 400 identical alpha pixel. If not provided, a call is made to
 401 FUNCTION for each pixel in the span."
 402   ;; It is the final step of the algorithm.
 403   (state-finalize state)
 404   (state-sort-cells state)
 405   (let ((cells (state-cells state)))
 406     (when cells
 407       (let* ((first-cell (first cells))
 408              (x (cell-x first-cell))
 409              (y (cell-y first-cell))
 410              (area (cell-area first-cell))
 411              (cover (cell-cover first-cell)))
 412         (flet ((call ()
 413                  (let ((alpha (compute-alpha cover area)))
 414                    (unless (zerop alpha)
 415                      (funcall function x y alpha)))))
 416           (dolist (cell (rest cells))
 417             (cond
 418               ;; different line
 419               ((/= y (cell-y cell))
 420                (call)
 421                (setf x (cell-x cell)
 422                      y (cell-y cell)
 423                      cover (cell-cover cell)
 424                      area (cell-area cell)))
 425               ;; same line, but different column
 426               ((/= x (cell-x cell))
 427                (call)
 428                (when (> (- (cell-x cell) x) 1)
 429                  ;; "solid span"
 430                  (let ((alpha (compute-alpha cover 0)))
 431                    (if function-span
 432                        (funcall function-span (1+ x) (cell-x cell) y alpha)
 433                        (loop for ix from (1+ x) below (cell-x cell)
 434                           do (funcall function ix y alpha)))))
 435                (setf x (cell-x cell)
 436                      area (cell-area cell))
 437                (incf cover (cell-cover cell)))
 438               ;; same line, same column, accumulate
 439               (t
 440                (incf cover (cell-cover cell))
 441                (incf area (cell-area cell)))))
 442           (call)))))
 443   (values))