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