parse-graphics.scm 8.38 KB
Newer Older
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33
;;; Commentary:

;; setup-gr-file
;; ID_CA.C, 859

;; GRHEADERLINKED assumed undefined

;; GFXV_WL6.H is special constant for Wolf3d full version.
;; GFXV_*.H is available for Wold3d shareware, as well as
;; Spear of Destiny

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

(use-modules (system foreign))

(define (bytevector-drop! bv count)
  (pointer->bytevector (bytevector->pointer bv count)
                       (- (bytevector-length bv)
                          count)))

34
;; taken from Common Lisp
35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65
(define-syntax-rule (begin1 first rest ...)
  (let ((return first))
    rest ...
    return))




;; @example
;; struct huffnode {
;;     uint16 bit0, bit1;
;; }
;; @end example
;; 0-#xFF char, > ptr to node

;; ID_CA.C, 387
;; optimize-nodes not applicable,
;; this is a "replacement"
(define (bytevector->huff-tree bv)
  ;; root always here, ID_CA.C, 427
  (let loop ((idx 254))
    ;; Doubling since we are looking at number pairs
    (let ((idx (* idx 2)))
      (let ((left  (u16vector-ref bv idx))
            (right (u16vector-ref bv (1+ idx))))
        (cons
         (if (< left  #x100) left  (loop (- left #x100)))
         (if (< right #x100) right (loop (- right #x100))))))))

;; ID_CA.C, 418
;; bytevector -> bytevector -> huffman-tree
Hugo Hörnquist's avatar
Hugo Hörnquist committed
66
(define (huffman-expand! source dest tree)
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 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112

  ;; Returns the next bit in from the source vector.
  (define next-bit!
    (let ((idx-major 0)                 ; which byte we are on
          (idx-minor 0))                ; which bit in the byte
      (lambda ()
        (when (= 8 idx-minor)
          (set! idx-minor 0)
          (set! idx-major (1+ idx-major)))
        (if (= idx-major (bytevector-length source))
            #f (begin1 (logand 1 (ash (bytevector-u8-ref source idx-major)
                                      (- idx-minor)))
                       (set! idx-minor (1+ idx-minor)))))))

  ;; Sets the next byte in the destination.
  (define set-byte!
    (let ((oidx 0))
      (lambda (b)
        (bytevector-u8-set! dest oidx b)
        (set! oidx (1+ oidx)))))

  ;; 1 => left
  ;; 0 => right
  (let ((subtree tree)
        (bit #f))
    (while (begin (set! bit (next-bit!)) bit)
      (let ((node ((if (= 1 bit) car cdr) subtree)))
        (if (pair? node)
            ;; continue down
            (set! subtree node)
            (begin                      ; restart from top
              (set-byte! node)
              (set! subtree tree)))))))





;; 255 huffnodes, total size 1024 bytes
;; ID_CA.C, 888
(define (read-huff-file file)
  (bytevector->huff-tree
   (call-with-input-file file
     get-bytevector-all #:binary #t)))


113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128
(define (huff-tree->graphviz huff-tree port)
  (format port "digraph {~%")
  (let loop ((tree huff-tree)
             (path ""))
    (let ((name (gensym)))
      (if (pair? tree)
          (let ((child-0 (loop (car tree) (string-append path "0")))
                (child-1 (loop (cdr tree) (string-append path "1"))))
            (format port "\"~a\" [label=\"\", color=gray];~%" name)
            (format port "\"~a\" -> \"~a\" [label=~a0];~%" name child-0 path)
            (format port "\"~a\" -> \"~a\" [color=red, label=~a1];~%" name child-1 path)
            )
          (format port "\"~a\" [label=~a];" name tree))
      name))
  (format port "}~%"))

129 130 131 132 133 134 135

;; #ifdef THREE_BYTE_GR_STARTS
(define FILEPOSSIZE 3)

;; verkar även finnas speciella för Spear of Destiny

(define NUMCHUNKS 149)                  ; GFXV_WL6.H, 183
136 137 138 139 140 141 142 143 144 145 146 147 148
(define NUMFONT 2)                      ; 184
(define NUMFONTM 0)                     ; 185
(define NUMPICS 132)                    ; GFXV_WL6.H, 186
(define NUMPICM 0)
(define NUMSPRITES 0)
(define NUMTILE8 72)
(define NUMTILE8M 0)
(define NUMTILE16 0)
(define NUMTILE16M 0)
(define NUMTILE32 0)
(define NUMTILE32M 0)
(define NUMEXTERNS 13)

149 150
(define STRUCTPIC 0)                    ; GFXV_WL6.H, 199
(define STARTTILE8 135)                 ; GFXV_WL6.H, 206
151 152 153 154 155
(define STARTTILE8M 136)                ; GFXV_WL6.H, 207
(define STARTTILE16 136)                ; GFXV_WL6.H, 208
(define STARTTILE16M 136)               ; GFXV_WL6.H, 209
(define STARTTILE32 136)                ; GFXV_WL6.H, 210
(define STARTTILE32M 136)               ; GFXV_WL6.H, 211
156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193
(define STARTEXTERNS 136)               ; GFXV_WL6.H, 212




;; ID_CA.C, 132
(define (3-byte-word-ref bv idx)
  "(gr-file-pos gr-starts)"
  (let ((mask #x00FFFFFF))
   (cond [(logand mask
                  (bytevector-u32-ref
                   bv (* 3 idx)
                   (endianness little)))
          (lambda (v) (not (= v mask))) => identity]
         [else -1])))


;; ID_CA.C, 195
;; set-up-gr-handle removed
(define (chunk-start table idx)
  (3-byte-word-ref table idx))

(define (chunk-length table idx)
  (- (chunk-start table (1+ idx))
     (chunk-start table idx)))

#;
(define (set-up-gr-handle gr-starts)
  (define start      (3-byte-word-ref gr-starts STRUCTPIC))
  (define next-start (3-byte-word-ref gr-starts (1+ STRUCTPIC)))
  (let ((chunk-explicit-len (-> port (get-bytevector-n 4) (s32-vector-ref 0)))
        (chunk-comp-len (- next-start start 4)))

    ;; (values chunk-explicit-len chunk-comp-len)
    ))



194 195 196 197 198 199 200 201 202 203 204 205
;; ID_CA.C, 1261
(define (get-gr-chunk-expanded-size idx source)
  (define BLOCK 64)
  (define MASKBLOCK 128)

  (if (<= STARTTILE8 idx (1- STARTEXTERNS))
      (cond [(< idx STARTTILE8M)  (* BLOCK NUMTILE8)]
            [(< idx STARTTILE16)  (* MASKBLOCK NUMTILE8)]
            [(< idx STARTTILE16M) (* BLOCK 4)]
            [(< idx STARTTILE32)  (* MASKBLOCK 4)]
            [[< idx STARTTILE32M] (* BLOCK 16)]
            [else (* MASKBLOCK 16)])
206 207 208 209
      (begin1
       (bytevector-u32-ref source 0 (endianness little))
       (bytevector-drop! source 4))))

210
#;
211 212 213
(define (expand-gr-chunk chunk source)
  (let ((expanded-size (get-gr-chunk-expanded-size chunk source)))
    (let ((dest (make-bytevector expanded-size)))
Hugo Hörnquist's avatar
Hugo Hörnquist committed
214
      (huffman-expand! source dest huff-tree)
215 216
      dest)))

217
;; int, bytevector ->
218
;; ID_CA.C, 1318
219
;; TODO rework this into being sensible, it's mostly a loading routine
220
;; since caching is done in a completely different way
221 222
;; port, 24bit-int-table, huff-tree, int -> 
(define (load-gr-chunk port chunk-table huff-tree idx)                       ; (cache-gr-chunk idx)
223

224
  (define compressed-size (chunk-length chunk-table idx))
225
  ;; TODO skip sparse tiles, ID_CA.C, 1341
226 227 228
  (define start (chunk-start chunk-table idx))

  (seek port start SEEK_SET)
229

230 231 232
  (let* ((source (get-bytevector-n port compressed-size))
         (expanded-size (get-gr-chunk-expanded-size idx source))
         (dest (make-bytevector expanded-size)))
Hugo Hörnquist's avatar
Hugo Hörnquist committed
233
    (huffman-expand! source dest huff-tree)
234
    dest))
235 236 237 238 239 240 241 242



;;; main

(chdir "/home/hugo/wolf/full/")

;; read and build the huffman tree
243
;; ID_CA.C, 887
244 245 246 247 248 249 250 251
(define huff-tree (read-huff-file "VGADICT.WL6"))


;; uint24 list
;; offsets into ega-graph for where images are?
;; gr-starts

;; read the table off offsets into the data
252
;; in VGAGRAPH.
253 254 255
;; TODO why not gr-starts?
;; ID_CA.C, 893
(define gr-starts
256 257 258 259 260 261 262 263
  (call-with-input-file "VGAHEAD.WL6"
    get-bytevector-all #:binary #t))

;; Size depends on version of game?
;; should in this case be
(* FILEPOSSIZE (1+ NUMCHUNKS))
;; => 450

264 265 266 267 268 269
(define gr-file-pos
 (map (lambda (i)
        (chunk-start gr-starts i))
      (iota (- (/ (bytevector-length gr-starts) 3)
               2))))

270
;; open the actual graphics file
271
;; ID_CA.C, 915
272
(define gr-handle (open-input-file "VGAGRAPH.WL6" #:binary #t))
273

Hugo Hörnquist's avatar
Hugo Hörnquist committed
274 275 276 277 278 279 280 281 282 283 284 285 286 287


(define pictable (make-bytevector (* NUMPICS (sizeof int16) 2)))

(define (read-s32 port)
  (s32vector-ref (get-bytevector-n port 4) 0))

(define (read-entry port chunk-idx)
  (define start (list-ref gr-file-pos chunk-idx))
  (define end (list-ref gr-file-pos (1+ chunk-idx)))
  (define comp-length (- end start 4))
  (seek port start SEEK_SET)
  (let ((exp-length (read-s32 port)))
    (values exp-length (get-bytevector-n port comp-length))))
288

Hugo Hörnquist's avatar
Hugo Hörnquist committed
289 290 291 292 293

;; ID_CA.C, 923
(define-values (exp-size bv) (read-entry gr-handle STRUCTPIC))

(huffman-expand! bv pictable huff-tree)
294 295


296 297 298 299 300 301 302

;; @example
;; struct pictabletype {
;;     sint16 width, height;
;; }
;; @end example

303 304 305
;;; WL_GAME.C, 877
(define MACHINEGUNPIC 94)                ; GFXV_WL6.H, 103

Hugo Hörnquist's avatar
Hugo Hörnquist committed
306 307
;; (define (print-list-list list-list)
;;   (format #t "~{|~{~2,x ~}|~%~}~%" list-list))