Add support for grey and rgb images to canvas

borodust · Aug 7, 2019 · dde98d9 · dde98d9
1 parent be7b395
commit dde98d9
Show file tree

Hide file tree

Showing 3 changed files with 52 additions and 11 deletions.
diff --git a/canvas/paint.lisp b/canvas/paint.lisp
@@ -24,14 +24,12 @@
 
 (define-system-function make-image-paint graphics-system
     (canvas image &key flip-vertically use-nearest-interpolation)
-  (unless (eq (ge.rsc:image-pixel-format image) :rgba)
-    (error "Only RGBA images supported"))
   (make-instance 'image-paint
                  :canvas canvas
                  :handle (bodge-canvas:make-rgba-image-paint
                           (%handle-of canvas)
                           (simple-array-of
-                           (ge.rsc:image->foreign-array image))
+                           (ge.rsc:image->foreign-array (ge.rsc:convert-to-rgba image)))
                           (ge.rsc:image-width image)
                           (ge.rsc:image-height image)
                           :flip-vertically flip-vertically

diff --git a/resources/image.lisp b/resources/image.lisp
@@ -22,11 +22,15 @@
    (data :initarg :data :reader image->foreign-array)))
 
 
+(defun pixel-format->channels (pixel-format)
+  (ecase pixel-format
+    (:grey 1)
+    (:rgb 3)
+    (:rgba 4)))
+
+
 (defun prepare-png-data (width height pixel-format data)
-  (loop with channels = (ecase pixel-format
-                          (:grey 1)
-                          (:rgb 3)
-                          (:rgba 4))
+  (loop with channels = (pixel-format->channels pixel-format)
         with result = (make-foreign-array (* width height channels) :element-type '(unsigned-byte 8))
         with array = (simple-array-of result)
         for i from 0 below height
@@ -44,10 +48,7 @@
   (let ((width (image-width image))
         (height (image-height image))
         (array (simple-array-of (image->foreign-array image))))
-    (loop with channels = (ecase (image-pixel-format image)
-                            (:grey 1)
-                            (:rgb 3)
-                            (:rgba 4))
+    (loop with channels = (pixel-format->channels (image-pixel-format image))
           for i from 0 below height
           do (loop for j from 0 below width
                    do (if (= channels 1)
@@ -59,6 +60,8 @@
     data))
 
 
+
+
 (defun read-image-from-stream (stream type)
   (let* ((data (opticl:read-image-stream stream type))
          (format (etypecase data
@@ -90,6 +93,45 @@
     (funcall writer stream opticl-data)))
 
 
+(defun convert-to-rgba (image &optional (alpha 1f0))
+  (let ((alpha (the (unsigned-byte 8)
+                    (round (alexandria:clamp (* alpha 255) 0 255)))))
+    (labels ((%expand-grey (src dst src-idx dst-idx)
+               (let ((color (aref src src-idx)))
+                 (setf (aref dst (+ dst-idx 0)) color
+                       (aref dst (+ dst-idx 1)) color
+                       (aref dst (+ dst-idx 2)) color
+                       (aref dst (+ dst-idx 3)) alpha)))
+             (%expand-rgb (src dst src-idx dst-idx)
+               (setf (aref dst (+ dst-idx 0)) (aref src (+ src-idx 0))
+                     (aref dst (+ dst-idx 1)) (aref src (+ src-idx 1))
+                     (aref dst (+ dst-idx 2)) (aref src (+ src-idx 2))
+                     (aref dst (+ dst-idx 3)) alpha))
+             (%convert (image)
+               (let* ((source (simple-array-of (image->foreign-array image)))
+                      (width (image-width image))
+                      (height (image-height image))
+                      (pixel-format (image-pixel-format image))
+                      (channels (pixel-format->channels pixel-format))
+                      (expander (ecase (image-pixel-format image)
+                                  (:grey #'%expand-grey)
+                                  (:rgb #'%expand-rgb)))
+                      (target (make-foreign-array (* width height 4))))
+                 (loop with destination = (simple-array-of target)
+                       for i from 0 below (* width height)
+                       do (funcall expander
+                                   source destination
+                                   (* i channels) (* i 4))
+                       finally (return target)))))
+      (if (eq (image-pixel-format image) :rgba)
+          image
+          (make-instance 'image
+                         :data (%convert image)
+                         :width (image-width image)
+                         :height (image-height image)
+                         :pixel-format :rgba)))))
+
+
 (defun load-png-image (path)
   (with-open-file (stream path :element-type '(unsigned-byte 8))
     (read-image-from-stream stream :png)))

diff --git a/resources/packages.lisp b/resources/packages.lisp
@@ -43,6 +43,7 @@
            pixel-format-p
            image-pixel-format
            image->foreign-array
+           convert-to-rgba
 
            ;; chunked
            write-chunk