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 \r
  40 ; Recognizes pitch & octave\r
  41 (setq pitch-regex "\\([a-z]+[,']*\\|<[^>]*>\\)\\(=[,']*\\)?")\r
  42 ; Recognizes duration\r
  43 (setq duration-regex "[ \t\n]*\\(\\(\\(128\\|6?4\\|3?2\\|16?\\|8\\)\\([.]*\\)\\)\\([ \t]*[*][ \t]*\\([0-9]+\\)\\(/\\([1-9][0-9]*\\)\\)?\\)?\\)")\r
  44 \r
  45 ; These keywords precede notes that should not be counted during beats\r
  46 (setq Parm-Keywords '("key" "clef" "appoggiatura" "acciaccatura" "grace"\r
  47                       "override" "revert" "glissando"))\r
  48 \r
  49 \r
  50 (defun extract-match (string match-num)\r
  51   (if (null (match-beginning match-num))\r
  52       nil\r
  53     (substring string (match-beginning match-num) (match-end match-num))))\r
  54 \r
  55 \r
  56 (defun add-fractions (f1 f2)\r
  57   "Adds two fractions, both are (numerator denominator)"\r
  58   (set 'result (list (+ (* (car f1) (cadr f2)) (* (car f2) (cadr f1)))\r
  59                      (* (cadr f1) (cadr f2))))\r
  60   (set 'result (reduce-fraction result 2))\r
  61   (set 'result (reduce-fraction result 3))\r
  62   (set 'result (reduce-fraction result 5))\r
  63   (set 'result (reduce-fraction result 7))\r
  64 )\r
  65 \r
  66 \r
  67 (defun reduce-fraction (f divisor)\r
  68   "Eliminates divisor from fraction if present"\r
  69   (while (and (= 0 (% (car result) divisor))\r
  70               (= 0 (% (cadr result) divisor))\r
  71               (< 1 (cadr result))\r
  72               (< 0 (car result)))\r
  73     (set 'result (list (/ (car result) divisor) (/ (cadr result) divisor))))\r
  74   result\r
  75 )\r
  76 \r
  77 \r
  78 (defun parse-duration (duration)\r
  79   "Returns a duration string parsed as '(numerator denominator)"\r
  80   (string-match duration-regex duration)\r
  81   (let ((result (list 1 (string-to-int (extract-match duration 2))))\r
  82         (dots (extract-match duration 4))\r
  83         (numerator (or (extract-match duration 6) "1"))\r
  84         (denominator (or (extract-match duration 8) "1")))\r
  85     (if (and (not (null dots)) (< 0 (string-width dots)))\r
  86         (dotimes (dummy (string-width dots))\r
  87           (set 'result (list (1+ (* 2 (car result))) (* 2 (cadr result))))))\r
  88     (list (* (string-to-int numerator) (car result))\r
  89           (* (string-to-int denominator) (cadr result)))\r
  90 ))\r
  91 \r
  92 (defun walk-note-duration ()\r
  93 "Returns duration of next note, moving point past note.\r
  94 If point is not before a note, returns nil\r
  95 If next note has no duration, returns t"\r
  96   (if (not (looking-at pitch-regex))\r
  97       nil\r
  98     (progn\r
  99       (goto-char (match-end 0))\r
 100       (if (not (looking-at duration-regex))\r
 101           t\r
 102         (progn\r
 103           (goto-char (match-end 0))\r
 104           (parse-duration (match-string 0)))))))\r
 105 \r
 106 ; returns nil if not at a comment\r
 107 (defun skip-comment ()\r
 108   (if (not (char-equal ?\% (following-char)))\r
 109       nil\r
 110     (progn\r
 111       (forward-char)\r
 112       (if (char-equal ?\{ (following-char))\r
 113           (re-search-forward "}%" nil t)\r
 114         (progn\r
 115           (skip-chars-forward "^\n")\r
 116           (forward-char)))\r
 117       t\r
 118 )))\r
 119 \r
 120 ; returns nil if not at a quotation\r
 121 (defun skip-quotation ()\r
 122   (if (not (char-equal ?\" (following-char)))\r
 123       nil\r
 124     (progn\r
 125       (forward-char)\r
 126       (skip-chars-forward "^\"")\r
 127       (forward-char)\r
 128       t\r
 129 )))\r
 130 \r
 131 ; returns nil if not at a sexp\r
 132 (defun skip-sexp ()\r
 133   (interactive)\r
 134   (if (not (char-equal ?\# (following-char)))\r
 135       nil\r
 136     (progn\r
 137       (forward-char)\r
 138       (if (char-equal ?\' (following-char))\r
 139           (forward-char))\r
 140       (if (not (char-equal ?\( (following-char)))\r
 141           (skip-chars-forward "^ \t\n")\r
 142         (progn\r
 143           (let ((paren 1))\r
 144             (while (< 0 paren)\r
 145               (forward-char)\r
 146               (cond ((char-equal ?\( (following-char))\r
 147                      (setq paren (1+ paren)))\r
 148                     ((char-equal ?\) (following-char))\r
 149                      (setq paren (1- paren)))))\r
 150             (forward-char)\r
 151             t\r
 152 ))))))\r
 153 \r
 154 (defun goto-note-begin ()\r
 155   (interactive)\r
 156   ; skip anything that is not ws. And skip any comments or quotations\r
 157   (while (or (< 0 (skip-chars-forward "^ \t\n~%#\""))\r
 158              (skip-comment)\r
 159              (skip-quotation)\r
 160              (skip-sexp)))\r
 161   ; Now skip anything that isn't alphanum or \. And skip comments or quotations\r
 162   (while (or (< 0 (skip-chars-forward "^A-Za-z<%}#=\""))\r
 163              (skip-comment)\r
 164              (skip-quotation)\r
 165              (skip-sexp)))\r
 166   ; (skip-chars-forward "^\\") Why doesn't this work?!!\r
 167   (if (char-equal ?\\ (preceding-char))\r
 168       (backward-char))\r
 169 )\r
 170 \r
 171 \r
 172 (defun skip-good-keywords ()\r
 173   (if (looking-at "\\\\\\([a-z]*\\)")\r
 174       (progn\r
 175         (goto-char (match-end 0))\r
 176         (if (member (match-string 1) Parm-Keywords)\r
 177             (progn\r
 178               (if (looking-at "[ \t\n]*\\([a-z0-9_]+\\|{[^}]*}\\)")\r
 179                   (goto-char (match-end 0))\r
 180                 (error "Improper regex match:")\r
 181                 (error "Unknown text: %s")\r
 182 ))))))\r
 183 \r
 184 (defun get-beat ()\r
 185   (save-excursion\r
 186     (save-restriction\r
 187       (let* ((end (point))\r
 188              (measure-start (or (re-search-backward "\|" 0 t) -1))\r
 189              (last-dur (or (re-search-backward duration-regex 0 t) -1))\r
 190              (duration (if (= -1 last-dur) 0 (parse-duration (match-string 0))))\r
 191              (result '(0 1)))           ; 0 in fraction form\r
 192         (if (= measure-start -1)\r
 193             (error "No | before point")\r
 194           (progn\r
 195             (goto-char (1+ measure-start))\r
 196             (goto-note-begin)\r
 197             (while (< (point) end)\r
 198               (set 'new-duration (walk-note-duration))\r
 199               (if (null new-duration)\r
 200                   (if (not (looking-at "\\\\times[ \t]*\\([1-9]*\\)/\\([1-9]*\\)[ \t\n]*{"))\r
 201                       (skip-good-keywords)\r
 202 \r
 203                                         ; handle \times specially\r
 204                     (let ((numerator (string-to-int (match-string 1)))\r
 205                           (denominator (string-to-int (match-string 2))))\r
 206                       (goto-char (match-end 0))\r
 207                       (goto-note-begin)\r
 208                       (while (and (not (looking-at "}"))\r
 209                                   (< (point) end))\r
 210                         (set 'new-duration (walk-note-duration))\r
 211                         (if (null new-duration)\r
 212                             (if (looking-at "\\\\[a-z]*[ \t]*[a-z]*")\r
 213                                 (goto-char (match-end 0))\r
 214                               (error "Unknown text: %S %s" result(buffer-substring (point) end))))\r
 215                         (if (not (eq new-duration t))\r
 216                             (set 'duration new-duration))\r
 217                         (set 'result (add-fractions result\r
 218                                                     (list (* numerator (car duration))\r
 219                                                           (* denominator (cadr duration)))))\r
 220                         (goto-note-begin))\r
 221                       (if (< (point) end)\r
 222                           (forward-char 1)))) ; skip }\r
 223 \r
 224                 (if (not (eq new-duration t))\r
 225                     (set 'duration new-duration))\r
 226                 (set 'result (add-fractions result duration)))\r
 227               (goto-note-begin))\r
 228 \r
 229             result\r
 230 ))))))\r
 231 \r
 232 (defun LilyPond-what-beat ()\r
 233   "Returns how much of a measure lies between last measaure '|' and point.\r
 234 Recognizes chords, and triples."\r
 235   (interactive)\r
 236   (let ((beat (get-beat)))\r
 237     (message "Beat: %d/%d" (car beat) (cadr beat)))\r
 238 )\r
 239 \r
 240 (defun LilyPond-electric-bar ()\r
 241   "Indicate the number of beats in last measure when a | is inserted"\r
 242   (interactive)\r
 243   (self-insert-command 1)\r
 244   (save-excursion\r
 245     (save-restriction\r
 246       (backward-char)\r
 247       (LilyPond-what-beat)\r
 248       (forward-char)\r
 249 )))\r
 250 \r
 251 \r