image.lisp

   1
   2 (in-package :tuple-trace)
   3
   4 (defclass image ()
   5   ((pixels :accessor pixels-of)
   6    (width :reader width-of)
   7    (height :reader height-of)))
   8
   9 (defmethod initialize-instance :after ((self image) &key width height)
  10   (setf (pixels-of self) (cl-tuples::make-colour-array (* width height)))
  11   (setf (slot-value self 'height) height)
  12   (setf (slot-value self 'width) width))
  13
  14 (defmethod pixel-of ((self image) x y)
  15   (make-colour
  16    (colour-aref (pixels-of self) (+ x (* y (width-of self))))))
  17
  18 (defmethod (setf pixel-of) (pixel (self image) x y)
  19   (setf (colour-aref  (pixels-of self) (+ x (* y (width-of self)))) (colour pixel)))
  20
  21
  22 (defun make-image (w h)
  23   (let ((result (make-instance 'image :width w :height h)))
  24     result))
  25
  26
  27 (defmethod dump-image ((self image) (filename pathname))
  28   (labels ((to-ubyte (x)
  29               (round  (* 255 x))))
  30     (let* ((png
  31             (make-instance 'zpng::png
  32                            :width (width-of self)
  33                            :height (height-of self)))
  34            (image (zpng::data-array png)))
  35       (loop
  36          for i from 0 below (colour-array-dimensions (pixels-of self))
  37          do
  38            (with-colour-aref ((pixels-of self) i (r g b a))
  39              (setf (row-major-aref image (* 3 i)) (to-ubyte r))
  40              (setf (row-major-aref image (1+ (* 3 i))) (to-ubyte g))
  41              (setf (row-major-aref image (+ 2 (* 3 i))) (to-ubyte b))))
  42       (zpng::write-png png filename))))
  43