1 ;; $RCSfile: lyqi-parser.el,v $
3 ;; $Date: 2003/09/27 16:33:49 $
6 ;;; Part of lyqi, a major emacs mode derived from LilyPond-Mode,
7 ;;; for quick note insertion while editing GNU LilyPond music scores.
9 ;;; (c) copyright 2003 Nicolas Sceaux <nicolas.sceaux@free.fr>
10 ;;; See http://nicolas.sceaux.free.fr/lilypond/
13 (eval-when-compile (require 'cl))
17 ;;;;;; few string utilities ;;;;;;;;;;
19 ;; for XEmacs21 compatibility
20 (if (not (fboundp 'match-string-no-properties))
21 (defalias 'match-string-no-properties 'match-string))
23 (defun my-join (string-list joiner)
24 "Returns a concatenation of all string-list elements, with joiner between elements"
27 (mapcar (lambda (str) (concat joiner str))
30 (defun my-sort-string-by-length (string-list)
31 "Sort the given string list by decreasing string length."
35 (or (< (length str1) (length str2))
36 (and (= (length str1) (length str2))
37 (string< str1 str2)))))))
39 (defun my-char-to-restring (char)
40 (concat (if (member char '(?. ?* ?+ ??)) "\\" "")
41 (char-to-string char)))
43 ;;;;;; parser classes ;;;;;;;;;
45 (defclass base-parser ()
46 ((regexp :initarg :regexp
47 :documentation "A regular expression associated with the parser"))
48 "base class for parsers")
50 (defmethod update-regexp ((parser base-parser))
51 "(do nothing) Return the parser's regexp"
52 (slot-value parser 'regexp))
54 (defclass syllab-parser (base-parser)
56 "A syllab parser, ie a specialized word component parser.")
58 (defclass word-parser (base-parser)
59 ((regexp-not-before :initarg :not-before
61 :documentation "A regexp describing what should not be found after the words
62 that the parser recognize.")
63 (regexp-not-after :initarg :not-after
65 :documentation "A regexp describing what should not be found before the words
66 that the parser recognize.")
67 (syllab-parsers :initarg :syllab-parsers
69 :documentation "A list of (syllab-parser . facultative) pair, where `syllab-parser'
70 is a syllab-parser object, and facultative says if the syylab if facultative in the word.")
71 (word-class :initarg :word-class
73 :documentation "The class name of the recognized words."))
74 "A word parser, which aims at building a given type of objects when parsing a recognized word.
75 A word is composed of syllabs, and thus a word-parser is composed of syllab-parsers.")
77 (defmethod update-regexp ((parser word-parser))
78 "Update the parser's regexp thanks to its syllabe-parsers regexps.
79 Return the new regexp."
80 (with-slots (syllab-parsers) parser
81 (setf (slot-value parser 'regexp)
82 (apply 'concat "\\b" (mapcar (lambda (sylparser)
83 (format (if (cdr sylparser) "\\(%s\\)?" "%s")
84 (update-regexp (car sylparser))))
87 (defclass text-parser (base-parser)
88 ((word-parsers :initarg :word-parsers
90 :documentation "List of word-parser objects used to parse a text. Order matters.")
91 (class-unknown :initarg :class-unknown
93 :documentation "Class name used to store not recognized text.")
94 (slot-unknown :initarg :slot-unknown
96 :documentation "Slot name of class-unknown where the not recognized text will be stored"))
97 "A text parser, which aims at building an object list, each object being built when a word is recognized.
98 A text is composed of words, and thus a text-parser is composed of word-parsers. When a piece of text is not
99 recognized by word-parsers, it is stored in the slot `slot-unknown' of an object of class `class-unknown'.")
101 (defmethod update-regexp ((parser text-parser))
102 "Update the text-parser's regexp thanks to its word-parsers regexps.
103 Return the new regexp."
104 (with-slots (word-parsers) parser
105 (setf (slot-value parser 'regexp)
106 (format "\\(%s\\)" (my-join (mapcar (lambda (word-parser)
107 (format "\\(%s\\)" (update-regexp word-parser)))
111 ;;;;;;;; mudela parser ;;;;;;;;;;;;;
112 ;; no multiple inheritance with eieio... can not define a base class that has an editing-state slot
114 (defclass mudela-syllab-parser (syllab-parser)
115 ((editing-state :initarg :editing-state
116 :documentation "The current editing state (language, relative/absolute octaves, etc),
117 used to generate mudela regexps"))
118 "A syllab parser specialized for mudela.")
120 (defmethod parse-string ((parser mudela-syllab-parser) mudela-str note-state)
124 (defclass duration-parser (mudela-syllab-parser)
126 "A duration and dots parser.")
128 (defmethod init-parser ((parser duration-parser) editing-state)
129 "Init the parser regexp"
130 (setf (slot-value parser 'editing-state) editing-state)
131 (setf (slot-value parser 'regexp)
132 (format "\\(%s\\)\\(%s*\\)"
133 (my-join (my-sort-string-by-length
134 (mapcar 'int-to-string
135 (mapcar (lambda (n) (expt 2 (- n 1)))
136 '(1 2 3 4 5 6 7 8))))
138 (my-char-to-restring (get-translation editing-state 'dot))))
141 (defmethod parse-string ((parser duration-parser) mudela-str note-state)
142 "If `parser' regexp matches `mudela-str', return slot initialization description,
143 ie (:duration N :dots P), with N and P read from `mudela-str'. Otherwise, a default definition
144 is generated thanks to `note-state'."
145 (with-slots (regexp) parser
146 (if (string-match regexp mudela-str)
147 (list :duration (round (1+ (log (string-to-number (match-string-no-properties 1 mudela-str)) 2)))
148 :dots (length (match-string-no-properties 2 mudela-str)))
149 (with-slots (duration dots) note-state
150 (list :duration duration :dots dots)))))
152 (defclass pitch-parser (mudela-syllab-parser)
154 "A pitch, alteration and octave parser.")
156 (defmethod update-regexp ((parser pitch-parser))
157 "Update the parser's regexp and return it"
158 (with-slots (editing-state) parser
159 (setf (slot-value parser 'regexp)
160 (format "\\(%s\\)\\(%s+\\|%s+\\)?"
161 (my-join (my-sort-string-by-length (mapcar 'cdr (slot-value editing-state 'pitch-dict)))
163 (my-char-to-restring (get-translation editing-state 'octave-down))
164 (my-char-to-restring (get-translation editing-state 'octave-up))))))
166 (defmethod init-parser ((parser pitch-parser) editing-state)
167 "Init the parser regexp"
168 (setf (slot-value parser 'editing-state) editing-state)
169 (update-regexp parser)
172 (defmethod parse-string ((parser pitch-parser) mudela-str note-state)
173 "If `parser' regexp matches `mudela-str', return slot initialization description,
174 ie (:pitch N :alteration P :octave Q), with N, P and Q read from `mudela-str'."
175 (with-slots (regexp editing-state) parser
176 (when (string-match regexp mudela-str)
177 (let* ((pitch-alter (get-pitch editing-state (match-string-no-properties 1 mudela-str)))
178 (pitch (car pitch-alter))
179 (alter (cdr pitch-alter)))
183 (if (slot-value editing-state 'relative-octave)
184 (+ (slot-value note-state 'octave)
185 (cond ((> (- pitch (slot-value note-state 'pitch)) 3) -1)
186 ((> (- (slot-value note-state 'pitch) pitch) 3) 1)
189 (if (match-string-no-properties 2 mudela-str)
190 (* (if (string= (char-to-string (get-translation editing-state 'octave-down))
191 (substring (match-string-no-properties 2 mudela-str) 0 1))
194 (length (match-string-no-properties 2 mudela-str)))
197 (defclass chromatic-parser (mudela-syllab-parser)
199 "A chromatic information parser.")
201 (defmethod init-parser ((parser chromatic-parser) editing-state)
202 "Init the parser regexp"
203 (setf (slot-value parser 'editing-state) editing-state)
204 (setf (slot-value parser 'regexp)
205 (format "\\(%s\\|%s\\)"
206 (my-char-to-restring (get-translation editing-state 'reminder-accidental))
207 (my-char-to-restring (get-translation editing-state 'cautionary-accidental))))
210 (defmethod parse-string ((parser chromatic-parser) mudela-str note-state)
211 "If `parser' regexp matches `mudela-str', return slot initialization description,
212 ie (:reminder-accidental N :cautionary-accidental P, with N and P read from `mudela-str'."
213 (with-slots (regexp editing-state) parser
214 (if (string-match regexp mudela-str)
215 (list :reminder-accidental (string= (char-to-string (get-translation editing-state 'reminder-accidental))
216 (substring (match-string-no-properties 0 mudela-str) 0 1))
217 :cautionary-accidental (string= (char-to-string (get-translation editing-state 'cautionary-accidental))
218 (substring (match-string-no-properties 0 mudela-str) 0 1)))
219 (list :reminder-accidental nil :cautionary-accidental nil))))
221 (defclass r-parser (mudela-syllab-parser)
223 "A r (rest) parser.")
225 (defmethod init-parser ((parser r-parser) editing-state)
226 "Init the parser regexp"
227 (setf (slot-value parser 'editing-state) editing-state)
228 (setf (slot-value parser 'regexp)
229 (format "\\(%s\\|%s\\)"
230 (get-translation editing-state 'rest)
231 (upcase (get-translation editing-state 'rest))))
234 (defclass s-parser (mudela-syllab-parser)
235 ((editing-state :initarg :editing-state
236 :documentation "The current editing state (language, relative/absolute octaves, etc),
237 used to generate mudela regexps"))
238 "A s (skip) parser.")
240 (defmethod init-parser ((parser s-parser) editing-state)
241 "Init the parser regexp"
242 (setf (slot-value parser 'editing-state) editing-state)
243 (setf (slot-value parser 'regexp) (get-translation editing-state 'skip))
246 (defclass mudela-word-parser (word-parser)
247 ((editing-state :initarg :editing-state
248 :documentation "The current editing state (language, relative/absolute octaves, etc),
249 used to generate mudela regexps"))
250 "A specialized mudella word parser.")
252 (defmethod init-parser ((parser mudela-word-parser) editing-state)
253 "Init the parser regexp"
254 (setf (slot-value parser 'editing-state) editing-state)
255 (with-slots (syllab-parsers) parser
256 (dolist (sylparser syllab-parsers)
257 (init-parser (car sylparser) editing-state)))
258 (update-regexp parser)
261 (defmethod parse-string ((parser mudela-word-parser) mudela-str note-state &optional before after)
262 "If the parser regexp matches `mudela-str' exactly and if `regexp-not-after' and
263 `regexp-not-before' do not match the strings `before' or `after', return an instance
264 of `word-class' by parsing `mudela-str'."
265 (with-slots (word-class syllab-parsers regexp regexp-not-after regexp-not-before) parser
266 (when (and (string-match regexp mudela-str)
267 (string= (match-string-no-properties 0 mudela-str) mudela-str)
268 (not (and before (string-match regexp-not-after before)))
269 (not (and after (string-match regexp-not-before after))))
270 (apply 'make-instance word-class (apply 'append
271 (remove-if 'null (mapcar (lambda (syl-parser)
272 (parse-string (car syl-parser) mudela-str note-state))
273 syllab-parsers)))))))
275 (defclass mudela-parser (text-parser)
276 ((editing-state :initarg :editing-state
277 :documentation "The current editing state (language, relative/absolute octaves, etc),
278 used to generate mudela regexps"))
279 "A simple mudela parser, that can read notes, rests and skips")
281 (defmethod init-parser ((parser mudela-parser) editing-state)
282 "Initialize `parser' : editing-state, syllab and word parsers, etc."
283 (setf (slot-value parser 'editing-state) editing-state)
284 (with-slots (word-parsers) parser
285 (dolist (word-pars word-parsers)
286 (init-parser word-pars editing-state)))
287 (update-regexp parser)
290 (defmethod parse-string ((parser mudela-parser) mudela-str note-state &optional before after)
291 "If `mudela-str' is exactly recognized as a known word, return an object
292 corresponding to that word. Otherwise, return nil."
293 (with-slots (word-parsers) parser
294 (do* ((wparsers word-parsers (cdr wparsers))
295 (wparser (car wparsers) (car wparsers))
297 ((or obj (not wparser)) obj)
298 (setq obj (parse-string wparser mudela-str note-state before after)))))
300 (defmethod get-word ((parser mudela-parser) note-state &optional backward limit)
301 "Return a (word beginning end) list, `word' being the first mudela-word
302 found after (if `backward' is nil) or before (otherwise) point, `beginning' and
303 `end' being its beginning and end points. If no such word is found,
304 (nil beginning end) is returned, `beginning' and `end' being the parsed region.
305 The position is preserved."
307 (with-slots (regexp) parser
309 (beginning (and (not backward) (point)))
310 (end (and backward (point))))
311 (while (and (not word)
313 (re-search-backward regexp limit t)
314 (re-search-forward regexp limit t)))
315 (let* ((b (match-beginning 0))
317 (point-before (and (> b (point-min)) (1- b)))
318 (point-after (and (< e (point-max)) e))
319 (str-before (and point-before (buffer-substring-no-properties point-before (1+ point-before))))
320 (str-after (and point-after (buffer-substring-no-properties point-after (1+ point-after))))
321 (token (parse-string parser (match-string-no-properties 0) note-state str-before str-after)))
326 (goto-char (if backward (1- e) (1+ b))))))
328 (if backward (or beginning limit) beginning)
329 (if backward end (or end limit)))))))
331 (defmethod parse-region ((parser mudela-parser) beginning end)
332 "Return an object list describing what as been read by `parser' in the
333 region delimited by `beginning' and `end'."
334 (with-slots (class-unknown slot-unknown) parser
335 (labels ((make-verbatim (text)
336 (let ((obj (make-instance class-unknown)))
337 (setf (slot-value obj slot-unknown) text)
340 (let ((start-verb beginning)
342 (note-state (make-instance 'mudela-note-state)))
343 (goto-char beginning)
344 (do ((word-descr (get-word parser note-state nil end)
345 (get-word parser note-state nil end)))
346 ((or (null (car word-descr)) (>= (point) end)))
347 ;; first, we push verbatim text in tokens
348 (push (make-verbatim (buffer-substring-no-properties start-verb (cadr word-descr))) tokens)
349 ;; then, the recognized word
350 (push (car word-descr) tokens)
351 ;; finally, update position
352 (goto-char (caddr word-descr))
353 (setq start-verb (point))
354 (setf note-state (update-note-state (car word-descr) note-state)))
355 ;; remaining verbatim text
356 (when (< start-verb end)
357 (push (make-verbatim (buffer-substring-no-properties start-verb end)) tokens))
358 (nreverse tokens))))))
361 (defun make-mudela-parser (editing-state)
362 "Build and initialize a simple mudela parser."
363 (let* (;; syllab-parsers
364 (duration-pars (make-instance 'duration-parser))
365 (pitch-pars (make-instance 'pitch-parser))
366 (chromatic-pars (make-instance 'chromatic-parser))
367 (r-pars (make-instance 'r-parser))
368 (s-pars (make-instance 's-parser))
370 (note-pars (make-instance 'mudela-word-parser
371 :not-before "[a-zA-Z]"
372 :not-after "[a-zA-Z\\\\]"
373 :word-class 'mudela-note
374 :syllab-parsers (list (cons pitch-pars nil)
375 (cons chromatic-pars t)
376 (cons duration-pars t))))
377 (rest-pars (make-instance 'mudela-word-parser
378 :not-before "[a-zA-Z]"
379 :not-after "[a-zA-Z\\\\]"
380 :word-class 'mudela-rest
381 :syllab-parsers (list (cons r-pars nil)
382 (cons duration-pars t))))
383 (skip-pars (make-instance 'mudela-word-parser
384 :not-before "[a-zA-Z]"
385 :not-after "[a-zA-Z\\\\]"
386 :word-class 'mudela-skip
387 :syllab-parsers (list (cons s-pars nil)
388 (cons duration-pars t))))
390 (mudela-pars (make-instance 'mudela-parser
391 :class-unknown 'mudela-verbatim
393 :word-parsers (list note-pars
396 (init-parser mudela-pars editing-state)
399 (provide 'lyqi-parser)