;;;; cl-aa -- Antialiasing stuff for Common Lisp ;;;; Copyright (C) 2006,2007 Frederic Jolliton ;;;; ;;;; This file implement the AA algorithm from the AntiGrain project ;;;; (http://antigrain.com/). ;;;; ;;;; Changelogs: ;;;; ;;;; 2007-01-20: Minors updates to comments and code. ;;;; ;;;; 2007-01-11: I chose to release the code in this file in public ;;;; domain. You can do whatever you want with the code. ;;;; ;;;; 2007-01-07: fixed 2 bugs related to cells reuse. The first bug ;;;; was that the cell after the last reused one was kept ;;;; in the list. The second bug occured when the latest ;;;; cell (the current one) was empty. The code was ;;;; failing to correctly eliminate unused cells in such ;;;; case. ;;;; ;;;; 2007-01-05: +cell-width+ is no longer passed as parameter to let ;;;; the CL compiler optimize various computation ;;;; involving this value. Added docstrings and ;;;; (hopefully) clarified some points. ;;;; ;;;; 2006-12-31: moved examples to a separate file ;;;; ;;;; 2006-12-30: added animated GIF (using Skippy) example ;;;; ;;;; 2006-12-30: cleaned the code, factorized, simplified ;;;; ;;;; 2006-12-30: map-grid-spans rewritten in term of map-line-spans ;;;; ;;;; 2006-12-30: first release ;;;; ;;;; About AntiGrain: "Anti-Grain Geometry (AGG) is an Open Source, ;;;; free of charge graphic library, written in industrially standard ;;;; C++." "A High Quality Rendering Engine for C++". Its main author ;;;; is Maxim Shemanarev. Project home page is at http://antigrain.com/ ;;;; ;;;; How to use it: ;;;; ;;;; 1) create a state with MAKE-STATE, or reuse a previous state by ;;;; calling STATE-RESET on it. ;;;; ;;;; 2) call LINE-F (or LINE) to draw each line of one or several ;;;; closed polygons. It is very important to close them to get a ;;;; coherent result. Note that nothing is really drawn at this ;;;; stage (not until the call to CELLS-SWEEP.) ;;;; ;;;; 3) finally, call CELLS-SWEEP to let it call your own function for ;;;; each pixels covered by the polygon(s), where the callback ;;;; function take 3 arguments: x, y, alpha. Pixels are scanned on ;;;; increasing y, then on increasing x. Optionnaly, CELLS-SWEEP ;;;; can take another callback function as parameter. See its ;;;; documentation for details. ;;;; ;;;; The alpha value passed to the callback function can be used in ;;;; various way. Usually you want: ;;;; ;;;; (defun normalize-alpha (alpha) ;;;; (min 255 (abs alpha))) ;;;; ;;;; to get a normalized alpha value between 0 and 255. But you may ;;;; also be interested by: ;;;; ;;;; (defun even-odd-alpha (alpha) ;;;; (let ((value (mod alpha 512))) ;;;; (min 255 (if (< value 256) value (- 512 value))))) ;;;; ;;;; to simulate "even/odd" fill. You can also use the alpha value ;;;; to render polygons without anti-aliasing by using: ;;;; ;;;; (defun bool-alpha (value) ;;;; (if (>= (abs value) 128) 255 0)) ;;;; ;;;; or, for "even/odd" fill: ;;;; ;;;; (defun bool-even-odd-alpha (value) ;;;; (if (<= 128 (mod (abs value) 256) 384) 255 0)) ;;;; ;;;; Note: Drawing direction (clockwise or counter-clockwise) is only ;;;; important if polygons overlap during a single ;;;; cells-state. Opposite directions produce hole at the intersection ;;;; (coverage is canceled), while identical directions does not ;;;; (coverage overflow.) ;;;; ;;;; The latest version can be downloaded from: ;;;; ;;;; http://tuxee.net/cl-aa.lisp ;;;; http://tuxee.net/cl-aa-sample.lisp ;;;; ;;;; See also: ;;;; ;;;; http://projects.tuxee.net/cl-aa-path/ ;;;; ;;;; See examples of output at: ;;;; ;;;; http://tuxee.net/cl-aa-1.png ;;;; http://tuxee.net/cl-aa-2.png (this one was a bug.) ;;;; http://tuxee.net/cl-aa-3.png ;;;; http://tuxee.net/cl-aa-4.png ;;;; http://tuxee.net/cl-aa-5.png (when testing transparency, but looks bad.) ;;;; http://tuxee.net/cl-aa-6.png ;;;; http://tuxee.net/cl-aa-7.png ;;;; http://tuxee.net/cl-aa-8.png ;;;; http://tuxee.net/cl-aa-stroke-0.png (using stroke functions not provided here.) ;;;; http://tuxee.net/cl-aa-stroke-1.png ;;;; http://tuxee.net/cl-aa-stroke-2.png ;;;; http://tuxee.net/cl-aa-skippy-1.gif (animated GIF, thanks to Skippy library) ;;;; http://tuxee.net/cl-aa-skippy-2.gif ;;;; ;;;; The code is absolutely NOT optimized in any way. It was mainly to ;;;; figure how the algorithm was working. Also, I don't have tested ;;;; many corner cases. It is absolutely NOT for production use. ;;;; ;;;; About the example, note that the resulting image is exported as a ;;;; PNM file. Not great, but no need for any external lib. You can ;;;; use pnmtopng to convert it to PNG afterward. ;;;; ;;;; Inspiration come from agg/include/agg_rasterizer_cells_aa.h and ;;;; agg/include/agg_rasterizer_scanline_aa.h sources files from the ;;;; AntiGrain project (version 2.5 at this date.) ;;;; ;;;; For animated GIF, see Zach Beane's Skippy project at: ;;;; http://www.cliki.net/Skippy ;;;; Naming convention: ;;;; foo-m for fixed-point mantissa, ;;;; foo-f for fixed-point fractional part. (defpackage #:net.tuxee.aa (:use #:common-lisp) (:nicknames #:aa) (:export #:make-state #:state-reset #:line #:line-f #:cells-sweep)) (in-package #:net.tuxee.aa) ;;;--[ Utility function ]----------------------------------------------------- (defconstant +cell-width+ 256 "A cell represent a pixel square, and the width is the fractional part of the fixed-point coordinate. A large value increase precision. 256 should be enough though. Note that smaller value should NOT increase performance.") ;;; This function is used to split a line at each pixel boundaries ;;; (when using sub-pixel coordinates.) Since the function only cut ;;; along one axis, it must be called twice (with the second call with ;;; coordinates swapped) to split along X and Y axis. ;;; ;;; In the comments below, by "main axis" I mean the X axis if A1 and ;;; A2 are the X coordinates, or the Y axis otherwise. (declaim (inline map-line-spans)) (defun map-line-spans (function a1 b1 a2 b2) "Call FUNCTION for each segment of a line with integer coordinates (A1,B1)-(A2,B2) cut by a grid of spacing +CELL-WIDTH+." (multiple-value-bind (b1-m b1-f) (floor b1 +cell-width+) (multiple-value-bind (b2-m b2-f) (floor b2 +cell-width+) (cond ;; The line doesn't cross the grid in the main axis. We have a ;; single segment. Just call FUNCTION. ((= b1-m b2-m) (funcall function b1-m a1 b1-f a2 b2-f)) ;; The line cross the grid in the main axis. We have at least ;; 2 segments. (t (let* ((b-m b1-m) (delta-a (- a2 a1)) (delta-b (abs (- b2 b1))) (b-increment (signum (- b2 b1))) (from-boundary (if (< b1 b2) 0 +cell-width+)) (to-boundary (if (< b1 b2) +cell-width+ 0))) (multiple-value-bind (a ma) (floor (+ (* delta-a (if (< b1 b2) (- +cell-width+ b1-f) b1-f)) ;; a littre change compared to ;; AntiGrain AA algorithm. Used ;; to round to the nearest integer ;; instead of the "floor" one. (floor delta-b 2)) delta-b) (incf a a1) ;; The first segment (to reach the first grid boundary) (funcall function b1-m a1 b1-f a to-boundary) (incf b-m b-increment) (when (/= b-m b2-m) (multiple-value-bind (step mod) (floor (* +cell-width+ delta-a) delta-b) (loop do (let ((prev-a a)) (incf a step) (incf ma mod) (when (>= ma delta-b) (incf a) (decf ma delta-b)) ;; A segment from one grid boundary to the other. (funcall function b-m prev-a from-boundary a to-boundary) (incf b-m b-increment)) while (/= b-m b2-m)))) ;; The last segment (from the latest grid boundary up to ;; the final coordinates.) (funcall function b-m a from-boundary a2 b2-f)))))))) (defun map-grid-spans (function x1 y1 x2 y2) "Call FUNCTION for each segments of the line from (X1,Y1) to (X2,Y2) cut by a grid with spacing +CELL-WIDTH+." (check-type x1 integer) (check-type y1 integer) (check-type x2 integer) (check-type y2 integer) (flet ((hline (y-m x1 y1-f x2 y2-f) (declare (integer y-m x1 y1-f x2 y2-f)) (flet ((pixel (x-m y1-f x1-f y2-f x2-f) (declare (integer x-m y1-f x1-f y2-f x2-f)) (funcall function x-m y-m x1-f y1-f x2-f y2-f))) ;; further split along Y axis (map-line-spans #'pixel y1-f x1 y2-f x2)))) ;; first split along X axis (map-line-spans #'hline x1 y1 x2 y2))) ;;;--[ cell ]----------------------------------------------------------------- ;;; Note that cover and area are unbound and could take any value ;;; while drawing polygons (even negative values), especially when ;;; drawing multiple overlapping polygons. However, for non ;;; overlapping polygons, cover is in the range (-width,width) and ;;; area in the range (-2*width*width,2*width*width), where width is ;;; +cell-width+ defined above. (defstruct cell "A cell used to represent the partial area covered by a line passing by a corresponding pixel. The cell alone doesn't hold all the information to calculate the area." (x 0 :type integer) (y 0 :type integer) (cover 0 :type integer) (area 0 :type integer)) (declaim (inline cell-empty-p)) (defun cell-empty-p (cell) "Test if the cell is empty. A cell is empty when COVER and AREA are both zero." (and (zerop (cell-cover cell)) (zerop (cell-area cell)))) (declaim (inline cell-reset)) (defun cell-reset (cell) "Reset the cell such that CELL-EMPTY-P is true." (setf (cell-area cell) 0 (cell-cover cell) 0)) (declaim (inline compare-cells)) (defun compare-cells (a b) "Compare coordinates between 2 cells. Used to sort cells by Y, then by X." (or (< (cell-y a) (cell-y b)) (and (= (cell-y a) (cell-y b)) (< (cell-x a) (cell-x b))))) (declaim (inline update-cell)) (defun update-cell (cell fx1 fy1 fx2 fy2) "Update COVER and AREA given a segment inside the corresponding cell. FX1, FY1, FX2 and FY2 must be subpixel coordinates between 0 and +CELL-WIDTH+ included." (let ((delta (- fy2 fy1))) (incf (cell-cover cell) delta) ;; Note: increase by twice the area, for optimization ;; purpose. Will be divided by 2 in the final pass. (incf (cell-area cell) (* (+ fx1 fx2) delta)))) ;;;------------------------------------------------------------------------- (defconstant +alpha-range+ 256 "For non overlapping polygons, the alpha value will be in the range (-limit,limit) where limit is +alpha-range+. The value is negative or positive accordingly to the polygon orientation (clockwise or counter-clockwise.)") (defconstant +alpha-divisor+ (floor (* 2 +cell-width+ +cell-width+) +alpha-range+) "Constant used to translate value computed by AREA and COVER to an alpha value.") (defstruct state "AA state. Hold all the cells generated when drawing lines." (current-cell (make-cell) :type cell) (cells nil) (recycling-cells (cons nil nil))) (defun state-reset (state) "Reset the state, losing all accumulated cells. It can be faster or less memory consuming to reset a state and reuse it, rather than creating a new state." (cell-reset (state-current-cell state)) (setf (state-recycling-cells state) (cons nil (state-cells state)))) (declaim (inline state-push-current-cell)) (defun state-push-cell (state cell) "Store a copy of the current cell into the cells list. If the state was reset, possibly reuse previous cells." (unless (cell-empty-p cell) (let ((recycling-cells (cdr (state-recycling-cells state)))) (cond (recycling-cells (let ((target-cell (car recycling-cells))) (setf (cell-x target-cell) (cell-x cell) (cell-y target-cell) (cell-y cell) (cell-cover target-cell) (cell-cover cell) (cell-area target-cell) (cell-area cell))) (setf (state-recycling-cells state) recycling-cells)) (t (push (copy-cell cell) (state-cells state))))))) (defun state-finalize (state) "Finalize the state." ;; Ensure that the current cell is stored with other cells and that ;; old cells (before the last reset) that were not reused are ;; correctly removed from the result. (let ((current-cell (state-current-cell state))) (unless (cell-empty-p current-cell) (state-push-cell state current-cell) (cell-reset current-cell)) (when (cdr (state-recycling-cells state)) (setf (cdr (state-recycling-cells state)) nil) (unless (car (state-recycling-cells state)) (setf (state-cells state) nil))))) (defun set-current-cell (state x y) "Ensure current cell is one at coordinate X and Y. If not, the current cell is stored, then reset accordingly to new coordinate. Returns the current cell." (let ((current-cell (state-current-cell state))) (when (or (/= x (cell-x current-cell)) (/= y (cell-y current-cell))) ;; Store the current cell, then reset it. (state-push-cell state current-cell) (setf (cell-x current-cell) x (cell-y current-cell) y (cell-cover current-cell) 0 (cell-area current-cell) 0)) current-cell)) (defun state-sort-cells (state) "Sort the cells by Y, then by X." (setf (state-cells state) (sort (state-cells state) #'compare-cells))) (defun line (state x1 y1 x2 y2) "Draw a line from (X1,Y1) to (X2,Y2). All coordinates are integers with subpixel accuracy (a pixel width is given by +CELL-WIDTH+.) The line must be part of a closed polygons." (declare (integer x1 y1 x2 y2)) (map-grid-spans (lambda (x y fx1 fy1 fx2 fy2) (update-cell (set-current-cell state x y) fx1 fy1 fx2 fy2)) x1 y1 x2 y2)) (defun line-f (state x1 y1 x2 y2) "Draw a line, whose coordinates are translated to fixed-point as expected by function LINE. This is a convenient function to not depend on +CELL-WIDTH+." (labels ((float-to-fixed (n) (values (round (* +cell-width+ n))))) (line state (float-to-fixed x1) (float-to-fixed y1) (float-to-fixed x2) (float-to-fixed y2)))) (declaim (inline compute-alpha)) (defun compute-alpha (cover area) "Compute the alpha value given the accumulated cover and the actual area of a cell." (truncate (- (* 2 +cell-width+ cover) area) +alpha-divisor+)) (defun cells-sweep (state function &optional (function-span)) "Call FUNCTION for each pixel on the polygon path described by previous call to LINE or LINE-F. The pixels are scanned in increasing Y, then on increasing X. For optimization purpose, the optional FUNCTION-SPAN, if provided, is called for a full span of identical alpha pixel. If not provided, a call is made to FUNCTION for each pixel in the span." ;; It is the final step of the algorithm. (state-finalize state) (state-sort-cells state) (let ((cells (state-cells state))) (when cells (let* ((first-cell (first cells)) (x (cell-x first-cell)) (y (cell-y first-cell)) (area (cell-area first-cell)) (cover (cell-cover first-cell))) (flet ((call () (let ((alpha (compute-alpha cover area))) (unless (zerop alpha) (funcall function x y alpha))))) (dolist (cell (rest cells)) (cond ;; different line ((/= y (cell-y cell)) (call) (setf x (cell-x cell) y (cell-y cell) cover (cell-cover cell) area (cell-area cell))) ;; same line, but different column ((/= x (cell-x cell)) (call) (when (> (- (cell-x cell) x) 1) ;; "solid span" (let ((alpha (compute-alpha cover 0))) (if function-span (funcall function-span (1+ x) (cell-x cell) y alpha) (loop for ix from (1+ x) below (cell-x cell) do (funcall function ix y alpha))))) (setf x (cell-x cell) area (cell-area cell)) (incf cover (cell-cover cell))) ;; same line, same column, accumulate (t (incf cover (cell-cover cell)) (incf area (cell-area cell))))) (call))))) (values))