aa-bin.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 ;;;; See http://projects.tuxee.net/cl-vectors/
  14
  15 ;;;; The name 'cl-aa-bin' is derived from 'cl-aa' which is the library
  16 ;;;; used to rasterize antialiased polygons. The '-bin' version
  17 ;;;; doesn't perform antialiasing (the alpha value is always a
  18 ;;;; multiple of 256), but support the same protocol (drop-in
  19 ;;;; replacement) hence the choice of the name.
  20
  21 ;;;; The aa-bin algorithm is faster and more accurate than when using
  22 ;;;; the original 'cl-aa' algorithm as a non-antialiasing rasterizer.
  23
  24 ;;;; The algorithm compute all the pixels whose "center" (assuming a
  25 ;;;; "pixel is a little square"..) are inside the polygon to
  26 ;;;; rasterize.
  27
  28 (defpackage #:net.tuxee.aa-bin
  29   (:use #:cl)
  30   (:nicknames #:aa-bin)
  31   (:export #:make-state
  32            #:line
  33            #:line-f
  34            #:cells-sweep))
  35
  36 (in-package #:net.tuxee.aa-bin)
  37
  38 (defconstant +cell-width+ 256
  39   "A cell represent a pixel square, and the width is the
  40 fractional part of the fixed-point coordinate. A large value
  41 increase precision. 256 should be enough though. Note that
  42 smaller value should NOT increase performance.")
  43
  44 (defconstant +alpha-range+ 256
  45   "For non overlapping polygons, the alpha value will be in the
  46 range (-limit,limit) where limit is +alpha-range+. The value is
  47 negative or positive accordingly to the polygon
  48 orientation (clockwise or counter-clockwise.)")
  49
  50 (defun map-line-intersections (function x1 y1 x2 y2)
  51   (declare (optimize speed (safety 0) (debug 0)))
  52   (when (/= y1 y2)
  53     (when (> y1 y2)
  54       (rotatef y1 y2)
  55       (rotatef x1 x2))
  56     (let ((dx (- x2 x1))
  57           (dy (- y2 y1)))
  58       ;; FIXME: optimize the loop with the usual Bresenham integer
  59       ;; algorithm
  60       (loop for n from (* +cell-width+ (ceiling y1 +cell-width+))
  61                   upto (* +cell-width+ (floor (1- y2) +cell-width+))
  62                   by +cell-width+
  63          do (funcall function
  64                      (+ x1 (floor (* dx (- n y1)) dy))
  65                      n)))))
  66
  67 (defstruct cell
  68   x y (value 0))
  69
  70 (defstruct state
  71   "AA state. Hold all the cells generated when drawing lines."
  72   (cells nil))
  73
  74 (defun state-reset (state)
  75   "Reset the state, losing all accumulated cells. It can be
  76 faster or less memory consuming to reset a state and reuse it,
  77 rather than creating a new state."
  78   (setf (state-cells state) nil))
  79
  80 (declaim (inline set-current-cell))
  81 (defun set-current-cell (state x y)
  82   (let ((cells (state-cells state)))
  83     (if (and cells
  84              (= (cell-x (first cells)) x)
  85              (= (cell-y (first cells)) y))
  86         (first cells)
  87         (let ((cell (make-cell :x x :y y)))
  88           (push cell (state-cells state))
  89           cell))))
  90
  91 (defun line (state x1 y1 x2 y2)
  92   (when (/= y1 y2)
  93     (map-line-intersections (lambda (x y)
  94                               (let ((x-m (ceiling x +cell-width+))
  95                                     (y-m (floor y +cell-width+)))
  96                                 (incf (cell-value (set-current-cell state x-m y-m))
  97                                       (if (< y1 y2) 1 -1))))
  98                             (- x1 (floor +cell-width+ 2))
  99                             (- y1 (floor +cell-width+ 2))
 100                             (- x2 (floor +cell-width+ 2))
 101                             (- y2 (floor +cell-width+ 2)))))
 102
 103 (defun line-f (state x1 y1 x2 y2)
 104   "Draw a line, whose coordinates are translated to fixed-point
 105 as expected by function LINE. This is a convenient function to
 106 not depend on +CELL-WIDTH+."
 107   (labels ((float-to-fixed (n)
 108              (values (round (* +cell-width+ n)))))
 109     (line state
 110           (float-to-fixed x1) (float-to-fixed y1)
 111           (float-to-fixed x2) (float-to-fixed y2))))
 112
 113 (declaim (inline compare-cells))
 114 (defun compare-cells (a b)
 115   "Compare coordinates between 2 cells. Used to sort cells by Y,
 116 then by X."
 117   (or (< (cell-y a) (cell-y b))
 118       (and (= (cell-y a) (cell-y b))
 119            (< (cell-x a) (cell-x b)))))
 120
 121 (defun cells-sweep (state function &optional span-function)
 122   "Call FUNCTION for each pixel on the polygon path described by
 123 previous call to LINE or LINE-F. The pixels are scanned in
 124 increasing Y, then on increasing X. For optimization purpose, the
 125 optional FUNCTION-SPAN, if provided, is called for a full span of
 126 identical alpha pixel. If not provided, a call is made to
 127 FUNCTION for each pixel in the span."
 128   (setf (state-cells state) (sort (state-cells state) #'compare-cells))
 129   (let (x y value)
 130     (flet ((call ()
 131              (unless (zerop value)
 132                (funcall function x y (* +alpha-range+ value)))))
 133       (dolist (cell (state-cells state))
 134         (cond
 135           ((null value)
 136            ;; first cell
 137            (setf x (cell-x cell)
 138                  y (cell-y cell)
 139                  value (cell-value cell)))
 140           ((/= (cell-y cell) y)
 141            ;; different y
 142            (call)
 143            (setf x (cell-x cell)
 144                  y (cell-y cell)
 145                  value (cell-value cell)))
 146           ((/= (cell-x cell) x)
 147            ;; same y, different x
 148            (call)
 149            (unless (zerop value)
 150              (let ((scaled-value (* +alpha-range+ value)))
 151                (if (and (> (- (cell-x cell) x) 1)
 152                         span-function)
 153                    (funcall span-function (1+ x) (cell-x cell) y scaled-value)
 154                    (loop for ix from (1+ x) below (cell-x cell)
 155                       do (funcall function ix y scaled-value)))))
 156            (setf x (cell-x cell))
 157            (incf value (cell-value cell)))
 158           (t
 159            ;; same cell, accumulate
 160            (incf value (cell-value cell)))))
 161       (when value
 162         (call)))))