lf2-survival-stage-generator/grammar.scm

(library (grammar)
  ;; export all non-terminal symbols for testing and usage
  ;; elsewhere in the code
  (export
   ;; special characters
   SPACE
   NEWLINE
   ATTRIBUTE-VALUE-SEPARATOR
   COMMENT-STARTER
   DIGIT
   NON-ZERO-DIGIT
   ;; character classes
   WHITESPACE
   WHITESPACE-EXCEPT-NEWLINE
   ;; special strings
   INTEGER
   POSITIVE-INTEGER
   SIMPLE-POSITIVE-FLOAT-NUMBER
   SIMPLE-FLOAT-NUMBER
   ACT-NUMBER
   NUMBER
   NON-NEWLINE-CONTAINING-STRING
   NON-WHITESPACE-CONTAINING-STRING
   FILENAME
   COMMENT-TEXT
   ENTITY-COMMENT-TEXT
   IGNORED-WHITESPACE
   IGNORED-WHITESPACE-EXCEPT-NEWLINE
   ;; tags
   STAGE-TAG
   STAGE-END-TAG
   PHASE-TAG
   PHASE-END-TAG
   BOSS-TAG
   SOLDIER-TAG
   END-TAG
   ;; attribute names
   ID-ATTRIBUTE-NAME
   BOUND-ATTRIBUTE-NAME
   MUSIC-ATTRIBUTE-NAME
   X-COORD-ATTRIBUTE-NAME
   Y-COORD-ATTRIBUTE-NAME
   HP-ATTRIBUTE-NAME
   RATIO-ATTRIBUTE-NAME
   TIMES-ATTRIBUTE-NAME
   RESERVE-ATTRIBUTE-NAME
   JOIN-ATTRIBUTE-NAME
   JOIN-RESERVE-ATTRIBUTE-NAME
   ACT-ATTRIBUTE-NAME
   GOTO-PHASE-ATTRIBUTE-NAME
   ;; attributes
   ID-ATTRIBUTE
   BOUND-ATTRIBUTE
   MUSIC-ATTRIBUTE
   X-COORD-ATTRIBUTE
   Y-COORD-ATTRIBUTE
   HP-ATTRIBUTE
   RATIO-ATTRIBUTE
   TIMES-ATTRIBUTE
   RESERVE-ATTRIBUTE
   JOIN-ATTRIBUTE
   JOIN-RESERVE-ATTRIBUTE
   ACT-ATTRIBUTE
   GOTO-PHASE-ATTRIBUTE
   STAGE-ID-ATTRIBUTE
   ;; compound parts
   COMMENT
   ENTITY-COMMENT
   MUSIC-SWITCH
   ENTITY-ATTRIBUTE
   ENTITY
   PHASE-ENTITIES
   PHASE
   SURVIVAL-STAGE-PHASES
   SURVIVAL-STAGE
   NORMAL-STAGE
   NORMAL-STAGES
   STAGE-DAT)

  (import
    (except (rnrs base) let-values map error)
    (only (guile)
          lambda* λ
          command-line
          string-null?)
    (ice-9 peg)
    (prefix (srfi srfi-1) srfi-1:)))


;; Explanation:

;; Non-terminal symbols are written in capital characters.

;; ==================
;; SPECIAL CHARACTERS
;; ==================

(define-peg-pattern SPACE none
  " ")

(define-peg-pattern NEWLINE none
  "\n")

(define-peg-pattern ATTRIBUTE-VALUE-SEPARATOR none
  ":")

(define-peg-pattern COMMENT-STARTER all
  "#")

