--- /dev/null
+;; $RCSfile: lyqi-base.el,v $
+;; $Revision: 1.5 $
+;; $Date: 2003/09/27 16:59:27 $
+;; $Author: nicolas $
+;;;
+;;; Part of lyqi, a major emacs mode derived from LilyPond-Mode,
+;;; for quick note insertion while editing GNU LilyPond music scores.
+;;;
+;;; (c) copyright 2003 Nicolas Sceaux <nicolas.sceaux@free.fr>
+;;; See http://nicolas.sceaux.free.fr/lilypond/
+;;;
+
+(eval-when-compile (require 'cl))
+(require 'eieio)
+
+;;;;;;;;;;;;;;;;
+
+(defconst mudela-translation-table
+ '((pitch . ((nederlands . ["c" "d" "e" "f" "g" "a" "b"])
+ (english . ["c" "d" "e" "f" "g" "a" "b"])
+ (deutsch . ["c" "d" "e" "f" "g" "a" "h"])
+ (norsk . ["c" "d" "e" "f" "g" "a" "h"])
+ (svenska . ["c" "d" "e" "f" "g" "a" "h"])
+ (italiano . ["do" "re" "mi" "fa" "sol" "la" "si"])
+ (catalan . ["do" "re" "mi" "fa" "sol" "la" "si"])
+ (espanol . ["do" "re" "mi" "fa" "sol" "la" "si"])))
+ (accidental . ((nederlands . ["eses" "es" "" "is" "isis"])
+ (english . ["ff" "f" "" "s" "ss"])
+ (deutsch . ["eses" "es" "" "is" "isis"])
+ (norsk . ["essess" "ess" "" "iss" "ississ"])
+ (svenska . ["essess" "ess" "" "iss" "ississ"])
+ (italiano . ["bb" "b" "" "d" "dd"])
+ (catalan . ["bb" "b" "" "d" "dd"])
+ (espanol . ["bb" "b" "" "s" "ss"])))
+ (replacements . ((nederlands . (("eeses" "eses") ("ees" "es")
+ ("aeses" "ases") ("aes" "as")))
+ (deutsch . (("hes" "b") ;("heses" "bes")
+ ("eeses" "eses") ("ees" "es")
+ ("aeses" "ases") ("aes" "as")))
+ (norsk . (("eessess" "essess") ("eess" "ess")
+ ("hess" "b") ("hessess" "bess")))
+ (svenska . (("eessess" "essess") ("eess" "ess")
+ ("aessess" "assess") ("aess" "ass")
+ ("hess" "b") ("hessess" "bess")))))
+ (rest . "r")
+ (skip . "s")
+ (octave-up . ?')
+ (octave-down . ?,)
+ (dot . ?.)
+ (reminder-accidental . ?!)
+ (cautionary-accidental . ??)))
+
+(defclass mudela-editing-state ()
+ ((translation-table :initarg :translation-table
+ :initform nil
+ :documentation "A mudela string or character <---> internal value translation table.")
+ (language :initarg :language
+ :initform nederlands
+ :documentation "Current output language")
+ (relative-octave :initarg :relative-octave
+ :initform nil
+ :documentation "Current octave mode. relative if non-nil, absolute otherwise.")
+ (force-duration :initarg :force-duration
+ :initform t
+ :documentation "Current duration output mode. always present if non-nil, ellipsed otherwise")
+ (pitch-dict :initarg :pitch-dict
+ :initform nil
+ :documentation "A mudela<->internal values dictionnnary for pitches and alterations")
+ (alterations :initarg :alterations
+ :initform [2 2 2 2 2 2 2]
+ :documenation "Last alteration for each note."))
+ "The current editing state : octave mode, language, etc.")
+
+;; (defmethod init-state ((editing-state mudela-editing-state) &optional lang)
+;; "Initialize `editing-state' pitch-dict due to `lang',
+;; and `translation-table' to `mudela-translation-table'."
+;; (setf (slot-value editing-state 'translation-table) mudela-translation-table)
+;; (with-slots (language) editing-state
+;; (set-language editing-state (or lang language)))
+;; editing-state)
+
+(defmethod get-translation ((editing-state mudela-editing-state) key)
+ "Return the value corresponding to `key' in `translation-table'"
+ (with-slots (translation-table) editing-state
+ (cdr (assoc key translation-table))))
+
+(defmethod get-pitch ((editing-state mudela-editing-state) pitch-string)
+ "Return a (pitch . alteration) pair corresponding to `pitch-string' in `pitch-dict' (if any)"
+ (with-slots (pitch-dict) editing-state
+ (car (rassoc pitch-string pitch-dict))))
+
+(defmethod get-pitch-string ((editing-state mudela-editing-state) pitch alteration)
+ "Return the mudela pitch string corresponding to the (`pitch' . `alteration') pair
+in `pitch-dict' (if any)"
+ (with-slots (pitch-dict) editing-state
+ (cdr (assoc (cons pitch alteration) pitch-dict))))
+
+(defmethod set-language ((editing-state mudela-editing-state) lang)
+ "Set the editing-state object's language and update its pitch-dict accordingly."
+ (labels ((get-translation2 (key)
+ (cdr (assoc lang (get-translation editing-state key)))))
+ (setf (slot-value editing-state 'language) (if (stringp lang) (intern lang) lang))
+ (setf (slot-value editing-state 'pitch-dict)
+ (let (dict)
+ (dotimes (pitch 7 (nreverse dict))
+ (dotimes (alter 5 dict)
+ (setq dict
+ (cons (cons (cons pitch alter)
+ (let ((note (concat (aref (get-translation2 'pitch) pitch)
+ (aref (get-translation2 'accidental) alter))))
+ (or (cadr (assoc note (get-translation2 'replacements)))
+ note)))
+ dict))))))
+ lang))
+
+;;;;;;;;;;;;;;;
+
+(defclass mudela-note-state ()
+ ((pitch :initarg :pitch
+ :initform 0
+ :documentation "Previous note pitch")
+ (octave :initarg :octave
+ :initform 1
+ :documentation "Previous note octave")
+ (duration :initarg :duration
+ :initform 3
+ :documentation "Previous music token duration")
+ (dots :initarg :dots
+ :initform 0
+ :documentation "Previous music token dot number"))
+ "Describe the current note state : current octave, duration, etc.")
+
+;;;;;;;;;;;;;;;;
+
+(defclass mudela-word ()
+ ((editing-state :allocation :class
+ :documentation "The current editing state (language, relative/absolute octaves, etc),
+used to generate mudela strings"))
+ "Base class for mudela words: notes, rests, skips, etc.")
+
+(defmethod mudela-string ((word mudela-word) &optional note-state)
+ "(return an empty string. should be reimplemented by derived classes)"
+ "")
+
+(defmethod set-alteration-up ((word mudela-word))
+ "Increase, if possible, the word alteration."
+ nil)
+
+(defmethod set-alteration-down ((word mudela-word))
+ "Decrease, if possible, the word alteration."
+ nil)
+
+(defmethod set-alteration-natural ((word mudela-word))
+ "Set, if possible, the word alteration to natural."
+ nil)
+
+(defmethod set-octave-up ((word mudela-word))
+ "Increase the word's octave."
+ nil)
+
+(defmethod set-octave-down ((word mudela-word))
+ "Decrease the word's octave."
+ nil)
+
+(defmethod set-octave-zero ((word mudela-word))
+ "Set the note octave to zero."
+ nil)
+
+(defmethod set-duration ((word mudela-word) duration)
+ "Set the word's duration."
+ duration)
+
+(defmethod set-dots ((word mudela-word))
+ "Increase, modulo 5, the word's dot number."
+ nil)
+
+(defmethod set-reminder-alt ((word mudela-word))
+ "Change reminder alteration state for word."
+ nil)
+
+(defmethod set-cautionary-alt ((word mudela-word))
+ "Change cautionary alteration state for word."
+ nil)
+
+(defmethod transpose ((word mudela-word) note-diff exact-pitch-diff &optional note-state)
+ "Transpose `word'."
+ word)
+
+(defclass mudela-word-duration (mudela-word)
+ ((duration :initarg :duration
+ :initform 3 ; 2^(3 - 1) = 4 ==> quater note
+ :documentation "duration, from 1 to 8. real-duration = 2^(duration - 1)")
+ (dots :initarg :dots
+ :initform 0 ; no dot
+ :documentation "dots, from 0 (no dot) to N>0 (N dots)"))
+ "A mudela word that have a duration information.")
+
+(defmethod set-duration ((word mudela-word-duration) duration)
+ "Set the word's duration."
+ (setf (slot-value word 'dots) 0)
+ (setf (slot-value word 'duration) duration))
+
+(defmethod set-dots ((word mudela-word-duration))
+ "Increase, modulo 5, the word's dot number."
+ (setf (slot-value word 'dots)
+ (mod (1+ (slot-value word 'dots)) 5)))
+
+(defmethod update-note-state ((word mudela-word-duration) note-state)
+ "Update the current `note-state' thanks to the given music `word': duration and dots."
+ (with-slots (duration dots) word
+ (setf (slot-value note-state 'duration) duration)
+ (setf (slot-value note-state 'dots) dots))
+ note-state)
+
+(defmethod mudela-duration ((word mudela-word-duration) &optional note-state)
+ "Return the mudela duration string for `word'. If `editing-state'
+indicates that duration is facultative, and `note-state' duration
+and dots are the same that `word' duration and dots, the string is empty."
+ (with-slots (duration dots editing-state) word
+ (if (and (not (slot-value editing-state 'force-duration))
+ note-state
+ (= duration (slot-value note-state 'duration))
+ (= dots (slot-value note-state 'dots)))
+ ;; same duration and dots, and user permit duration ellipse
+ ""
+ (format "%d%s"
+ (expt 2 (1- duration))
+ (make-string dots (get-translation editing-state 'dot))))))
+
+(defclass mudela-note (mudela-word-duration)
+ ((pitch :initarg :pitch
+ :initform 0 ; do / c
+ :documentation "note pitch, from 0 (do / c) to 6 (si / b)")
+ (alteration :initarg :alteration
+ :initform 2 ; becarre / natural
+ :documentation "note alteration, from 0 (bb) to 4 (##)")
+ (octave :initarg :octave
+ :initform 1
+ :documentation "note octave, 0 being the octave starting with the do / c
+which is in the 2nd interline in bass clef (4th line F clef)")
+ (reminder-accidental :initarg :reminder-accidental
+ :initform nil
+ :documentation "if non-nil, force a reminder accidental")
+ (cautionary-accidental :initarg :cautionary-accidental
+ :initform nil
+ :documentation "if non-nil and reminder-accidental is nil,
+indicate a cautionary accidental"))
+ "Note : duration and pitch")
+
+(defmethod set-alteration-natural ((note mudela-note))
+ "Set notes's alteration to natural"
+ ;; we update the alterations table in the current editing state
+ (aset (slot-value (slot-value note 'editing-state) 'alterations)
+ (slot-value note 'pitch)
+ 2)
+ ;; reset reminder and cautionary slots
+ (setf (slot-value note 'cautionary-accidental) nil)
+ (setf (slot-value note 'reminder-accidental) nil)
+ (setf (slot-value note 'alteration) 2))
+
+(defmethod set-alteration-up ((note mudela-note))
+ "Increase, if possible, the note alteration."
+ (with-slots (alteration) note
+ (when (< alteration 4)
+ ;; we update the alterations table in the current editing state
+ (aset (slot-value (slot-value note 'editing-state) 'alterations)
+ (slot-value note 'pitch)
+ (1+ alteration))
+ ;; reset reminder and cautionary slots
+ (setf (slot-value note 'cautionary-accidental) nil)
+ (setf (slot-value note 'reminder-accidental) nil)
+ (setf (slot-value note 'alteration) (1+ alteration)))))
+
+(defmethod set-alteration-down ((note mudela-note))
+ "Decrease, if possible, the note alteration."
+ (with-slots (alteration) note
+ (when (> alteration 0)
+ ;; we update the alterations table in the current editing state
+ (aset (slot-value (slot-value note 'editing-state) 'alterations)
+ (slot-value note 'pitch)
+ (1- alteration))
+ ;; reset reminder and cautionary slots
+ (setf (slot-value note 'cautionary-accidental) nil)
+ (setf (slot-value note 'reminder-accidental) nil)
+ (setf (slot-value note 'alteration) (1- alteration)))))
+
+(defmethod set-octave-up ((note mudela-note))
+ "Increase the note's octave."
+ (with-slots (octave) note
+ (when (< octave 4)
+ (setf (slot-value note 'octave) (1+ octave)))))
+
+(defmethod set-octave-down ((note mudela-note))
+ "Decrease the note's octave."
+ (with-slots (octave) note
+ (when (> octave -3)
+ (setf (slot-value note 'octave) (1- octave)))))
+
+(defmethod set-octave-zero ((note mudela-note))
+ "Set the note octave to zero."
+ (setf (slot-value note 'octave) 0))
+
+(defmethod set-reminder-alt ((note mudela-note))
+ "Change reminder alteration state for note."
+ (with-slots (reminder-accidental) note
+ (setf (slot-value note 'reminder-accidental) (not reminder-accidental))))
+
+(defmethod set-cautionary-alt ((note mudela-note))
+ "Change cautionary alteration state for note."
+ (with-slots (cautionary-accidental) note
+ (unless cautionary-accidental
+ (setf (slot-value note 'reminder-accidental) nil))
+ (setf (slot-value note 'cautionary-accidental) (not cautionary-accidental))))
+
+(defmethod update-note-state ((note mudela-note) note-state)
+ "Update the current `note-state' thanks to the given `note': duration, dots, pitch and octave."
+ (call-next-method)
+ (with-slots (pitch octave) note
+ (setf (slot-value note-state 'pitch) pitch)
+ (setf (slot-value note-state 'octave) octave))
+ note-state)
+
+(defmethod mudela-string ((note mudela-note) &optional note-state)
+ "Return the mudela string for `note', depending on the context
+given by `editing-state' and `note-state': pitch, accidental, octave,
+duration (with dots), reminder or cautionary accidental."
+ (format "%s%s%s%s"
+ (mudela-pitch note)
+ (mudela-octave note note-state)
+ (mudela-chromatic note)
+ (mudela-duration note note-state)))
+
+(defmethod mudela-pitch ((note mudela-note))
+ "Return the mudela pitch (with alteration) string for `note'"
+ (with-slots (pitch alteration editing-state) note
+ (get-pitch-string editing-state pitch alteration)))
+
+(defmethod mudela-octave ((note mudela-note) &optional note-state)
+ "Return the mudela octave string for `note'. In case of relative octave mode,
+`note-state' is mandatory."
+ (with-slots (pitch octave editing-state) note
+ (if (slot-value editing-state 'relative-octave)
+ ;; relative octave
+ (when note-state
+ (let ((abspitch1 (+ (* 7 (slot-value note-state 'octave))
+ (slot-value note-state 'pitch)))
+ (abspitch2 (+ (* 7 octave) pitch)))
+ (if (< (abs (- abspitch1 abspitch2)) 4)
+ "" ; same relative octave
+ (if (> abspitch1 abspitch2)
+ (make-string (+ (/ (- abspitch1 abspitch2 4) 7) 1)
+ (get-translation editing-state 'octave-down))
+ (make-string (+ (/ (- abspitch2 abspitch1 4) 7) 1)
+ (get-translation editing-state 'octave-up))))))
+ ;; absolute octave
+ (if (> octave 0)
+ (make-string octave (get-translation editing-state 'octave-up))
+ (make-string (* -1 octave) (get-translation editing-state 'octave-down))))))
+
+(defmethod mudela-chromatic ((note mudela-note))
+ "Return the mudela chromatic information string for `note'."
+ (with-slots (reminder-accidental cautionary-accidental editing-state) note
+ (cond (reminder-accidental
+ (char-to-string (get-translation editing-state 'reminder-accidental)))
+ (cautionary-accidental
+ (char-to-string (get-translation editing-state 'cautionary-accidental)))
+ (t ""))))
+
+(defmethod midi-pitch ((note mudela-note))
+ "Return `note''s midi pitch, from 0 to 127."
+ (with-slots (pitch alteration octave) note
+ (+ (aref [0 2 4 5 7 9 11] pitch)
+ (- alteration 2)
+ (* octave 12)
+ 48)))
+
+(defmethod transpose ((note mudela-note) note-diff exact-pitch-diff)
+ "Transpose `note'. Ex: (transpose [do] -5 -9) -> [mib,]"
+ (with-slots (pitch octave alteration) note
+ (let ((newnote (copy-sequence note)))
+ ;; pitch
+ (setf (slot-value newnote 'pitch) (mod (+ pitch note-diff) 7))
+ ;; octave
+ (cond ((< (+ pitch note-diff) 0)
+ (setf (slot-value newnote 'octave)
+ (+ octave (/ (+ pitch note-diff -6) 7))))
+ ((> (+ pitch note-diff) 6)
+ (setf (slot-value newnote 'octave)
+ (+ octave (/ (+ pitch note-diff) 7)))))
+ ;; alteration
+ (setf (slot-value newnote 'alteration)
+ (min (max (+ (- exact-pitch-diff (- (midi-pitch newnote) (midi-pitch note)))
+ alteration)
+ 0)
+ 4))
+ newnote)))
+
+
+(defclass mudela-rest (mudela-word-duration)
+ nil
+ "Rest.")
+
+(defmethod mudela-string ((rest mudela-rest) &optional note-state)
+ "Return the mudela string for `rest'."
+ (with-slots (editing-state) rest
+ (format "%s%s"
+ (get-translation editing-state 'rest)
+ (mudela-duration rest note-state))))
+
+(defclass mudela-skip (mudela-word-duration)
+ nil
+ "Skip.")
+
+(defmethod mudela-string ((skip mudela-skip) &optional note-state)
+ "Return the mudela string for `skip'."
+ (with-slots (editing-state) skip
+ (format "%s%s"
+ (get-translation editing-state 'skip)
+ (mudela-duration skip note-state))))
+
+(defclass mudela-verbatim (mudela-word)
+ ((text :initarg :text
+ :initform ""
+ :documentation "Verbatim mudela text, storing not recognized mudela words"))
+ "Not recognized text")
+
+(defmethod update-note-state ((verbatim mudela-verbatim) note-state)
+ "(do nothing)"
+ note-state)
+
+(defmethod mudela-string ((verbatim mudela-verbatim) &optional note-state)
+ "Return the verbatim mudela string contained in this object"
+ (with-slots (text) verbatim
+ text))
+
+(provide 'lyqi-base)
projects / lib.git / blobdiff