parse-map.scm

;;; 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)              ; u16vector-ref
             ((srfi srfi-9) #:select (define-record-type))
             ((srfi srfi-9 gnu) #:select (set-record-type-printer!))
             )



;; 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-syntax ->
  (syntax-rules ()
    ((-> obj)
     obj)
    ((-> obj (func args ...) rest ...)
     (-> (func obj args ...) rest ...))
    ((-> obj func rest ...)
     (-> (func obj) rest ...))))

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



;; Constants

(define MAPPLANES 2)
(define AREATILE 107)



;; Datatypes

;; @example
;; struct mapfiletype {
;;     uint16_t RLEWtag;
;;     uint32_t headeroffsets[100];
;; }
;; @end example
(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~)~^ ~})>"
           (get-rlew r)
           (take-while (negate zero?) (get-offsets r)))))

;; @example
;; struct maptype {
;;     uint32_t planestart[3];
;;     uint32_t planelength[3];
;;     uint16_t width, height;
;;     char name[16];
;; }
;; @end example
(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))



;; Pure procedures

;; ID_CA.C, 609
;; bytevector, int -> bytevector
(define (carmack-expand source expanded-length)
  (define neartag #xa7)
  (define fartag  #xa8)

  (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)))
               (ch-high (ash ch -8))
               (count   (logand ch #xFF)))
          (cond [(memv ch-high (list neartag fartag))
                 (cond [(zero? count)
                        ;; special case for literal a7 and a8
                        (u16vector-set! dest oidx
                                        (logior ch (bytevector-u8-ref source (+ 2 iidx))))
                        (loop (1- length)
                              (+ iidx 3)
                              (1+ oidx))]
                       [(= ch-high neartag)
                        (bytevector-copy! dest (* 2 (- oidx (bytevector-u8-ref source (+ 2 iidx))))
                                          dest (* 2 oidx)
                                          (* 2 count))
                        (loop (- length count)
                              (+ iidx 3)
                              (+ oidx count))]
                       [(= ch-high fartag)
                        ;; bytevector-copy! :: source source-start target target-start len
                        (let ((offset (bytevector-u16-ref source (+ 2 iidx) (endianness little))))
                          (bytevector-copy! dest (* 2 offset) dest (* 2 oidx) (* 2 count))
                          (loop (- length count)
                                (+ iidx 4)
                                (+ oidx count)))])]
                [else
                 (u16vector-set! dest oidx ch)
                 (loop (1- length)
                       (+ iidx 2)
                       (1+ oidx))]))))
    dest))


;; 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"
  (let loop ((done '())
             (rem source))
    (cond [(null? rem)
           (concatenate (reverse done))]

          [(= rlew-tag (car rem))
           (let ((count (cadr  rem))
                 (value (caddr rem))
                 (rest  (cdddr rem)))
             (loop (cons (make-list count value) done)
                   rest))]

          [else (loop (cons (list (car rem)) done)
                      (cdr rem))])))


;; 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)
                (when (< tile AREATILE)
                  (apply array-set! tilemap tile coord)))
              tile-list
              (cross-product (iota 64) (iota 64)))
    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
            (-> 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
            ;; (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)))
           (-> port
               (get-bytevector-n      (- compressed 2))
               (carmack-expand        len)
               (bytevector->uint-list (endianness little) 2)
               cdr                      ; car contains expected size
               rlew-expand)))
       (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))))))