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