Commit a1e5f5c4 authored by Hugo Hörnquist's avatar Hugo Hörnquist

Cleanup in parse-map.

parent 9f4135a8
(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,63 +150,106 @@
"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)
(loop (cons (make-list count value) done)
rest
(+ len count)))
(cdr 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)
(+ len 1))])))
(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)))
(cdr rem))])))
(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)
(let ((tile (logand tile #xFF)))
(when (< tile AREATILE)
(apply array-set! tilemap tile coord))))
tile-list
(cross-product (iota 64) (iota 64)))
tilemap))
(let ((tilemap (make-array 0 64 64)))
(for-each (lambda (tile coord)
(let ((tile (logand tile #xFF)))
(when (< tile AREATILE)
(apply array-set! tilemap tile coord))))
tile-list
(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))))))
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment