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   (set 'result (list (+ (* (car f1) (cadr f2)) (* (car f2) (cadr f1)))
  61                      (* (cadr f1) (cadr f2))))
  62   (set 'result (reduce-fraction result 2))
  63   (set 'result (reduce-fraction result 3))
  64   (set 'result (reduce-fraction result 5))
  65   (set '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     (set '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-int (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           (set 'result (list (1+ (* 2 (car result))) (* 2 (cadr result))))))
  90     (list (* (string-to-int numerator) (car result))
  91           (* (string-to-int 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   (if (not (looking-at pitch-regex))
  99       nil
 100     (progn
 101       (goto-char (match-end 0))
 102       (if (not (looking-at duration-regex))
 103           t
 104         (progn
 105           (goto-char (match-end 0))
 106           (parse-duration (match-string 0)))))))
 107
 108 ; returns nil if not at a comment
 109 (defun skip-comment ()
 110   (if (not (char-equal ?\% (following-char)))
 111       nil
 112     (progn
 113       (forward-char)
 114       (if (char-equal ?\{ (following-char))
 115           (re-search-forward "}%" nil t)
 116         (progn
 117           (skip-chars-forward "^\n")
 118           (forward-char)))
 119       t
 120 )))
 121
 122 ; returns nil if not at a quotation
 123 (defun skip-quotation ()
 124   (if (not (char-equal ?\" (following-char)))
 125       nil
 126     (progn
 127       (forward-char)
 128       (skip-chars-forward "^\"")
 129       (forward-char)
 130       t
 131 )))
 132
 133 ; returns nil if not at a sexp
 134 (defun skip-sexp ()
 135   (interactive)
 136   (if (not (char-equal ?\# (following-char)))
 137       nil
 138     (progn
 139       (forward-char)
 140       (if (char-equal ?\' (following-char))
 141           (forward-char))
 142       (if (not (char-equal ?\( (following-char)))
 143           (skip-chars-forward "^ \t\n")
 144         (progn
 145           (let ((paren 1))
 146             (while (< 0 paren)
 147               (forward-char)
 148               (cond ((char-equal ?\( (following-char))
 149                      (setq paren (1+ paren)))
 150                     ((char-equal ?\) (following-char))
 151                      (setq paren (1- paren)))))
 152             (forward-char)
 153             t
 154 ))))))
 155
 156 (defun goto-note-begin ()
 157   (interactive)
 158   ; skip anything that is not ws. And skip any comments or quotations
 159   (while (or (< 0 (skip-chars-forward "^ \t\n~%#\""))
 160              (skip-comment)
 161              (skip-quotation)
 162              (skip-sexp)))
 163   ; Now skip anything that isn't alphanum or \. And skip comments or quotations
 164   (while (or (< 0 (skip-chars-forward "^A-Za-z<%}#=\""))
 165              (skip-comment)
 166              (skip-quotation)
 167              (skip-sexp)))
 168   ; (skip-chars-forward "^\\") Why doesn't this work?!!
 169   (if (char-equal ?\\ (preceding-char))
 170       (backward-char))
 171 )
 172
 173
 174 (defun skip-good-keywords ()
 175   (if (looking-at "\\\\\\([a-z]*\\)")
 176       (progn
 177         (goto-char (match-end 0))
 178         (if (member (match-string 1) Parm-Keywords)
 179             (progn
 180               (if (looking-at "[ \t\n]*?\\([a-z0-9_]+\\|{[^}]*}\\|\"[^\"]*\"\\)")
 181                   (goto-char (match-end 0))
 182                 (error "Improper regex match:")
 183                 (error "Unknown text: %s")
 184 ))))))
 185
 186 (defun find-measure-start ()
 187   (let ((start (re-search-backward "\|" 0 t)))
 188     (if (null start)
 189         -1
 190       (if (looking-at "[^ \n\t]*\"")
 191           (find-measure-start)
 192         (point)
 193 ))))
 194
 195 (defun get-beat ()
 196   (save-excursion
 197     (save-restriction
 198       (let* ((end (point))
 199              (measure-start (find-measure-start))
 200              (last-dur (or (re-search-backward duration-regex 0 t) -1))
 201              (duration (if (= -1 last-dur) 0 (parse-duration (match-string 0))))
 202              (result '(0 1)))           ; 0 in fraction form
 203         (if (= measure-start -1)
 204             (error "No | before point")
 205           (progn
 206             (goto-char (1+ measure-start))
 207             (goto-note-begin)
 208             (while (< (point) end)
 209               (set 'new-duration (walk-note-duration))
 210               (if (null new-duration)
 211                   (if (not (looking-at "\\\\times[ \t]*\\([1-9]*\\)/\\([1-9]*\\)[ \t\n]*{"))
 212                       (skip-good-keywords)
 213
 214                                         ; handle \times specially
 215                     (let ((numerator (string-to-int (match-string 1)))
 216                           (denominator (string-to-int (match-string 2))))
 217                       (goto-char (match-end 0))
 218                       (goto-note-begin)
 219                       (while (and (not (looking-at "}"))
 220                                   (< (point) end))
 221                         (set 'new-duration (walk-note-duration))
 222                         (if (null new-duration)
 223                             (if (looking-at "\\\\[a-z]*[ \t]*[a-z]*")
 224                                 (goto-char (match-end 0))
 225                               (error "Unknown text: %S %s" result(buffer-substring (point) end))))
 226                         (if (not (eq new-duration t))
 227                             (set 'duration new-duration))
 228                         (set 'result (add-fractions result
 229                                                     (list (* numerator (car duration))
 230                                                           (* denominator (cadr duration)))))
 231                         (goto-note-begin))
 232                       (if (< (point) end)
 233                           (forward-char 1)))) ; skip }
 234
 235                 (if (not (eq new-duration t))
 236                     (set 'duration new-duration))
 237                 (set 'result (add-fractions result duration)))
 238               (goto-note-begin))
 239
 240             result
 241 ))))))
 242
 243 (defun LilyPond-what-beat ()
 244   "Returns how much of a measure lies between last measaure '|' and point.
 245 Recognizes chords, and triples."
 246   (interactive)
 247   (let ((beat (get-beat)))
 248     (message "Beat: %d/%d" (car beat) (cadr beat)))
 249 )
 250
 251 (defun LilyPond-electric-bar ()
 252   "Indicate the number of beats in last measure when a | is inserted"
 253   (interactive)
 254   (self-insert-command 1)
 255   (save-excursion
 256     (save-restriction
 257       (backward-char)
 258       (LilyPond-what-beat)
 259       (forward-char)
 260 )))
 261
 262