elisp/lilypond-what-beat.el

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