BRF image import

borodust · Dec 15, 2016 · 551b4e7 · 551b4e7
1 parent aa2b74b
commit 551b4e7
Show file tree

Hide file tree

Showing 8 changed files with 138 additions and 38 deletions.
diff --git a/cl-bodge.asd b/cl-bodge.asd
@@ -181,7 +181,7 @@
   :author "Pavel Korolev"
   :mailto "dev@borodust.org"
   :license "MIT"
-  :depends-on (cl-bodge/engine cl-bodge/utils cl-bodge/graphics-resources
+  :depends-on (cl-bodge/engine cl-bodge/utils cl-bodge/graphics-resources flexi-streams
                                cl-bodge/audio-resources bodge-sndfile log4cl cl-fad opticl)
   :pathname "resources"
   :serial t
@@ -215,6 +215,19 @@
                (:file "system")))
 
 
+(defsystem cl-bodge/text
+  :description "Bodacious Game Engine text rendering"
+  :version "0.3.0"
+  :author "Pavel Korolev"
+  :mailto "dev@borodust.org"
+  :license "MIT"
+  :depends-on (cl-bodge/engine cl-bodge/utils cl-bodge/graphics cl-bodge/assets log4cl)
+  :pathname "text"
+  :serial t
+  :components ((:file "packages")
+               (:file "system")))
+
+
 (defsystem cl-bodge/scenegraph
   :description "Bodacious Game Engine scenegraph implementation"
   :version "0.3.0"

diff --git a/resource-interfaces/graphics.lisp b/resource-interfaces/graphics.lisp
@@ -6,6 +6,7 @@
   (:use :cl-bodge.utils
         :cl)
   (:export pixel-format
+           pixel-format-p
 
            pixel-format-of
            image->array

diff --git a/resources/image.lisp b/resources/image.lisp
@@ -8,7 +8,24 @@
 
 
 (defclass png-image (image)
-  ((data :initarg :data :reader pixels-of)))
+  ((data :initarg :data :reader data-of)))
+
+
+(defun prepare-png-data (width height pixel-format data)
+  (loop with channels = (ecase pixel-format
+                          (:grey 1)
+                          (:rgb 3)
+                          (:rgba 4))
+     with result = (make-array (* width height channels) :element-type '(unsigned-byte 8))
+     for i from 0 below height do
+       (loop for j from 0 below width do
+            (if (= channels 1)
+                (setf (aref result (+ j (* i width)))
+                       (aref data i j))
+                (loop for k from 0 below channels do
+                     (setf (aref result (+ k (* j channels) (* (- height i 1) width channels)))
+                           (aref data i j k)))))
+     finally (return result)))
 
 
 (defun load-png-image (path)
@@ -19,7 +36,7 @@
                    (opticl:8-bit-rgba-image :rgba))))
     (opticl:with-image-bounds (h w) data
       (make-instance 'png-image
-                     :data data
+                     :data (prepare-png-data w h format data)
                      :width w
                      :height h
                      :pixel-format format))))
@@ -30,20 +47,34 @@
 
 
 (defmethod ge.gx.rsc:image->array ((this png-image))
-  (loop with width = (width-of this)
-     and height = (height-of this)
-     and channels = (ecase (ge.gx.rsc:pixel-format-of this)
-                      (:grey 1)
-                      (:rgb 3)
-                      (:rgba 4))
-     and data = (pixels-of this)
-     with result = (make-array (* width height channels) :element-type '(unsigned-byte 8))
-     for i from 0 below height do
-       (loop for j from 0 below width do
-            (if (= channels 1)
-                (setf (aref result (+ j (* i width)))
-                       (aref data i j))
-                (loop for k from 0 below channels do
-                     (setf (aref result (+ k (* j channels) (* (- height i 1) width channels)))
-                           (aref data i j k)))))
-     finally (return result)))
+  (data-of this))
+
+
+(defstruct (image-chunk
+             (:constructor make-image-chunk (name image)))
+  (name nil :read-only t)
+  (image nil :read-only t))
+
+
+(defmethod read-chunk-data ((type (eql :image)) parameters stream)
+  (destructuring-bind (&key size &allow-other-keys) parameters
+    (let* ((image-data (make-array size :element-type '(unsigned-byte 8)))
+           (bytes-read (read-sequence image-data stream)))
+      (unless (= size bytes-read)
+        (error "Incorrect :size provided for chunk data: provided ~a, but ~a read"
+               size bytes-read))
+      image-data)))
+
+
+(defmethod parse-chunk ((type (eql :image)) parameters data)
+  (destructuring-bind (&key name width height type pixel-format &allow-other-keys) parameters
+    (unless (eq type :png)
+      (error "Image type ~a unsupported" type))
+    (unless (pixel-format-p pixel-format)
+      (error "Unsupported pixel format: ~a" pixel-format))
+
+    (make-image-chunk name (make-instance 'png-image
+                                          :data data
+                                          :width width
+                                          :height height
+                                          :pixel-format pixel-format))))
diff --git a/resources/resource-loader.lisp b/resources/resource-loader.lisp
@@ -11,6 +11,11 @@
     (error "Unknown chunk type: ~a" chunk-type)))
 
 
