Browse files

Image loads return pixel-type and pixel-format now, standardising thi…

…ngs a bit better.
  • Loading branch information...
Shinmera committed Aug 27, 2018
1 parent 58d4990 commit e60002a9d6019f9813bbc1104bcd5033667382fb
Showing with 147 additions and 91 deletions.
  1. +49 −50 assets/image.lisp
  2. +0 −41 resources/texture.lisp
  3. +98 −0 toolkit.lisp
@@ -9,7 +9,7 @@
(defclass image (gl-asset texture)
(defgeneric load-image (path type &key width height depth pixel-type format &allow-other-keys))
(defgeneric load-image (path type &key width height pixel-type pixel-format &allow-other-keys))
(defmethod load-image (path (type (eql :tga)) &key)
(let* ((tga (tga:read-tga path))
@@ -19,9 +19,7 @@
(values buffer
(tga:image-width tga)
(tga:image-height tga)
(/ (tga:image-bpp tga)
(tga:image-channels tga))
(infer-pixel-type (tga:image-bpp tga) :unsigned)
(ecase (tga:image-channels tga)
(3 :bgr)
(4 :bgra))))))
@@ -33,15 +31,12 @@
(values (pngload:data png)
(pngload:width png)
(pngload:height png)
(pngload:bit-depth png)
(infer-pixel-type (pngload:bit-depth png) :unsigned)
(ecase (pngload:color-type png)
(:greyscale :red)
(:greyscale-alpha :rg)
(:truecolour :rgb)
(:truecolour-alpha :rgba)
(error "FIXME: Can't deal with indexed colour.")))))))
(:truecolour-alpha :rgba))))))
(defmethod load-image (path (type (eql :tiff)) &key)
(let* ((tiff (retrospectiff:read-tiff-file path))
@@ -53,8 +48,7 @@
(values buffer
(retrospectiff:tiff-image-width tiff)
(retrospectiff:tiff-image-length tiff)
(infer-pixel-type bits :unsigned)
(ecase (retrospectiff:tiff-image-samples-per-pixel tiff)
(1 :red)
(3 :rgb)
@@ -68,8 +62,7 @@
(values (jpeg:decode-image path)
(ecase components
(1 :red)
(2 :rg)
@@ -79,45 +72,52 @@
(defmethod load-image (path (type (eql :jpg)) &rest args)
(apply #'load-image path :jpeg args))
(defmethod load-image (path (type (eql :raw)) &key width height depth pixel-type format)
(defmethod load-image (path (type (eql :raw)) &key width height pixel-type pixel-format)
(declare (optimize speed))
(let ((depth (or depth 8)))
(with-open-file (stream path :element-type (ecase pixel-type
((NIL :unsigned) `(unsigned-byte ,depth))
(:signed `(signed-byte ,depth))
(:float (ecase depth
(16 'short-float)
(32 'single-float)
(64 'double-float)))))
(let* ((data (make-static-vector (file-length stream) :element-type (stream-element-type stream)))
(c (format-components format))
(width (or width (when height (/ (length data) height c)) (floor (sqrt (/ (length data) c)))))
(height (or height (when width (/ (length data) width c)) (floor (sqrt (/ (length data) c))))))
(declare (type (unsigned-byte 8) c))
(declare (type (simple-array * (*)) data))
(loop for reached = 0 then (read-sequence data stream :start reached)
while (< reached (length data)))
(values data
(with-open-file (stream path :element-type '(unsigned-byte 8))
(let* ((data (make-static-vector (file-length stream) :element-type (ecase pixel-type
(:float 'single-float)
(:byte '(signed-byte 8))
(:short '(signed-byte 16))
(:int '(signed-byte 32))
(:unsigned-byte '(unsigned-byte 8))
(:unsigned-short '(unsigned-byte 16))
(:unsigned-int '(unsigned-byte 32)))))
(c (internal-format-components pixel-format))
(width (or width (when height (/ (length data) height c)) (floor (sqrt (/ (length data) c)))))
(height (or height (when width (/ (length data) width c)) (floor (sqrt (/ (length data) c)))))
(reader (ecase pixel-type
(:float (lambda (b) (ieee-floats:decode-float32 (fast-io:readu32-le b))))
(:byte #'fast-io:read8-le)
(:short #'fast-io:read16-le)
(:int #'fast-io:read32-le)
(:unsigned-byte #'fast-io:readu8-le)
(:unsigned-short #'fast-io:readu16-le)
(:unsigned-int #'fast-io:readu32-le))))
(declare (type (unsigned-byte 8) c))
(declare (type (simple-array * (*)) data))
(fast-io:with-fast-input (buffer NIL stream)
(loop for i from 0 below (length data)
do (setf (aref data i) (funcall reader buffer))))
(values data
(defmethod load-image (path (type (eql :r16)) &rest args)
(apply #'load-image path :raw :depth 16 :pixel-type :float args))
(apply #'load-image path :raw :pixel-type :half-float args))
(defmethod load-image (path (type (eql :r32)) &rest args)
(apply #'load-image path :raw :depth 32 :pixel-type :float args))
(apply #'load-image path :raw :pixel-type :float args))
(defmethod load-image (path (type (eql :ter)) &key)
(let ((terrain (terrable:read-terrain path)))
(tg:cancel-finalization terrain)
(values (terrable:data terrain)
(terrable:width terrain)
(terrable:height terrain)
(defmethod load-image (path (type (eql T)) &rest args)
@@ -137,36 +137,35 @@
(with-retry-restart (retry "Retry loading the image path.")
(load-image path T)))))
(let ((input (coerce-asset-input image T)))
(multiple-value-bind (bits width height depth type pixel-format) (load-image (unlist input))
(multiple-value-bind (bits width height pixel-type pixel-format) (load-image (unlist input))
(assert (not (null bits)))
(with-unwind-protection (mapcar #'free-image-data (enlist (pixel-data image)))
;; FIXME: Maybe attempt to reconcile/compare user-provided data?
;; FIXME: This whole crap needs to be revised to allow updates anyway
(setf (pixel-data image) bits)
(when width
(setf (width image) width))
(when height
(setf (height image) height))
(when pixel-format
(setf (pixel-format image) pixel-format))
(when (and depth type)
(setf (pixel-type image) (infer-pixel-type depth type)))
(when (and depth type pixel-format)
(setf (internal-format image) (infer-internal-format depth type pixel-format)))
(when pixel-type
(setf (pixel-type image) pixel-type))
(when (and pixel-format pixel-type)
(setf (internal-format image) (infer-internal-format pixel-type pixel-format)))
(when (listp input)
(setf (pixel-data image) (list (pixel-data image)))
(dolist (input (rest input))
(multiple-value-bind (bits width height depth type pixel-format) (load-image input)
(multiple-value-bind (bits width height pixel-type pixel-format) (load-image input)
(assert (not (null bits)))
(when width
(assert (= width (width image))))
(when height
(assert (= height (height image))))
(when pixel-format
(assert (eq pixel-format (pixel-format image))))
(when (and depth type)
(assert (eq (infer-pixel-type depth type) (pixel-type image))))
(when (and depth type pixel-format)
(assert (eq (infer-internal-format depth type pixel-format) (internal-format image))))
(when pixel-type
(assert (eq pixel-type (pixel-type image))))
(push bits (pixel-data image))))
(setf (pixel-data image) (nreverse (pixel-data image))))
(allocate image))))))
@@ -362,44 +362,3 @@
(go next)
(defun infer-internal-format (depth type pixel-format)
(format NIL "~a~a~a"
(ecase pixel-format
((:r :red) :r)
((:rg :gr) :rg)
((:rgb :bgr) :rgb)
((:rgba :bgra) :rgba))
(ecase depth
(8 8)
(16 16)
(32 32))
;; KLUDGE: If we have signed formats, the pixel-format needs to be *-integer
(ecase type
(:signed :i)
(:unsigned "")
(:float :f)))
(defun infer-pixel-type (depth type)
(ecase depth
( 8 (ecase type
(:signed :byte)
(:unsigned :unsigned-byte)))
(16 (ecase type
(:signed :short)
(:unsigned :unsigned-short)
(:float :half-float)))
(32 (ecase type
(:signed :int)
(:unsigned :unsigned-int)
(:float :float)))))
(defun format-components (format)
(let ((format (string format)))
(cond ((or (search "RGBA" format) (search "BGRA" format)) 4)
((or (search "RGB" format) (search "BGR" format)) 3)
((or (search "RG" format) (search "GR" format)) 2)
((search "RED" format) 1)
(T (error "Unknown format: ~s" format)))))
@@ -593,3 +593,101 @@
:color-attachment0 :color-attachment1 :color-attachment2 :color-attachment3
:color-attachment4 :color-attachment5 :color-attachment6 :color-attachment7
:depth-attachment :stencil-attachment :depth-stencil-attachment)
(defun internal-format-components (format)
(case format
((:red :r8 :r8-snorm :r8i :r8ui
:r16 :r16-snorm :r16f :r16i :r16ui
:r32f :r32i :r32ui
:compressed-red :compressed-red-rgtc1
:compressed-signed-red-rgtc1) 1)
((:rg :rg8 :rg8-snorm :rg8i :rg8ui
:rg16 :rg16-snorm :rg16f :rg16i :rg16ui
:compressed-rg :compressed-rg-rgtc2 :compressed-signed-rg-rgtc2) 2)
((:rg32f :rg32i :rg32ui
:rgb :rgb8 :rgb8-snorm :rgb8i :rgb8ui
:r3-g3-b2 :rgb4 :rgb5 :rgb9-e5 :rgb10 :r11f-g11f-b10f :rgb12
:rgb16-snorm :rgb16f :rgb16i :rgb16ui
:rgb32f :rgb32i :rgb32ui :srgb8
:compressed-rgb :compressed-rgb-bptc-signed-float
:compressed-rgb-bptc-unsigned-float :compressed-srgb) 3)
((:rgba :rgba2 :rgba4 :rgb5-a1 :rgb10-a2 :rgb10-a2ui :rgba12
:rgba8 :rgba8-snorm :rgba8i :rgba8ui
:rgba16 :rgba16f :rgba16i :rgba16ui
:rgba32f :rgba32i :rgba32ui :srgb8-alpha8
:compressed-rgba :compressed-rgba-bptc-unorm
:compressed-srgb-alpha :compressed-srgb-alpha-bptc-unorm) 4)
((:depth-component :depth-component16 :depth-component24 :depth-component32 :depth-component32f
:stencil-index :stencil-index1 :stencil-index4 :stencil-index8 :stencil-index16) 1)
((:depth-stencil :depth24-stencil8 :depth32f-stencil8) 2)))
(defun internal-format-pixel-size (format)
(case format
((:red :r8 :r8-snorm :r8i :r8ui) 8)
((:r16 :r16-snorm :r16f :r16i :r16ui) 16)
((:r32f :r32i :r32ui) 32)
((:rg :rg8 :rg8-snorm :rg8i :rg8ui) 16)
((:rg16 :rg16-snorm :rg16f :rg16i :rg16ui) 32)
((:rg32f :rg32i :rg32ui) 64)
((:rgb :rgb8 :rgb8-snorm :rgb8i :rgb8ui) 24)
(:r3-g3-b2 8)
(:rgb9-e5 32)
(:r11f-g11f-b10f 32)
(:rgb12 32)
(:rgb4 12)
(:rgb5 15)
(:rgb10 30)
((:rgb16-snorm :rgb16f :rgb16i :rgb16ui) 48)
((:rgb32f :rgb32i :rgb32ui) 96)
(:rgba2 8)
(:rgba4 16)
(:rgb5-a1 16)
(:rgb10-a2 32)
(:rgb10-a2ui 32)
(:rgba12 48)
((:rgba :rgba8 :rgba8-snorm :rgba8i :rgba8ui) 32)
((:rgba16 :rgba16f :rgba16i :rgba16ui) 64)
((:rgba32f :rgba32i :rgba32ui) 128)
(:srgb8 24) (:srgb8-alpha8 32)
(:depth-component 8)
(:depth-component16 16)
(:depth-component24 24)
((:depth-component32 :depth-component32f) 32)
(:stencil-index 8)
(:stencil-index1 1)
(:stencil-index4 4)
(:stencil-index8 8)
(:stencil-index16 16)
(:depth-stencil 8)
(:depth24-stencil8 32)
(:depth32f-stencil8 40)))
(defun infer-internal-format (pixel-type pixel-format)
(format NIL "~a~a"
(ecase pixel-format
((:r :red) :r)
((:rg :gr) :rg)
((:rgb :bgr) :rgb)
((:rgba :bgra) :rgba))
(ecase pixel-type
((:byte :unsigned-byte) :8)
((:short :unsigned-short) :16)
((:int :unsigned-int) :32)
((:short-float) :16f)
((:float) :32f)))
(defun infer-pixel-type (depth type)
(ecase depth
( 8 (ecase type
(:signed :byte)
(:unsigned :unsigned-byte)))
(16 (ecase type
(:signed :short)
(:unsigned :unsigned-short)
(:float :half-float)))
(32 (ecase type
(:signed :int)
(:unsigned :unsigned-int)
(:float :float)))))

0 comments on commit e60002a

Please sign in to comment.