aa-misc.lisp

   1 ;;;; cl-vectors -- Rasterizer and paths manipulation library
   2 ;;;; Copyright (C) 2007  Frédéric Jolliton <frederic@jolliton.com>
   3 ;;;;
   4 ;;;; This library is free software; you can redistribute it and/or
   5 ;;;; modify it under the terms of the Lisp Lesser GNU Public License
   6 ;;;; (http://opensource.franz.com/preamble.html), known as the LLGPL.
   7 ;;;;
   8 ;;;; This library is distributed in the hope that it will be useful, but
   9 ;;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  10 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the Lisp
  11 ;;;; Lesser GNU Public License for more details.
  12
  13 (defpackage #:net.tuxee.aa-misc
  14   (:use #:common-lisp)
  15   (:nicknames #:aa-misc)
  16   (:export ;; minimal image support (for testing purpose!)
  17            #:make-image
  18            #:image-width
  19            #:image-height
  20            ;; Rendering functions.
  21            #:image-put-pixel
  22            #:image-put-span
  23            ;; Loading, saving and displaying image.
  24            #:load-image
  25            #:save-image
  26            #:show-image
  27            #:*external-viewer*
  28            ))
  29
  30 (in-package #:net.tuxee.aa-misc)
  31
  32 (defvar *external-viewer* "xv"
  33   "Default program to run to display a PNM image.")
  34
  35 (deftype octet () '(unsigned-byte 8))
  36
  37 (defun make-image (width height &optional default-color)
  38   "Create a new image.
  39
  40 width -- width of the image
  41 height -- height of the image
  42 default-color -- if not NIL, then the image is filled with the
  43 specified color. If unspecified, then the contents of the image
  44 is also unspecified.
  45
  46 Return the newly created image."
  47   (let ((image (make-array (list height width 3)
  48                            :element-type 'octet)))
  49     (when default-color
  50       (loop for y below height
  51            do (loop for x below width
  52                    do (loop for rgb below 3
  53                          do (setf (aref image y x rgb) (aref default-color rgb))))))
  54     image))
  55
  56 (defun image-width (image)
  57   (array-dimension image 1))
  58
  59 (defun image-height (image)
  60   (array-dimension image 0))
  61
  62 ;;;--[ Rendering ]-----------------------------------------------------------
  63
  64 (declaim (inline blend-value))
  65 (defun blend-value (a b alpha)
  66   (max 0 (min 255 (floor (+ (* (- 256 alpha) a)
  67                             (* alpha b))
  68                          256))))
  69
  70 (defun alpha/normalized (alpha)
  71   (min 255 (abs alpha)))
  72
  73 (defun alpha/even-odd (alpha)
  74   (min 255 (- 256 (abs (- 256 (mod (abs alpha) 512))))))
  75
  76 (defun image-put-pixel (image &optional (color #(0 0 0)) (opacity 1.0) (alpha-function :normalized))
  77   (check-type image (array octet (* * 3)))
  78   (let ((width (image-width image))
  79         (height (image-height image)))
  80     (case alpha-function
  81       (:normalized
  82        (setf alpha-function #'alpha/normalized))
  83       (:even-odd
  84        (setf alpha-function #'alpha/even-odd)))
  85     (if (/= opacity 1.0)
  86         (lambda (x y alpha)
  87           (declare (optimize speed (safety 0) (debug 0)))
  88           (when (and (<= 0 x (1- width))
  89                      (<= 0 y (1- height)))
  90             (loop for rgb below 3
  91                do (setf (aref image y x rgb)
  92                         (blend-value (aref image y x rgb)
  93                                      (aref color rgb)
  94                                      (floor (* opacity (funcall alpha-function alpha))))))))
  95         (lambda (x y alpha)
  96           (declare (optimize speed (safety 0) (debug 0)))
  97           (when (and (<= 0 x (1- width))
  98                      (<= 0 y (1- height)))
  99             (loop for rgb below 3
 100                do (setf (aref image y x rgb)
 101                         (blend-value (aref image y x rgb)
 102                                      (aref color rgb)
 103                                      (funcall alpha-function alpha)))))))))
 104
 105 (defun image-put-span (image &optional (color #(0 0 0)) (opacity 1.0) (alpha-function :normalized))
 106   (check-type image (array octet (* * 3)))
 107   (let ((width (image-width image))
 108         (height (image-height image)))
 109     (case alpha-function
 110       (:normalized
 111        (setf alpha-function #'alpha/normalized))
 112       (:even-odd
 113        (setf alpha-function #'alpha/even-odd)))
 114     (if (/= opacity 1.0)
 115         (lambda (x1 x2 y alpha)
 116           (declare (optimize speed (safety 0) (debug 0)))
 117           (when (and (< x1 width)
 118                      (> x2 0)
 119                      (<= 0 y (1- height)))
 120             (setf alpha (funcall alpha-function alpha))
 121             (loop for x from (max 0 x1) below (min x2 width)
 122                do (loop for rgb below 3
 123                      do (setf (aref image y x rgb)
 124                               (blend-value (aref image y x rgb)
 125                                            (aref color rgb)
 126                                            (floor (* opacity alpha))))))))
 127         (lambda (x1 x2 y alpha)
 128           (declare (optimize speed (safety 0) (debug 0)))
 129           (when (and (< x1 width)
 130                      (> x2 0)
 131                      (<= 0 y (1- height)))
 132             (setf alpha (funcall alpha-function alpha))
 133             (loop for x from (max 0 x1) below (min x2 width)
 134                do (loop for rgb below 3
 135                      do (setf (aref image y x rgb)
 136                               (blend-value (aref image y x rgb)
 137                                            (aref color rgb)
 138                                            alpha)))))))))
 139
 140 ;;;--[ load/save/display ]---------------------------------------------------
 141
 142 (defun %load-image/pnm (filename)
 143   (with-open-file (file filename :element-type 'octet)
 144     (flet ((read-word (&optional limit)
 145              "Read the next \"word\" (a sequence of non-space
 146              characters) skipping initial blanks. The first blank
 147              character after the word is also consumed."
 148              (declare (ignore limit))   ; FIXME
 149              (let ((result (make-array 0
 150                                        :element-type 'octet
 151                                        :fill-pointer 0
 152                                        :adjustable t)))
 153                ;; skip blanks, extract the word, consume the following
 154                ;; blank.
 155                (loop for byte = (read-byte file)
 156                   while (member byte '(9 10 13 32))
 157                   finally (vector-push-extend byte result))
 158                (loop for byte = (read-byte file)
 159                   until (member byte '(9 10 13 32))
 160                   do (vector-push-extend byte result))
 161                result))
 162            (parse-ascii-integer (seq)
 163              "Parse an integer represented by the ASCII charset
 164              in the array SEQ."
 165              (let ((result 0))
 166                (loop for digit in (coerce seq 'list)
 167                   unless (<= 48 digit 57)
 168                   do (error "Invalid ASCII integer")
 169                   do (setf result (+ (* 10 result) (- digit 48))))
 170                result)))
 171       (let ((format (read-word 3)))
 172         (unless (equalp format #(80 54))
 173           (error "Expected P6 image format (got ASCII sequence ~S)" (subseq format 0 16)))
 174         (let ((width (parse-ascii-integer (read-word 10)))
 175               (height (parse-ascii-integer (read-word 10)))
 176               (maxval (parse-ascii-integer (read-word 10))))
 177           (when (/= maxval 255)
 178             (error "Expected 24 bits color image"))
 179           (unless (and (<= 1 width 4096)
 180                        (<= 1 height 4096))
 181             (error "Cowardly refusing to read an image of size ~Dx~D" width height))
 182           (let* ((image (make-array (list height width 3) :element-type 'octet))
 183                  (index 0)
 184                  (end-index (apply #'* (array-dimensions image))))
 185             ;; skip blanks to find the first byte of data.
 186             (loop for byte = (read-byte file)
 187                while (member byte '(9 10 13 32))
 188                finally (setf (row-major-aref image index) byte))
 189             (incf index)
 190             ;; read the rest of the data.
 191             (loop while (< index end-index)
 192                  for byte = (read-byte file)
 193                  do (setf (row-major-aref image index) byte)
 194                  (incf index))
 195             image))))))
 196
 197 (defun load-image (filename format)
 198   (ecase format
 199     (:pnm
 200      (%load-image/pnm filename))))
 201
 202 (defun make-array-flat-displaced (array &optional (start 0))
 203   (make-array (apply #'* (array-dimensions array))
 204               :element-type (array-element-type array)
 205               :displaced-to array
 206               :displaced-index-offset start))
 207
 208 (defun save-image/pnm (filename image)
 209   "Save image with PNM format into the file with filename
 210 FILENAME. IMAGE must be an (UNSIGNED-BYTE 8) array of
 211 dimension (* * 3). Last axis represent the RGB component in that
 212 order."
 213   (with-open-file (file filename
 214                         :element-type 'octet
 215                         :direction :output
 216                         :if-does-not-exist :create
 217                         :if-exists :overwrite)
 218     (labels ((write-ascii-integer (n stream)
 219                (when (minusp n)
 220                  (write-byte 45 stream) ; #\-
 221                  (setf n (- n)))
 222                (write-sequence (loop with digits = ()
 223                                   for digit = (mod n 10)
 224                                   do (push (+ 48 digit) digits)
 225                                   (setf n (floor n 10))
 226                                   while (plusp n)
 227                                   finally (return digits))
 228                                stream)))
 229       ;; "P6" <width> <height> <maxval>
 230       (write-sequence #(80 54) file)
 231       (write-byte 32 file)
 232       (write-ascii-integer (array-dimension image 1) file)
 233       (write-byte 32 file)
 234       (write-ascii-integer (array-dimension image 0) file)
 235       (write-byte 32 file)
 236       (write-ascii-integer 255 file)
 237       (write-byte 10 file)
 238       (write-sequence (make-array-flat-displaced image) file))))
 239
 240 (defun save-image (filename image format)
 241   (ecase format
 242     ((:pnm :ppm)
 243      (save-image/pnm filename image)))
 244   (values))
 245
 246 ;;; WARNING: Run external program.
 247 (defun show-image (image &optional (external-viewer *external-viewer*))
 248   "Display IMAGE using the specified external viewver."
 249   (let ((temp-filename "/tmp/.cl-aa-tmp.pnm"))
 250     (save-image temp-filename image :pnm)
 251     (asdf:run-shell-command "~S ~S" external-viewer temp-filename)
 252     (delete-file temp-filename)))