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 ellipse-arc (cx cy rx ry theta eta1 eta2)
 187   (loop while (< eta2 eta1) do (incf eta2 (* 2 pi)))
 188   (let ((curves (approximate-elliptical-arc cx cy rx ry theta eta1 eta2)))
 189     (draw-arc-curves curves)))
 190
 191 (defun ellipse-arcn (cx cy rx ry theta eta1 eta2)
 192   (loop while (< eta1 eta2) do (decf eta2 (* 2 pi)))
 193   (let ((curves (approximate-elliptical-arc cx cy rx ry theta eta2 eta1)))
 194     (draw-arc-curves (nreverse (mapcar #'nreverse curves)))))
 195
 196
 197
 198 (defun close-subpath ()
 199   (%close-subpath *graphics-state*))
 200
 201 (defun end-path-no-op ()
 202   (%end-path-no-op *graphics-state*)
 203   (clear-paths *graphics-state*))
 204
 205 (defun clip-path ()
 206   (%clip-path *graphics-state*))
 207
 208 (defun even-odd-clip-path ()
 209   (%even-odd-clip-path *graphics-state*))
 210
 211 (defun get-font (file)
 212   (%get-font *graphics-state* file))
 213
 214 (defun set-font (font size)
 215   (%set-font *graphics-state* font size))
 216
 217 (defun set-character-spacing (spacing)
 218   (setf (character-spacing *graphics-state*) spacing))
 219
 220 (defun draw-string (x y string)
 221   (%draw-string *graphics-state* x y string))
 222
 223 (defun draw-centered-string (x y string)
 224   (%draw-centered-string *graphics-state* x y string))
 225
 226 (defun set-dash-pattern (vector phase)
 227   (if (zerop (length vector))
 228       (setf (dash-vector *graphics-state*) nil
 229             (dash-phase *graphics-state*) nil)
 230       (setf (dash-vector *graphics-state*) vector
 231             (dash-phase *graphics-state*) phase)))
 232
 233 (defun set-line-cap (style)
 234   (assert (member style '(:butt :square :round)))
 235   (setf (cap-style *graphics-state*) style))
 236
 237 (defun set-line-join (style)
 238   (assert (member style '(:bevel :miter :round)))
 239   (setf (join-style *graphics-state*) (if (eql style :bevel) :none style)))
 240
 241 (defun set-line-width (width)
 242   (setf (line-width *graphics-state*) width))
 243
 244 (defun set-rgba-color (color r g b a)
 245   (setf (red color) (clamp-range 0.0 r 1.0)
 246         (green color) (clamp-range 0.0 g 1.0)
 247         (blue color) (clamp-range 0.0 b 1.0)
 248         (alpha color) (clamp-range 0.0 a 1.0))
 249   color)
 250
 251 (defun set-rgb-color (color r g b)
 252   (setf (red color) (clamp-range 0.0 r 1.0)
 253         (green color) (clamp-range 0.0 g 1.0)
 254         (blue color) (clamp-range 0.0 b 1.0)
 255         (alpha color) 1.0)
 256   color)
 257
 258 (defun set-rgb-stroke (r g b)
 259   (set-rgb-color (stroke-color *graphics-state*) r g b))
 260
 261 (defun set-rgba-stroke (r g b a)
 262   (set-rgba-color (stroke-color *graphics-state*) r g b a))
 263
 264 (defun set-rgb-fill (r g b)
 265   (clear-fill-source *graphics-state*)
 266   (set-rgb-color (fill-color *graphics-state*) r g b))
 267
 268 (defun set-rgba-fill (r g b a)
 269   (clear-fill-source *graphics-state*)
 270   (set-rgba-color (fill-color *graphics-state*) r g b a))
 271
 272 (defun stroke ()
 273   (draw-stroked-paths *graphics-state*)
 274   (clear-paths *graphics-state*))
 275
 276 (defun stroke-to-paths ()
 277   (let ((paths (state-stroke-paths *graphics-state*)))
 278     (clear-paths *graphics-state*)
 279     (setf (paths *graphics-state*) paths)
 280     (%close-subpath *graphics-state*)))
 281
 282 (defun fill-path ()
 283   (draw-filled-paths *graphics-state*)
 284   (after-painting *graphics-state*)
 285   (clear-paths *graphics-state*))
 286
 287 (defun even-odd-fill ()
 288   (draw-even-odd-filled-paths *graphics-state*)
 289   (after-painting *graphics-state*)
 290   (clear-paths *graphics-state*))
 291
 292 (defun fill-and-stroke ()
 293   (draw-filled-paths *graphics-state*)
 294   (draw-stroked-paths *graphics-state*)
 295   (after-painting *graphics-state*)
 296   (clear-paths *graphics-state*))
 297
 298 (defun even-odd-fill-and-stroke ()
 299   (draw-even-odd-filled-paths *graphics-state*)
 300   (draw-stroked-paths *graphics-state*)
 301   (after-painting *graphics-state*)
 302   (clear-paths *graphics-state*))
 303
 304
 305 (defun clear-canvas ()
 306   (let ((color (fill-color *graphics-state*)))
 307     (fill-image (image-data *graphics-state*)
 308                 (red color)
 309                 (green color)
 310                 (blue color)
 311                 (alpha color))))
 312
 313 (defun translate (x y)
 314   (%translate *graphics-state* x y))
 315
 316 (defun scale (x y)
 317   (%scale *graphics-state* x y))
 318
 319 (defun skew (x y)
 320   (%skew *graphics-state* x y))
 321
 322 (defun rotate (radians)
 323   (%rotate *graphics-state* radians))
 324
 325 (defun rotate-degrees (degrees)
 326   (%rotate *graphics-state* (* (/ pi 180) degrees)))
 327
 328 (defun save-png (file)
 329   (zpng:write-png (image *graphics-state*) file))
 330
 331 (defun save-png-stream (stream)
 332   (zpng:write-png-stream (image *graphics-state*) stream))
 333
 334 (defmacro with-canvas ((&key width height) &body body)
 335   `(let ((*graphics-state* (make-instance 'graphics-state)))
 336      (state-image *graphics-state* ,width ,height)
 337      (unwind-protect
 338           (progn
 339             ,@body)
 340        (clear-state *graphics-state*))))
 341
 342 (defmacro with-graphics-state (&body body)
 343   `(let ((*graphics-state* (copy *graphics-state*)))
 344      ,@body))