scm/double-plus-new-chord-name.scm

   1 ;;;; double-plus-new-chord-name.scm -- Compile chord names
   2 ;;;;
   3 ;;;;  source file of the GNU LilyPond music typesetter
   4 ;;;;
   5 ;;;; (c) 2003 Jan Nieuwenhuizen <janneke@gnu.org>
   6
   7
   8 ;;;; NOTE: this is experimental code
   9 ;;;; Base and inversion are ignored.
  10 ;;;; Naming of the base chord (steps 1-5) is handled by exceptions only
  11 ;;;; see input/test/chord-names-dpnj.ly
  12
  13 (define (markup-or-empty-markup markup)
  14   "Return MARKUP if markup, else empty-markup"
  15   (if (markup? markup) markup empty-markup))
  16
  17 (define (conditional-kern-before markup bool amount)
  18   "Add AMOUNT of space before MARKUP if BOOL is true."
  19   (if bool
  20       (make-line-markup
  21        (list (make-hspace-markup amount)
  22              markup))
  23       markup))
  24
  25 (define-public (double-plus-new-chord->markup-banter . args)
  26   (apply double-plus-new-chord->markup (cons 'banter args)))
  27
  28 (define-public (double-plus-new-chord->markup-jazz . args)
  29   (apply double-plus-new-chord->markup (cons 'jazz args)))
  30
  31 ;; FIXME: if/when double-plus-new-chord->markup get installed
  32 ;; setting and calling can be done a bit handier.
  33 (define-public (double-plus-new-chord->markup
  34                 func pitches bass inversion
  35                 context)
  36   "Entry point for New_chord_name_engraver.  See
  37 double-plus-new-chord-name.scm for the signature of FUNC.  PITCHES,
  38 BASS and INVERSION are lily pitches.  OPTIONS is an alist-alist (see
  39 input/test/dpncnt.ly).
  40  "
  41   (define options (ly:get-context-property context 'chordNameExceptions))
  42
  43   (define (step-nr pitch)
  44     (let* ((pitch-nr (+ (* 7 (ly:pitch-octave pitch))
  45                         (ly:pitch-notename pitch)))
  46            (root-nr (+ (* 7 (ly:pitch-octave (car pitches)))
  47                         (ly:pitch-notename (car pitches)))))
  48       (+ 1 (- pitch-nr root-nr))))
  49
  50   (define (next-third pitch)
  51     (ly:pitch-transpose pitch
  52                         (ly:make-pitch 0 2 (if (or (= (step-nr pitch) 3)
  53                                                    (= (step-nr pitch) 5))
  54                                                -1 0))))
  55
  56   (define (step-alteration pitch)
  57     (let* ((diff (ly:pitch-diff (ly:make-pitch 0 0 0) (car pitches)))
  58            (normalized-pitch (ly:pitch-transpose pitch diff))
  59            (alteration (ly:pitch-alteration normalized-pitch)))
  60       (if (= (step-nr pitch) 7) (+ alteration 1) alteration)))
  61
  62   (define (pitch-unalter pitch)
  63     (let ((alteration (step-alteration pitch)))
  64       (if (= alteration 0)
  65           pitch
  66           (ly:make-pitch (ly:pitch-octave pitch) (ly:pitch-notename pitch)
  67                          (- (ly:pitch-alteration pitch) alteration)))))
  68
  69   (define (step-even-or-altered? pitch)
  70     (let ((nr (step-nr pitch)))
  71       (if (!= (modulo nr 2) 0)
  72           (!= (step-alteration pitch) 0)
  73           #t)))
  74
  75   (define (step->markup-plusminus pitch)
  76     (make-line-markup
  77      (list
  78       (make-simple-markup (number->string (step-nr pitch)))
  79       (make-simple-markup
  80        (case (step-alteration pitch)
  81          ((-2) "--")
  82          ((-1) "-")
  83          ((0) "")
  84          ((1) "+")
  85          ((2) "++"))))))
  86
  87   (define (step->markup-accidental pitch)
  88     (make-line-markup
  89      (list
  90       (accidental->markup (step-alteration pitch))
  91       (make-simple-markup (number->string (step-nr pitch))))))
  92
  93   ;; tja, kennok
  94   (define (make-sub->markup step->markup)
  95     (lambda (pitch)
  96       (make-line-markup (list (make-simple-markup "no")
  97                               (step->markup pitch)))))
  98
  99   (define (step-based-sub->markup step->markup pitch)
 100     (make-line-markup (list (make-simple-markup "no") (step->markup pitch))))
 101
 102   (define (get-full-list pitch)
 103     (if (<= (step-nr pitch) (step-nr (tail pitches)))
 104         (cons pitch (get-full-list (next-third pitch)))
 105         '()))
 106
 107   (define (get-consecutive nr pitches)
 108     (if (pair? pitches)
 109         (let* ((pitch-nr (step-nr (car pitches)))
 110                (next-nr (if (!= (modulo pitch-nr 2) 0) (+ pitch-nr 2) nr)))
 111           (if (<= pitch-nr nr)
 112               (cons (car pitches) (get-consecutive next-nr (cdr pitches)))
 113               '()))
 114         '()))
 115
 116   (define (full-match exceptions)
 117     (if (pair? exceptions)
 118         (let* ((e (car exceptions))
 119                (e-pitches (car e)))
 120           (if (equal? e-pitches pitches)
 121               e
 122               (full-match (cdr exceptions))))
 123         '(())))
 124
 125   (define (partial-match exceptions)
 126     (if (pair? exceptions)
 127         (let* ((e (car exceptions))
 128                (e-pitches (car e)))
 129           (if (equal? e-pitches (first-n (length e-pitches) pitches))
 130               e
 131               (partial-match (cdr exceptions))))
 132         '(())))
 133
 134   (if #f (begin
 135   (write-me "options: " options)
 136   (write-me "pitches: " pitches)))
 137   (let* ((full-exceptions (assoc-get 'full-exceptions options))
 138          (full-exception (full-match full-exceptions))
 139          (full-markup (cdr full-exception))
 140
 141          (partial-exceptions (assoc-get 'partial-exceptions options))
 142          (partial-exception (partial-match partial-exceptions))
 143          (partial-pitches (car partial-exception))
 144          (partial-markup (markup-or-empty-markup (cdr partial-exception)))
 145
 146          (root (car pitches))
 147          (full (get-full-list root))
 148          ;; kludge alert: replace partial matched lower part of all with
 149          ;; 'normal' pitches from full
 150          ;; (all pitches)
 151          (all (append (first-n (length partial-pitches) full)
 152                       (butfirst-n (length partial-pitches) pitches)))
 153
 154          (highest (tail all))
 155          (missing (list-minus full (map pitch-unalter all)))
 156          (consecutive (get-consecutive 1 all))
 157          (rest (list-minus all consecutive))
 158          (altered (filter-list step-even-or-altered? all))
 159          (cons-alt (filter-list step-even-or-altered? consecutive))
 160          (base (list-minus consecutive altered)))
 161
 162
 163      (if #f (begin
 164     (write-me "full:" full)
 165     ;; (write-me "partial-pitches:" partial-pitches)
 166     (write-me "full-markup:" full-markup)
 167     (write-me "partial-markup:" partial-markup)
 168     (write-me "all:" all)
 169     (write-me "altered:" altered)
 170     (write-me "missing:" missing)
 171     (write-me "consecutive:" consecutive)
 172     (write-me "rest:" rest)
 173     (write-me "base:" base)))
 174
 175     (case func
 176       ((banter)
 177        ;;    root
 178        ;;    + steps:altered + (highest all -- if not altered)
 179        ;;    + subs:missing
 180
 181        (let* ((root->markup (assoc-get-default
 182                               'root->markup options note-name->markup))
 183               (step->markup (assoc-get-default
 184                              'step->markup options step->markup-plusminus))
 185               (sub->markup (assoc-get-default
 186                             'sub->markup options
 187                             (lambda (x)
 188                               (step-based-sub->markup step->markup x))))
 189               (sep (assoc-get-default
 190                     'separator options (make-simple-markup "/"))))
 191
 192          (if
 193           (pair? full-markup)
 194           (make-line-markup (list (root->markup root) full-markup))
 195
 196           (make-line-markup
 197            (list
 198             (root->markup root)
 199             partial-markup
 200             (make-normal-size-super-markup
 201              (markup-join
 202               (apply append
 203                      (map step->markup
 204                           (append altered
 205                                   (if (and (> (step-nr highest) 5)
 206                                            (not
 207                                             (step-even-or-altered? highest)))
 208                                       (list highest) '())))
 209
 210                      (list (map sub->markup missing)))
 211               sep)))))))
 212
 213
 214       ((jazz)
 215        ;;    root
 216        ;;    + steps:(highest base) + cons-alt
 217        ;;    + 'add'
 218        ;;    + steps:rest
 219        (let* ((root->markup (assoc-get-default
 220                               'root->markup options note-name->markup))
 221               (step->markup (assoc-get-default
 222                              'step->markup options step->markup-accidental))
 223               (sep (assoc-get-default
 224                     'separator options (make-simple-markup " ")))
 225               (add-prefix (assoc-get-default 'add-prefix options
 226                                              (make-simple-markup " add"))))
 227
 228          (if
 229           (pair? full-markup)
 230           (make-line-markup (list (root->markup root) full-markup))
 231
 232           (make-line-markup
 233            (list
 234             (root->markup root)
 235             partial-markup
 236             (make-normal-size-super-markup
 237              (make-line-markup
 238               (list
 239
 240                ;; kludge alert: omit <= 5
 241                ;;(markup-join (map step->markup
 242                ;;                        (cons (tail base) cons-alt)) sep)
 243
 244                ;; This fixes:
 245                ;;  c     C5       -> C
 246                ;;  c:2   C5 2     -> C2
 247                ;;  c:3-  Cm5      -> Cm
 248                ;;  c:6.9 C5 6add9 -> C6 add 9 (add?)
 249                ;;  ch = \chords { c c:2 c:3- c:6.9^7 }
 250                (markup-join (map step->markup
 251                                  (let ((tb (tail base)))
 252                                    (if (> (step-nr tb) 5)
 253                                        (cons tb cons-alt)
 254                                        cons-alt))) sep)
 255
 256                (if (pair? rest)
 257                    add-prefix
 258                    empty-markup)
 259                (markup-join (map step->markup rest) sep)))))))))
 260
 261        (else empty-markup))))
 262
 263