parse-map.scm 10.3 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))

66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92
(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)))

Hugo Hörnquist's avatar
Hugo Hörnquist committed
93

Hugo Hörnquist's avatar
Hugo Hörnquist committed
94 95 96 97 98 99 100 101 102

;; Constants

(define MAPPLANES 2)
(define AREATILE 107)



;; Datatypes
103 104 105 106 107 108 109

;; @example
;; struct mapfiletype {
;;     uint16_t RLEWtag;
;;     uint32_t headeroffsets[100];
;; }
;; @end example
110 111 112 113 114 115 116 117 118 119
(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~)~^ ~})>"
120
           (get-rlew r) (get-offsets r))))
Hugo Hörnquist's avatar
Hugo Hörnquist committed
121

122 123 124 125 126 127 128 129
;; @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
130 131 132 133 134 135 136 137 138
(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))

139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154
;; 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)))))

Hugo Hörnquist's avatar
Hugo Hörnquist committed
155 156 157


;; Pure procedures
Hugo Hörnquist's avatar
Hugo Hörnquist committed
158 159

;; ID_CA.C, 609
160
;; bytevector, int -> bytevector
Hugo Hörnquist's avatar
Hugo Hörnquist committed
161
(define (carmack-expand source expanded-length)
162 163 164
  (define neartag #xa7)
  (define fartag  #xa8)

Hugo Hörnquist's avatar
Hugo Hörnquist committed
165 166 167 168 169 170 171
  (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)))
172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201
               (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
Hugo Hörnquist's avatar
Hugo Hörnquist committed
202 203 204
    dest))


205 206 207 208 209
;; 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"
210 211
  (let loop ((rem source))
    (cond [(null? rem) '()]
212
          [(= rlew-tag (car rem))
Hugo Hörnquist's avatar
Hugo Hörnquist committed
213 214 215
           (let ((count (cadr  rem))
                 (value (caddr rem))
                 (rest  (cdddr rem)))
216 217 218 219
             (append! (make-list count value)
                      (loop rest)))]
          [else (cons (car rem)
                      (loop (cdr rem)))])))
Hugo Hörnquist's avatar
Hugo Hörnquist committed
220 221


222
;; WL_GAME.C, 663
Hugo Hörnquist's avatar
Hugo Hörnquist committed
223
;; lays out the given 1d list into a 2d, 64x64 grid.
224
(define (tile-list->tilemap tile-list)
Hugo Hörnquist's avatar
Hugo Hörnquist committed
225 226
  (let ((tilemap (make-array 0 64 64)))
    (for-each (lambda (tile coord)
Hugo Hörnquist's avatar
Hugo Hörnquist committed
227 228
                (when (< tile AREATILE)
                  (apply array-set! tilemap tile coord)))
Hugo Hörnquist's avatar
Hugo Hörnquist committed
229 230 231
              tile-list
              (cross-product (iota 64) (iota 64)))
    tilemap))
Hugo Hörnquist's avatar
Hugo Hörnquist committed
232 233


Hugo Hörnquist's avatar
Hugo Hörnquist committed
234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252


;; 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
253 254 255 256 257 258 259 260 261 262 263
            (-> 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
264 265 266 267 268 269 270 271
            ))))
   (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
272 273 274 275 276 277 278
         (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
279 280 281
       (get-planestart map-metadata)
       (get-planelength map-metadata)))

282 283 284 285 286 287 288 289 290 291 292 293 294 295



;; 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))

296 297 298 299 300

(define (dump-tilemap! wolf-map)
  (let ((fname (format #f "~a/~a.ppm"
                       (getcwd)
                       (string->filename (get-name (get-metadata wolf-map))))))
301
    (call-with-output-file fname
302
      (lambda (port) (array->ppm port (get-data wolf-map)
303 304 305 306 307 308 309
                            (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)
310
    (set-file! wolf-map fname)))
Hugo Hörnquist's avatar
Hugo Hörnquist committed
311 312 313 314




315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333
(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))))))))
334

335 336 337 338 339 340 341 342 343 344 345 346 347 348

(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)))))