Jump to content
Search In
  • More options...
Find results that contain...
Find results in...

YukiRaven

Members
  • Content count

    4186
  • Joined

  • Last visited

About YukiRaven

  • Rank
    Will DDR for food

Recent Profile Visitors

The recent visitors block is disabled and is not being shown to other users.

Single Status Update

See all updates by YukiRaven

  1. Had a sudden urge to hack today, so I very quickly hacked together a parser for UDMF in Common Lisp just for the hell of it.  Not the cleanest code, but it works well enough.  I still hope to eventually release this whole Waddle library of mine someday...

     

    My testing so far, using my current map which has about 5.5mb of UDMF data, shows that it parses the raw text into a preliminary raw form in about 0.3-0.4 seconds on a Core2Quad @2.4GHz.  A full parse from raw text to final form takes 0.7-0.8 seconds.  Still needs some optimization in some places, I think, especially in the second pass.

     

    Here's the bit of code I was using to check that it worked and get a very basic idea of performance:

    (asdf:load-system :waddle)
    (in-package :waddle)
    
    (let* ((wad (load-wad-file #P"/mnt/storage/alexa-extended/bin/games/doom/Mine/raven/raven01.wad"))
           (level (get-lump wad "TEXTMAP" :as-text t :return-data t)))
      (time (elt (parse-udmf (parse-udmf->ast level)) 42)))

     

    Here's the actual code, minus all the DEFSTRUCT calls to create the structs that hold stuff.

    ;;;; Waddle
    ;;;; Copyright (C) 2017 Alexa Jones-Gonzales  <alexa@partition36.com>
    ;;;;
    ;;;; This program is free software: you can redistribute it and/or modify
    ;;;; it under the terms of the GNU General Public License as published by
    ;;;; the Free Software Foundation, either version 3 of the License, or
    ;;;; (at your option) any later version.
    ;;;;
    ;;;; This program is distributed in the hope that it will be useful,
    ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
    ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    ;;;; GNU General Public License for more details.
    ;;;;
    ;;;; You should have received a copy of the GNU General Public License
    ;;;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
    
    ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    ;;;;
    ;;;; Parser for UDMF data
    ;;;;
    ;;;; I've optimized this code as well as I can, but a few things are
    ;;;; lacking. Most glaring is that errors do not report the line or
    ;;;; column number during parsing.
    ;;;;
    ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    
    (in-package :p36.waddle)
    
    (eval-when (:compile-toplevel)
      (declaim (optimize (debug 0) (safety 1) (compilation-speed 0))))
    
    (defparameter *udmf-line-regex*
      (let ((cl-ppcre:*regex-char-code-limit* 256)
            (cl-ppcre:*use-bmh-matchers* t))
        (cl-ppcre:create-scanner "[;{}]" :single-line-mode t)))
    
    (defmacro get-valid-int (the-str)
      "Parses THE-STR for a valid integer and returns that integer, or nil
    if it could not be parsed."
      (let ((the-num (gensym))
            (parsed-len (gensym)))
        `(when (not (find #\. ,the-str :test #'eql))
           (multiple-value-bind
                 (,the-num ,parsed-len)
               (parse-integer ,the-str :junk-allowed t)
             (when (= ,parsed-len (length ,the-str))
               ,the-num)))))
    
    ;;
    ;; These constants make identifier parsing a bit faster
    ;;
    (alexandria:define-constant +ascii-num-min+   48)
    (alexandria:define-constant +ascii-num-max+   57)
    
    (alexandria:define-constant +ascii-upper-min+ 65)
    (alexandria:define-constant +ascii-upper-max+ 90)
    
    (alexandria:define-constant +ascii-lower-min+ 97)
    (alexandria:define-constant +ascii-lower-max+ 122)
    
    (alexandria:define-constant +ascii-_-code+    95)
    
    ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    ;;;
    ;;; UDMF Parser Class
    ;;;
    ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    
    (defstruct udmf-parser
      (source "" :type simple-string)
      (line   0  :type fixnum)
      (column 0  :type fixnum))
    
    ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    ;;;
    ;;; AST Classes
    ;;;
    ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    
    (defstruct udmf-raw-block
      (name "" :type simple-string)
      (expressions (make-array 32 :element-type 'cons :adjustable t :fill-pointer 0 :initial-element '(nil))
                   :type (vector cons)
                   :read-only t))
    
    (defstruct udmf-variable
      (name "" :type simple-string)
      (value 0 :type (or simple-string fixnum float boolean)))
    
    ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    ;;;
    ;;; UDMF Parsing Condition Stuff
    ;;;
    ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    
    (define-condition udmf-parse-error (error)
      ((text
        :initarg :text
        :type string
        :reader text
        :initform "Could not parse UDMF data")
    
       (parser
        :initarg :parser
        :type (or udmf-parser null)
        :reader parser
        :initform nil)
    
       (data
        :initarg :data
        :type string
        :initform "(no data given)"
        :reader data)))
    
    (define-condition udmf-parse-error/invalid-identifier (udmf-parse-error)
      ())
    
    (define-condition udmf-parse-error/invalid-string (udmf-parse-error)
      ())
    
    (define-condition udmf-parse-error/invalid-assignment (udmf-parse-error)
      ())
    
    (define-condition udmf-parse-error/invalid-block (udmf-parse-error)
      ())
    
    (defmethod print-object ((obj udmf-parse-error) out)
      (let ((line "(unknown)")
            (line-num "?"))
    
        (when (parser obj)
          (setf line (udmf-parser-line (parser obj)))
          (setf line-num (udmf-parser-line (parser obj))))
    
        (format out "Error: ~a~%Data: ~s~%Line #~a: ~s"
                (text obj) (data obj)
                (if (numberp line-num)
                    (1+ line-num)
                    line-num)
                line)))
    
    ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    ;;;
    ;;; UDMF Parsing
    ;;;
    ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    
    ;;
    ;; We define our own floating point parser since we don't need a lot
    ;; of fancy features.  Just plain decimal notation.
    ;;
    ;; NOTE: Actually, UDMF allows for a bit more notation, such as
    ;; 12.4e20.  But as the maps I've tested this on don't have that
    ;; notation, I haven't implemented it yet.  When I find one, or
    ;; someone needs it, I will.
    ;;
    (defun parse-udmf-float (str &optional (error-on-int t) nil-on-error)
      "Parses a string into a floating point number, as defined by UDMF.
    Strings that have valid integers are converted into floating point
    numbers only if ERROR-ON-INT is non-NIL.  If NIL-ON-ERROR is non-NIL,
    then a value of NIL is returned rather than raising an ERROR."
      (declare (type simple-string str)
               (optimize (speed 3) (safety 0) (debug 0)))
    
      (macrolet
          ((error-or-return (&optional (msg "Could not parse UDMF float"))
             `(if nil-on-error
                  (return-from parse-udmf-float nil)
                  (error ,msg))))
    
        (let ((decimal-pos 0)
              (int-str "")
              (dec-str "")
              (int-part 0)
              (dec-part 0)
              (sign 1))
          (declare (type fixnum decimal-pos sign)
                   (type (or fixnum null) int-part dec-part)
                   (type simple-string int-str dec-str))
    
          ;; Check for integers
          (when (and (get-valid-int str) error-on-int)
            (error-or-return "Could not parse UDMF float: string represents a valid integer"))
    
          ;; Check for negative sign and adjust the number accordingly
          (when (find (elt str 0) #(#\+ #\-) :test #'eql)
            (cond
              ((eql (elt str 0) #\-)
               (setf sign -1)
               (setf str (subseq str 1)))
    
              ((eql (elt str 0) #\+)
               (setf str (subseq str 1)))))
    
          ;; Search for a decimal point
          (when (not (setf decimal-pos (position #\. str :test #'eql)))
            (error-or-return))
    
          ;; Split at the decimal point
          (setf int-str (subseq str 0 decimal-pos))
          (setf dec-str (subseq str (1+ decimal-pos)))
    
          ;; Check to make sure each part has a valid integer
          (setf int-part (get-valid-int int-str))
          (setf dec-part (get-valid-int dec-str))
          (when (or (not int-part) (not dec-part))
            (error-or-return "Could not parse UDMF float, junk found in value"))
    
          ;; Return a floating point made from the parts
          (* sign (coerce (+ (coerce int-part 'float)
                             (* (coerce dec-part 'float)
                                (coerce (expt 10 (coerce (- (length dec-str)) 'float)) 'float)))
                          'float)))))
    
    (defun parse-udmf-identifier (token)
      (declare (type simple-string token)
               (optimize (speed 3) (safety 0) (debug 0)))
    
      (let ((char1 (char-code (elt token 0))))
        (declare (type (unsigned-byte 8) char1))
    
        (when (and (or (< char1 +ascii-upper-min+)
                       (> char1 +ascii-upper-max+))
                   (or (< char1 +ascii-lower-min+)
                       (> char1 +ascii-lower-max+))
                   (not (= char1 +ascii-_-code+)))
          (error 'udmf-parse-error/invalid-identifier
                 :text "Invalid UDMF identifier" :data token))
    
        ;; Check the rest of the characters
        (dotimes (i (1- (length token)))
          (setf char1 (char-code (elt token i)))
          (when (and (or (< char1 +ascii-num-min+)
                         (> char1 +ascii-num-max+))
                     (or (< char1 +ascii-upper-min+)
                         (> char1 +ascii-upper-max+))
                     (or (< char1 +ascii-lower-min+)
                         (> char1 +ascii-lower-max+))
                     (not (= char1 +ascii-_-code+)))
            (error 'udmf-parse-error/invalid-identifier
                   :text "Invalid UDMF identifier" :data token)))
    
        token))
    
    (defun parse-udmf-value (token)
      (declare (type simple-string token)
               (optimize (speed 3) (safety 0) (debug 0)))
    
      (cond
        ((and (eql (elt token 0) #\")
              (eql (elt token (1- (length token))) #\"))
         (return-from parse-udmf-value (subseq token 1 (1- (length token)))))
    
        ((or (and (eql (elt token 0) #\")
                  (not (eql (elt token (1- (length token))) #\")))
             (and (not (eql (elt token 0) #\"))
                  (eql (elt token (1- (length token))) #\")))
         (error 'udmf-parse-error/invalid-string
                :text "Malformed string value" :data token)))
    
      (when (string= token "true")
        (return-from parse-udmf-value t))
    
      (when (string= token "false")
        (return-from parse-udmf-value nil))
    
      (or (get-valid-int token)
          (parse-udmf-float token)))
    
    (defun parse-udmf-assignment-expr (line)
      (declare (type simple-string line)
               (optimize (speed 3) (safety 0) (debug 0)))
    
      (when (not (eql (elt line (1- (length line))) #\;))
        (error 'udmf-parse-error/invalid-assignment
               :text "Unexpected end of assignment" :data line))
    
      (let ((pos-of-= (or (position #\= line :test #'eql)
                          (error 'udmf-parse-error/invalid-assignment
                                 :text "No equal sign found in assignment" :data line)))
            (ident "")
            (value ""))
        (declare (type (or fixnum null) pos-of-=)
                 (type simple-string ident value))
    
        (setf ident (parse-udmf-identifier (string-trim '(#\Space)     (subseq line 0 pos-of-=))))
        (setf value (parse-udmf-value      (string-trim '(#\Space #\;) (subseq line (1+ pos-of-=)))))
        (cons ident value)))
    
    (defun parse-udmf-block (line stream)
      (declare (type string-stream stream)
               (type simple-string line)
               (optimize (speed 3) (safety 0) (debug 0)))
    
      (let* ((ret (make-udmf-raw-block :name (parse-udmf-identifier (string-trim '(#\Space #\{) line)))))
        (declare (type simple-string line)
                 (type udmf-raw-block ret))
    
        ;; We now start parsing assignment expressions until we hit a }
        (loop
           do (progn
                (handler-case
                    (setf line (read-line stream))
                  (end-of-file ()
                    (error 'udmf-parse-error/invalid-block
                           :text "Unclosed block encountered" :data line)))
    
                (when (string= line "}")
                  (return))
    
                (unless (string= line "{")
                  (vector-push-extend (parse-udmf-assignment-expr line)
                                      (udmf-raw-block-expressions ret)))))
    
        ret))
    
    (defmacro parse-udmf-line-into-array (line arr stream)
      (declare (type simple-string line)
               (type string-stream stream)
               (type vector arr)
               (optimize (speed 3) (safety 0) (debug 0)))
    
      `(if (and (eql (elt ,line (1- (length ,line))) #\;)
                (position #\= ,line :test #'eql))
           (vector-push-extend (parse-udmf-assignment-expr ,line) ,arr)
           (vector-push-extend (parse-udmf-block line ,stream) ,arr)))
    
    (defun parse-udmf->ast (udmf)
      (declare (type string udmf)
               (optimize (speed 3) (safety 0) (debug 0)))
    
      (let ((parser (make-udmf-parser :source udmf))
            (ret (make-array 2 :element-type '(or udmf-raw-block cons)
                             :adjustable t :fill-pointer 0 :initial-element '(nil)))
            (line "")
            (sub-line "")
            (last-end 0))
        (declare (type simple-string line sub-line)
                 (type fixnum last-end)
                 (type udmf-parser parser)
                 (type (vector (or udmf-raw-block cons)) ret))
    
        (handler-case
            (with-input-from-string (in (udmf-parser-source parser))
              (loop do
                   (progn
                     (setf line (read-line in))
    
                     ;; Ignore blank lines
                     (when (not (string= line ""))
                       (setf last-end 0)
    
                       ;; We only use CL-PPCRE:DO-SCANS if we absolutely need to
                       (if (> (count-if #'(lambda (char) (char= char #\; #\{ #\})) line) 1)
                           (cl-ppcre:do-scans (mstart mend regs rege *udmf-line-regex* line)
                             (setf sub-line (string-trim '(#\Space) (subseq line last-end mend)))
                             (setf last-end mend)
    
                             (when (not (string= sub-line ""))
                               (parse-udmf-line-into-array line ret in)))
    
                           (parse-udmf-line-into-array line ret in))))))
    
          (end-of-file ()
            ret))))
    
    ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    ;;;
    ;;; UDMF AST -> UDMF Structures Translation
    ;;;
    ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    
    ;;
    ;; This will create a function to take a raw UDMF block and turn it
    ;; into a UDMF structure.
    ;;
    (defmacro create-udmf-raw-block->udmf-struct-translator (fn-name type)
      (declare (optimize (debug 0) (compilation-speed 0)))
    
      (let ((waddle-pkg (find-package :p36.waddle))
            (fn-arg (gensym "FN-ARG-"))
            (ret (gensym "FN-RET-"))
            (expr (gensym "FN-EXPR-"))
            (type-accessor-prefix (concatenate 'string
                                               (subseq (string type)
                                                       (1+ (position #\/ (string type)
                                                                     :test #'eql
                                                                     :from-end t)))
                                               "-")))
    
        `(defun ,fn-name (,fn-arg)
           (let ((,ret (,(intern (concatenate 'string "MAKE-" (string type)))
                         :name (udmf-raw-block-name ,fn-arg))))
    
             (loop for ,expr cons across (udmf-raw-block-expressions ,fn-arg) do
                  (cond
                    ,@(loop for slot in (closer-mop:class-slots (find-class type))
                        when (equal waddle-pkg (symbol-package (closer-mop:slot-definition-name slot)))
                        collecting
                          (let* ((slot-name-str (string-downcase (string (closer-mop:slot-definition-name slot))))
                                 (slot-accessor (intern (concatenate 'string type-accessor-prefix (string-upcase slot-name-str)))))
                            `((string= ,slot-name-str (car ,expr))
                              (setf (,slot-accessor ,ret) (cdr ,expr)))))))
    
             ,ret))))
    
    ;;
    ;; Create all the functions needed to turn raw UDMF blocks into UDMF structures
    ;;;
    (create-udmf-raw-block->udmf-struct-translator udmf-raw-block->udmf-vertex udmf-block/vertex)
    (create-udmf-raw-block->udmf-struct-translator udmf-raw-block->udmf-linedef udmf-block/linedef)
    (create-udmf-raw-block->udmf-struct-translator udmf-raw-block->udmf-sidedef udmf-block/sidedef)
    (create-udmf-raw-block->udmf-struct-translator udmf-raw-block->udmf-sector udmf-block/sector)
    (create-udmf-raw-block->udmf-struct-translator udmf-raw-block->udmf-thing udmf-block/thing)
    
    (create-udmf-raw-block->udmf-struct-translator udmf-raw-block->udmf-zdoom-vertex udmf-block/zdoom/vertex)
    (create-udmf-raw-block->udmf-struct-translator udmf-raw-block->udmf-zdoom-linedef udmf-block/zdoom/linedef)
    (create-udmf-raw-block->udmf-struct-translator udmf-raw-block->udmf-zdoom-sidedef udmf-block/zdoom/sidedef)
    (create-udmf-raw-block->udmf-struct-translator udmf-raw-block->udmf-zdoom-sector udmf-block/zdoom/sector)
    (create-udmf-raw-block->udmf-struct-translator udmf-raw-block->udmf-zdoom-thing udmf-block/zdoom/thing)
    
    ;;
    ;; Parses the AST generated by PARSE-UDMF->AST into a vector of UDMF
    ;; structures and CONSes.  In the resulting array, CONSes represent
    ;; toplevel assignments.
    ;;
    (defun parse-udmf (udmf-ast)
      (declare (type (vector (or cons udmf-raw-block)) udmf-ast)
               (optimize (speed 3) (debug 0)))
    
      (let ((ret (make-array (length udmf-ast) :adjustable t :fill-pointer 0))
            (block-name "")
            (zdoom nil)
            (thing '(nil)))
        (declare (type simple-string block-name)
                 (type vector ret)
                 (type boolean zdoom)
                 (type (or cons udmf-raw-block) thing))
    
        (dotimes (i (length udmf-ast))
          (setf thing (elt udmf-ast i))
    
          (typecase thing
            (cons
             (format t "~a: ~a~%" (car thing) (cdr thing))
    
             (when (and (string= (the string (car thing)) "namespace")
                        (or (string= (string-downcase (cdr thing)) "zdoom")
                            (string= (string-downcase (cdr thing)) "zdoomtranslated")))
               ;; We're in ZDoom, so keep track of this so we can also
               ;; call ZDoom translation functions
               (setf zdoom t))
    
             (vector-push-extend thing ret))
    
            (udmf-raw-block
             (setf block-name (udmf-raw-block-name thing))
    
             (if zdoom
                 (cond
                   ((string= "thing" block-name)
                    (vector-push-extend (udmf-raw-block->udmf-thing thing) ret))
    
                   ((string= "linedef" block-name)
                    (vector-push-extend (udmf-raw-block->udmf-linedef thing) ret))
    
                   ((string= "sidedef" block-name)
                    (vector-push-extend (udmf-raw-block->udmf-sidedef thing) ret))
    
                   ((string= "vertex" block-name)
                    (vector-push-extend (udmf-raw-block->udmf-vertex thing) ret))
    
                   ((string= "sector" block-name)
                    (vector-push-extend (udmf-raw-block->udmf-sector thing) ret))
    
                   (t
                    (format t "Don't know how to handle a ~a block~%" block-name)))
    
                 (cond
                   ((string= "thing" block-name)
                    (vector-push-extend (udmf-raw-block->udmf-zdoom-thing thing) ret))
    
                   ((string= "linedef" block-name)
                    (vector-push-extend (udmf-raw-block->udmf-zdoom-linedef thing) ret))
    
                   ((string= "sidedef" block-name)
                    (vector-push-extend (udmf-raw-block->udmf-zdoom-sidedef thing) ret))
    
                   ((string= "vertex" block-name)
                    (vector-push-extend (udmf-raw-block->udmf-zdoom-vertex thing) ret))
    
                   ((string= "sector" block-name)
                    (vector-push-extend (udmf-raw-block->udmf-zdoom-sector thing) ret))
    
                   (t
                    (format t "Don't know how to handle a ~a block~%" block-name)))))))
    
        ret))
    

     

    1. Show previous comments  2 more
    2. Phade102

      Phade102

      Ahh I get it. thats really interesting. I'm not really a big fan of scripts, but I believe I do remember using a very simple one a long long time ago to place fog in a level.

       

      As you said though, this isn't a script. it'd be interesting to see where this program can be used.

    3. Rosh Fragger

      Rosh Fragger

      I mostly play Watch Dogs 2 in such urges lol

    4. Csonicgo

      Csonicgo

      Wonderful work!

       

×