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