(define-peg-pattern DIGIT body
  (or (range #\0 #\9)))

(define-peg-pattern NON-ZERO-DIGIT body
  (or (range #\1 #\9)))

;; =================
;; CHARACTER CLASSES
;; =================

(define-peg-pattern WHITESPACE none
  (or "\n"
      " "
      "\t"
      "\r"))

(define-peg-pattern WHITESPACE-EXCEPT-NEWLINE none
  (or " "
      "\t"
      "\r"))

;; ===============
;; SPECIAL STRINGS
;; ===============
(define-peg-pattern INTEGER body
  (or (and (? "-") NON-ZERO-DIGIT (* DIGIT))
      "0"))

(define-peg-pattern POSITIVE-INTEGER body
  (or (and NON-ZERO-DIGIT (* DIGIT))
      "0"))

(define-peg-pattern SIMPLE-POSITIVE-FLOAT-NUMBER body
  (or (and (* DIGIT) "." (+ DIGIT))))

(define-peg-pattern SIMPLE-FLOAT-NUMBER body
  (or (and (? "-") (* DIGIT) "." (+ DIGIT))))

(define-peg-pattern NUMBER body
  ;; Note: must put the more complex non-terminal first, to
  ;; avoid matching an INTEGER and then being stuck with a
  ;; SIMPLE-POSITIVE-FLOAT-NUMBER rest, which consists of
  ;; "." and any number of DIGIT, which would not be parsed,
  ;; because attributes expect only one number. --> (or ...)
  ;; is still an ordered choice operator!
  (or SIMPLE-FLOAT-NUMBER
      SIMPLE-POSITIVE-FLOAT-NUMBER
      INTEGER
      POSITIVE-INTEGER))

;; The act number is a reference to a frame inside
;; criminal.dat. Only some integer values work properly for
;; the act attribute.
(define-peg-pattern MONK-ACT-NUMBER body "0")
(define-peg-pattern MARK-ACT-NUMBER body "10")
(define-peg-pattern JACK-ACT-NUMBER body "20")
(define-peg-pattern SORCERER-ACT-NUMBER body "30")
(define-peg-pattern BANDIT-ACT-NUMBER body "40")
(define-peg-pattern HUNTER-ACT-NUMBER body "50")
(define-peg-pattern JAN-ACT-NUMBER body "60")
(define-peg-pattern ACT-NUMBER body
  (or MONK-ACT-NUMBER
      MARK-ACT-NUMBER
      JACK-ACT-NUMBER
      SORCERER-ACT-NUMBER
      BANDIT-ACT-NUMBER
      HUNTER-ACT-NUMBER
      JAN-ACT-NUMBER))

;; Note the pattern in the following non-terminal symbol
;; NON-NEWLINE-CONTAINING-STRING. To make an expression not match a specific
;; character or string, use (not-followed-by ...) first and (and ...) it the
;; other thing, which contains the things you excluded using (not-followed-by
;; ...). This way you are saying "I want this, but without the thing in
;; (not-followed-by ...).".
(define-peg-pattern NON-NEWLINE-CONTAINING-STRING body
  (+ (and (not-followed-by NEWLINE) peg-any)))

(define-peg-pattern NON-WHITESPACE-CONTAINING-STRING body
  (+ (and (not-followed-by WHITESPACE) peg-any)))

(define-peg-pattern FILENAME all
  NON-NEWLINE-CONTAINING-STRING)

(define-peg-pattern COMMENT-TEXT all
  NON-NEWLINE-CONTAINING-STRING)

(define-peg-pattern ENTITY-COMMENT-TEXT all
  NON-WHITESPACE-CONTAINING-STRING)

(define-peg-pattern IGNORED-WHITESPACE none
  (ignore (* WHITESPACE)))

(define-peg-pattern IGNORED-WHITESPACE-EXCEPT-NEWLINE none
  (ignore (* WHITESPACE-EXCEPT-NEWLINE)))

;; ====
;; TAGS
;; ====

(define-peg-pattern STAGE-TAG all
  "<stage>")

(define-peg-pattern STAGE-END-TAG all
  "<stage_end>")

(define-peg-pattern PHASE-TAG all
  "<phase>")

(define-peg-pattern PHASE-END-TAG all
  "<phase_end>")

(define-peg-pattern BOSS-TAG all
  "<boss>")

(define-peg-pattern SOLDIER-TAG all
  "<soldier>")

(define-peg-pattern END-TAG all
  "<end>")

;; NOTE: The <end> tag is actually completely useless in terms of semantics and
;; might as well be a sloppy remnant of a once imagined need for an over all
;; ending marker. It should be ignored whenever possible.
(define-peg-pattern IGNORED-END-TAG none
  (ignore (* END-TAG)))

;; ==========
;; ATTRIBUTES
;; ==========

(define-peg-pattern ID-ATTRIBUTE-NAME all
  "id")

(define-peg-pattern BOUND-ATTRIBUTE-NAME all
  "bound")

(define-peg-pattern MUSIC-ATTRIBUTE-NAME all
  "music")

(define-peg-pattern X-COORD-ATTRIBUTE-NAME all
  "x")

(define-peg-pattern Y-COORD-ATTRIBUTE-NAME all
  "y")

(define-peg-pattern HP-ATTRIBUTE-NAME all
  "hp")

(define-peg-pattern RATIO-ATTRIBUTE-NAME all
  "ratio")

(define-peg-pattern TIMES-ATTRIBUTE-NAME all
  "times")

(define-peg-pattern RESERVE-ATTRIBUTE-NAME all
  "reserve")

(define-peg-pattern JOIN-ATTRIBUTE-NAME all
  "join")

(define-peg-pattern JOIN-RESERVE-ATTRIBUTE-NAME all
  "join_reserve")

(define-peg-pattern ACT-ATTRIBUTE-NAME all
  "act")

(define-peg-pattern GOTO-PHASE-ATTRIBUTE-NAME all
  "when_clear_goto_phase")

(define-peg-pattern ID-ATTRIBUTE all
  (and ID-ATTRIBUTE-NAME
       ATTRIBUTE-VALUE-SEPARATOR
       IGNORED-WHITESPACE-EXCEPT-NEWLINE
       POSITIVE-INTEGER))

(define-peg-pattern BOUND-ATTRIBUTE all
  (and BOUND-ATTRIBUTE-NAME
       ATTRIBUTE-VALUE-SEPARATOR
       IGNORED-WHITESPACE-EXCEPT-NEWLINE
       POSITIVE-INTEGER))

(define-peg-pattern MUSIC-ATTRIBUTE all
  (and MUSIC-ATTRIBUTE-NAME
       ATTRIBUTE-VALUE-SEPARATOR
       IGNORED-WHITESPACE-EXCEPT-NEWLINE
       FILENAME))

(define-peg-pattern X-COORD-ATTRIBUTE all
  (and X-COORD-ATTRIBUTE-NAME
       ATTRIBUTE-VALUE-SEPARATOR
       IGNORED-WHITESPACE-EXCEPT-NEWLINE
       INTEGER))

(define-peg-pattern Y-COORD-ATTRIBUTE all
  (and Y-COORD-ATTRIBUTE-NAME
       ATTRIBUTE-VALUE-SEPARATOR
       IGNORED-WHITESPACE-EXCEPT-NEWLINE
       INTEGER))

(define-peg-pattern HP-ATTRIBUTE all
  (and HP-ATTRIBUTE-NAME
       ATTRIBUTE-VALUE-SEPARATOR
       IGNORED-WHITESPACE-EXCEPT-NEWLINE
       POSITIVE-INTEGER))

(define-peg-pattern RATIO-ATTRIBUTE all
  (and RATIO-ATTRIBUTE-NAME
       ATTRIBUTE-VALUE-SEPARATOR
       IGNORED-WHITESPACE-EXCEPT-NEWLINE
       (or SIMPLE-POSITIVE-FLOAT-NUMBER
           POSITIVE-INTEGER)))

(define-peg-pattern TIMES-ATTRIBUTE all
  (and TIMES-ATTRIBUTE-NAME
       ATTRIBUTE-VALUE-SEPARATOR
       (ignore (* WHITESPACE))
       POSITIVE-INTEGER))

(define-peg-pattern RESERVE-ATTRIBUTE all
  (and RESERVE-ATTRIBUTE-NAME
       ATTRIBUTE-VALUE-SEPARATOR
       IGNORED-WHITESPACE-EXCEPT-NEWLINE
       POSITIVE-INTEGER))

(define-peg-pattern JOIN-ATTRIBUTE all
  (and JOIN-ATTRIBUTE-NAME
       ATTRIBUTE-VALUE-SEPARATOR
       IGNORED-WHITESPACE-EXCEPT-NEWLINE
       POSITIVE-INTEGER))

(define-peg-pattern JOIN-RESERVE-ATTRIBUTE all
  (and JOIN-RESERVE-ATTRIBUTE-NAME
       ATTRIBUTE-VALUE-SEPARATOR
       IGNORED-WHITESPACE-EXCEPT-NEWLINE
       POSITIVE-INTEGER))

(define-peg-pattern ACT-ATTRIBUTE all
  (and ACT-ATTRIBUTE-NAME
       ATTRIBUTE-VALUE-SEPARATOR
       IGNORED-WHITESPACE-EXCEPT-NEWLINE
       ACT-NUMBER))

(define-peg-pattern GOTO-PHASE-ATTRIBUTE all
  (and GOTO-PHASE-ATTRIBUTE-NAME
       ATTRIBUTE-VALUE-SEPARATOR
       IGNORED-WHITESPACE-EXCEPT-NEWLINE
       POSITIVE-INTEGER))

(define-peg-pattern STAGE-ID-ATTRIBUTE all
  ID-ATTRIBUTE)

;; (define-peg-pattern ENTITY-ID-ATTRIBUTE all
;;   ID-ATTRIBUTE)

;; ==============
;; COMPOUND PARTS
;; ==============

(define-peg-pattern COMMENT all
  (and COMMENT-STARTER
       ;; Ignore whitespace until next content.
       (ignore (* WHITESPACE))
       COMMENT-TEXT))

(define-peg-pattern ENTITY-COMMENT all
  (and COMMENT-STARTER
       ENTITY-COMMENT-TEXT))

(define-peg-pattern MUSIC-SWITCH all
  MUSIC-ATTRIBUTE)



(define-peg-pattern ENTITY-ATTRIBUTE body
  (or ID-ATTRIBUTE
      X-COORD-ATTRIBUTE
      Y-COORD-ATTRIBUTE
      HP-ATTRIBUTE
      ACT-ATTRIBUTE
      RATIO-ATTRIBUTE
      TIMES-ATTRIBUTE
      RESERVE-ATTRIBUTE
      JOIN-ATTRIBUTE
      JOIN-RESERVE-ATTRIBUTE
      BOSS-TAG
      SOLDIER-TAG
      ENTITY-COMMENT))


(define-peg-pattern ENTITY all
  (and
   ;; ensure, that one opponent only matches until the
   ;; end of the line
   (not-followed-by "\n")
   ;; In any order match all of the possible
   ;; attributes. This might technically be slightly
   ;; incorrect, because it allows for an attribute to
   ;; appear multiple times, but I do not know currently
   ;; how to comfortably solve this in a better way,
   ;; without creating many variants of opponent
   ;; definitions, each specifying an ordered set of
   ;; attributes appearing in the original stage.dat
   ;; file.
   (* (and ENTITY-ATTRIBUTE IGNORED-WHITESPACE-EXCEPT-NEWLINE))))


(define-peg-pattern PHASE-ENTITIES all
  ;; NOTE: A phase must contain at least one entity. If (* ...) was used, then
  ;; an empty string prefix could be matched at the start of a string, leaving
  ;; the rest of the string to be matched later, but still resulting in a match.
  (+ (and ENTITY IGNORED-WHITESPACE)))


(define-peg-pattern PHASE all
  (and PHASE-TAG
       IGNORED-WHITESPACE
       BOUND-ATTRIBUTE
       IGNORED-WHITESPACE
       (? COMMENT)
       IGNORED-WHITESPACE
       (? MUSIC-SWITCH)
       IGNORED-WHITESPACE
       PHASE-ENTITIES
       IGNORED-WHITESPACE
       ;; If there is any goto attribute, it is the last
       ;; thing in the phase.
       (? GOTO-PHASE-ATTRIBUTE)
       IGNORED-WHITESPACE
       ;; NOTE: A phase does not eat up trailing whitespace, as such does not
       ;; really belong to the phase. If the phase end tag is considered to be a
       ;; real end marker, then the phase has no business matching anything
       ;; coming after that.
       PHASE-END-TAG))


(define-peg-pattern SURVIVAL-STAGE-PHASES all
  ;; NOTE: SURVIVAL-STAGE-PHASES is a pattern composing phases and as such takes
  ;; care of dropping the irrelevant whitespace between phases.
  (+ (and PHASE IGNORED-WHITESPACE)))


(define-peg-pattern SURVIVAL-STAGE all
  (and
   ;; First match the stage tag ...
   STAGE-TAG
   ;; ... then delimit survival stage by disallowing another
   ;; stage tag to be parsed ...
   (not-followed-by STAGE-TAG)
   ;; ... then match the rest of the possible parts.
   IGNORED-WHITESPACE-EXCEPT-NEWLINE
   STAGE-ID-ATTRIBUTE
   IGNORED-WHITESPACE-EXCEPT-NEWLINE
   (? COMMENT)
   IGNORED-WHITESPACE
   SURVIVAL-STAGE-PHASES
   IGNORED-WHITESPACE))


(define-peg-pattern NORMAL-STAGE all
  (and
   ;; First match the stage tag ...
   STAGE-TAG
   ;; ... then delimit stage by disallowing another
   ;; stage tag to be parsed ...
   (not-followed-by STAGE-TAG)
   ;; ... then match the rest of the possible parts.
   IGNORED-WHITESPACE-EXCEPT-NEWLINE
   STAGE-ID-ATTRIBUTE
   IGNORED-WHITESPACE-EXCEPT-NEWLINE
   (? COMMENT)
   IGNORED-WHITESPACE
   SURVIVAL-STAGE-PHASES
   IGNORED-WHITESPACE
   STAGE-END-TAG))


(define-peg-pattern NORMAL-STAGES all
  (+ (and NORMAL-STAGE
          IGNORED-WHITESPACE
          IGNORED-END-TAG
          IGNORED-WHITESPACE)))


(define-peg-pattern STAGE-DAT all
  (and SURVIVAL-STAGE
       NORMAL-STAGES
       IGNORED-WHITESPACE
       IGNORED-END-TAG
       IGNORED-WHITESPACE))