lilypond-mode

Emacs mode for editing LilyPond source
git clone https://git.jamzattack.xyz/lilypond-mode
Log | Files | Refs

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