parse-map.scm 8.74 KB
Newer Older
1 2 3 4
#!/usr/bin/guile \
-e main -s
!#

Hugo Hörnquist's avatar
Hugo Hörnquist committed
5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20
;;; 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)
Hugo Hörnquist's avatar
Hugo Hörnquist committed
21
             (rnrs bytevectors)
Hugo Hörnquist's avatar
Hugo Hörnquist committed
22

Hugo Hörnquist's avatar
Hugo Hörnquist committed
23
             (srfi srfi-1)
Hugo Hörnquist's avatar
Hugo Hörnquist committed
24 25 26
             (srfi srfi-4)              ; u16vector-ref
             ((srfi srfi-9) #:select (define-record-type))
             ((srfi srfi-9 gnu) #:select (set-record-type-printer!))
Hugo Hörnquist's avatar
Hugo Hörnquist committed
27
             )
28 29 30 31 32 33


(define rgb:black #vu8(0 0 0))
(define rgb:brown #vu8(0 #xFF #xFF))
(define rgb:blue #vu8(0 #x99 #xFF))
(define rgb:red #vu8(#xCC 0 0))
Hugo Hörnquist's avatar
Hugo Hörnquist committed
34

Hugo Hörnquist's avatar
Hugo Hörnquist committed
35

Hugo Hörnquist's avatar
Hugo Hörnquist committed
36

Hugo Hörnquist's avatar
Hugo Hörnquist committed
37
;; Util
Hugo Hörnquist's avatar
Hugo Hörnquist committed
38

Hugo Hörnquist's avatar
Hugo Hörnquist committed
39 40 41 42 43 44 45 46 47 48 49 50 51
(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)))

Hugo Hörnquist's avatar
Hugo Hörnquist committed
52 53 54 55 56 57 58 59
(define-syntax ->
  (syntax-rules ()
    ((-> obj)
     obj)
    ((-> obj (func args ...) rest ...)
     (-> (func obj args ...) rest ...))
    ((-> obj func rest ...)
     (-> (func obj) rest ...))))
Hugo Hörnquist's avatar
Hugo Hörnquist committed
60 61 62 63 64 65

(define* (bytevector->c-string
          bv #:key (transcoder (make-transcoder "ASCII")))
  (string-trim-right (bytevector->string bv transcoder)
                     #\nul))

Hugo Hörnquist's avatar
Hugo Hörnquist committed
66

Hugo Hörnquist's avatar
Hugo Hörnquist committed
67 68 69 70 71 72 73 74 75

;; Constants

(define MAPPLANES 2)
(define AREATILE 107)



;; Datatypes
76 77 78 79 80 81 82

;; @example
;; struct mapfiletype {
;;     uint16_t RLEWtag;
;;     uint32_t headeroffsets[100];
;; }
;; @end example
83 84 85 86 87 88 89 90 91 92
(define-record-type <maphead>
  (make-maphead rlew headeroffsets)
  maphead?
  (rlew get-rlew)
  (headeroffsets get-offsets))

(set-record-type-printer!
 <maphead>
 (lambda (r p)
   (format p "#<<maphead> RLEW: #x~:@(~x~), offsets: (~{#x~:@(~4,'0x~)~^ ~})>"
93
           (get-rlew r) (get-offsets r))))
Hugo Hörnquist's avatar
Hugo Hörnquist committed
94

95 96 97 98 99 100 101 102
;; @example
;; struct maptype {
;;     uint32_t planestart[3];
;;     uint32_t planelength[3];
;;     uint16_t width, height;
;;     char name[16];
;; }
;; @end example
Hugo Hörnquist's avatar
Hugo Hörnquist committed
103 104 105 106 107 108 109 110 111
(define-record-type <maptype>
  (make-maptype planestart planelength width height name)
  maptype?
  (planestart  get-planestart)
  (planelength get-planelength)
  (width       get-width)
  (height      get-height)
  (name        get-name))

Hugo Hörnquist's avatar
Hugo Hörnquist committed
112 113 114


;; Pure procedures
115 116

;; ID_CA.C, 609
117
;; bytevector, int -> bytevector
Hugo Hörnquist's avatar
Hugo Hörnquist committed
118
(define (carmack-expand source expanded-length)
119 120 121
  (define neartag #xa7)
  (define fartag  #xa8)

122 123 124 125 126 127 128
  (let ((dest (make-bytevector expanded-length)))
    (let loop ((length (floor/ expanded-length 2))
               (iidx 0)
               (oidx 0))
      (unless (zero? length)
        ;; bytevector-{}-ref takes bytes from start, NOT word with
        (let* ((ch (bytevector-u16-ref source iidx (endianness little)))
129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158
               (ch-high (ash ch -8)))

          (if (memv ch-high (list neartag fartag))
              (let ((count (logand ch #xFF)))
                (if (zero? count)
                    (let ((ch (logior ch (bytevector-u8-ref source (+ 2 iidx)))))
                      ;; special case for literal a7 and a8
                      (u16vector-set! dest oidx ch)
                      (loop (1- length) (+ iidx 3) (1+ oidx)))

                    ;; else
                    (let* ((l (if (= ch-high neartag) 1 2))
                           (offset-base (bytevector-uint-ref source (+ 2 iidx)
                                                             (endianness little)
                                                             l))
                           (offset (if (= ch-high neartag)
                                       (- oidx offset-base)
                                       offset-base)))
                      (bytevector-copy! dest (* 2 offset)
                                        dest (* 2 oidx) (* 2 count))
                      (loop (- length count)
                            (+ iidx 2 l)
                            (+ oidx count)))))

              ;; else
              (begin
                (u16vector-set! dest oidx ch)
                (loop (1- length) (+ iidx 2) (1+ oidx)))))))

    ;; return
159 160 161
    dest))


162 163 164 165 166
;; ID_CA.C, 734
;; uint16-list [, uint16] -> uint16-list
(define* (rlew-expand source #:optional (rlew-tag #xABCD))
  "If car = #xABCD, repeat the next next value next number times.
else insert the value as given"
167 168
  (let loop ((rem source))
    (cond [(null? rem) '()]
169
          [(= rlew-tag (car rem))
Hugo Hörnquist's avatar
Hugo Hörnquist committed
170 171 172
           (let ((count (cadr  rem))
                 (value (caddr rem))
                 (rest  (cdddr rem)))
173 174 175 176
             (append! (make-list count value)
                      (loop rest)))]
          [else (cons (car rem)
                      (loop (cdr rem)))])))
177 178


179
;; WL_GAME.C, 663
Hugo Hörnquist's avatar
Hugo Hörnquist committed
180
;; lays out the given 1d list into a 2d, 64x64 grid.
181
(define (tile-list->tilemap tile-list)
Hugo Hörnquist's avatar
Hugo Hörnquist committed
182 183
  (let ((tilemap (make-array 0 64 64)))
    (for-each (lambda (tile coord)
Hugo Hörnquist's avatar
Hugo Hörnquist committed
184 185
                (when (< tile AREATILE)
                  (apply array-set! tilemap tile coord)))
Hugo Hörnquist's avatar
Hugo Hörnquist committed
186 187 188
              tile-list
              (cross-product (iota 64) (iota 64)))
    tilemap))
189 190


Hugo Hörnquist's avatar
Hugo Hörnquist committed
191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209


;; 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
Hugo Hörnquist's avatar
Hugo Hörnquist committed
210 211 212 213 214 215 216 217 218 219 220
            (-> port                    ; planestart
                (get-bytevector-n (* 3 4))
                u32vector->list
                (list-head MAPPLANES))
            (-> port                    ; planelength
                (get-bytevector-n (* 3 2))
                u16vector->list
                (list-head MAPPLANES))
            (-> port (get-bytevector-n  2) (u16vector-ref 0)) ; width
            (-> port (get-bytevector-n  2) (u16vector-ref 0)) ; height
            (-> port (get-bytevector-n 16) bytevector->c-string)  ; name
Hugo Hörnquist's avatar
Hugo Hörnquist committed
221 222 223 224 225 226 227 228
            ))))
   (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
Hugo Hörnquist's avatar
Hugo Hörnquist committed
229 230 231 232 233 234 235
         (let ((len (u16vector-ref (get-bytevector-n port 2) 0)))
           (-> port
               (get-bytevector-n      (- compressed 2))
               (carmack-expand        len)
               (bytevector->uint-list (endianness little) 2)
               cdr                      ; car contains expected size
               rlew-expand)))
Hugo Hörnquist's avatar
Hugo Hörnquist committed
236 237 238
       (get-planestart map-metadata)
       (get-planelength map-metadata)))

239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264



;; binary-port x 2d-array<T> x (T → RGB bytevector) → *unspecified#*
;; writes image to file
(define (array->ppm port array mapper)
  (let ((dim (array-dimensions array)))
    (format port "P6~%~a ~a~%255~%"
            (list-ref dim 1)
            (list-ref dim 0)))
  (array-for-each
   (lambda (el) (put-bytevector port (mapper el)))
   array))

(define (dump-tilemap map-head tilemap)
  (let ((fname (format #f "~a.ppm" (get-name map-head))))
    (call-with-output-file fname
      (lambda (port) (array->ppm port tilemap
                            (lambda (tile) ; WL_GAME.C, 624
                              (cond ((= tile 0) rgb:black)  ; floor
                                    ((<= 90 tile 101) rgb:brown) ; door
                                    ((< tile AREATILE) rgb:blue)  ; wall
                                    (else rgb:red))
                              )))
      #:binary #t)
    (format #t "Wrote map to ~a~%" fname)))
Hugo Hörnquist's avatar
Hugo Hörnquist committed
265 266 267 268 269




(define (main args)
270
  (define og-dir (getcwd))
Hugo Hörnquist's avatar
Hugo Hörnquist committed
271 272
  (chdir "/home/hugo/wolf/full/")

273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289
  (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)))
290 291 292 293 294
      (chdir og-dir)
      (let ((tilemap (-> data car tile-list->tilemap)))
        (display-tilemap tilemap)
        (dump-tilemap maph tilemap)))))