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    (blend-style
  76     :initarg :blend-style
  77     :accessor blend-style)
  78    (transform-matrix
  79     :initarg :transform-matrix
  80     :accessor transform-matrix)
  81    (clipping-path
  82     :initarg :clipping-path
  83     :accessor clipping-path)
  84    (after-paint-fun
  85     :initarg :after-paint-fun
  86     :accessor after-paint-fun)
  87    (font-loaders
  88     :initarg :font-loaders
  89     :accessor font-loaders)
  90    (font
  91     :initarg :font
  92     :accessor font)
  93    (character-spacing
  94     :initarg :character-spacing
  95     :accessor character-spacing))
  96   (:default-initargs
  97    :paths nil
  98    :path nil
  99    :stroke-color (make-instance 'rgba-color)
 100    :line-width 1.0
 101    :dash-vector nil
 102    :dash-phase 0
 103    :fill-color (make-instance 'rgba-color)
 104    :fill-source nil
 105    :join-style :miter
 106    :cap-style :butt
 107    :blend-style :blend
 108    :transform-matrix (scaling-matrix 1.0 -1.0)
 109    :after-paint-fun (constantly nil)
 110    :font-loaders (make-hash-table :test 'equal)
 111    :font nil
 112    :character-spacing *default-character-spacing*))
 113
 114 (defgeneric image-data (state)
 115   (:method (state)
 116     (zpng:image-data (image state))))
 117
 118 (defgeneric transform-function (state)
 119   (:documentation "Return a function that takes x, y coordinates
 120 and returns them transformed by STATE's current transformation
 121 matrix as multiple values.")
 122   (:method (state)
 123     (make-transform-function (transform-matrix state))))
 124
 125
 126 (defgeneric call-after-painting (state fun)
 127   (:documentation
 128    "Call FUN after painting, and reset the post-painting fun to a no-op.")
 129   (:method (state fun)
 130     (setf (after-paint-fun state)
 131           (lambda ()
 132             (funcall fun)
 133             (setf (after-paint-fun state) (constantly nil))))))
 134
 135 (defgeneric after-painting (state)
 136   (:documentation "Invoke the post-painting function.")
 137   (:method (state)
 138     (funcall (after-paint-fun state))))
 139
 140
 141 (defgeneric apply-matrix (state matrix)
 142   (:documentation "Replace the current transform matrix of STATE
 143 with the result of premultiplying it with MATRIX.")
 144   (:method (state matrix)
 145     (let ((old (transform-matrix state)))
 146       (setf (transform-matrix state) (mult matrix old)))))
 147
 148 (defgeneric clear-paths (state)
 149   (:documentation "Clear out any paths in STATE.")
 150   (:method (state)
 151     (setf (paths state) nil
 152           (path state) nil
 153           (after-paint-fun state) (constantly nil))))
 154
 155 (defmethod (setf paths) :after (new-value (state graphics-state))
 156   (setf (path state) (first new-value)))
 157
 158 (defun state-image (state width height)
 159   "Set the backing image of the graphics state to an image of the
 160 specified dimensions."
 161   (setf (image state)
 162         (make-instance 'zpng:png
 163                        :width width
 164                        :height height
 165                        :color-type +png-color-type+)
 166         (width state) width
 167         (height state) height
 168         (clipping-path state) (make-clipping-path width height))
 169   (apply-matrix state (translation-matrix 0 (- height))))
 170
 171
 172 (defun find-font-loader (state file)
 173   (let* ((cache (font-loaders state))
 174          (key (namestring (truename file))))
 175     (or (gethash key cache)
 176         (setf (gethash key cache) (zpb-ttf:open-font-loader file)))))
 177
 178 (defgeneric close-font-loaders (state)
 179   (:documentation "Close any font loaders that were obtained with GET-FONT.")
 180   (:method (state)
 181     (maphash (lambda (filename loader)
 182                (declare (ignore filename))
 183                (ignore-errors (zpb-ttf:close-font-loader loader)))
 184              (font-loaders state))))
 185
 186 (defgeneric clear-state (state)
 187   (:documentation "Clean up any state in STATE.")
 188   (:method ((state graphics-state))
 189     (close-font-loaders state)))
 190
 191 (defun clear-fill-source (state)
 192   (setf (fill-source state) nil))
 193
 194 (defmethod copy ((state graphics-state))
 195   (make-instance 'graphics-state
 196                  :paths (paths state)
 197                  :path (path state)
 198                  :height (height state)
 199                  :width (width state)
 200                  :image (image state)
 201                  :stroke-color (copy (stroke-color state))
 202                  :line-width (line-width state)
 203                  :dash-vector (copy-seq (dash-vector state))
 204                  :dash-phase (dash-phase state)
 205                  :fill-color (copy (fill-color state))
 206                  :fill-source (fill-source state)
 207                  :join-style (join-style state)
 208                  :cap-style (cap-style state)
 209                  :transform-matrix (copy-seq (transform-matrix state))
 210                  :clipping-path (copy (clipping-path state))
 211                  :after-paint-fun (after-paint-fun state)
 212                  :font-loaders (font-loaders state)
 213                  :font (font state)
 214                  :character-spacing (character-spacing state)))