+(defgeneric read-chunk-data (chunk-type parameters stream)
+  (:method (chunk-type parameters stream)
+    (read (flexi-streams:make-flexi-stream stream :external-format :utf-8))))
+
+
 (defun push-object (id obj)
   (setf (gethash id *objects*) obj))
 
@@ -98,20 +103,23 @@
   (flet ((resolve-references (resolvers)
            (dolist (fn resolvers)
              (funcall fn))))
-    (with-open-file (in (fad:canonical-pathname path))
-      (destructuring-bind (format version) (read in)
-        (unless (eq :brf format)
-          (error "Unknown format: ~a" format))
-        (unless (eql 1 version)
-          (error "Unsupported version: ~a" version))
-        (let* ((*objects* (make-hash-table :test 'equal))
-               (*resource-path* path)
-               (*resolvers* '())
-               (chunk-table (make-hash-table)))
-          (loop for chunk-header = (read in nil nil)
-             until (null chunk-header) do
-               (destructuring-bind (chunk-type &rest parameters) chunk-header
-                 (with-hash-entries ((chunks chunk-type)) chunk-table
-                   (push (parse-chunk chunk-type parameters (read in)) chunks))))
-          (resolve-references *resolvers*)
-          (make-instance 'resource :chunks chunk-table))))))
+    (with-open-file (in (fad:canonical-pathname path) :element-type '(unsigned-byte 8))
+      (let ((char-stream (flexi-streams:make-flexi-stream in :external-format :utf-8)))
+        (destructuring-bind (format version) (read char-stream)
+          (unless (eq :brf format)
+            (error "Unknown format: ~a" format))
+          (unless (eql 1 version)
+            (error "Unsupported version: ~a" version))
+          (let* ((*objects* (make-hash-table :test 'equal))
+                 (*resource-path* path)
+                 (*resolvers* '())
+                 (chunk-table (make-hash-table)))
+            (loop for chunk-header = (read-preserving-whitespace char-stream nil nil nil)
+               until (null chunk-header) do
+                 (destructuring-bind (chunk-type &rest parameters) chunk-header
+                   (with-hash-entries ((chunks chunk-type)) chunk-table
+                     (push (parse-chunk chunk-type parameters
+                                        (read-chunk-data chunk-type parameters in))
+                           chunks))))
+            (resolve-references *resolvers*)
+            (make-instance 'resource :chunks chunk-table)))))))
diff --git a/text/packages.lisp b/text/packages.lisp
@@ -0,0 +1,6 @@
+(in-package :cl-bodge.asdf)
+
+
+(defpackage :cl-bodge.text
+  (:nicknames :ge.text)
+  (:use :cl :cl-bodge.graphics))
diff --git a/text/text.lisp b/text/text.lisp
@@ -0,0 +1,17 @@
+(in-package :cl-bodge.text)
+
+
+(defclass glyph-atlas () ())
+
+
+(defclass glyph () ())
+
+
+(defclass text ()
+  (text position))
+
+
+(defmethod render ((this text))
+  (with-slots (text position) this
+    (loop for char across text do
+         (render (find-glyph glyph atlas)))))
diff --git a/utils/packages.lisp b/utils/packages.lisp
@@ -52,4 +52,5 @@
            list->array
            reexporting
            define-package
-           when-debugging))
+           when-debugging
+           flatten-array))
diff --git a/utils/utils.lisp b/utils/utils.lisp
@@ -257,3 +257,26 @@
             `(defpackage ,name ,@std)
             `(reexporting ,reexport-from ,name
                (defpackage ,name ,@std)))))))
+
+
+(defun flatten-array (array)
+  (let* ((dims (array-dimensions array)))
+    (labels ((total-offset (offsets sizes)
+               (if offsets
+                   (+ (* (first offsets) (reduce #'* sizes))
+                      (total-offset (rest offsets) (rest sizes)))
+                   0))
+             (copy-dimension (dst src offset rest-dims)
+               (if (null rest-dims)
+                   (let ((dst-offset (total-offset offset (rest dims))))
+                     (setf (aref dst dst-offset) (apply #'aref src offset)))
+                   (loop with size = (first rest-dims)
+                      for i from 0 below size
+                      do (copy-dimension dst src (append offset (list i)) (rest rest-dims))))))
+
+      (if (null (cdr dims))
+          array
+          (let* ((result (make-array (reduce #'* dims)
+                                     :element-type (array-element-type array))))
+            (copy-dimension result array '() dims)
+            result)))))