scm/modal-transforms.scm

   1 ;;; modal-transforms.scm --- Modal transposition, inversion, and retrograde.
   2
   3 ;; Copyright (C) 2011--2015 Ellis & Grant, Inc.
   4
   5 ;; Author: Michael Ellis <michael.f.ellis@gmail.com>
   6
   7 ;; COPYRIGHT NOTICE
   8
   9 ;; This program is free software; you can redistribute it and/or modify
  10 ;; it under the terms of the GNU General Public License as published by
  11 ;; the Free Software Foundation; either version 2 of the License, or
  12 ;; (at your option) any later version.
  13
  14 ;; This program is distributed in the hope that it will be useful, but
  15 ;; WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
  16 ;; or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  17 ;; for more details.
  18
  19 ;; You should have received a copy of the GNU General Public License
  20 ;; along with this program; if not, write to the Free Software
  21 ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA.
  22
  23
  24 (define (transposer-factory scale)
  25   "Returns a transposer for the specified @var{scale}.
  26 It is an error if either argument to a transposer is not in the scale
  27 it was created with.  A transposer knows nothing about LilyPond
  28 internals.  It treats scales as an ordered list of arbitrary items and
  29 pitches as members of a scale.
  30 "
  31
  32   (define (index item lis)
  33     (list-index (lambda (x) (equal? item x)) lis))
  34
  35   (lambda (from-pitch to-pitch pitch)
  36     (cond
  37      ((not (member from-pitch scale))
  38       (ly:warning (_i "'from' pitch not in scale; ignoring"))
  39       pitch)
  40
  41      ((not (member to-pitch scale))
  42       (ly:warning (_i "'to' pitch not in scale; ignoring"))
  43       pitch)
  44
  45      ((not (member pitch scale))
  46       (ly:warning (_i "pitch to be transposed not in scale; ignoring"))
  47       pitch)
  48
  49      (else
  50       (list-ref scale
  51                 (modulo
  52                  (+ (index pitch scale)
  53                     (- (index to-pitch scale)
  54                        (index from-pitch scale)))
  55                  (length scale)))))))
  56
  57 (define (inverter-factory scale)
  58   "Returns an inverter for the specified @var{scale}.
  59 It is an error if either argument to an inverter
  60 is not in the scale it was created with.  An inverter knows nothing
  61 about LilyPond internals.  It treats scales as an ordered list of
  62 arbitrary items and pitches as members of a scale.
  63 "
  64
  65   (define (index item lis)
  66     (list-index (lambda (x) (equal? item x)) lis))
  67
  68   (lambda (around-pitch to-pitch pitch)
  69     (cond
  70      ((not (member around-pitch scale))
  71       (ly:warning (_i "'around' pitch not in scale; ignoring"))
  72       pitch)
  73
  74      ((not (member to-pitch scale))
  75       (ly:warning (_i "'to' pitch not in scale; ignoring"))
  76       pitch)
  77
  78      ((not (member pitch scale))
  79       (ly:warning (_i "pitch to be inverted not in scale; ignoring"))
  80       pitch)
  81
  82      (else
  83       (list-ref scale
  84                 (modulo
  85                  (+ (index to-pitch scale)
  86                     (- (index around-pitch scale)
  87                        (index pitch scale)))
  88                  (length scale)))))))
  89
  90 (define (replicate-modify lis n mod-proc)
  91   "Apply @code{(mod-proc lis n)} to each element of a list and
  92 concatenate the results.  Knows nothing of LilyPond internals."
  93   (cond
  94    ((< n 0)
  95     (ly:warning (_i "negative replication count; ignoring")))
  96    ((= n 0)
  97     '())
  98    ((= n 1)
  99     (mod-proc lis 1))
 100    ((> n 1)
 101     (append
 102      (replicate-modify lis (- n 1) mod-proc)
 103      (mod-proc lis n)))))
 104
 105
 106
 107 (define-public (change-pitches music converter)
 108   "Recurse through @var{music}, applying @var{converter} to pitches.
 109 Converter is typically a transposer or an inverter as defined above in
 110 this module, but may be user-defined.  The converter function must take
 111 a single pitch as its argument and return a new pitch.  These are
 112 LilyPond scheme pitches, e.g. @code{(ly:make-pitch 0 2 0)}
 113 "
 114   (let ((elements (ly:music-property music 'elements))
 115         (element (ly:music-property music 'element))
 116         (pitch (ly:music-property music 'pitch)))
 117
 118     (cond
 119      ((ly:pitch? pitch)
 120       (ly:music-set-property! music 'pitch (converter pitch)))
 121
 122      ((pair? elements)
 123       (for-each (lambda (x) (change-pitches x converter)) elements))
 124
 125      ((ly:music? element)
 126       (change-pitches element converter)))))
 127
 128
 129 (define (make-scale music)
 130   "Recurse through @var{music}, extracting pitches.
 131 Returns a list of pitch objects, e.g
 132 @code{'((ly:make-pitch 0 2 0) (ly:make-pitch 0 4 0) ... )}
 133 Typically used to construct a scale for input to
 134 @code{transposer-factory}."
 135
 136   (let ((elements (ly:music-property music 'elements))
 137         (element (ly:music-property music 'element))
 138         (pitch (ly:music-property music 'pitch)))
 139
 140     (cond
 141      ((ly:pitch? pitch)
 142       (list pitch))
 143
 144      ((pair? elements)
 145       (append-map
 146        (lambda (x) (make-scale x))
 147        elements))
 148
 149      ((ly:music? element)
 150       (make-scale element)))))
 151
 152 (define (make-extended-scale music)
 153   "Extend scale given by @var{music} by 5 octaves up and down."
 154   ;; This is a bit of a hack since, in theory, someone might want to
 155   ;; transpose further than 5 octaves from the original scale
 156   ;; definition.  In practice this seems unlikely to occur very often.
 157   (define extender
 158     (lambda (lis n)
 159       (map
 160        (lambda (i)
 161          (ly:make-pitch
 162           (+ (- n 6) (ly:pitch-octave i))
 163           (ly:pitch-notename i)
 164           (ly:pitch-alteration i)))
 165        lis)))
 166
 167   (let ((scale (make-scale music)))
 168     (replicate-modify scale 11 extender)))
 169
 170
 171 ;; ------------- PUBLIC FUNCTIONS -----------------------------
 172
 173 (define-public (make-modal-transposer from to scale)
 174   "Wrapper function for transposer-factory."
 175   (let ((transposer (transposer-factory (make-extended-scale scale))))
 176     (lambda (p)
 177       (transposer from to p))))
 178
 179 (define-public (make-modal-inverter around to scale)
 180   "Wrapper function for inverter-factory"
 181   (let ((inverter (inverter-factory (make-extended-scale scale))))
 182     (lambda (p)
 183       (inverter around to p))))
 184
 185
 186 (define-public (retrograde-music music)
 187   "Returns @var{music} in retrograde (reversed) order."
 188   ;; Included here to allow this module to provide a complete set of
 189   ;; common formal operations on motives, i.e transposition,
 190   ;; inversion and retrograding.
 191
 192   (define (reverse-span! m)
 193     ;; invert direction of two-sided spanners
 194     (let ((spd (ly:music-property m 'span-direction)))
 195       (if (ly:dir? spd)
 196           (begin
 197             (set! (ly:music-property m 'span-direction) (- spd))
 198             (case (ly:music-property m 'name)
 199               ((CrescendoEvent)
 200                (make-music 'DecrescendoEvent m))
 201               ((DecrescendoEvent)
 202                (make-music 'CrescendoEvent m))
 203               (else m)))
 204           m)))
 205
 206   ;; carryover is a possible list of tie events, the loop returns any
 207   ;; such trailing list from the given expression
 208   (define (loop m carryover)
 209     (define (filter-ties! m carryover field)
 210       (let ((vals (ly:music-property m field)))
 211         (if (pair? vals)
 212             (call-with-values
 213                 (lambda ()
 214                   (partition! (music-type-predicate
 215                                '(tie-event glissando-event)) vals))
 216               (lambda (ties no-ties)
 217                 (set! (ly:music-property m field)
 218                       (append! (map! reverse-span! no-ties) carryover))
 219                 ties))
 220             (begin
 221               (if (pair? carryover)
 222                   (set! (ly:music-property m field) carryover))
 223               '()))))
 224
 225     ;; The reversal will let some prefatory material stay in front of
 226     ;; the following element.  Most prominently single
 227     ;; overrides/reverts/sets/unsets and applyContext.  This does not
 228     ;; change the position of a clef (which will generally be useless
 229     ;; after retrograding) but it does not jumble the clef change
 230     ;; command internals.  Also, stuff like \once\override stays at
 231     ;; the affected element.
 232
 233     (define (prefatory? m)
 234       (or ((music-type-predicate
 235             '(apply-context apply-output-event layout-instruction-event)) m)
 236           (and
 237            (music-is-of-type? m 'music-wrapper-music)
 238            (prefatory? (ly:music-property m 'element)))))
 239
 240     (define (musiclistreverse lst)
 241       (let loop ((lst lst) (res '()) (zeros '()))
 242         (cond ((null? lst) (reverse! zeros res))
 243               ((prefatory? (car lst))
 244                (loop (cdr lst) res (cons (car lst) zeros)))
 245               (else
 246                (loop (cdr lst) (reverse! zeros (cons (car lst) res)) '())))))
 247
 248     (cond ((music-is-of-type? m 'event-chord)
 249            (let* ((chord-ties
 250                    (append!
 251                     (filter-ties! m carryover 'elements)
 252                     ;; articulations on an event-chord do not occur
 253                     ;; "naturally" but are supported when user-generated
 254                     ;; elsewhere, so we treat them properly
 255                     (filter-ties! m '() 'articulations)))
 256                   ;; in-chord ties are converted to per-chord ties.
 257                   ;; This is less than optimal but pretty much the
 258                   ;; best we can hope to achieve with this approach.
 259                   (element-ties
 260                    (append-map!
 261                     (lambda (m) (filter-ties! m '() 'articulations))
 262                     (ly:music-property m 'elements))))
 263              (append! chord-ties element-ties)))
 264
 265           ((music-is-of-type? m 'rhythmic-event)
 266            (filter-ties! m carryover 'articulations))
 267
 268           ;; The following is hardly correct but tieing inside of
 269           ;; <<...>> is really beyond our pay grade.
 270           ((music-is-of-type? m 'simultaneous-music)
 271            (append-map! (lambda (m) (loop m (ly:music-deep-copy carryover)))
 272                         (ly:music-property m 'elements)))
 273           (else
 274            (let ((elt (ly:music-property m 'element))
 275                  (elts (ly:music-property m 'elements)))
 276              (let ((res
 277                     (fold loop
 278                           (if (ly:music? elt) (loop elt carryover) carryover)
 279                           elts)))
 280                (if (ly:music? elt)
 281                    (set! (ly:music-property m 'element)
 282                          (reverse-span! elt)))
 283                (if (pair? elts)
 284                    (set! (ly:music-property m 'elements)
 285                          (map! reverse-span! (musiclistreverse elts))))
 286                (append! res (filter-ties! m '() 'articulations)))))))
 287   (let ((dangling (loop music '())))
 288     (for-each
 289      (lambda (t) (ly:music-warning t (_ "Dangling tie in \\retrograde")))
 290      dangling))
 291   music)
 292
 293 (define-public (pitch-invert around to music)
 294   "If @var{music} is a single pitch, inverts it about @var{around}
 295 and transposes from @var{around} to @var{to}."
 296   (let ((p (ly:music-property music 'pitch)))
 297     (if (ly:pitch? p)
 298         (ly:music-set-property!
 299          music 'pitch
 300          (ly:pitch-transpose to (ly:pitch-diff around p))))
 301     music))
 302
 303 (define-public (music-invert around to music)
 304   "Applies pitch-invert to all pitches in @var{music}."
 305   (music-map (lambda (x) (pitch-invert around to x)) music))