1 ;; $RCSfile: lyqi-base.el,v $
3 ;; $Date: 2003/09/27 16:59:27 $
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))
18 (defconst mudela-translation-table
19 '((pitch . ((nederlands . ["c" "d" "e" "f" "g" "a" "b"])
20 (english . ["c" "d" "e" "f" "g" "a" "b"])
21 (deutsch . ["c" "d" "e" "f" "g" "a" "h"])
22 (norsk . ["c" "d" "e" "f" "g" "a" "h"])
23 (svenska . ["c" "d" "e" "f" "g" "a" "h"])
24 (italiano . ["do" "re" "mi" "fa" "sol" "la" "si"])
25 (catalan . ["do" "re" "mi" "fa" "sol" "la" "si"])
26 (espanol . ["do" "re" "mi" "fa" "sol" "la" "si"])))
27 (accidental . ((nederlands . ["eses" "es" "" "is" "isis"])
28 (english . ["ff" "f" "" "s" "ss"])
29 (deutsch . ["eses" "es" "" "is" "isis"])
30 (norsk . ["essess" "ess" "" "iss" "ississ"])
31 (svenska . ["essess" "ess" "" "iss" "ississ"])
32 (italiano . ["bb" "b" "" "d" "dd"])
33 (catalan . ["bb" "b" "" "d" "dd"])
34 (espanol . ["bb" "b" "" "s" "ss"])))
35 (replacements . ((nederlands . (("eeses" "eses") ("ees" "es")
36 ("aeses" "ases") ("aes" "as")))
37 (deutsch . (("hes" "b") ;("heses" "bes")
38 ("eeses" "eses") ("ees" "es")
39 ("aeses" "ases") ("aes" "as")))
40 (norsk . (("eessess" "essess") ("eess" "ess")
41 ("hess" "b") ("hessess" "bess")))
42 (svenska . (("eessess" "essess") ("eess" "ess")
43 ("aessess" "assess") ("aess" "ass")
44 ("hess" "b") ("hessess" "bess")))))
50 (reminder-accidental . ?!)
51 (cautionary-accidental . ??)))
53 (defclass mudela-editing-state ()
54 ((translation-table :initarg :translation-table
56 :documentation "A mudela string or character <---> internal value translation table.")
57 (language :initarg :language
59 :documentation "Current output language")
60 (relative-octave :initarg :relative-octave
62 :documentation "Current octave mode. relative if non-nil, absolute otherwise.")
63 (force-duration :initarg :force-duration
65 :documentation "Current duration output mode. always present if non-nil, ellipsed otherwise")
66 (pitch-dict :initarg :pitch-dict
68 :documentation "A mudela<->internal values dictionnnary for pitches and alterations")
69 (alterations :initarg :alterations
70 :initform [2 2 2 2 2 2 2]
71 :documenation "Last alteration for each note."))
72 "The current editing state : octave mode, language, etc.")
74 ;; (defmethod init-state ((editing-state mudela-editing-state) &optional lang)
75 ;; "Initialize `editing-state' pitch-dict due to `lang',
76 ;; and `translation-table' to `mudela-translation-table'."
77 ;; (setf (slot-value editing-state 'translation-table) mudela-translation-table)
78 ;; (with-slots (language) editing-state
79 ;; (set-language editing-state (or lang language)))
82 (defmethod get-translation ((editing-state mudela-editing-state) key)
83 "Return the value corresponding to `key' in `translation-table'"
84 (with-slots (translation-table) editing-state
85 (cdr (assoc key translation-table))))
87 (defmethod get-pitch ((editing-state mudela-editing-state) pitch-string)
88 "Return a (pitch . alteration) pair corresponding to `pitch-string' in `pitch-dict' (if any)"
89 (with-slots (pitch-dict) editing-state
90 (car (rassoc pitch-string pitch-dict))))
92 (defmethod get-pitch-string ((editing-state mudela-editing-state) pitch alteration)
93 "Return the mudela pitch string corresponding to the (`pitch' . `alteration') pair
94 in `pitch-dict' (if any)"
95 (with-slots (pitch-dict) editing-state
96 (cdr (assoc (cons pitch alteration) pitch-dict))))
98 (defmethod set-language ((editing-state mudela-editing-state) lang)
99 "Set the editing-state object's language and update its pitch-dict accordingly."
100 (labels ((get-translation2 (key)
101 (cdr (assoc lang (get-translation editing-state key)))))
102 (setf (slot-value editing-state 'language) (if (stringp lang) (intern lang) lang))
103 (setf (slot-value editing-state 'pitch-dict)
105 (dotimes (pitch 7 (nreverse dict))
106 (dotimes (alter 5 dict)
108 (cons (cons (cons pitch alter)
109 (let ((note (concat (aref (get-translation2 'pitch) pitch)
110 (aref (get-translation2 'accidental) alter))))
111 (or (cadr (assoc note (get-translation2 'replacements)))
118 (defclass mudela-note-state ()
119 ((pitch :initarg :pitch
121 :documentation "Previous note pitch")
122 (octave :initarg :octave
124 :documentation "Previous note octave")
125 (duration :initarg :duration
127 :documentation "Previous music token duration")
130 :documentation "Previous music token dot number"))
131 "Describe the current note state : current octave, duration, etc.")
135 (defclass mudela-word ()
136 ((editing-state :allocation :class
137 :documentation "The current editing state (language, relative/absolute octaves, etc),
138 used to generate mudela strings"))
139 "Base class for mudela words: notes, rests, skips, etc.")
141 (defmethod mudela-string ((word mudela-word) &optional note-state)
142 "(return an empty string. should be reimplemented by derived classes)"
145 (defmethod set-alteration-up ((word mudela-word))
146 "Increase, if possible, the word alteration."
149 (defmethod set-alteration-down ((word mudela-word))
150 "Decrease, if possible, the word alteration."
153 (defmethod set-alteration-natural ((word mudela-word))
154 "Set, if possible, the word alteration to natural."
157 (defmethod set-octave-up ((word mudela-word))
158 "Increase the word's octave."
161 (defmethod set-octave-down ((word mudela-word))
162 "Decrease the word's octave."
165 (defmethod set-octave-zero ((word mudela-word))
166 "Set the note octave to zero."
169 (defmethod set-duration ((word mudela-word) duration)
170 "Set the word's duration."
173 (defmethod set-dots ((word mudela-word))
174 "Increase, modulo 5, the word's dot number."
177 (defmethod set-reminder-alt ((word mudela-word))
178 "Change reminder alteration state for word."
181 (defmethod set-cautionary-alt ((word mudela-word))
182 "Change cautionary alteration state for word."
185 (defmethod transpose ((word mudela-word) note-diff exact-pitch-diff &optional note-state)
189 (defclass mudela-word-duration (mudela-word)
190 ((duration :initarg :duration
191 :initform 3 ; 2^(3 - 1) = 4 ==> quater note
192 :documentation "duration, from 1 to 8. real-duration = 2^(duration - 1)")
195 :documentation "dots, from 0 (no dot) to N>0 (N dots)"))
196 "A mudela word that have a duration information.")
198 (defmethod set-duration ((word mudela-word-duration) duration)
199 "Set the word's duration."
200 (setf (slot-value word 'dots) 0)
201 (setf (slot-value word 'duration) duration))
203 (defmethod set-dots ((word mudela-word-duration))
204 "Increase, modulo 5, the word's dot number."
205 (setf (slot-value word 'dots)
206 (mod (1+ (slot-value word 'dots)) 5)))
208 (defmethod update-note-state ((word mudela-word-duration) note-state)
209 "Update the current `note-state' thanks to the given music `word': duration and dots."
210 (with-slots (duration dots) word
211 (setf (slot-value note-state 'duration) duration)
212 (setf (slot-value note-state 'dots) dots))
215 (defmethod mudela-duration ((word mudela-word-duration) &optional note-state)
216 "Return the mudela duration string for `word'. If `editing-state'
217 indicates that duration is facultative, and `note-state' duration
218 and dots are the same that `word' duration and dots, the string is empty."
219 (with-slots (duration dots editing-state) word
220 (if (and (not (slot-value editing-state 'force-duration))
222 (= duration (slot-value note-state 'duration))
223 (= dots (slot-value note-state 'dots)))
224 ;; same duration and dots, and user permit duration ellipse
227 (expt 2 (1- duration))
228 (make-string dots (get-translation editing-state 'dot))))))
230 (defclass mudela-note (mudela-word-duration)
231 ((pitch :initarg :pitch
233 :documentation "note pitch, from 0 (do / c) to 6 (si / b)")
234 (alteration :initarg :alteration
235 :initform 2 ; becarre / natural
236 :documentation "note alteration, from 0 (bb) to 4 (##)")
237 (octave :initarg :octave
239 :documentation "note octave, 0 being the octave starting with the do / c
240 which is in the 2nd interline in bass clef (4th line F clef)")
241 (reminder-accidental :initarg :reminder-accidental
243 :documentation "if non-nil, force a reminder accidental")
244 (cautionary-accidental :initarg :cautionary-accidental
246 :documentation "if non-nil and reminder-accidental is nil,
247 indicate a cautionary accidental"))
248 "Note : duration and pitch")
250 (defmethod set-alteration-natural ((note mudela-note))
251 "Set notes's alteration to natural"
252 ;; we update the alterations table in the current editing state
253 (aset (slot-value (slot-value note 'editing-state) 'alterations)
254 (slot-value note 'pitch)
256 ;; reset reminder and cautionary slots
257 (setf (slot-value note 'cautionary-accidental) nil)
258 (setf (slot-value note 'reminder-accidental) nil)
259 (setf (slot-value note 'alteration) 2))
261 (defmethod set-alteration-up ((note mudela-note))
262 "Increase, if possible, the note alteration."
263 (with-slots (alteration) note
264 (when (< alteration 4)
265 ;; we update the alterations table in the current editing state
266 (aset (slot-value (slot-value note 'editing-state) 'alterations)
267 (slot-value note 'pitch)
269 ;; reset reminder and cautionary slots
270 (setf (slot-value note 'cautionary-accidental) nil)
271 (setf (slot-value note 'reminder-accidental) nil)
272 (setf (slot-value note 'alteration) (1+ alteration)))))
274 (defmethod set-alteration-down ((note mudela-note))
275 "Decrease, if possible, the note alteration."
276 (with-slots (alteration) note
277 (when (> alteration 0)
278 ;; we update the alterations table in the current editing state
279 (aset (slot-value (slot-value note 'editing-state) 'alterations)
280 (slot-value note 'pitch)
282 ;; reset reminder and cautionary slots
283 (setf (slot-value note 'cautionary-accidental) nil)
284 (setf (slot-value note 'reminder-accidental) nil)
285 (setf (slot-value note 'alteration) (1- alteration)))))
287 (defmethod set-octave-up ((note mudela-note))
288 "Increase the note's octave."
289 (with-slots (octave) note
291 (setf (slot-value note 'octave) (1+ octave)))))
293 (defmethod set-octave-down ((note mudela-note))
294 "Decrease the note's octave."
295 (with-slots (octave) note
297 (setf (slot-value note 'octave) (1- octave)))))
299 (defmethod set-octave-zero ((note mudela-note))
300 "Set the note octave to zero."
301 (setf (slot-value note 'octave) 0))
303 (defmethod set-reminder-alt ((note mudela-note))
304 "Change reminder alteration state for note."
305 (with-slots (reminder-accidental) note
306 (setf (slot-value note 'reminder-accidental) (not reminder-accidental))))
308 (defmethod set-cautionary-alt ((note mudela-note))
309 "Change cautionary alteration state for note."
310 (with-slots (cautionary-accidental) note
311 (unless cautionary-accidental
312 (setf (slot-value note 'reminder-accidental) nil))
313 (setf (slot-value note 'cautionary-accidental) (not cautionary-accidental))))
315 (defmethod update-note-state ((note mudela-note) note-state)
316 "Update the current `note-state' thanks to the given `note': duration, dots, pitch and octave."
318 (with-slots (pitch octave) note
319 (setf (slot-value note-state 'pitch) pitch)
320 (setf (slot-value note-state 'octave) octave))
323 (defmethod mudela-string ((note mudela-note) &optional note-state)
324 "Return the mudela string for `note', depending on the context
325 given by `editing-state' and `note-state': pitch, accidental, octave,
326 duration (with dots), reminder or cautionary accidental."
329 (mudela-octave note note-state)
330 (mudela-chromatic note)
331 (mudela-duration note note-state)))
333 (defmethod mudela-pitch ((note mudela-note))
334 "Return the mudela pitch (with alteration) string for `note'"
335 (with-slots (pitch alteration editing-state) note
336 (get-pitch-string editing-state pitch alteration)))
338 (defmethod mudela-octave ((note mudela-note) &optional note-state)
339 "Return the mudela octave string for `note'. In case of relative octave mode,
340 `note-state' is mandatory."
341 (with-slots (pitch octave editing-state) note
342 (if (slot-value editing-state 'relative-octave)
345 (let ((abspitch1 (+ (* 7 (slot-value note-state 'octave))
346 (slot-value note-state 'pitch)))
347 (abspitch2 (+ (* 7 octave) pitch)))
348 (if (< (abs (- abspitch1 abspitch2)) 4)
349 "" ; same relative octave
350 (if (> abspitch1 abspitch2)
351 (make-string (+ (/ (- abspitch1 abspitch2 4) 7) 1)
352 (get-translation editing-state 'octave-down))
353 (make-string (+ (/ (- abspitch2 abspitch1 4) 7) 1)
354 (get-translation editing-state 'octave-up))))))
357 (make-string octave (get-translation editing-state 'octave-up))
358 (make-string (* -1 octave) (get-translation editing-state 'octave-down))))))
360 (defmethod mudela-chromatic ((note mudela-note))
361 "Return the mudela chromatic information string for `note'."
362 (with-slots (reminder-accidental cautionary-accidental editing-state) note
363 (cond (reminder-accidental
364 (char-to-string (get-translation editing-state 'reminder-accidental)))
365 (cautionary-accidental
366 (char-to-string (get-translation editing-state 'cautionary-accidental)))
369 (defmethod midi-pitch ((note mudela-note))
370 "Return `note''s midi pitch, from 0 to 127."
371 (with-slots (pitch alteration octave) note
372 (+ (aref [0 2 4 5 7 9 11] pitch)
377 (defmethod transpose ((note mudela-note) note-diff exact-pitch-diff)
378 "Transpose `note'. Ex: (transpose [do] -5 -9) -> [mib,]"
379 (with-slots (pitch octave alteration) note
380 (let ((newnote (copy-sequence note)))
382 (setf (slot-value newnote 'pitch) (mod (+ pitch note-diff) 7))
384 (cond ((< (+ pitch note-diff) 0)
385 (setf (slot-value newnote 'octave)
386 (+ octave (/ (+ pitch note-diff -6) 7))))
387 ((> (+ pitch note-diff) 6)
388 (setf (slot-value newnote 'octave)
389 (+ octave (/ (+ pitch note-diff) 7)))))
391 (setf (slot-value newnote 'alteration)
392 (min (max (+ (- exact-pitch-diff (- (midi-pitch newnote) (midi-pitch note)))
399 (defclass mudela-rest (mudela-word-duration)
403 (defmethod mudela-string ((rest mudela-rest) &optional note-state)
404 "Return the mudela string for `rest'."
405 (with-slots (editing-state) rest
407 (get-translation editing-state 'rest)
408 (mudela-duration rest note-state))))
410 (defclass mudela-skip (mudela-word-duration)
414 (defmethod mudela-string ((skip mudela-skip) &optional note-state)
415 "Return the mudela string for `skip'."
416 (with-slots (editing-state) skip
418 (get-translation editing-state 'skip)
419 (mudela-duration skip note-state))))
421 (defclass mudela-verbatim (mudela-word)
422 ((text :initarg :text
424 :documentation "Verbatim mudela text, storing not recognized mudela words"))
425 "Not recognized text")
427 (defmethod update-note-state ((verbatim mudela-verbatim) note-state)
431 (defmethod mudela-string ((verbatim mudela-verbatim) &optional note-state)
432 "Return the verbatim mudela string contained in this object"
433 (with-slots (text) verbatim