graphics-state.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: graphics-state.lisp,v 1.15 2007/10/01 02:24:44 xach Exp $
  28
  29 (in-package #:vecto)
  30
  31 (defconstant +png-channels+ 4)
  32 (defconstant +png-color-type+ :truecolor-alpha)
  33 (defvar *default-character-spacing* 1.0d0)
  34
  35 (defclass graphics-state ()
  36   ((paths
  37     :initarg :paths
  38     :accessor paths)
  39    (path
  40     :initarg :path
  41     :accessor path)
  42    (height
  43     :initarg :height
  44     :accessor height)
  45    (width
  46     :initarg :width
  47     :accessor width)
  48    (image
  49     :initarg :image
  50     :accessor image)
  51    (stroke-color
  52     :initarg :stroke-color
  53     :accessor stroke-color)
  54    (line-width
  55     :initarg :line-width
  56     :accessor line-width)
  57    (dash-vector
  58     :initarg :dash-vector
  59     :accessor dash-vector)
  60    (dash-phase
  61     :initarg :dash-phase
  62     :accessor dash-phase)
  63    (fill-color
  64     :initarg :fill-color
  65     :accessor fill-color)
  66    (fill-source
  67     :initarg :fill-source
  68     :accessor fill-source)
  69    (join-style
  70     :initarg :join-style
  71     :accessor join-style)
  72    (cap-style
  73     :initarg :cap-style
  74     :accessor cap-style)
  75    (transform-matrix
  76     :initarg :transform-matrix
  77     :accessor transform-matrix)
  78    (clipping-path
  79     :initarg :clipping-path
  80     :accessor clipping-path)
  81    (after-paint-fun
  82     :initarg :after-paint-fun
  83     :accessor after-paint-fun)
  84    (font-loaders
  85     :initarg :font-loaders
  86     :accessor font-loaders)
  87    (font
  88     :initarg :font
  89     :accessor font)
  90    (character-spacing
  91     :initarg :character-spacing
  92     :accessor character-spacing))
  93   (:default-initargs
  94    :paths nil
  95    :path nil
  96    :stroke-color (make-instance 'rgba-color)
  97    :line-width 1.0
  98    :dash-vector nil
  99    :dash-phase 0
 100    :fill-color (make-instance 'rgba-color)
 101    :fill-source nil
 102    :join-style :miter
 103    :cap-style :butt
 104    :transform-matrix (scaling-matrix 1.0 -1.0)
 105    :after-paint-fun (constantly nil)
 106    :font-loaders (make-hash-table :test 'equal)
 107    :font nil
 108    :character-spacing *default-character-spacing*))
 109
 110 (defgeneric image-data (state)
 111   (:method (state)
 112     (zpng:image-data (image state))))
 113
 114 (defgeneric transform-function (state)
 115   (:documentation "Return a function that takes x, y coordinates
 116 and returns them transformed by STATE's current transformation
 117 matrix as multiple values.")
 118   (:method (state)
 119     (make-transform-function (transform-matrix state))))
 120
 121
 122 (defgeneric call-after-painting (state fun)
 123   (:documentation
 124    "Call FUN after painting, and reset the post-painting fun to a no-op.")
 125   (:method (state fun)
 126     (setf (after-paint-fun state)
 127           (lambda ()
 128             (funcall fun)
 129             (setf (after-paint-fun state) (constantly nil))))))
 130
 131 (defgeneric after-painting (state)
 132   (:documentation "Invoke the post-painting function.")
 133   (:method (state)
 134     (funcall (after-paint-fun state))))
 135
 136
 137 (defgeneric apply-matrix (state matrix)
 138   (:documentation "Replace the current transform matrix of STATE
 139 with the result of premultiplying it with MATRIX.")
 140   (:method (state matrix)
 141     (let ((old (transform-matrix state)))
 142       (setf (transform-matrix state) (mult matrix old)))))
 143
 144 (defgeneric clear-paths (state)
 145   (:documentation "Clear out any paths in STATE.")
 146   (:method (state)
 147     (setf (paths state) nil
 148           (path state) nil
 149           (after-paint-fun state) (constantly nil))))
 150
 151 (defmethod (setf paths) :after (new-value (state graphics-state))
 152   (setf (path state) (first new-value)))
 153
 154 (defun state-image (state width height)
 155   "Set the backing image of the graphics state to an image of the
 156 specified dimensions."
 157   (setf (image state)
 158         (make-instance 'zpng:png
 159                        :width width
 160                        :height height
 161                        :color-type +png-color-type+)
 162         (width state) width
 163         (height state) height
 164         (clipping-path state) (make-clipping-path width height))
 165   (apply-matrix state (translation-matrix 0 (- height))))
 166
 167
 168 (defun find-font-loader (state file)
 169   (let* ((cache (font-loaders state))
 170          (key (namestring (truename file))))
 171     (or (gethash key cache)
 172         (setf (gethash key cache) (zpb-ttf:open-font-loader file)))))
 173
 174 (defgeneric close-font-loaders (state)
 175   (:documentation "Close any font loaders that were obtained with GET-FONT.")
 176   (:method (state)
 177     (maphash (lambda (filename loader)
 178                (declare (ignore filename))
 179                (ignore-errors (zpb-ttf:close-font-loader loader)))
 180              (font-loaders state))))
 181
 182 (defgeneric clear-state (state)
 183   (:documentation "Clean up any state in STATE.")
 184   (:method ((state graphics-state))
 185     (close-font-loaders state)))
 186
 187 (defun clear-fill-source (state)
 188   (setf (fill-source state) nil))
 189
 190 (defmethod copy ((state graphics-state))
 191   (make-instance 'graphics-state
 192                  :paths (paths state)
 193                  :path (path state)
 194                  :height (height state)
 195                  :width (width state)
 196                  :image (image state)
 197                  :stroke-color (copy (stroke-color state))
 198                  :line-width (line-width state)
 199                  :dash-vector (copy-seq (dash-vector state))
 200                  :dash-phase (dash-phase state)
 201                  :fill-color (copy (fill-color state))
 202                  :fill-source (fill-source state)
 203                  :join-style (join-style state)
 204                  :cap-style (cap-style state)
 205                  :transform-matrix (copy-seq (transform-matrix state))
 206                  :clipping-path (copy (clipping-path state))
 207                  :after-paint-fun (after-paint-fun state)
 208                  :font-loaders (font-loaders state)
 209                  :font (font state)
 210                  :character-spacing (character-spacing state)))