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
 115 (defun %draw-string (state x y string)
 116   (draw-paths/state (%string-paths state x y string)
 117                     state))
 118
 119 (defun %draw-centered-string (state x y string)
 120   (let* ((font (font state))
 121          (bbox (string-bounding-box string (size font) (loader font)))
 122          (width/2 (/ (- (xmax bbox) (xmin bbox)) 2.0)))
 123     (%draw-string state (- x width/2) y string)))
 124
 125 (defun string-paths (state x y string)
 126   (setf (paths state)
 127         (append (paths state) (%string-paths state x y string)))
 128   (values))
 129
 130 (defun centered-string-paths (state x y string)
 131   (let* ((font (font state))
 132          (bbox (string-bounding-box string (size font) (loader font)))
 133          (width/2 (/ (- (xmax bbox) (xmin bbox)) 2.0)))
 134     (setf (paths state)
 135           (append (paths state) (%string-paths state (- x width/2) y string)))
 136     (values)))
 137
 138
 139 ;;; Low-level transforms
 140
 141 (defun %translate (state tx ty)
 142   (apply-matrix state (translation-matrix tx ty)))
 143
 144 (defun %scale (state sx sy)
 145   (apply-matrix state (scaling-matrix sx sy)))
 146
 147 (defun %skew (state x y)
 148   (apply-matrix state (skewing-matrix x y)))
 149
 150 (defun %rotate (state radians)
 151   (apply-matrix state (rotation-matrix radians)))
 152
 153 ;;; User-level commands
 154
 155 (defun move-to (x y)
 156   (%move-to *graphics-state* x y))
 157
 158 (defun line-to (x y)
 159   (%line-to *graphics-state* x y))
 160
 161 (defun curve-to (cx1 cy1 cx2 cy2 x y)
 162   (%curve-to *graphics-state* cx1 cy1 cx2 cy2 x y))
 163
 164 (defun quadratic-to (cx cy x y)
 165   (%quadratic-to *graphics-state* cx cy x y))
 166
 167 (defun arc (cx cy r theta1 theta2)
 168   (loop while (< theta2 theta1) do (incf theta2 (* 2 pi)))
 169   (let ((curves
 170          (approximate-elliptical-arc cx cy r r 0 theta1 theta2)))
 171     (draw-arc-curves curves)))
 172
 173 (defun arcn (cx cy r theta1 theta2)
 174   (loop while (< theta1 theta2) do (decf theta2 (* 2 pi)))
 175   (let ((curves (approximate-elliptical-arc cx cy r r 0 theta2 theta1)))
 176     (draw-arc-curves (nreverse (mapcar #'nreverse curves)))))
 177
 178 (defun close-subpath ()
 179   (%close-subpath *graphics-state*))
 180
 181 (defun end-path-no-op ()
 182   (%end-path-no-op *graphics-state*)
 183   (clear-paths *graphics-state*))
 184
 185 (defun clip-path ()
 186   (%clip-path *graphics-state*))
 187
 188 (defun even-odd-clip-path ()
 189   (%even-odd-clip-path *graphics-state*))
 190
 191 (defun get-font (file)
 192   (%get-font *graphics-state* file))
 193
 194 (defun set-font (font size)
 195   (%set-font *graphics-state* font size))
 196
 197 (defun draw-string (x y string)
 198   (%draw-string *graphics-state* x y string))
 199
 200 (defun draw-centered-string (x y string)
 201   (%draw-centered-string *graphics-state* x y string))
 202
 203 (defun set-dash-pattern (vector phase)
 204   (if (zerop (length vector))
 205       (setf (dash-vector *graphics-state*) nil
 206             (dash-phase *graphics-state*) nil)
 207       (setf (dash-vector *graphics-state*) vector
 208             (dash-phase *graphics-state*) phase)))
 209
 210 (defun set-line-cap (style)
 211   (assert (member style '(:butt :square :round)))
 212   (setf (cap-style *graphics-state*) style))
 213
 214 (defun set-line-join (style)
 215   (assert (member style '(:bevel :miter :round)))
 216   (setf (join-style *graphics-state*) (if (eql style :bevel) :none style)))
 217
 218 (defun set-line-width (width)
 219   (setf (line-width *graphics-state*) width))
 220
 221 (defun set-rgba-color (color r g b a)
 222   (setf (red color) (clamp-range 0.0 r 1.0)
 223         (green color) (clamp-range 0.0 g 1.0)
 224         (blue color) (clamp-range 0.0 b 1.0)
 225         (alpha color) (clamp-range 0.0 a 1.0))
 226   color)
 227
 228 (defun set-rgb-color (color r g b)
 229   (setf (red color) (clamp-range 0.0 r 1.0)
 230         (green color) (clamp-range 0.0 g 1.0)
 231         (blue color) (clamp-range 0.0 b 1.0)
 232         (alpha color) 1.0)
 233   color)
 234
 235 (defun set-rgb-stroke (r g b)
 236   (set-rgb-color (stroke-color *graphics-state*) r g b))
 237
 238 (defun set-rgba-stroke (r g b a)
 239   (set-rgba-color (stroke-color *graphics-state*) r g b a))
 240
 241 (defun set-rgb-fill (r g b)
 242   (set-rgb-color (fill-color *graphics-state*) r g b))
 243
 244 (defun set-rgba-fill (r g b a)
 245   (set-rgba-color (fill-color *graphics-state*) r g b a))
 246
 247 (defun stroke ()
 248   (draw-stroked-paths *graphics-state*)
 249   (clear-paths *graphics-state*))
 250
 251 (defun stroke-to-paths ()
 252   (let ((paths (state-stroke-paths *graphics-state*)))
 253     (clear-paths *graphics-state*)
 254     (setf (paths *graphics-state*) paths)
 255     (%close-subpath *graphics-state*)))
 256
 257 (defun fill-path ()
 258   (draw-filled-paths *graphics-state*)
 259   (after-painting *graphics-state*)
 260   (clear-paths *graphics-state*))
 261
 262 (defun even-odd-fill ()
 263   (draw-even-odd-filled-paths *graphics-state*)
 264   (after-painting *graphics-state*)
 265   (clear-paths *graphics-state*))
 266
 267 (defun fill-and-stroke ()
 268   (draw-filled-paths *graphics-state*)
 269   (draw-stroked-paths *graphics-state*)
 270   (clear-paths *graphics-state*))
 271
 272 (defun even-odd-fill-and-stroke ()
 273   (draw-even-odd-filled-paths *graphics-state*)
 274   (draw-stroked-paths *graphics-state*)
 275   (after-painting *graphics-state*)
 276   (clear-paths *graphics-state*))
 277
 278
 279 (defun clear-canvas ()
 280   (let ((color (fill-color *graphics-state*)))
 281     (fill-image (image-data *graphics-state*)
 282                 (red color)
 283                 (green color)
 284                 (blue color)
 285                 (alpha color))))
 286
 287 (defun translate (x y)
 288   (%translate *graphics-state* x y))
 289
 290 (defun scale (x y)
 291   (%scale *graphics-state* x y))
 292
 293 (defun skew (x y)
 294   (%skew *graphics-state* x y))
 295
 296 (defun rotate (radians)
 297   (%rotate *graphics-state* radians))
 298
 299 (defun rotate-degrees (degrees)
 300   (%rotate *graphics-state* (* (/ pi 180) degrees)))
 301
 302 (defun save-png (file)
 303   (zpng:write-png (image *graphics-state*) file))
 304
 305 (defun save-png-stream (stream)
 306   (zpng:write-png-stream (image *graphics-state*) stream))
 307
 308 (defmacro with-canvas ((&key width height) &body body)
 309   `(let ((*graphics-state* (make-instance 'graphics-state)))
 310      (state-image *graphics-state* ,width ,height)
 311      (unwind-protect
 312           (progn
 313             ,@body)
 314        (clear-state *graphics-state*))))
 315
 316 (defmacro with-graphics-state (&body body)
 317   `(let ((*graphics-state* (copy *graphics-state*)))
 318      ,@body))