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