Please have a look at these enhancements and see if you want to merge them

drawing.lisp

@@ -47,18 +47,25 @@
 ;; ( (t) = (a) * (b) + 0x80, ( ( ( (t)>>8 ) + (t) )>>8 ) )
 
 (defun imult (a b)
+  (declare (type octet a)
+           ;; b is usually expected to be an octet as well, but in the special
+           ;; case of the caller lerp, can be negative
+           (type (integer -255 255) b))
   (let ((temp (+ (* a b) #x80)))
     (logand #xFF (ash (+ (ash temp -8) temp) -8))))
 
 (defun lerp (p q a)
+  (declare (type octet p q a))
   (logand #xFF (+ p (imult a (- q p)))))
 
 (defun prelerp (p q a)
+  (declare (type octet p q a))
   (logand #xFF (- (+ p q) (imult a p))))
 
 (defun draw-function (data width height fill-source alpha-fun)
   "From http://www.teamten.com/lawrence/graphics/premultiplication/"
-  (declare (ignore height))
+  (declare (ignore height)
+           (type octet-vector data))
   (lambda (x y alpha)
     (multiple-value-bind (r.fg g.fg b.fg a.fg)
         (funcall fill-source x y)
@@ -85,7 +92,8 @@
                               fill-source
                               alpha-fun)
   "Like DRAW-FUNCTION, but uses uses the clipping channel."
-  (declare (ignore height))
+  (declare (ignore height)
+           (type octet-vector data))
   (lambda (x y alpha)
     (let* ((clip-index (+ x (* y width)))
            (clip (aref clip-data clip-index)))
@@ -164,6 +172,7 @@ for the set of paths PATHS."
 
 (defun fill-image (image-data red green blue alpha)
   "Completely fill IMAGE with the given colors."
+  (declare (type octet-vector image-data))
   (let ((r (float-octet red))
         (g (float-octet green))
         (b (float-octet blue))
@@ -173,6 +182,7 @@ for the set of paths PATHS."
          (j 2 (+ j 4))
          (k 3 (+ k 4)))
         ((<= (length image-data) k))
+      (declare (type vector-index h i j k))
       (setf (aref image-data h) r
             (aref image-data i) g
             (aref image-data j) b

graphics-state.lisp

@@ -179,10 +179,14 @@ specified dimensions."
                (ignore-errors (zpb-ttf:close-font-loader loader)))
              (font-loaders state))))
 
-(defgeneric clear-state (state)
+(defgeneric clear-state (state &key &allow-other-keys)
   (:documentation "Clean up any state in STATE.")
-  (:method ((state graphics-state))
-    (close-font-loaders state)))
+  (:method ((state graphics-state) &key (close-font-loaders t))
+    ;; Optionally close font loaders. We may wish to re-use them across 
+    ;; different graphics states when time is of the essence, in which
+    ;; case, they must not be closed prematurely.
+    (when close-font-loaders
+      (close-font-loaders state))))
 
 (defun clear-fill-source (state)
   (setf (fill-source state) nil))

package.lisp

@@ -39,6 +39,7 @@
    ;; canvas operations
    #:with-canvas
    #:clear-canvas
+   #:*write-png-function*
    #:save-png
    #:save-png-stream
    ;; path construction
@@ -91,7 +92,10 @@
    #:set-font
    #:set-character-spacing
    #:draw-string
+   #:draw-string-fast
    #:string-paths
    #:draw-centered-string
    #:centered-string-paths
-   #:string-bounding-box))
+   #:string-bounding-box
+   ;; images
+   #:draw-image))

user-drawing.lisp

@@ -92,6 +92,70 @@ through one control point."
   (call-after-painting state
                        (make-clipping-path-function state :even-odd)))
 
+;;; Image drawing
+
+(defun %draw-image (dest-image-data dest-image-width source-image-data 
+                    source-image-width x y &key override-r override-g override-b)
+  "Combine, with alpha blending, the RGBA octet vector SOURCE-IMAGE-DATA into
+the RGBA octet vector DEST-IMAGE-DATA at offset (X,Y). The red, green, and
+blue channels in SOURCE-IMAGE-DATA may be overridden as if all (non-transparent) 
+pixels have a particular value for the overriden channel."
+  (declare (type octet-vector dest-image-data source-image-data))
+  (let* ((src-row-length (* source-image-width 4))
+         (dst-row-length (* dest-image-width 4))
+         (src-vec-length (length source-image-data))
+         (start-index (* (+ x (* (- (height *graphics-state*) 
+                                    y 
+                                    (/ src-vec-length src-row-length)) 
+                                 dest-image-width))
+                         4)))
+    (declare (type vector-index start-index src-row-length 
+                   dst-row-length src-vec-length))
+    (do* ((i-dst start-index (+ i-dst 4))
+          (line-start i-dst (if (>= (- i-dst line-start) src-row-length)
+                                (setf i-dst (+ (- dst-row-length src-row-length) i-dst))
+                                line-start))
+          (i-src 0 (+ i-src 4)))
+         ((<= src-vec-length i-src))
+      (declare (type vector-index i-dst line-start i-src))
+      (let ((a.fg-octet (aref source-image-data (+ i-src 3))))
+        (cond 
+          ;; opaque pixel, copy without blending
+          ((= a.fg-octet #xFF)
+           (setf (aref dest-image-data i-dst)
+                 (or override-r (aref source-image-data i-src))
+                 (aref dest-image-data (+ i-dst 1))
+                 (or override-g (aref source-image-data (+ i-src 1)))
+                 (aref dest-image-data (+ i-dst 2))
+                 (or override-b (aref source-image-data (+ i-src 2)))
+                 (aref dest-image-data (+ i-dst 3)) #xFF))
+          ;; semi-transparent pixel, blend (skip if fully transparent)
+          ((plusp a.fg-octet)
+           (let* ((a.fg (octet-float a.fg-octet))
+                  (a.bg (octet-float (aref dest-image-data (+ i-dst 3))))
+                  (a.bg*a.fg_inverse (* a.bg (- 1.0 a.fg)))
+                  (a.new (+ a.fg a.bg*a.fg_inverse)))
+             (declare (type float a.fg a.bg a.bg*a.fg_inverse a.new))
+             (setf (aref dest-image-data (+ i-dst 3)) (float-octet a.new))
+             (flet ((blend (fg bg)
+                      (float-octet (/ 
+                                    (+ (* (octet-float fg) a.fg) 
+                                       (* (octet-float bg) a.bg*a.fg_inverse)) 
+                                    a.new))))
+               (if (zerop a.new)
+                   (setf (aref dest-image-data i-dst) 0
+                         (aref dest-image-data (+ i-dst 1)) 0
+                         (aref dest-image-data (+ i-dst 2)) 0)
+                   (setf (aref dest-image-data i-dst)
+                         (blend (or override-r (aref source-image-data i-src)) 
+                                (aref dest-image-data i-dst))
+                         (aref dest-image-data (+ i-dst 1))
+                         (blend (or override-g (aref source-image-data (+ i-src 1))) 
+                                (aref dest-image-data (+ i-dst 1)))
+                         (aref dest-image-data (+ i-dst 2))
+                         (blend (or override-b (aref source-image-data (+ i-src 2))) 
+                                (aref dest-image-data (+ i-dst 2)))))))))))))
+
 ;;; Text
 
 (defun %get-font (state file)
@@ -113,6 +177,106 @@ through one control point."
     (string-primitive-paths x y string font
                             :character-spacing (character-spacing state))))
 
+(defparameter *font-render-caches* (make-hash-table :test #'equal))
+(defparameter *last-font* nil)
+(defparameter *last-font-hash-key* nil)
+
+(defun get-character-glyph-bitmap (character font)
+  "Retrieve a glyph bitmap from the cache if it is present. Otherwise, render
+it, add it to the cache, and return it."
+  (let* ((font-key 
+          ;; Use namestring of the font loader pathname as the hash
+          ;; key. Namestring can be somewhat expensive to do on a
+          ;; per-character basis depending on how it is implemented, hence we
+          ;; cache it under *last-font-hash-key*
+          (or (when (eq *last-font* font) *last-font-hash-key*) 
+              (setf *last-font* font
+                    *last-font-hash-key*
+                    (namestring (zpb-ttf::input-stream (loader font))))))
+         (font-cache-plist (gethash font-key *font-render-caches*))
+         (font-cache (getf font-cache-plist (size font))))
+    (unless font-cache
+      (setf font-cache (make-hash-table :size 128))
+      (setf (getf font-cache-plist (size font)) font-cache)
+      (setf (gethash font-key *font-render-caches*) font-cache-plist))
+    (let ((cached-image (gethash character font-cache))) 
+      (if cached-image 
+          cached-image
+          (setf (gethash character font-cache) 
+                (render-character-glyph-bitmap character font))))))
+
+(defun render-character-glyph-bitmap (character font)
+  "Returns a zpng:png instance containing the rendered character. More
+efficient representations are possible but 32-bit RGBA was chosen for
+convenience."
+  (let* ((loader (loader font))
+         (font-size (size font))
+         (scale-factor (loader-font-scale font-size loader))
+         (glyph (zpb-ttf:find-glyph character loader))
+         (bbox (bounding-box glyph))
+         (ch-width (+ 2 (round (* scale-factor (- (xmax bbox) (xmin bbox))))))
+         (ch-height (+ 2 (round (* scale-factor (- (ymax bbox) (ymin bbox))))))
+         (ch-x-offset (1+ (round (* scale-factor (- (xmin bbox))))))
+         (ch-y-offset (1+ (round (* scale-factor (- (ymin bbox))))))
+         (ch-state (make-instance 'graphics-state
+                                  :fill-color (make-instance 'rgba-color 
+                                                             :red 0.0 :green 0.0 
+                                                             :blue 0.0 :alpha 1.0)
+                                  :fill-source (fill-source *graphics-state*)
+                                  :font-loaders (font-loaders *graphics-state*)
+                                  :font font
+                                  :character-spacing (character-spacing *graphics-state*))))
+    (state-image ch-state ch-width ch-height)
+    (fill-image (image-data ch-state) 1.0 1.0 1.0 0.0)
+    (%draw-string ch-state ch-x-offset ch-y-offset (string character))
+    (image ch-state)))
+
+(defun draw-string-fast (x y string)
+  "Like DRAW-STRING, but caches glyph bitmaps to avoid re-rendering. Results
+are similar to DRAW-STRING, but might not be pixel-for-pixel identical."
+  (let* ((font (font *graphics-state*))
+         (font-size (size font))
+         (loader (loader font))
+         (spacing (character-spacing *graphics-state*))
+         prev-char-width
+         ch
+         (ch-width 0)
+         ch-height
+         x-offset
+         y-offset
+         max-height
+         (glyphs (string-glyphs string loader))
+         glyph
+         (scale-factor (loader-font-scale font-size loader)))
+    (setf max-height 
+          (let ((string-bbox (string-bounding-box string font-size loader 
+                                                  :character-spacing spacing)))
+            (+ 2 (round (- (ymax string-bbox) (ymin string-bbox))))))
+    (dotimes (i (length string))
+      (setf ch (char string i))
+      (setf glyph (pop glyphs))
+      (setf prev-char-width ch-width)
+      (let* ((bbox (bounding-box glyph))
+             (ymin (ymin bbox))
+             (xmin (xmin bbox)))
+        (setf ch-width (+ 2 (round (* scale-factor (- (xmax bbox) (xmin bbox))))))
+        (setf ch-height (+ 2 (round (* scale-factor (- (ymax bbox) ymin)))))
+        (setf x-offset (round (* scale-factor xmin)))
+        (setf y-offset (round (* scale-factor ymin))))
+      (unless (and (<= ch-width 2) (<= ch-height 2))
+        (let ((image (get-character-glyph-bitmap ch font))
+              (override-color (fill-color *graphics-state*)))
+          (%draw-image (image-data *graphics-state*) (width *graphics-state*) (zpng:image-data image) 
+                       (zpng:width image) (+ x x-offset -1) (+ y y-offset -1)
+                       :override-r (float-octet (red override-color))
+                       :override-g (float-octet (green override-color))
+                       :override-b (float-octet (blue override-color)))))
+      (when glyphs
+        (let* ((w (zpb-ttf:advance-width glyph))
+               (k (zpb-ttf:kerning-offset glyph (first glyphs) loader))
+               (offset (round (* scale-factor (+ w k)))))
+          (incf x offset))))))
+
 (defun %draw-string (state x y string)
   (draw-paths/state (%string-paths state x y string)
                     state))
@@ -201,6 +365,10 @@ through one control point."
 (defun set-character-spacing (spacing)
   (setf (character-spacing *graphics-state*) spacing))
 
+(defun draw-image (x y image)
+  (%draw-image (image-data *graphics-state*) (width *graphics-state*) 
+               (zpng:image-data image) (zpng:width image) x y))
+
 (defun draw-string (x y string)
   (%draw-string *graphics-state* x y string))
 
@@ -309,19 +477,31 @@ through one control point."
 (defun rotate-degrees (degrees)
   (%rotate *graphics-state* (* (/ pi 180) degrees)))
 
+(defparameter *write-png-function* nil
+  "Optional PNG writing function for use by SAVE-PNG. If NIL, ZPNG's
+  facilities will be used. If non-NIL, is a function compatible with the
+  lambda list (FILE IMAGE-DATA WIDTH HEIGHT) that encodes a PNG image into the
+  file named by FILE, a pathname designator. IMAGE-DATA must be an RGBA array
+  of type OCTET-VECTOR containing uncompressed image data. WIDTH and HEIGHT
+  are the width and height of the image in pixels, respectively.")
+
 (defun save-png (file)
-  (zpng:write-png (image *graphics-state*) file))
+  (let ((image (image *graphics-state*))) 
+    (if *write-png-function*
+        (funcall *write-png-function* file (zpng::image-data image) 
+                 (zpng::width image) (zpng::height image))
+        (zpng:write-png image file))))
 
 (defun save-png-stream (stream)
   (zpng:write-png-stream (image *graphics-state*) stream))
 
-(defmacro with-canvas ((&key width height) &body body)
+(defmacro with-canvas ((&key width height (close-font-loaders t)) &body body)
   `(let ((*graphics-state* (make-instance 'graphics-state)))
      (state-image *graphics-state* ,width ,height)
      (unwind-protect
           (progn
             ,@body)
-       (clear-state *graphics-state*))))
+       (clear-state *graphics-state* :close-font-loaders ,close-font-loaders))))
 
 (defmacro with-graphics-state (&body body)
   `(let ((*graphics-state* (copy *graphics-state*)))