vecto-imago/vecto-imago.lisp

   1 (defpackage #:vecto-imago
   2   (:use #:cl)
   3   (:local-nicknames (#:v #:vecto) (#:i #:imago) (#:z #:zpng)))
   4
   5 (in-package #:vecto-imago)
   6
   7 (declaim (inline blend-alpha))
   8 (defun blend-alpha (src-a dest-a)
   9   (declare (optimize speed))
  10   (declare (type (unsigned-byte 8) src-a dest-a))
  11   (let* ((src-a (* 1f0 1/255 src-a))
  12          (dest-a (* 1f0 1/255 dest-a))
  13          (result (+ src-a (* dest-a (- 1f0 src-a)))))
  14     (round (* result 255f0))))
  15
  16 (declaim (inline blend))
  17 (defun blend (ca cb aa ab ar)
  18   (declare (optimize speed))
  19   (declare (type (unsigned-byte 8) ca cb aa ab ar))
  20   (cond ((= 0 aa) cb)
  21         ((= 0 ab) ca)
  22         (t (let* ((aa (* 1f0 1/255 aa))
  23                   (ab (* 1f0 1/255 ab))
  24                   (ar (* 1f0 1/255 ar)))
  25              (let* ((left (* ca aa))
  26                     (right (* cb ab (- 1f0 aa)))
  27                     (result (/ (+ left right) ar)))
  28                (declare (type (single-float 0f0 255f0) left right result))
  29                (round result))))))
  30
  31 (deftype png-image-dimension () '(unsigned-byte 31))
  32
  33 (defmethod v:compose ((layer imago:rgb-image) x-offset y-offset)
  34   (declare (optimize speed))
  35   (declare (type (signed-byte 32) x-offset y-offset))
  36   (let* ((src (imago:image-pixels layer))
  37          (zpng (v:zpng-object))
  38          (dest (zpng:image-data zpng)))
  39     (declare (type (simple-array imago:rgb-pixel (* *)) src))
  40     (declare (type (simple-array (unsigned-byte 8) (*)) dest))
  41     (destructuring-bind (src-height src-width) (array-dimensions src)
  42       (declare (type png-image-dimension src-height src-width))
  43       (let* ((dest-height (z:height zpng))
  44              (dest-width (z:width zpng))
  45              ;; TODO: stop being ugly here, write a reader function in vecto
  46              ;; which returns the transform matrix
  47              ;; and then export accessor functions for it
  48              (matrix (v::transform-matrix v::*graphics-state*))
  49              (matrix-x-offset (ceiling
  50                                (the (single-float 0f0 #.(* (ash 1 31) 1f0))
  51                                     (v::transform-matrix-x-offset matrix))))
  52              (matrix-y-offset (ceiling
  53                                (the (single-float 0f0 #.(* (ash 1 31) 1f0))
  54                                     (v::transform-matrix-y-offset matrix))))
  55              (x-offset (+ matrix-x-offset x-offset))
  56              (y-offset (- matrix-y-offset y-offset src-height)))
  57         (declare (type png-image-dimension dest-height dest-width))
  58         (dotimes (src-y src-height)
  59           (dotimes (src-x src-width)
  60             (let ((dest-y (+ src-y y-offset))
  61                   (dest-x (+ src-x x-offset)))
  62               (declare (type (signed-byte 32) dest-x dest-x))
  63               (when (and (<= 0 dest-y (1- dest-height))
  64                          (<= 0 dest-x (1- dest-width)))
  65                 (let* ((src-color (aref src src-y src-x))
  66                        (src-a (i:color-alpha src-color))
  67                        (src-r (i:color-red src-color))
  68                        (src-g (i:color-green src-color))
  69                        (src-b (i:color-blue src-color))
  70                        (dest-y-offset (* dest-y dest-width))
  71                        (dest-xy-offset (+ dest-y-offset dest-x))
  72                        (dest-offset (* (the (unsigned-byte 8)
  73                                             (z:samples-per-pixel zpng))
  74                                        dest-xy-offset))
  75                        (dest-a (aref dest (+ dest-offset 3)))
  76                        (dest-b (aref dest (+ dest-offset 2)))
  77                        (dest-g (aref dest (+ dest-offset 1)))
  78                        (dest-r (aref dest (+ dest-offset 0))))
  79                   (declare (type png-image-dimension
  80                                  dest-y-offset dest-offset))
  81                   (unless (= src-a 0)
  82                     (let* ((a (blend-alpha src-a dest-a))
  83                            (r (blend src-r dest-r src-a dest-a a))
  84                            (g (blend src-g dest-g src-a dest-a a))
  85                            (b (blend src-b dest-b src-a dest-a a)))
  86                       (setf (aref dest (+ dest-offset 3)) a
  87                             (aref dest (+ dest-offset 2)) b
  88                             (aref dest (+ dest-offset 1)) g
  89                             (aref dest (+ dest-offset 0)) r))))))))))))