1 files changed, 200 insertions, 0 deletions
diff --git a/lisparuga/asset.scm b/lisparuga/asset.scm
new file mode 100644
index 0000000..b4969b0
--- /dev/null
+++ b/lisparuga/asset.scm
@@ -0,0 +1,200 @@
+;;; Lisparuga
+;;; Copyright © 2020 David Thompson <dthompson2@worcester.edu>
+;;;
+;;; Lisparuga is free software: you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published
+;;; by the Free Software Foundation, either version 3 of the License,
+;;; or (at your option) any later version.
+;;;
+;;; Lisparuga is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with Lisparuga.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; Abstraction for loading game data from the file system, including
+;; automatically reloading the data when it changes.
+;;
+;;; Code:
+
+(define-module (lisparuga asset)
+  #:use-module (ice-9 ftw)
+  #:use-module (ice-9 match)
+  #:use-module (oop goops)
+  #:use-module (srfi srfi-1)
+  #:use-module (lisparuga inotify)
+  #:export (<asset>
+            artifact
+            file-name
+            loader
+            args
+            watch-assets
+            watching-assets?
+            watch-asset-directory
+            reload-modified-assets
+            clear-asset-cache
+            asset-ref
+            define-asset))
+
+(define-class <asset> ()
+  (watch? #:allocation #:class #:init-form #f)
+  ;; class slots for asset cache and live reloading
+  (inotify #:allocation #:class #:init-form #f)
+  ;; file-name -> assets mapping
+  (asset-file-map #:allocation #:class #:init-form (make-hash-table))
+  ;; args -> artifact mapping
+  (artifact-cache #:allocation #:class #:init-form (make-weak-value-hash-table))
+  ;; asset -> artifact mapping
+  (asset-artifact-map #:allocation #:class #:init-form (make-weak-key-hash-table))
+  (watches #:allocation #:class #:init-form '())
+  ;; instance slots
+  (file-name #:getter file-name #:init-keyword #:file-name)
+  (loader #:getter loader #:init-keyword #:loader)
+  (loader-args #:getter loader-args #:init-form '()
+               #:init-keyword #:loader-args))
+
+(define (absolute-file-name file-name)
+  (if (absolute-file-name? file-name)
+      file-name
+      (string-append (getcwd) "/" file-name)))
+
+(define-method (initialize (asset <asset>) initargs)
+  (next-method)
+  ;; Convert file name to an absolute file name.
+  (slot-set! asset 'file-name (absolute-file-name (file-name asset)))
+  ;; Add asset to the file-name -> asset map
+  (let* ((asset-file-map (class-slot-ref <asset> 'asset-file-map))
+         ;; Using a weak key hash table instead of a list to keep
+         ;; track of all the assets that are associated with a file.
+         ;; This way, their presence in the cache won't save them from
+         ;; the GC.
+         (sub-table (or (hash-ref asset-file-map (file-name asset))
+                        (let ((wt (make-weak-key-hash-table)))
+                          (hash-set! asset-file-map (file-name asset) wt)
+                          wt))))
+    (hash-set! sub-table asset asset)))
+
+(define (asset-inotify)
+  (class-slot-ref <asset> 'inotify))
+
+(define (asset-file-map)
+  (class-slot-ref <asset> 'asset-file-map))
+
+(define (artifact-cache)
+  (class-slot-ref <asset> 'artifact-cache))
+
+(define (asset-artifact-map)
+  (class-slot-ref <asset> 'asset-artifact-map))
+
+(define (asset-watches)
+  (class-slot-ref <asset> 'watches))
+
+(define (watch-assets watch?)
+  (let ((old-watch? (watching-assets?)))
+    (class-slot-set! <asset> 'watch? watch?)
+    (cond
+     ;; Watching is being turned on.
+     ((and watch? (not old-watch?))
+      ;; Retroactively add watches for all existing assets.
+      (hash-for-each (lambda (file-name assets)
+                       (watch-asset-directory (dirname file-name)))
+                     (asset-file-map)))
+     ;; Watching is being turned off.
+     ((and (not watch?) old-watch?)
+      ;; Deactive inotify watches.
+      (for-each inotify-watch-remove! (inotify-watches (asset-inotify)))))))
+
+(define (watching-assets?)
+  (class-slot-ref <asset> 'watch?))
+
+(define (directory-watched? dir)
+  (find (lambda (watch)
+          (string=? (inotify-watch-file-name watch) dir))
+        (asset-watches)))
+
+(define (watch-asset-directory dir)
+  ;; Lazily activate inotify.
+  (unless (asset-inotify)
+    (class-slot-set! <asset> 'inotify (make-inotify)))
+  ;; Add watch if it doesn't already exist.
+  (unless (directory-watched? dir)
+    (class-slot-set! <asset> 'watches
+                     (cons (inotify-add-watch! (asset-inotify)
+                                               dir
+                                               '(create close-write moved-to))
+                           (asset-watches)))))
+
+(define (reload-modified-assets)
+  (let ((inotify (asset-inotify)))
+    (when inotify
+      (while (inotify-pending-events? inotify)
+        (let* ((event (inotify-read-event inotify))
+               (type (inotify-event-type event))
+               (file-name (string-append (inotify-watch-file-name
+                                          (inotify-event-watch event))
+                                         "/"
+                                         (inotify-event-file-name event)))
+               (assets (hash-ref (asset-file-map) file-name)))
+          (cond
+           ((and assets (or (eq? type 'close-write) (eq? type 'moved-to)))
+            ;; Expire everything from cache, then reload.
+            (hash-for-each (lambda (key asset)
+                             (expire-cached-artifact (cache-key asset)))
+                           assets)
+            (hash-for-each (lambda (key asset)
+                             (load! asset))
+                           assets))))))))
+
+(define (cache-key asset)
+  (list (loader asset) (file-name asset) (loader-args asset)))
+
+(define (cache-artifact key artifact)
+  (hash-set! (artifact-cache) key artifact))
+
+(define (expire-cached-artifact key)
+  (hash-remove! (artifact-cache) key))
+
+(define (clear-asset-cache)
+  (hash-clear! (artifact-cache))
+  (hash-clear! (asset-artifact-map)))
+
+(define (fetch-cached-artifact key)
+  (hash-ref (artifact-cache) key))
+
+(define (load-artifact cache-key loader file-name loader-args add-watch?)
+  (or (fetch-cached-artifact cache-key)
+      (let ((artifact (apply loader file-name loader-args)))
+        (cache-artifact cache-key artifact)
+        (when (and add-watch? (watching-assets?))
+          (watch-asset-directory (dirname file-name)))
+        artifact)))
+
+(define* (load! asset #:optional add-watch?)
+  (let ((thing (load-artifact (cache-key asset)
+                              (loader asset)
+                              (file-name asset)
+                              (loader-args asset)
+                              add-watch?)))
+    (hashq-set! (asset-artifact-map) asset thing)
+    thing))
+
+(define-method (asset-ref (asset <asset>))
+  ;; Assets are lazy-loaded upon first access.
+  (or (hashq-ref (asset-artifact-map) asset)
+      (load! asset #t)))
+
+;; Make assets that are outside of the cache "just work".
+(define-method (asset-ref x) x)
+
+;; Handy syntax for defining new assets.
+(define-syntax-rule (define-asset name
+                      (loader file-name loader-args ...))
+  (define name
+    (make <asset>
+      #:file-name file-name
+      #:loader loader
+      #:loader-args (list loader-args ...))))