elisp/lilypond-what-beat.el

   1 ; Features:
   2 ;
   3 ; -> Counts number of notes between last | and point. Adds durations of
   4 ; each note up, and returns result.
   5 ;
   6 ; -> Works well on notes and chords.
   7 ;
   8 ; -> Ignores most keywords, like \override
   9 ;
  10 ; -> Is aware of certain keywords which often contain parameters that
  11 ; look like notes, but should not be counted.
  12 ;  | a \key b \minor c    % b is not counted, but a and c are.
  13 ;
  14 ; -> Ignores Scheme expressions, which start with #
  15 ;
  16 ; -> Doesn't ignore the \times keyword. Intelligently handles triplets.
  17 ;
  18 ;
  19 ; Caveats:
  20 ;
  21 ; -> Doesn't work on regions that aren't preceded by a |. This is because such
  22 ; notes are only delimited by a {, and what-beat can't distinguish a { that
  23 ; opens a set of notes from an internal { (say from a triplet)
  24 ;
  25 ; -> Doesn't work with << >>  expressions or nested {} expressions (unless
  26 ; {} is part of a keyword like \times)
  27 ;
  28 ; -> Keywords abutted against a note are not visible to what-beat, and
  29 ; can therefore surreptitiosly sneak fake notes into what-beat.
  30 ; | c\glissando f       <- BAD:  the f gets counted, but shouldn't
  31 ; | c \glissando f      <- GOOD: the f gets ignored
  32 ;
  33 ; -> Does not look outside notes context. Derivation rules don't work:
  34 ; str = \notes { a8 b c d }
  35 ; \score { \notes { | e4 %{ gets counted }% \str %{gets ignored}%
  36 ;
  37 ; -> Does not handle repeats.
  38 ;
  39 ; -> Ignores \bar commands (and does not get confused by a | inside a \bar)
  40 ;
  41
  42 ; Recognizes pitch & octave
  43 (setq pitch-regex "\\([a-z]+[,']*\\|<[^>]*>\\)\\(=[,']*\\)?")
  44 ; Recognizes duration
  45 (setq duration-regex "[ \t\n]*\\(\\(\\(128\\|6?4\\|3?2\\|16?\\|8\\)\\([.]*\\)\\)\\([ \t]*[*][ \t]*\\([0-9]+\\)\\(/\\([1-9][0-9]*\\)\\)?\\)?\\)")
  46
  47 ; These keywords precede notes that should not be counted during beats
  48 (setq Parm-Keywords '("key" "clef" "appoggiatura" "acciaccatura" "grace"
  49                       "override" "revert" "glissando"))
  50
  51
  52 (defun extract-match (string match-num)
  53   (if (null (match-beginning match-num))
  54       nil
  55     (substring string (match-beginning match-num) (match-end match-num))))
  56
  57
  58 (defun add-fractions (f1 f2)
  59   "Adds two fractions, both are (numerator denominator)"
  60   (setq result (list (+ (* (car f1) (cadr f2)) (* (car f2) (cadr f1)))
  61                      (* (cadr f1) (cadr f2))))
  62   (setq result (reduce-fraction result 2))
  63   (setq result (reduce-fraction result 3))
  64   (setq result (reduce-fraction result 5))
  65   (setq result (reduce-fraction result 7))
  66 )
  67
  68
  69 (defun reduce-fraction (f divisor)
  70   "Eliminates divisor from fraction if present"
  71   (while (and (= 0 (% (car result) divisor))
  72               (= 0 (% (cadr result) divisor))
  73               (< 1 (cadr result))
  74               (< 0 (car result)))
  75     (setq result (list (/ (car result) divisor) (/ (cadr result) divisor))))
  76   result
  77 )
  78
  79
  80 (defun parse-duration (duration)
  81   "Returns a duration string parsed as '(numerator denominator)"
  82   (string-match duration-regex duration)
  83   (let ((result (list 1 (string-to-number (extract-match duration 2))))
  84         (dots (extract-match duration 4))
  85         (numerator (or (extract-match duration 6) "1"))
  86         (denominator (or (extract-match duration 8) "1")))
  87     (if (and (not (null dots)) (< 0 (string-width dots)))
  88         (dotimes (dummy (string-width dots))
  89           (setq result (list (1+ (* 2 (car result))) (* 2 (cadr result))))))
  90     (list (* (string-to-number numerator) (car result))
  91           (* (string-to-number denominator) (cadr result)))
  92 ))
  93
  94 (defun walk-note-duration ()
  95   "Returns duration of next note, moving point past note.
  96 If point is not before a note, returns nil
  97 If next note has no duration, returns t"
  98   (let ((have-pitch (looking-at pitch-regex)))
  99     (if have-pitch (goto-char (match-end 0)))
 100     (if (not (looking-at duration-regex))
 101         have-pitch
 102       (goto-char (match-end 0))
 103       (parse-duration (match-string 0)))))
 104
 105 ; returns nil if not at a comment
 106 (defun skip-comment ()
 107   (if (not (char-equal ?\% (following-char)))
 108       nil
 109     (progn
 110       (forward-char)
 111       (if (char-equal ?\{ (following-char))
 112           (re-search-forward "}%" nil t)
 113         (progn
 114           (skip-chars-forward "^\n")
 115           (forward-char)))
 116       t
 117 )))
 118
 119 ; returns nil if not at a quotation
 120 (defun skip-quotation ()
 121   (if (not (char-equal ?\" (following-char)))
 122       nil
 123     (progn
 124       (forward-char)
 125       (skip-chars-forward "^\"")
 126       (forward-char)
 127       t
 128 )))
 129
 130 ; returns nil if not at a sexp
 131 (defun skip-sexp ()
 132   (interactive)
 133   (if (not (char-equal ?\# (following-char)))
 134       nil
 135     (progn
 136       (forward-char)
 137       (if (char-equal ?\' (following-char))
 138           (forward-char))
 139       (if (not (char-equal ?\( (following-char)))
 140           (skip-chars-forward "^ \t\n")
 141         (progn
 142           (let ((paren 1))
 143             (while (< 0 paren)
 144               (forward-char)
 145               (cond ((char-equal ?\( (following-char))
 146                      (setq paren (1+ paren)))
 147                     ((char-equal ?\) (following-char))
 148                      (setq paren (1- paren)))))
 149             (forward-char)
 150             t
 151 ))))))
 152
 153 (defun goto-note-begin ()
 154   (interactive)
 155   ; skip anything that is not ws. And skip any comments or quotations
 156   (while (or (< 0 (skip-chars-forward "^ \t\n~%#\""))
 157              (skip-comment)
 158              (skip-quotation)
 159              (skip-sexp)))
 160   ; Now skip anything that isn't alphanum or \. And skip comments or quotations
 161   (while (or (< 0 (skip-chars-forward "^A-Za-z1-9<%}#=\""))
 162              (skip-comment)
 163              (skip-quotation)
 164              (skip-sexp)))
 165   ; (skip-chars-forward "^\\") Why doesn't this work?!!
 166   (if (char-equal ?\\ (preceding-char))
 167       (backward-char))
 168 )
 169
 170
 171 (defun skip-good-keywords ()
 172   (if (looking-at "\\\\\\([a-z]*\\)")
 173       (progn
 174         (goto-char (match-end 0))
 175         (if (member (match-string 1) Parm-Keywords)
 176             (progn
 177               (if (looking-at "[ \t\n]*?\\([a-z0-9_]+\\|{[^}]*}\\|\"[^\"]*\"\\)")
 178                   (goto-char (match-end 0))
 179                 (error "Improper regex match:")
 180                 (error "Unknown text: %s")
 181 ))))))
 182
 183 (defun find-measure-start ()
 184   (let ((start (re-search-backward "\|" 0 t)))
 185     (if (null start)
 186         -1
 187       (if (looking-at "[^ \n\t]*\"")
 188           (find-measure-start)
 189         (point)
 190 ))))
 191
 192 (defun get-beat ()
 193   (save-excursion
 194     (save-restriction
 195       (let* ((end (point))
 196              (measure-start (find-measure-start))
 197              (last-dur (or (re-search-backward duration-regex 0 t) -1))
 198              (duration (if (= -1 last-dur) 0 (parse-duration (match-string 0))))
 199              (result '(0 1)))           ; 0 in fraction form
 200         (if (= measure-start -1)
 201             (message "No | before point")
 202           (goto-char (1+ measure-start))
 203           (goto-note-begin)
 204           (while (< (point) end)
 205             (let ((new-duration (walk-note-duration)))
 206               (if (null new-duration)
 207                   (if (not (looking-at
 208                             (concat "\\\\t\\(?:\\(imes\\)\\|uplet\\)[ \t]*\\([0-9]+\\)/\\([0-9]+\\)\\(?:[ \t\n]"
 209                                     duration-regex "\\)?[ \t\n]*{")))
 210                       (skip-good-keywords)
 211
 212                                         ; handle \times/\tuplet specially
 213                     (let* ((times-p (match-beginning 1))
 214                            (numerator (string-to-number (match-string (if times-p 2 3))))
 215                            (denominator (string-to-number (match-string (if times-p 3 2)))))
 216                       (goto-char (match-end 0))
 217                       (goto-note-begin)
 218                       (while (and (not (looking-at "}"))
 219                                   (< (point) end))
 220                         (setq new-duration (walk-note-duration))
 221                         (if (null new-duration)
 222                             (if (looking-at "\\\\[a-z]*[ \t]*[a-z]*")
 223                                 (goto-char (match-end 0))
 224                               (error "Unknown text: %S %s" result(buffer-substring (point) end))))
 225                         (if (not (eq new-duration t))
 226                             (setq duration new-duration))
 227                         (setq result (add-fractions result
 228                                                     (list (* numerator (car duration))
 229                                                           (* denominator (cadr duration)))))
 230                         (goto-note-begin))
 231                       (if (< (point) end)
 232                           (forward-char 1)))) ; skip }
 233
 234                 (if (not (eq new-duration t))
 235                     (setq duration new-duration))
 236                 (setq result (add-fractions result duration)))
 237               (goto-note-begin)))
 238
 239           result)))))
 240
 241 (defun LilyPond-what-beat ()
 242   "Returns how much of a measure lies between last measaure '|' and point.
 243 Recognizes chords, and triples."
 244   (interactive)
 245   (let ((beat (get-beat)))
 246     (message "Beat: %d/%d" (car beat) (cadr beat)))
 247 )
 248
 249 (defun LilyPond-electric-bar ()
 250   "Indicate the number of beats in last measure when a | is inserted"
 251   (interactive)
 252   (self-insert-command 1)
 253   (save-excursion
 254     (save-restriction
 255       (backward-char)
 256       (LilyPond-what-beat)
 257       (forward-char)
 258 )))
 259
 260