Commit some previously uncommitted files.HEADmaster

2 files changed, 96 insertions, 0 deletions

diff --git a/assets/images/lightness.xcf b/assets/images/lightness.xcf
new file mode 100644
index 0000000..db09c0c
--- /dev/null
+++ b/assets/images/lightness.xcf
diff --git a/shake-tree.scm b/shake-tree.scm
new file mode 100644
index 0000000..88e34ec
--- /dev/null
+++ b/shake-tree.scm
@@ -0,0 +1,96 @@
+(use-modules (ice-9 match)
+             (srfi srfi-1)
+             (test-subject game))
+
+(define (root-module)
+  (resolve-module '() #f #f #:ensure #f))
+
+(define (loaded-modules)
+  (define (scan-submodules module)
+    (hash-fold (lambda (k m memo)
+                 (if (module-filename m)
+                     (cons (module-filename m)
+                           (append (scan-submodules m)
+                                   memo))
+                     (append (scan-submodules m) memo)))
+               '()
+               (module-submodules module)))
+  (delete-duplicates (cons* "ice-9/eval.scm"
+                            "ice-9/i18n.scm"
+                            "ice-9/posix.scm"
+                            "ice-9/psyntax-pp.scm"
+                            "ice-9/quasisyntax.scm"
+                            "ice-9/match.upstream.scm"
+                            "ice-9/networking.scm"
+                            "ice-9/r6rs-libraries.scm"
+                            "ice-9/r7rs-libraries.scm"
+                            (scan-submodules (root-module)))
+                     string=?))
+
+(define (in-load-path path file-name)
+  (let loop ((path path))
+    (match path
+      (() #f)
+      ((dir . rest)
+       (let ((f (string-append dir "/" file-name)))
+         (if (file-exists? f)
+             f
+             (loop rest)))))))
+
+(define (scm->go file-name)
+  (string-append (substring file-name 0 (- (string-length file-name) 4)) ".go"))
+
+(define (shake-tree)
+  (map (lambda (f)
+         (list f
+               (in-load-path %load-path f)
+               (in-load-path %load-compiled-path
+                             (scm->go f))))
+       (sort (loaded-modules) string<)))
+
+;; Snarfed from Guix
+(define (mkdir-p dir)
+  "Create directory DIR and all its ancestors."
+  (define absolute?
+    (string-prefix? "/" dir))
+
+  (define not-slash
+    (char-set-complement (char-set #\/)))
+
+  (let loop ((components (string-tokenize dir not-slash))
+             (root       (if absolute?
+                             ""
+                             ".")))
+    (match components
+      ((head tail ...)
+       (let ((path (string-append root "/" head)))
+         (catch 'system-error
+           (lambda ()
+             (mkdir path)
+             (loop tail path))
+           (lambda args
+             (if (= EEXIST (system-error-errno args))
+                 (loop tail path)
+                 (apply throw args))))))
+      (() #t))))
+
+(define (install-modules spec prefix)
+  (let ((v (string-append (major-version) ".0")))
+    (for-each (match-lambda
+                ((suffix source compiled)
+                 (let ((scm-dest (string-append prefix "/share/guile/" v "/"
+                                                suffix))
+                       (go-dest (string-append prefix "/lib/guile/" v "/ccache/"
+                                               (scm->go suffix))))
+                   (mkdir-p (dirname scm-dest))
+                   (mkdir-p (dirname go-dest))
+                   (display (string-append "copy " source " to " scm-dest))
+                   (newline)
+                   (copy-file source scm-dest)
+                   (when compiled
+                     (display (string-append "copy " compiled " to " go-dest))
+                     (newline)
+                     (copy-file compiled go-dest)))))
+              spec)))
+
+(install-modules (shake-tree) "/home/dthompson/Code/bundle2/the-test-subject")