lib/libmusic.scm

   1 ;------------------------------------------------------------------;
   2 ; opus_libre -- libmusic.scm                                       ;
   3 ;                                                                  ;
   4 ; (c) 2008-2011 Valentin Villenave <valentin@villenave.net>        ;
   5 ;                                                                  ;
   6 ;     opus_libre is a free framework for GNU LilyPond: you may     ;
   7 ; redistribute it and/or modify it under the terms of the GNU      ;
   8 ; General Public License as published by the Free Software         ;
   9 ; Foundation, either version 3 of the License, or (at your option) ;
  10 ; any later version.                                               ;
  11 ;     This program is distributed WITHOUT ANY WARRANTY; without    ;
  12 ; even the implied warranty of MERCHANTABILITY or FITNESS FOR A    ;
  13 ; PARTICULAR PURPOSE.  You should have received a copy of the GNU  ;
  14 ; General Public License along with this program (typically in the ;
  15 ; share/doc/ directory).  If not, see http://www.gnu.org/licenses/ ;
  16 ;                                                                  ;
  17 ;------------------------------------------------------------------;
  18
  19
  20 ; Music functions.
  21
  22 ;; Articulation marks -- after Gilles Thibault's snippet: see
  23 ;; http://lists.gnu.org/archive/html/lilypond-user/2008-06/msg00012.html
  24
  25 (define tieEvent? #f)
  26
  27 (define (add-script music x)
  28   (let ((eventname (ly:music-property  music 'name))
  29         (elts (ly:music-property music 'elements))
  30         (elt  (ly:music-property music 'element))
  31         (rest '()))
  32     (if (list? x)
  33         (begin
  34           (set! rest (cdr x))
  35           (set! x (car x))))
  36     (cond
  37      ((pair? elts)
  38       (begin
  39         (if (and
  40              (eq? eventname 'EventChord)
  41              (eq? (ly:music-property (car elts) 'name) 'NoteEvent)
  42              (not tieEvent?))
  43             (set! (ly:music-property music 'elements)
  44                   (append elts (list
  45                                 (make-music
  46                                  'ArticulationEvent
  47                                  'articulation-type x))))
  48             (set! tieEvent? #f))
  49         (map (lambda (m) (add-script m x)) elts)))
  50      ((ly:music? elt) (add-script elt x))
  51      ((eq? eventname 'TieEvent) (set! tieEvent? #t)))
  52     (if (not-null? rest) (add-script music rest))
  53     music))
  54
  55
  56 ;; Automatic octavation -- after Jay Anderson:
  57 ;; http://lists.gnu.org/archive/html/lilypond-user/2008-04/msg00431.html
  58 ;; http://lists.gnu.org/archive/html/lilypond-user/2008-05/msg00592.html
  59
  60 (define (octave-up noteevent)
  61   (let* ((pitch (ly:music-property noteevent 'pitch))
  62          (octave (ly:pitch-octave pitch))
  63          (note (ly:pitch-notename pitch))
  64          (alteration (ly:pitch-alteration pitch))
  65          (duration (ly:music-property noteevent 'duration))
  66          (newnoteevent
  67           (make-music 'NoteEvent
  68                       'duration duration
  69                       'pitch (ly:make-pitch (1- octave) note alteration))))
  70     newnoteevent))
  71
  72 (define (octavize-chord elements)
  73   (cond ((null? elements) elements)
  74         ((eq? (ly:music-property (car elements) 'name) 'NoteEvent)
  75          (cons (car elements)
  76                (cons (octave-up (car elements))
  77                      (octavize-chord (cdr elements)))))
  78         (else (cons (car elements) (octavize-chord (cdr elements))))))
  79
  80 (define (octavize music)
  81   (let* ((es (ly:music-property music 'elements))
  82          (e (ly:music-property music 'element))
  83          (name (ly:music-property music 'name)))
  84     (cond ((eq? name 'EventChord)
  85            (ly:music-set-property! music 'elements (octavize-chord es)))
  86           ((pair? es)
  87            (for-each (lambda(x) (octavize x)) es))
  88           ((ly:music? e)
  89            (octavize e))))
  90   music)
  91
  92
  93 ;;; Smart transposition -- from LSR #266
  94
  95 (define  (naturalize-pitch p)
  96  (let* ((o (ly:pitch-octave p))
  97         (a (* 4 (ly:pitch-alteration p)))
  98    ; alteration, a, in quarter tone steps, for historical reasons
  99         (n (ly:pitch-notename p)))
 100    (cond
 101     ((and (> a 1) (or (eq? n 6) (eq? n 2)))
 102      (set! a (- a 2))
 103      (set! n (+ n 1)))
 104     ((and (< a -1) (or (eq? n 0) (eq? n 3)))
 105      (set! a (+ a 2))
 106      (set! n (- n 1))))
 107    (cond
 108     ((> a 2) (set! a (- a 4)) (set! n (+ n 1)))
 109     ((< a -2) (set! a (+ a 4)) (set! n (- n 1))))
 110    (if (< n 0) (begin (set! o (- o 1)) (set! n (+ n 7))))
 111    (if (> n 6) (begin (set! o (+ o 1)) (set! n (- n 7))))
 112    (ly:make-pitch o n (/ a 4))))
 113
 114 (define (naturalize music)
 115  (let* ((es (ly:music-property music 'elements))
 116         (e (ly:music-property music 'element))
 117         (p (ly:music-property music 'pitch)))
 118    (if (pair? es)
 119        (ly:music-set-property!
 120         music 'elements
 121         (map (lambda (x) (naturalize x)) es)))
 122    (if (ly:music? e)
 123        (ly:music-set-property!
 124         music 'element
 125         (naturalize e)))
 126    (if (ly:pitch? p)
 127        (begin
 128          (set! p (naturalize-pitch p))
 129          (ly:music-set-property! music 'pitch p)))
 130    music))
 131
 132 ;; copied from upstream scm/define-markup-commands.scm
 133 ;; for some reason it wasn't define-public'ed there...
 134
 135 (define (parse-my-duration duration-string)
 136   "Parse the `duration-string', e.g. ''4..'' or ''breve.'',
 137 and return a (log dots) list.
 138   Unlike the original `parse-simple-duration',
 139 this function is whitespace-insensitive."
 140   (let* ((duration-string (string-trim-both duration-string))
 141          (match (regexp-exec (make-regexp "(breve|longa|maxima|[0-9]+)(\\.*)")
 142                              duration-string)))
 143     (if (and match (string=? duration-string (match:substring match 0)))
 144         (let ((len (match:substring match 1))
 145               (dots (match:substring match 2)))
 146           (list (cond ((string=? len "breve") -1)
 147                       ((string=? len "longa") -2)
 148                       ((string=? len "maxima") -3)
 149                       (else (log2 (string->number len))))
 150                 (if dots (string-length dots) 0)))
 151         (ly:error (_ "not a valid duration string: ~a") duration-string))))
 152