Cleanup in parse-map.

parse-map.scm

-(use-modules (system foreign)
-             (ice-9 binary-ports)
-             (ice-9 iconv)
-             (rnrs base)
+;;; Commentary
+
+;; This is a parser for the Wolfenstein 3d mapdata
+;; It should work with both the shareware and full version, as well as Spear of
+;; Destiny. It requires that the files are Carmack-compressed.
+
+;; Procedures is as far as possible anotated with where in which file they
+;; originated from. The original Wolf3D source can be found at:
+;; https://github.com/id-Software/wolf3d
+
+;;; Code
+
+(use-modules (ice-9 format)
+
+             ((rnrs base) #:select (assert))
+             (rnrs io ports)
              (rnrs bytevectors)
+
              (srfi srfi-1)
-             (srfi srfi-4)
-             (srfi srfi-9)
-             (srfi srfi-9 gnu)
-             (srfi srfi-26)
-             (srfi srfi-71)
+             (srfi srfi-4)              ; u16vector-ref
+             ((srfi srfi-9) #:select (define-record-type))
+             ((srfi srfi-9 gnu) #:select (set-record-type-printer!))
              )
 
+
 
-
-(define MAPPLANES 2)
+;; Util
 
 (define (hex a)
   (format #f "~:@(~4,'0x~)" a))
 
+(define (cross-product l1 l2)
+  (concatenate
+   (map (lambda (a)
+          (map (lambda (b) (list a b))
+               l2))
+        l1)))
+
+
+;; Displays a 2d array, representing 0 as a space and everything else as an octophorpe
+(define (display-tilemap tilemap)
+  (format #t "~{|~{~[ ~:;#~]~}|~%~}"
+          (array->list tilemap)))
+
+
+(define* (bytevector->c-string
+          bv #:key (transcoder (make-transcoder "ASCII")))
+  (string-trim-right (bytevector->string bv transcoder)
+                     #\nul))
+
 
-(chdir "/home/hugo/wolf/full/")
+
+;; Constants
+
+(define MAPPLANES 2)
+(define AREATILE 107)
+
+
+
+;; Datatypes
 
 ;; @example
 ;; struct mapfiletype {
@@ -40,15 +78,6 @@
            (get-rlew r)
            (take-while (negate zero?) (get-offsets r)))))
 
-(define maphead
-  (call-with-input-file "MAPHEAD.WL6"
-    (lambda (port)
-      (make-maphead (u16vector-ref   (get-bytevector-n port 2) 0)
-                    (u32vector->list (get-bytevector-all port))))
-    #:binary #t))
-
-(assert (= #xABCD (get-rlew maphead)))
-
 ;; @example
 ;; struct maptype {
 ;;     uint32_t planestart[3];
@@ -66,40 +95,13 @@
   (height      get-height)
   (name        get-name))
 
-;;; ID_CA.C, 1000
-(define maps
- (call-with-input-file "GAMEMAPS.WL6"
-   (lambda (port)
-     (filter-map
-      (lambda (pos)
-        (if (= pos 0) #f
-            (begin
-              (seek port pos SEEK_SET)
-              (make-maptype
-               (list-head        ; planestart
-                (u32vector->list
-                 (get-bytevector-n port (* 3 (sizeof long))))
-                MAPPLANES)
-               (list-head        ; planelength
-                (u16vector->list
-                 (get-bytevector-n port (* 3 (sizeof unsigned))))
-                MAPPLANES)
-               (u16vector-ref (get-bytevector-n port (sizeof unsigned)) 0) ; width
-               (u16vector-ref (get-bytevector-n port (sizeof unsigned)) 0) ; height
-               (string-trim-right (bytevector->string (get-bytevector-n port 16) "ASCII")
-                                  #\nul)
-               ;; (bytevector->string (get-bytevector-n port  4) "ASCII") ; "!ID!"
-               ))))
-      (get-offsets maphead)))
-   #:binary #t))
+
 
-(for-each (lambda (m)
-            (assert (= 64 (get-width m) (get-height m))))
-          maps)
+;; Pure procedures
 
 ;; ID_CA.C, 609
 ;; bytevector, int -> bytevector
-(define (carmak-expand source expanded-length)
+(define (carmack-expand source expanded-length)
   (define neartag #xa7)
   (define fartag  #xa8)
 
@@ -148,50 +150,23 @@
   "If car = #xABCD, repeat the next next value next number times.
 else insert the value as given"
   (let loop ((done '())
-             (rem source)
-             (len 0))
+             (rem source))
     (cond [(null? rem)
            (concatenate (reverse done))]
 
           [(= rlew-tag (car rem))
-           (apply (lambda (count value . rest)
+           (let ((count (cadr  rem))
+                 (value (caddr rem))
+                 (rest  (cdddr rem)))
              (loop (cons (make-list count value) done)
-                          rest
-                          (+ len count)))
-                  (cdr rem))]
+                   rest))]
 
           [else (loop (cons (list (car rem)) done)
-                      (cdr rem)
-                      (+ len 1))])))
-
+                      (cdr rem))])))
 
-(define read-mapdata
- (call-with-input-file "GAMEMAPS.WL6"
-   (lambda (port)
-     (map (lambda (m)
-            (map (lambda (pos compressed)
-                   (seek port pos SEEK_SET)  ; ID_CA.C, 1454
-                   (let ((len (u16vector-ref (get-bytevector-n port 2) 0)))
-                     (list len (get-bytevector-n port (- compressed -2)))))
-                 (get-planestart m)
-                 (get-planelength m)))
-          maps))
-   #:binary #t))
-
-(define expanded
- (let ((bv (apply carmak-expand (reverse (caar read-mapdata)))))
-   (rlew-expand (cdr (bytevector->uint-list bv (endianness little) 2)))))
-
-(define (cross-product l1 l2)
-  (concatenate
-   (map (lambda (a)
-          (map (lambda (b) (list a b))
-               l2))
-        l1)))
-
-(define AREATILE 107)
 
 ;; WL_GAME.C, 663
+;; lays out the given 1d list into a 2d, 64x64 grid.
 (define (tile-list->tilemap tile-list)
   (let ((tilemap (make-array 0 64 64)))
     (for-each (lambda (tile coord)
@@ -202,9 +177,79 @@ else insert the value as given"
               (cross-product (iota 64) (iota 64)))
     tilemap))
 
-(define (display-tilemap tilemap)
-  (format #t "~{|~{~[ ~:;#~]~}|~%~}"
-          (array->list tilemap)))
 
+
+
+;; Reading and parsing procedures
+
+;; port -> maphead
+(define (parse-maphead port)
+  (make-maphead (u16vector-ref   (get-bytevector-n port 2) 0)
+                (u32vector->list (get-bytevector-all port))))
+
+
+;; ID_CA.C, 1000
+;; maphead, port -> (list map-metadata)
+(define (parse-map-metadata maphead port)
+  (filter-map
+   (lambda (pos)
+     (if (= pos 0) #f
+         (begin
+           (seek port pos SEEK_SET)
+           (make-maptype
+            (list-head        ; planestart
+             (u32vector->list
+              (get-bytevector-n port (* 3 4)))
+             MAPPLANES)
+            (list-head        ; planelength
+             (u16vector->list
+              (get-bytevector-n port (* 3 2)))
+             MAPPLANES)
+            (u16vector-ref (get-bytevector-n port 2) 0) ; width
+            (u16vector-ref (get-bytevector-n port 2) 0) ; height
+            (bytevector->c-string (get-bytevector-n port 16))
+
+            ;; (bytevector->string (get-bytevector-n port  4) "ASCII") ; "!ID!"
+            ))))
+   (get-offsets maphead)))
+
+
+;; map-metadata, port -> map-data[2] (list uint16)
+(define (parse-map-data map-metadata port)
+  (map (lambda (pos compressed)
+         (seek port pos SEEK_SET)  ; ID_CA.C, 1454
+         (let* ((len (u16vector-ref (get-bytevector-n port 2) 0))
+                (raw-bytes (get-bytevector-n port (- compressed 2))))
+           (let* ((cexpanded (carmack-expand raw-bytes len))
+                  (uint-list (bytevector->uint-list cexpanded (endianness little) 2)))
+             (assert (= (* 2 64 64) (car uint-list)))
+             (rlew-expand (cdr uint-list)))))
+       (get-planestart map-metadata)
+       (get-planelength map-metadata)))
+
+
+
+
+
+(define (main args)
+  (chdir "/home/hugo/wolf/full/")
+
+  (let* ((maphead
+          (call-with-input-file "MAPHEAD.WL6"
+            parse-maphead #:binary #t))
+         (mapdata
+          (call-with-input-file "GAMEMAPS.WL6"
+            (lambda (port)
+              (let ((map-metadata (parse-map-metadata maphead port)))
+                (assert
+                 (fold (lambda (m t) (and t (= 64 (get-width m) (get-height m))))
+                       #t map-metadata))
+
+                (map (lambda (m) (parse-map-data m port))
+                     map-metadata)))
+            #:binary #t)))
+
+    (assert (= #xABCD (get-rlew maphead)))
 
 
+    (display-tilemap (tile-list->tilemap (car (caddr mapdata))))))