user-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: user-drawing.lisp,v 1.21 2007/10/01 14:12:55 xach Exp $
  28
  29 (in-package #:vecto)
  30
  31 (defvar *graphics-state*)
  32 (setf (documentation '*graphics-state* 'variable)
  33       "The currently active graphics state. Bound for the
  34       duration of WITH-GRAPICS-STATE.")
  35
  36 ;;; Low-level path construction
  37
  38 (defun %move-to (state x y)
  39   (let ((path (paths:create-path :open-polyline)))
  40     (push (setf (path state) path) (paths state))
  41     (paths:path-reset path (paths:make-point x y))))
  42
  43 (defun %line-to (state x y)
  44   (paths:path-extend (path state) (paths:make-straight-line)
  45                      (paths:make-point x y)))
  46
  47 (defun %curve-to (state cx1 cy1 cx2 cy2 x y)
  48   "Draw a cubic Bezier curve from the current point to (x,y)
  49 through two control points."
  50   (let ((control-point-1 (paths:make-point cx1 cy1))
  51         (control-point-2 (paths:make-point cx2 cy2))
  52         (end-point (paths:make-point x y)))
  53     (paths:path-extend (path state)
  54                        (paths:make-bezier-curve (list control-point-1
  55                                                       control-point-2))
  56                        end-point)))
  57
  58 (defun %quadratic-to (state cx cy x y)
  59   "Draw a quadratic Bezier curve from the current point to (x,y)
  60 through one control point."
  61   (paths:path-extend (path state)
  62                      (paths:make-bezier-curve (list (paths:make-point cx cy)))
  63                      (paths:make-point x y)))
  64
  65 (defun draw-arc-curves (curves)
  66   (destructuring-bind (((startx . starty) &rest ignored-curve)
  67                        &rest ignored-curves)
  68       curves
  69     (declare (ignore ignored-curve ignored-curves))
  70     (if (path *graphics-state*)
  71         (line-to startx starty)
  72         (move-to startx starty)))
  73   (loop for ((x1 . y1)
  74              (cx1 . cy1)
  75              (cx2 . cy2)
  76              (x2 . y2)) in curves
  77         do (curve-to cx1 cy1 cx2 cy2 x2 y2)))
  78
  79 (defun %close-subpath (state)
  80   (setf (paths::path-type (path state)) :closed-polyline))
  81
  82 ;;; Clipping path
  83
  84 (defun %end-path-no-op (state)
  85   (after-painting state))
  86
  87 (defun %clip-path (state)
  88   (call-after-painting state
  89                        (make-clipping-path-function state :nonzero-winding)))
  90
  91 (defun %even-odd-clip-path (state)
  92   (call-after-painting state
  93                        (make-clipping-path-function state :even-odd)))
  94
  95 ;;; Text
  96
  97 (defun %get-font (state file)
  98   (find-font-loader state file))
  99
 100 (defun %set-font (state loader size)
 101   (let* ((scale (loader-font-scale size loader))
 102          (matrix (scaling-matrix scale scale)))
 103     (setf (font state)
 104           (make-instance 'font
 105                          :loader loader
 106                          :transform-matrix matrix
 107                          :size size))))
 108
 109 (defun %string-paths (state x y string)
 110   (let ((font (font state)))
 111     (unless font
 112       (error "No font currently set"))
 113     (string-primitive-paths x y string font
 114                             :character-spacing (character-spacing state))))
 115
 116 (defun %draw-string (state x y string)
 117   (draw-paths/state (%string-paths state x y string)
 118                     state))
 119
 120 (defun %draw-centered-string (state x y string)
 121   (let* ((font (font state))
 122          (bbox
 123           (string-bounding-box string
 124                                (size font)
 125                                (loader font)
 126                                :character-spacing (character-spacing state)))
 127          (xmin (xmin bbox))
 128          (width/2 (/ (- (xmax bbox) xmin) 2.0)))
 129     (%draw-string state (- x (+ width/2 xmin)) y string)))
 130
 131 (defun string-paths (x y string)
 132   (setf (paths *graphics-state*)
 133         (append (paths *graphics-state*)
 134                 (%string-paths *graphics-state* x y string)))
 135   (values))
 136
 137 (defun centered-string-paths (x y string)
 138   (let* ((font (font *graphics-state*))
 139          (bbox (string-bounding-box string (size font) (loader font)))
 140          (width/2 (/ (- (xmax bbox) (xmin bbox)) 2.0)))
 141     (setf (paths *graphics-state*)
 142           (append (paths *graphics-state*)
 143                   (%string-paths *graphics-state* (- x width/2) y string)))
 144     (values)))
 145
 146
 147 ;;; Low-level transforms
 148
 149 (defun %translate (state tx ty)
 150   (apply-matrix state (translation-matrix tx ty)))
 151
 152 (defun %scale (state sx sy)
 153   (apply-matrix state (scaling-matrix sx sy)))
 154
 155 (defun %skew (state x y)
 156   (apply-matrix state (skewing-matrix x y)))
 157
 158 (defun %rotate (state radians)
 159   (apply-matrix state (rotation-matrix radians)))
 160
 161 ;;; User-level commands
 162
 163 (defun move-to (x y)
 164   (%move-to *graphics-state* x y))
 165
 166 (defun line-to (x y)
 167   (%line-to *graphics-state* x y))
 168
 169 (defun curve-to (cx1 cy1 cx2 cy2 x y)
 170   (%curve-to *graphics-state* cx1 cy1 cx2 cy2 x y))
 171
 172 (defun quadratic-to (cx cy x y)
 173   (%quadratic-to *graphics-state* cx cy x y))
 174
 175 (defun arc (cx cy r theta1 theta2)
 176   (loop while (< theta2 theta1) do (incf theta2 (* 2 pi)))
 177   (let ((curves
 178          (approximate-elliptical-arc cx cy r r 0 theta1 theta2)))
 179     (draw-arc-curves curves)))
 180
 181 (defun arcn (cx cy r theta1 theta2)
 182   (loop while (< theta1 theta2) do (decf theta2 (* 2 pi)))
 183   (let ((curves (approximate-elliptical-arc cx cy r r 0 theta2 theta1)))
 184     (draw-arc-curves (nreverse (mapcar #'nreverse curves)))))
 185
 186 (defun close-subpath ()
 187   (%close-subpath *graphics-state*))
 188
 189 (defun end-path-no-op ()
 190   (%end-path-no-op *graphics-state*)
 191   (clear-paths *graphics-state*))
 192
 193 (defun clip-path ()
 194   (%clip-path *graphics-state*))
 195
 196 (defun even-odd-clip-path ()
 197   (%even-odd-clip-path *graphics-state*))
 198
 199 (defun get-font (file)
 200   (%get-font *graphics-state* file))
 201
 202 (defun set-font (font size)
 203   (%set-font *graphics-state* font size))
 204
 205 (defun set-character-spacing (spacing)
 206   (setf (character-spacing *graphics-state*) spacing))
 207
 208 (defun draw-string (x y string)
 209   (%draw-string *graphics-state* x y string))
 210
 211 (defun draw-centered-string (x y string)
 212   (%draw-centered-string *graphics-state* x y string))
 213
 214 (defun set-dash-pattern (vector phase)
 215   (if (zerop (length vector))
 216       (setf (dash-vector *graphics-state*) nil
 217             (dash-phase *graphics-state*) nil)
 218       (setf (dash-vector *graphics-state*) vector
 219             (dash-phase *graphics-state*) phase)))
 220
 221 (defun set-line-cap (style)
 222   (assert (member style '(:butt :square :round)))
 223   (setf (cap-style *graphics-state*) style))
 224
 225 (defun set-line-join (style)
 226   (assert (member style '(:bevel :miter :round)))
 227   (setf (join-style *graphics-state*) (if (eql style :bevel) :none style)))
 228
 229 (defun set-line-width (width)
 230   (setf (line-width *graphics-state*) width))
 231
 232 (defun set-rgba-color (color r g b a)
 233   (setf (red color) (clamp-range 0.0 r 1.0)
 234         (green color) (clamp-range 0.0 g 1.0)
 235         (blue color) (clamp-range 0.0 b 1.0)
 236         (alpha color) (clamp-range 0.0 a 1.0))
 237   color)
 238
 239 (defun set-rgb-color (color r g b)
 240   (setf (red color) (clamp-range 0.0 r 1.0)
 241         (green color) (clamp-range 0.0 g 1.0)
 242         (blue color) (clamp-range 0.0 b 1.0)
 243         (alpha color) 1.0)
 244   color)
 245
 246 (defun set-rgb-stroke (r g b)
 247   (set-rgb-color (stroke-color *graphics-state*) r g b))
 248
 249 (defun set-rgba-stroke (r g b a)
 250   (set-rgba-color (stroke-color *graphics-state*) r g b a))
 251
 252 (defun set-rgb-fill (r g b)
 253   (clear-fill-source *graphics-state*)
 254   (set-rgb-color (fill-color *graphics-state*) r g b))
 255
 256 (defun set-rgba-fill (r g b a)
 257   (clear-fill-source *graphics-state*)
 258   (set-rgba-color (fill-color *graphics-state*) r g b a))
 259
 260 (defun stroke ()
 261   (draw-stroked-paths *graphics-state*)
 262   (clear-paths *graphics-state*))
 263
 264 (defun stroke-to-paths ()
 265   (let ((paths (state-stroke-paths *graphics-state*)))
 266     (clear-paths *graphics-state*)
 267     (setf (paths *graphics-state*) paths)
 268     (%close-subpath *graphics-state*)))
 269
 270 (defun fill-path ()
 271   (draw-filled-paths *graphics-state*)
 272   (after-painting *graphics-state*)
 273   (clear-paths *graphics-state*))
 274
 275 (defun even-odd-fill ()
 276   (draw-even-odd-filled-paths *graphics-state*)
 277   (after-painting *graphics-state*)
 278   (clear-paths *graphics-state*))
 279
 280 (defun fill-and-stroke ()
 281   (draw-filled-paths *graphics-state*)
 282   (draw-stroked-paths *graphics-state*)
 283   (after-painting *graphics-state*)
 284   (clear-paths *graphics-state*))
 285
 286 (defun even-odd-fill-and-stroke ()
 287   (draw-even-odd-filled-paths *graphics-state*)
 288   (draw-stroked-paths *graphics-state*)
 289   (after-painting *graphics-state*)
 290   (clear-paths *graphics-state*))
 291
 292
 293 (defun clear-canvas ()
 294   (let ((color (fill-color *graphics-state*)))
 295     (fill-image (image-data *graphics-state*)
 296                 (red color)
 297                 (green color)
 298                 (blue color)
 299                 (alpha color))))
 300
 301 (defun translate (x y)
 302   (%translate *graphics-state* x y))
 303
 304 (defun scale (x y)
 305   (%scale *graphics-state* x y))
 306
 307 (defun skew (x y)
 308   (%skew *graphics-state* x y))
 309
 310 (defun rotate (radians)
 311   (%rotate *graphics-state* radians))
 312
 313 (defun rotate-degrees (degrees)
 314   (%rotate *graphics-state* (* (/ pi 180) degrees)))
 315
 316 (defun save-png (file)
 317   (zpng:write-png (image *graphics-state*) file))
 318
 319 (defun save-png-stream (stream)
 320   (zpng:write-png-stream (image *graphics-state*) stream))
 321
 322 (defmacro with-canvas ((&key width height) &body body)
 323   `(let ((*graphics-state* (make-instance 'graphics-state)))
 324      (state-image *graphics-state* ,width ,height)
 325      (unwind-protect
 326           (progn
 327             ,@body)
 328        (clear-state *graphics-state*))))
 329
 330 (defmacro with-graphics-state (&body body)
 331   `(let ((*graphics-state* (copy *graphics-state*)))
 332      ,@body))