#!/usr/bin/guile \
-e main -s
!#

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

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



;; Util

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

(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

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

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

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

          (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
    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 ((rem source))
    (cond [(null? rem) '()]
          [(= rlew-tag (car rem))
           (let ((count (cadr  rem))
                 (value (caddr rem))
                 (rest  (cdddr rem)))
             (append! (make-list count value)
                      (loop rest)))]
          [else (cons (car rem)
                      (loop (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
            ))))
   (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)))




;; 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! 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 (get-data wolf-map)
                            (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)
    (set-file! wolf-map fname)))




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