Add direct image output of maps to Emacs and Terminology.

parse-map.scm

@@ -63,6 +63,33 @@
   (string-trim-right (bytevector->string bv transcoder)
                      #\nul))
 
+(define (string->filename str)
+  (use-modules (ice-9 regex))
+  (regexp-substitute/global
+   #f "[ ]" str
+   'pre "_" 'post))
+
+
+;; Calls thunk with current working directory changed to dir
+(define (call-with-cwd dir thunk)
+  (let ((old-dir #f))
+   (dynamic-wind
+     (lambda ()
+       (set! old-dir (getcwd))
+       (chdir dir))
+     thunk
+     (lambda () (chdir old-dir)))))
+
+
+;; Attempts to display the given image file through w3m's terminal image magick;
+;; currently always places it in the top left corner.
+(define (w3m-display-image filename)
+  (let ((pipe ((@ (ice-9 popen) open-output-pipe) "/usr/lib/w3m/w3mimgdisplay")))
+    (format pipe "0;1;0;0;64;64;;;;;~a~%;4;~%3;~%"
+            filename
+            )
+    ((@ (ice-9 popen) close-pipe) pipe)))
+
 
 
 ;; Constants
@@ -109,6 +136,22 @@
   (height      get-height)
   (name        get-name))
 
+;; My scheme level object above wolf map data
+(define-record-type <wolf-map>
+  (make-wolf-map metadata data file)
+  wolf-map?
+  (metadata get-metadata)
+  (data get-data)
+  (file get-file set-file!))
+
+;; Emacs actually renders the #<Image: ...> tag!
+(set-record-type-printer!
+ <wolf-map>
+ (lambda (r p)
+   (if (get-file r)
+       (format p "#<Image: ~a>" (get-file r))
+       (format p "#<Wolf Map: ~a>" (-> r get-metadata get-name)))))
+
 
 
 ;; Pure procedures
@@ -250,10 +293,13 @@ else insert the value as given"
    (lambda (el) (put-bytevector port (mapper el)))
    array))
 
-(define (dump-tilemap map-head tilemap)
-  (let ((fname (format #f "~a.ppm" (get-name map-head))))
+
+(define (dump-tilemap! wolf-map)
+  (let ((fname (format #f "~a/~a.ppm"
+                       (getcwd)
+                       (string->filename (get-name (get-metadata wolf-map))))))
     (call-with-output-file fname
-      (lambda (port) (array->ppm port tilemap
+      (lambda (port) (array->ppm port (get-data wolf-map)
                             (lambda (tile) ; WL_GAME.C, 624
                               (cond ((= tile 0) rgb:black)  ; floor
                                     ((<= 90 tile 101) rgb:brown) ; door
@@ -261,34 +307,42 @@ else insert the value as given"
                                     (else rgb:red))
                               )))
       #:binary #t)
-    (format #t "Wrote map to ~a~%" fname)))
+    (set-file! wolf-map fname)))
 
 
 
 
-(define (main args)
-  (define og-dir (getcwd))
-  (chdir "/home/hugo/wolf/full/")
-
-  (let* ((maphead (call-with-input-file "MAPHEAD.WL6"
-                    parse-maphead #:binary #t))
-         (mapmeta (call-with-input-file "GAMEMAPS.WL6"
-                    (lambda (port) (parse-map-metadata maphead port)) #:binary #t)))
-
-    (when (or (= 1 (length args))
-              (member (cadr args) '("--help" "-h" "-?" "--list" "-l")))
-      (format #t "Available maps:~%")
-      (for-each (lambda (i m) (format #t "~2,a : ~a~%" i (get-name m)))
-                (iota (length mapmeta))
-                mapmeta)
-      (exit))
-
-    (let* ((maph (list-ref mapmeta (string->number (cadr args))))
-           (data (call-with-input-file "GAMEMAPS.WL6"
-                   (lambda (port) (parse-map-data maph port))
-                   #:binary #t)))
-      (chdir og-dir)
-      (let ((tilemap (-> data car tile-list->tilemap)))
-        (display-tilemap tilemap)
-        (dump-tilemap maph tilemap)))))
+(define get-map
+  (call-with-cwd
+   "/home/hugo/wolf/full/"
+   (lambda ()
+     (define map-file (open-input-file "GAMEMAPS.WL6" #:binary #t))
+     (let* ((maphead (call-with-input-file "MAPHEAD.WL6"
+                       parse-maphead #:binary #t))
+            (mapmeta (parse-map-metadata maphead map-file)))
+       ;; function bound to get-map
+       (lambda (idx)
+         (if (eq? idx 'list)
+             (zip (iota (length mapmeta))
+                  (map get-name mapmeta))
+             (let ((maph (list-ref mapmeta idx)))
+               (make-wolf-map maph
+                              (-> maph
+                                  (parse-map-data map-file)
+                                  car tile-list->tilemap)
+                              #f))))))))
 
+
+(define (main args)
+  (when (or (= 1 (length args))
+            (member (cadr args) '("--help" "-h" "-?" "--list" "-l")))
+    (format #t "Available maps:~%~:{~2,a: ~a~%~}"
+            (get-map 'list))
+    (exit))
+
+  (let ((wolf-map (get-map (string->number (cadr args)))))
+    (dump-tilemap! wolf-map)
+    (format #t "Wrote image to ~a~%" (get-file wolf-map))
+    (if (getenv "TERMINOLOGY")
+        (system* "tycat" (get-file wolf-map))
+        (w3m-display-image (get-file wolf-map)))))