emacs_el/lyqi-base.el

   1 ;;      $RCSfile: lyqi-base.el,v $
   2 ;;      $Revision: 1.5 $
   3 ;;      $Date: 2003/09/27 16:59:27 $
   4 ;;      $Author: nicolas $
   5 ;;;
   6 ;;; Part of lyqi, a major emacs mode derived from LilyPond-Mode,
   7 ;;; for quick note insertion while editing GNU LilyPond music scores.
   8 ;;;
   9 ;;; (c) copyright 2003 Nicolas Sceaux <nicolas.sceaux@free.fr>
  10 ;;; See http://nicolas.sceaux.free.fr/lilypond/
  11 ;;;
  12
  13 (eval-when-compile (require 'cl))
  14 (require 'eieio)
  15
  16 ;;;;;;;;;;;;;;;;
  17
  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")))))
  45     (rest . "r")
  46     (skip . "s")
  47     (octave-up . ?')
  48     (octave-down . ?,)
  49     (dot . ?.)
  50     (reminder-accidental . ?!)
  51     (cautionary-accidental . ??)))
  52
  53 (defclass mudela-editing-state ()
  54   ((translation-table :initarg :translation-table
  55                       :initform nil
  56                       :documentation "A mudela string or character <---> internal value translation table.")
  57    (language :initarg :language
  58              :initform nederlands
  59              :documentation "Current output language")
  60    (relative-octave :initarg :relative-octave
  61                     :initform nil
  62                     :documentation "Current octave mode. relative if non-nil, absolute otherwise.")
  63    (force-duration :initarg :force-duration
  64                    :initform t
  65                    :documentation "Current duration output mode. always present if non-nil, ellipsed otherwise")
  66    (pitch-dict :initarg :pitch-dict
  67                :initform nil
  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.")
  73
  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)))
  80 ;;   editing-state)
  81
  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))))
  86
  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))))
  91
  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))))
  97
  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)
 104           (let (dict)
 105             (dotimes (pitch 7 (nreverse dict))
 106               (dotimes (alter 5 dict)
 107                 (setq 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)))
 112                                         note)))
 113                             dict))))))
 114     lang))
 115
 116 ;;;;;;;;;;;;;;;
 117
 118 (defclass mudela-note-state ()
 119   ((pitch :initarg :pitch
 120           :initform 0
 121           :documentation "Previous note pitch")
 122    (octave :initarg :octave
 123            :initform 1
 124            :documentation "Previous note octave")
 125    (duration :initarg :duration
 126              :initform 3
 127              :documentation "Previous music token duration")
 128    (dots :initarg :dots
 129          :initform 0
 130          :documentation "Previous music token dot number"))
 131   "Describe the current note state : current octave, duration, etc.")
 132
 133 ;;;;;;;;;;;;;;;;
 134
 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.")
 140
 141 (defmethod mudela-string ((word mudela-word) &optional note-state)
 142   "(return an empty string. should be reimplemented by derived classes)"
 143   "")
 144
 145 (defmethod set-alteration-up ((word mudela-word))
 146   "Increase, if possible, the word alteration."
 147   nil)
 148
 149 (defmethod set-alteration-down ((word mudela-word))
 150   "Decrease, if possible, the word alteration."
 151   nil)
 152
 153 (defmethod set-alteration-natural ((word mudela-word))
 154   "Set, if possible, the word alteration to natural."
 155   nil)
 156
 157 (defmethod set-octave-up ((word mudela-word))
 158   "Increase the word's octave."
 159   nil)
 160
 161 (defmethod set-octave-down ((word mudela-word))
 162   "Decrease the word's octave."
 163   nil)
 164
 165 (defmethod set-octave-zero ((word mudela-word))
 166   "Set the note octave to zero."
 167   nil)
 168
 169 (defmethod set-duration ((word mudela-word) duration)
 170   "Set the word's duration."
 171   duration)
 172
 173 (defmethod set-dots ((word mudela-word))
 174   "Increase, modulo 5, the word's dot number."
 175   nil)
 176
 177 (defmethod set-reminder-alt ((word mudela-word))
 178   "Change reminder alteration state for word."
 179   nil)
 180
 181 (defmethod set-cautionary-alt ((word mudela-word))
 182   "Change cautionary alteration state for word."
 183   nil)
 184
 185 (defmethod transpose ((word mudela-word) note-diff exact-pitch-diff &optional note-state)
 186   "Transpose `word'."
 187   word)
 188
 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)")
 193    (dots :initarg :dots
 194          :initform 0                    ; no dot
 195          :documentation "dots, from 0 (no dot) to N>0 (N dots)"))
 196   "A mudela word that have a duration information.")
 197
 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))
 202
 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)))
 207
 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))
 213   note-state)
 214
 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))
 221              note-state
 222              (= duration (slot-value note-state 'duration))
 223              (= dots     (slot-value note-state 'dots)))
 224         ;; same duration and dots, and user permit duration ellipse
 225         ""
 226         (format "%d%s"
 227                 (expt 2 (1- duration))
 228                 (make-string dots (get-translation editing-state 'dot))))))
 229
 230 (defclass mudela-note (mudela-word-duration)
 231   ((pitch :initarg :pitch
 232           :initform 0                   ; do / c
 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
 238            :initform 1
 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
 242                         :initform nil
 243                         :documentation "if non-nil, force a reminder accidental")
 244    (cautionary-accidental :initarg :cautionary-accidental
 245                           :initform nil
 246                           :documentation "if non-nil and reminder-accidental is nil,
 247 indicate a cautionary accidental"))
 248   "Note : duration and pitch")
 249
 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)
 255         2)
 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))
 260
 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)
 268             (1+ alteration))
 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)))))
 273
 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)
 281             (1- alteration))
 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)))))
 286
 287 (defmethod set-octave-up ((note mudela-note))
 288   "Increase the note's octave."
 289   (with-slots (octave) note
 290     (when (< octave 4)
 291       (setf (slot-value note 'octave) (1+ octave)))))
 292
 293 (defmethod set-octave-down ((note mudela-note))
 294   "Decrease the note's octave."
 295   (with-slots (octave) note
 296     (when (> octave -3)
 297       (setf (slot-value note 'octave) (1- octave)))))
 298
 299 (defmethod set-octave-zero ((note mudela-note))
 300   "Set the note octave to zero."
 301   (setf (slot-value note 'octave) 0))
 302
 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))))
 307
 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))))
 314
 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."
 317   (call-next-method)
 318   (with-slots (pitch octave) note
 319     (setf (slot-value note-state 'pitch) pitch)
 320     (setf (slot-value note-state 'octave) octave))
 321   note-state)
 322
 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."
 327   (format "%s%s%s%s"
 328           (mudela-pitch note)
 329           (mudela-octave note note-state)
 330           (mudela-chromatic note)
 331           (mudela-duration note note-state)))
 332
 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)))
 337
 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)
 343         ;; relative octave
 344         (when note-state
 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))))))
 355         ;; absolute octave
 356         (if (> octave 0)
 357             (make-string octave (get-translation editing-state 'octave-up))
 358             (make-string (* -1 octave) (get-translation editing-state 'octave-down))))))
 359
 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)))
 367           (t ""))))
 368
 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)
 373        (- alteration 2)
 374        (* octave 12)
 375        48)))
 376
 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)))
 381       ;; pitch
 382       (setf (slot-value newnote 'pitch) (mod (+ pitch note-diff) 7))
 383       ;; octave
 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)))))
 390       ;; alteration
 391       (setf (slot-value newnote 'alteration)
 392             (min (max (+ (- exact-pitch-diff (- (midi-pitch newnote) (midi-pitch note)))
 393                          alteration)
 394                       0)
 395                  4))
 396       newnote)))
 397
 398
 399 (defclass mudela-rest (mudela-word-duration)
 400   nil
 401   "Rest.")
 402
 403 (defmethod mudela-string ((rest mudela-rest) &optional note-state)
 404   "Return the mudela string for `rest'."
 405   (with-slots (editing-state) rest
 406     (format "%s%s"
 407             (get-translation editing-state 'rest)
 408             (mudela-duration rest note-state))))
 409
 410 (defclass mudela-skip (mudela-word-duration)
 411   nil
 412   "Skip.")
 413
 414 (defmethod mudela-string ((skip mudela-skip) &optional note-state)
 415   "Return the mudela string for `skip'."
 416   (with-slots (editing-state) skip
 417     (format "%s%s"
 418             (get-translation editing-state 'skip)
 419             (mudela-duration skip note-state))))
 420
 421 (defclass mudela-verbatim (mudela-word)
 422   ((text :initarg :text
 423          :initform ""
 424          :documentation "Verbatim mudela text, storing not recognized mudela words"))
 425   "Not recognized text")
 426
 427 (defmethod update-note-state ((verbatim mudela-verbatim) note-state)
 428   "(do nothing)"
 429   note-state)
 430
 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
 434     text))
 435
 436 (provide 'lyqi-base)