Permalink
Browse files

More image wrangling shit

  • Loading branch information...
Shinmera committed Jun 26, 2018
1 parent 2a3a220 commit 74a96df1201e82849b9808ab2bf1058b565d3fa5
Showing with 214 additions and 219 deletions.
  1. +73 −73 assets/image.lisp
  2. +101 −146 geometry-clipmap.lisp
  3. +40 −0 resources/texture.lisp
@@ -9,7 +9,9 @@
(defclass image (gl-asset texture)
())
(defmethod load-image (path (type (eql :tga)))
(defgeneric load-image (path type &key width height depth pixel-type format &allow-other-keys))
(defmethod load-image (path (type (eql :tga)) &key)
(let* ((tga (tga:read-tga path))
(buffer (make-static-vector (length (tga:image-data tga))
:initial-contents (tga:image-data tga))))
@@ -19,18 +21,20 @@
(tga:image-height tga)
(/ (tga:image-bpp tga)
(tga:image-channels tga))
:unsigned
(ecase (tga:image-channels tga)
(3 :bgr)
(4 :bgra))))))
(defmethod load-image (path (type (eql :png)))
(defmethod load-image (path (type (eql :png)) &key)
(let ((png (pngload:load-file path :flatten T :flip-y T :static-vector T)))
(mark-static-vector (pngload:data png))
(with-cleanup-on-failure (maybe-free-static-vector (pngload:data png))
(values (pngload:data png)
(pngload:width png)
(pngload:height png)
(pngload:bit-depth png)
:unsigned
(ecase (pngload:color-type png)
(:greyscale :red)
(:greyscale-alpha :rg)
@@ -39,7 +43,7 @@
(:indexed-colour
(error "FIXME: Can't deal with indexed colour.")))))))
(defmethod load-image (path (type (eql :tiff)))
(defmethod load-image (path (type (eql :tiff)) &key)
(let* ((tiff (retrospectiff:read-tiff-file path))
(bits (aref (retrospectiff:tiff-image-bits-per-sample tiff) 1))
(buffer (make-static-vector (length (retrospectiff:tiff-image-data tiff))
@@ -50,12 +54,16 @@
(retrospectiff:tiff-image-width tiff)
(retrospectiff:tiff-image-length tiff)
bits
:unsigned
(ecase (retrospectiff:tiff-image-samples-per-pixel tiff)
(1 :red)
(3 :rgb)
(4 :rgba))))))
(defmethod load-image (path (type (eql :jpeg)))
(defmethod load-image (path (type (eql :tif)) &rest args)
(apply #'load-image path :tiff args))
(defmethod load-image (path (type (eql :jpeg)) &key)
(multiple-value-bind (height width components) (jpeg:jpeg-file-dimensions path)
(let ((buffer (make-static-vector (* height width components) :element-type '(unsigned-byte 8))))
(with-cleanup-on-failure (maybe-free-static-vector buffer)
@@ -69,46 +77,57 @@
width
height
8
:unsigned
(ecase components
(1 :red)
(2 :rg)
(3 :bgr)
(4 :bgra)))))))
(defmethod load-image (path (type (eql :jpg)))
(load-image path :jpeg))
(defmethod load-image (path (type (eql :raw)))
(with-open-file (stream path :element-type '(unsigned-byte 8))
(let ((data (make-static-vector (file-length stream))))
(loop for reached = 0 then (read-sequence data stream :start reached)
while (< reached (length data))
finally (return data)))))
(defmethod load-image (path (type (eql :r16)))
(values (load-image path :raw)
NIL
NIL
:f16))
(defmethod load-image (path (type (eql :r32)))
(values (load-image path :raw)
NIL
NIL
:f32))
(defmethod load-image (path (type (eql :ter)))
(let ((terrain (terrable:read-terragen path)))
(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)
(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))))))
(loop for reached = 0 then (read-sequence data stream :start reached)
while (< reached (length data)))
(values data
width
height
depth
pixel-type
format)))))
(defmethod load-image (path (type (eql :r16)) &rest args)
(apply #'load-image path :raw :depth 16 :pixel-type :float args))
(defmethod load-image (path (type (eql :r32)) &rest args)
(apply #'load-image path :raw :depth 32 :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)
:s16
16
:signed
:red)))
(defmethod load-image (path (type (eql T)))
(defmethod load-image (path (type (eql T)) &rest args)
(let ((type (pathname-type path)))
(load-image path (intern (string-upcase type) "KEYWORD"))))
(apply #'load-image path (intern (string-upcase type) "KEYWORD") args)))
(defun free-image-data (data)
(etypecase data
@@ -117,60 +136,41 @@
(vector
(maybe-free-static-vector data))))
(defun infer-internal-format (bittage pixel-format)
(intern
(format NIL "~a~a"
(ecase pixel-format
((:r :red) :r)
((:rg :gr) :rg)
((:rgb :bgr) :rgb)
((:rgba :bgra) :rgba))
(ecase bittage
((:u8 8) :8)
((:u16 16) :16)
((:u32 32) :32)
((:s8) :8i)
((:s16) :16i)
((:s32) :32i)
((:f16) :16f)
((:f32) :32f)))))
(defun infer-pixel-type (bittage)
(ecase bittage
((:u8 8) :unsigned-byte)
((:u16 16) :unsigned-short)
((:u32 32) :unsigned-int)
((:s8) :byte)
((:s16) :short)
((:s32) :int)
((:f16) :half-float)
((:f32) :float)))
(defmethod load ((image image))
;; FIXME: Convert pixel data to raw buffer.
(flet ((load-image (path)
(with-new-value-restart (path) (new-path "Specify a new image path.")
(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 bittage pixel-format) (load-image (unlist input))
(multiple-value-bind (bits width height depth 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 user-provided data?
;; FIXME: Maybe attempt to reconcile/compare user-provided data?
(setf (pixel-data image) bits)
(when pixel-format (setf (pixel-format image) pixel-format))
(when (and bittage pixel-format) (setf (internal-format image) (infer-internal-format bittage pixel-format)))
(when bittage (setf (pixel-type image) (infer-pixel-type bittage)))
(when width (setf (width image) width))
(when height (setf (height image) height))
(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 (listp input)
(setf (pixel-data image) (list (pixel-data image)))
(dolist (input (rest input))
(multiple-value-bind (bits width height bittage pixel-format) (load-image input)
(assert (or (null width) (= width (width image))))
(assert (or (null height) (= height (height image))))
(assert (or (null pixel-format) (eq pixel-format (pixel-format image))))
(assert (or (null bittage) (null pixel-format) (eq (infer-internal-format bittage pixel-format) (internal-format image))))
(multiple-value-bind (bits width height depth type pixel-format) (load-image input)
(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))))
(push bits (pixel-data image))))
(setf (pixel-data image) (nreverse (pixel-data image))))
(allocate image))))))
Oops, something went wrong.

0 comments on commit 74a96df

Please sign in to comment.