FOX5 decoder, first sketch

fox5.lisp

;;;; CL-FOX5 2017 © Michał "phoe" Herda
;;;; MIT license

;; (ql:quickload :fast-io)
;; (ql:quickload :cl-lzma)
;; (ql:quickload :alexandria)

;;; UTILS

(defun make-byte-array (n &rest options)
  (apply #'make-array n :element-type '(unsigned-byte 8) options))

(defun read-uint-le (stream nbytes)
  (loop for i from 0 below nbytes
        for byte = (read-byte stream)
        sum (* byte (ash 1 (* 8 i)))))

(defun read-uint-be (stream nbytes)
  (loop for i from (1- nbytes) downto 0
        for byte = (read-byte stream)
        sum (* byte (ash 1 (* 8 i)))))

(defun read-string (stream &optional (external-format :utf-8))
  (let* ((n (read-uint-be stream 2))
         (vector (make-byte-array n)))
    (read-sequence vector stream)
    (octets-to-string vector :external-format external-format)))

;;; HEADER

(defvar *magic-string*
  #.(make-byte-array 8 :initial-contents '(70 79 88 53 46 49 46 49)))

(defvar *magic-string-mismatch*
  #.(format nil "FOX5 magic string mismatch.~%Expected: ~~S~%Got:      ~~S"))

(defun load-fox5-header (pathname)
  (with-open-file (stream pathname :direction :input
                                   :element-type '(unsigned-byte 8)
                                   :if-does-not-exist :error)
    (file-position stream (- (file-length stream) 20))
    (let ((vector (make-byte-array 20)))
      (read-sequence vector stream)
      vector)))

(defun analyze-fox5-header (header)
  (let ((buffer (make-input-buffer :vector header))
        (data '()))
    (flet ((add (key value)
             (setf data (append (list (cons key value)) data))))
      ;; U8  Compression Type
      (add :compression-type (case (read8-be buffer) (1 :zlib) (2 :lzma)))
      ;; U8  Encryption Type
      (add :encryption (case (read8-be buffer) (0 :no) (t :yes)))
      ;; U16 Reserved
      (read16-be buffer)
      ;; U32 Compressed Size
      (add :compressed-size (read32-be buffer))
      ;; U32 Decompressed Size
      (add :decompressed-size (read32-be buffer))
      ;; U64 Magic String
      (validate-magic-string buffer)
      ;; analysis done - return the values
      (nreverse data))))

(defun validate-magic-string (buffer)
  (let* ((magic-string (make-byte-array 8))
         (magic-buffer (make-output-buffer :vector magic-string)))
    (dotimes (i 8)
      (fast-write-byte (fast-read-byte buffer) magic-buffer))
    (finish-output-buffer magic-buffer)
    (when (not (equal (coerce magic-string 'list)
                      (coerce *magic-string* 'list)))
      (error *magic-string-mismatch* *magic-string* magic-string))))

;;;; COMMAND BLOCK

(defun load-command-block (pathname compressed-length)
  (with-open-file (stream pathname :direction :input
                                   :element-type '(unsigned-byte 8)
                                   :if-does-not-exist :error)
    (let* ((props (make-byte-array 5))
           (data (make-byte-array compressed-length))
           length)
      (read-sequence props stream)
      (setf length (read-uint-le stream 8))
      (read-sequence data stream)
      (values data props length))))

(defun decompress-command-block (pathname compressed-length)
  (multiple-value-bind (data props length)
      (load-command-block pathname compressed-length)
    (cl-lzma:lzma-decompress data props length)))

(defgeneric parse-command (command stream))

(defmethod parse-command ((command (eql #x00)) stream)
  "Any > NOP.")

(defmethod parse-command ((command (eql #x4C)) stream)
  "Any > Start List.
U8  List level. 0=File; 1=Object; 2=Shape; 3=Frame; 4=Channel;
                (reserved, unused now: 5=KS-line; 6=Sprite; 7=Overlay)
U32 Number of items in list"
  (let* ((level (read-uint-be stream 1))
         (n (read-uint-be stream 4)))
    (declare (ignore level))
    (loop repeat n
          collect (parse-command (read-uint-be stream 1) stream)
          do (assert (= (read-uint-be stream 1) #x3C)))))

(defmethod parse-command ((command (eql #x67)) stream)
  "File > Generator.
U8  Generator ID. 0-127 Furcadia reserved, 128-255 third-party reserved."
  (list :generator (read-uint-be stream 1)))

(defmethod parse-command ((command (eql #x53)) stream)
  "File > ImageList.
U32 Number of images (N), then N structs:
  U32 Compressed size
  U16 Width, max 2048
  U16 Height, max 2048
  U8  Format (0=8bit, 1=32bit ARGB)"
  (flet ((parse-image (stream)
           `(:compressed-size ,(read-uint-be stream 4)
             :width ,(read-uint-be stream 2)
             :height ,(read-uint-be stream 2)
             :format ,(case (read-uint-le stream 1)
                        (0 :8-bit) (1 :32-bit)))))
    (let* ((n (read-uint-be stream 4))
           (images (loop repeat n
                         collect (parse-image stream))))
      `(:image-list ,@images))))

(defmethod parse-command ((command (eql #x72)) stream)
  "Object > Revision count.
U16 Revision ID"
  (list :revision-count (read-uint-be stream 1)))

(defmethod parse-command ((command (eql #x61)) stream)
  "Object > Author history.
U16 Number of strings (N), then N structs:
  U16 String length (M), then UTF-8 string of M bytes"
  (let* ((n (read-uint-be stream 2))
         (strings (loop repeat n collect (read-string stream))))
    (list :author-history strings)))

(defmethod parse-command ((command (eql #x6C)) stream)
  "Object > License.
0=FC-BY-SA, 1=FC0, 2=FC-BY-NC-SA,
3=FC-ND-NC-SA, 4=FC-Private-SA, 5=FC-BY-X-SA"
  (list :license (case (read-uint-be stream 1)
                   (0 :fc-by-sa) (1 :fc0)
                   (2 :fc-by-nc-sa) (3 :fc-nd-nc-sa)
                   (4 :fc-private-sa) (5 :fc-by-x-sa))))

(defmethod parse-command ((command (eql #x6B)) stream)
  "Object > Keywords.
U16 Number of strings (N), then N structs:
  U16 String length (M), then UTF-8 string of M bytes"
  (let* ((n (read-uint-be stream 2))
         (strings (loop repeat n collect (read-string stream))))
    (list :keywords strings)))

(defmethod parse-command ((command (eql #x6E)) stream)
  "Object > Name.
U16 String length (M), then UTF-8 string of M bytes"
  (list :name (read-string stream)))

(defmethod parse-command ((command (eql #x64)) stream)
  "Object > Description.
U16 String length (M), then UTF-8 string of M bytes"
  (list :description (read-string stream)))

(defvar *command-flags*
  '(:walkable :gettable :sittable :flyable
    :swimmable :clickable :highlightable :kickable))

(defmethod parse-command ((command (eql #x21)) stream)
  "Object > Flags.
U8  Bitfield:
0x01 = Walkable (Walls, Floors, Items only)
0x02 = Gettable (Items only)
0x04 = Sittable (Items only)
0x08 = Flyable (Floors only)
0x10 = Swimmable (Floors only)
0x20 = Clickable, blocks clickthru (Buttons, avatars)
0x40 = MouseOver hilite, blocks clickthru (Avatars)
0x80 = Kickable (evades player, eg Red ball item)"
  (let ((bitfield (read-uint-be stream 1)))
    (list :flags (loop for i from 0
                       for keyword in *command-flags*
                       if (logbitp i bitfield)
                         collect keyword))))

(defmethod parse-command ((command (eql #x50)) stream)
  "Object > Teleport URL.
U16 String length (M), then UTF-8 string of M bytes"
  (list :teleport (read-string stream :iso-8859-1)))

;; TODO add a step for parsing this together with shape purpose
(defmethod parse-command ((command (eql #x3F)) stream)
  "Object > Extended Flags.
U16 Bitfield:
[Dream Pad types]
0x0000 0000 - Everyone can upload to this pad, as restricted by
              DS or share commands. (default value)
0x0000 0001 - SS
0x0000 0002 - GS
0x0000 0080 - Lower Group Packages
0x0000 0100 - High Group Packages
0x0000 8000 - Dep Staff/Associates
[Avatar types]
0x0000 0001 - Hopping
0x0000 0002 - Flying
0x0000 0004 - Swimming
0x0000 0008 - Child"
  (list :extended-flags (read-uint-be stream 1)))

(defmethod parse-command ((command (eql #x69)) stream)
  "Object identifier.
S32 Object number. -1=number from position in file, 0+=this number"
  (let ((number (read-uint-be stream 4)))
    (list :object-id (if (= number #xFFFFFFFF) :default number))))