Run grand-replace (issue 3765)

[lilypond.git] / scm / chord-ignatzek-names.scm

diff --git a/scm/chord-ignatzek-names.scm b/scm/chord-ignatzek-names.scm
index 696d02fc7af43ab3ae2383f670a51ecc98afde9d..22f54fec85e523adde58e5715ebd9bee0d6947a1 100644 (file)
--- a/scm/chord-ignatzek-names.scm
+++ b/scm/chord-ignatzek-names.scm
@@ -1,6 +1,6 @@
 ;;;; This file is part of LilyPond, the GNU music typesetter.
 ;;;;
 ;;;; This file is part of LilyPond, the GNU music typesetter.
 ;;;;

-;;;; Copyright (C) 2000--2011  Han-Wen Nienhuys <hanwen@xs4all.nl>
+;;;; Copyright (C) 2000--2014  Han-Wen Nienhuys <hanwen@xs4all.nl>

 ;;;;
 ;;;; LilyPond is free software: you can redistribute it and/or modify
 ;;;; it under the terms of the GNU General Public License as published by
 ;;;;
 ;;;; LilyPond is free software: you can redistribute it and/or modify
 ;;;; it under the terms of the GNU General Public License as published by


@@ -44,63 +44,63 @@
   (if (null? ps)
       #f
       (if (= (- x 1) (ly:pitch-steps (car ps)))
   (if (null? ps)
       #f
       (if (= (- x 1) (ly:pitch-steps (car ps)))

-         (car ps)
-         (get-step x (cdr ps)))))
+          (car ps)
+          (get-step x (cdr ps)))))

 
 (define (replace-step p ps)
   "Copy PS, but replace the step of P in PS."
   (if (null? ps)
       '()
       (let* ((t (replace-step p (cdr ps))))
 
 (define (replace-step p ps)
   "Copy PS, but replace the step of P in PS."
   (if (null? ps)
       '()
       (let* ((t (replace-step p (cdr ps))))

-       (if (= (ly:pitch-steps p) (ly:pitch-steps (car ps)))
-           (cons p t)
-           (cons (car ps) t)))))
+        (if (= (ly:pitch-steps p) (ly:pitch-steps (car ps)))
+            (cons p t)
+            (cons (car ps) t)))))

 
 (define (remove-step x ps)
   "Copy PS, but leave out the Xth step."
   (if (null? ps)
       '()
       (let* ((t (remove-step x (cdr ps))))
 
 (define (remove-step x ps)
   "Copy PS, but leave out the Xth step."
   (if (null? ps)
       '()
       (let* ((t (remove-step x (cdr ps))))

-       (if (= (- x 1) (ly:pitch-steps (car ps)))
-           t
-           (cons (car ps) t)))))
+        (if (= (- x 1) (ly:pitch-steps (car ps)))
+            t
+            (cons (car ps) t)))))

 
 
 (define-public (ignatzek-chord-names
 
 
 (define-public (ignatzek-chord-names

-               in-pitches bass inversion
-               context)
+                in-pitches bass inversion
+                context)

 
   (define (remove-uptil-step x ps)
     "Copy PS, but leave out everything below the Xth step."
     (if (null? ps)
 
   (define (remove-uptil-step x ps)
     "Copy PS, but leave out everything below the Xth step."
     (if (null? ps)

-       '()
-       (if (< (ly:pitch-steps (car ps)) (- x 1))
-           (remove-uptil-step x (cdr ps))
-           ps)))
+        '()
+        (if (< (ly:pitch-steps (car ps)) (- x 1))
+            (remove-uptil-step x (cdr ps))
+            ps)))

 
   (define name-root (ly:context-property context 'chordRootNamer))
   (define name-note
     (let ((nn (ly:context-property context 'chordNoteNamer)))
       (if (eq? nn '())
 
   (define name-root (ly:context-property context 'chordRootNamer))
   (define name-note
     (let ((nn (ly:context-property context 'chordNoteNamer)))
       (if (eq? nn '())

-         ;; replacing the next line with name-root gives guile-error...? -rz
+          ;; replacing the next line with name-root gives guile-error...? -rz

 
 

-         ;; apparently sequence of defines is equivalent to let, not let* ? -hwn
-         (ly:context-property context 'chordRootNamer)
-         ;; name-root
-         nn)))
+          ;; apparently sequence of defines is equivalent to let, not let* ? -hwn
+          (ly:context-property context 'chordRootNamer)
+          ;; name-root
+          nn)))

 
   (define (is-natural-alteration? p)
     (= (natural-chord-alteration p) (ly:pitch-alteration p)))
 
   (define (ignatzek-format-chord-name
 
   (define (is-natural-alteration? p)
     (= (natural-chord-alteration p) (ly:pitch-alteration p)))
 
   (define (ignatzek-format-chord-name

-          root
-          prefix-modifiers
-          main-name
-          alteration-pitches
-          addition-pitches
-          suffix-modifiers
-          bass-pitch
-          lowercase-root?)
+           root
+           prefix-modifiers
+           main-name
+           alteration-pitches
+           addition-pitches
+           suffix-modifiers
+           bass-pitch
+           lowercase-root?)

 
     "Format for the given (lists of) pitches.  This is actually more
 work than classifying the pitches."
 
     "Format for the given (lists of) pitches.  This is actually more
 work than classifying the pitches."


@@ -109,99 +109,103 @@ work than classifying the pitches."
       "The main name: don't print anything for natural 5 or 3."
       (if
        (or (not (ly:pitch? p))
       "The main name: don't print anything for natural 5 or 3."
       (if
        (or (not (ly:pitch? p))

-          (and (is-natural-alteration? p)
-               (or (= (pitch-step p) 5)
-                   (= (pitch-step p) 3))))
+           (and (is-natural-alteration? p)
+                (or (= (pitch-step p) 5)
+                    (= (pitch-step p) 3))))

        '()
        (list (name-step p))))
 
     (define (glue-word-to-step word x)
       (make-line-markup
        (list
        '()
        (list (name-step p))))
 
     (define (glue-word-to-step word x)
       (make-line-markup
        (list

-       (make-simple-markup word)
-       (name-step x))))
+        (make-simple-markup word)
+        (name-step x))))

 
     (define (suffix-modifier->markup mod)
       (if (or (= 4 (pitch-step mod))
 
     (define (suffix-modifier->markup mod)
       (if (or (= 4 (pitch-step mod))

-             (= 2 (pitch-step mod)))
-         (glue-word-to-step "sus" mod)
-         (glue-word-to-step "huh" mod)))
+              (= 2 (pitch-step mod)))
+          (glue-word-to-step "sus" mod)
+          (glue-word-to-step "huh" mod)))

 
     (define (prefix-modifier->markup mod)
       (if (and (= 3 (pitch-step mod))
 
     (define (prefix-modifier->markup mod)
       (if (and (= 3 (pitch-step mod))

-              (= FLAT (ly:pitch-alteration mod)))
-         (make-simple-markup (if lowercase-root? "" "m"))
-         (make-simple-markup "huh")))
+               (= FLAT (ly:pitch-alteration mod)))
+          (if lowercase-root?
+              empty-markup
+              (ly:context-property context 'minorChordModifier))
+          (make-simple-markup "huh")))

 
     (define (filter-alterations alters)
       "Filter out uninteresting (natural) pitches from ALTERS."
 
       (define (altered? p)
 
     (define (filter-alterations alters)
       "Filter out uninteresting (natural) pitches from ALTERS."
 
       (define (altered? p)

-       (not (is-natural-alteration? p)))
+        (not (is-natural-alteration? p)))

 
       (if
        (null? alters)
        '()
        (let* ((lst (filter altered? alters))
 
       (if
        (null? alters)
        '()
        (let* ((lst (filter altered? alters))

-             (lp (last-pair alters)))
+              (lp (last-pair alters)))

 
 

-        ;; we want the highest also if unaltered
-        (if (and (not (altered? (car lp)))
-                 (> (pitch-step (car lp)) 5))
-            (append lst (last-pair alters))
-            lst))))
+         ;; we want the highest also if unaltered
+         (if (and (not (altered? (car lp)))
+                  (> (pitch-step (car lp)) 5))
+             (append lst (last-pair alters))
+             lst))))

 
     (define (name-step pitch)
       (define (step-alteration pitch)
 
     (define (name-step pitch)
       (define (step-alteration pitch)

-       (- (ly:pitch-alteration pitch)
-          (natural-chord-alteration pitch)))
+        (- (ly:pitch-alteration pitch)
+           (natural-chord-alteration pitch)))

 
       (let* ((num-markup (make-simple-markup
 
       (let* ((num-markup (make-simple-markup

-                         (number->string (pitch-step pitch))))
-            (args (list num-markup))
-            (total (if (= (ly:pitch-alteration pitch) 0)
-                       (if (= (pitch-step pitch) 7)
-                           (list (ly:context-property context 'majorSevenSymbol))
-                           args)
-                       (cons (accidental->markup (step-alteration pitch)) args))))
+                          (number->string (pitch-step pitch))))
+             (args (list num-markup))
+             (total (if (= (ly:pitch-alteration pitch) 0)
+                        (if (= (pitch-step pitch) 7)
+                            (list (ly:context-property context 'majorSevenSymbol))
+                            args)
+                        (cons (accidental->markup (step-alteration pitch)) args))))

 
 

-       (make-line-markup total)))
+        (make-line-markup total)))

 
     (let* ((sep (ly:context-property context 'chordNameSeparator))
 
     (let* ((sep (ly:context-property context 'chordNameSeparator))

-          (root-markup (name-root root lowercase-root?))
-          (add-markups (map (lambda (x) (glue-word-to-step "add" x))
-                            addition-pitches))
-          (filtered-alterations (filter-alterations alteration-pitches))
-          (alterations (map name-step filtered-alterations))
-          (suffixes (map suffix-modifier->markup suffix-modifiers))
-          (prefixes (map prefix-modifier->markup prefix-modifiers))
-          (main-markups (filter-main-name main-name))
-          (to-be-raised-stuff (markup-join
-                               (append
-                                main-markups
-                                alterations
-                                suffixes
-                                add-markups) sep))
-          (base-stuff (if (ly:pitch? bass-pitch)
-                          (list sep (name-note bass-pitch #f))
-                          '())))
+           (slashsep (ly:context-property context 'slashChordSeparator))
+           (root-markup (name-root root lowercase-root?))
+           (add-pitch-prefix (ly:context-property context 'additionalPitchPrefix))
+           (add-markups (map (lambda (x) (glue-word-to-step add-pitch-prefix x))
+                             addition-pitches))
+           (filtered-alterations (filter-alterations alteration-pitches))
+           (alterations (map name-step filtered-alterations))
+           (suffixes (map suffix-modifier->markup suffix-modifiers))
+           (prefixes (map prefix-modifier->markup prefix-modifiers))
+           (main-markups (filter-main-name main-name))
+           (to-be-raised-stuff (markup-join
+                                (append
+                                 main-markups
+                                 alterations
+                                 suffixes
+                                 add-markups) sep))
+           (base-stuff (if (ly:pitch? bass-pitch)
+                           (list slashsep (name-note bass-pitch #f))
+                           '())))

 
       (set! base-stuff
 
       (set! base-stuff

-           (append
-            (list root-markup
-                  (conditional-kern-before (markup-join prefixes sep)
-                                           (and (not (null? prefixes))
-                                                (= (ly:pitch-alteration root) NATURAL))
-                                           (ly:context-property context 'chordPrefixSpacer))
-                  (make-super-markup to-be-raised-stuff))
-            base-stuff))
+            (append
+             (list root-markup
+                   (conditional-kern-before (markup-join prefixes sep)
+                                            (and (not (null? prefixes))
+                                                 (= (ly:pitch-alteration root) NATURAL))
+                                            (ly:context-property context 'chordPrefixSpacer))
+                   (make-super-markup to-be-raised-stuff))
+             base-stuff))

       (make-line-markup base-stuff)))
 
   (define (ignatzek-format-exception
       (make-line-markup base-stuff)))
 
   (define (ignatzek-format-exception

-          root
-          exception-markup
-          bass-pitch
-          lowercase-root?)
+           root
+           exception-markup
+           bass-pitch
+           lowercase-root?)

 
     (make-line-markup
      `(
 
     (make-line-markup
      `(


@@ -209,83 +213,82 @@ work than classifying the pitches."
        ,exception-markup
        .
        ,(if (ly:pitch? bass-pitch)
        ,exception-markup
        .
        ,(if (ly:pitch? bass-pitch)

-           (list (ly:context-property context 'chordNameSeparator)
-                 (name-note bass-pitch #f))
-           '()))))
+            (list (ly:context-property context 'slashChordSeparator)
+                  (name-note bass-pitch #f))
+            '()))))

 
   (let* ((root (car in-pitches))
 
   (let* ((root (car in-pitches))

-        (pitches (map (lambda (x) (ly:pitch-diff x root)) (cdr in-pitches)))
-        (lowercase-root?
-         (and (ly:context-property context 'chordNameLowercaseMinor)
-       (let ((third (get-step 3 pitches)))
-           (and third (= (ly:pitch-alteration third) FLAT)))))
-        (exceptions (ly:context-property context 'chordNameExceptions))
-        (exception (assoc-get pitches exceptions))
-        (prefixes '())
-        (suffixes '())
-        (add-steps '())
-        (main-name #f)
-        (bass-note
-         (if (ly:pitch? inversion)
-             inversion
-             bass))
-        (alterations '()))
+         (pitches (map (lambda (x) (ly:pitch-diff x root)) (cdr in-pitches)))
+         (lowercase-root?
+          (and (ly:context-property context 'chordNameLowercaseMinor)
+               (let ((third (get-step 3 pitches)))
+                 (and third (= (ly:pitch-alteration third) FLAT)))))
+         (exceptions (ly:context-property context 'chordNameExceptions))
+         (exception (assoc-get pitches exceptions))
+         (prefixes '())
+         (suffixes '())
+         (add-steps '())
+         (main-name #f)
+         (bass-note
+          (if (ly:pitch? inversion)
+              inversion
+              bass))
+         (alterations '()))

 
     (if exception
 
     (if exception

-       (ignatzek-format-exception root exception bass-note lowercase-root?)
-
-       (begin
-         ;; no exception.
-         ;; handle sus4 and sus2 suffix: if there is a 3 together with
-         ;; sus2 or sus4, then we explicitly say add3.
-         (map
-          (lambda (j)
-            (if (get-step j pitches)
-                (begin
-                  (if (get-step 3 pitches)
-                      (begin
-                        (set! add-steps (cons (get-step 3 pitches) add-steps))
-                        (set! pitches (remove-step 3 pitches))))
-                  (set! suffixes (cons (get-step j pitches) suffixes)))))
-          '(2 4))
-
-         ;; do minor-3rd modifier.
-         (if (and (get-step 3 pitches)
-                  (= (ly:pitch-alteration (get-step 3 pitches)) FLAT))
-             (set! prefixes (cons (get-step 3 pitches) prefixes)))
-
-         ;; lazy bum. Should write loop.
-         (cond
-          ((get-step 7 pitches) (set! main-name (get-step 7 pitches)))
-          ((get-step 6 pitches) (set! main-name (get-step 6 pitches)))
-          ((get-step 5 pitches) (set! main-name (get-step 5 pitches)))
-          ((get-step 4 pitches) (set! main-name (get-step 4 pitches)))
-          ((get-step 3 pitches) (set! main-name (get-step 3 pitches))))
-
-         (let* ((3-diff? (lambda (x y)
-                           (= (- (pitch-step y) (pitch-step x)) 2)))
-                (split (split-at-predicate
-                        3-diff? (remove-uptil-step 5 pitches))))
-           (set! alterations (append alterations (car split)))
-           (set! add-steps (append add-steps (cdr split)))
-           (set! alterations (delq main-name alterations))
-           (set! add-steps (delq main-name add-steps))
-
-
-           ;; chords with natural (5 7 9 11 13) or leading subsequence.
-           ;; etc. are named by the top pitch, without any further
-           ;; alterations.
-           (if (and
-                (ly:pitch? main-name)
-                (= 7 (pitch-step main-name))
-                (is-natural-alteration? main-name)
-                (pair? (remove-uptil-step 7 alterations))
-                (reduce (lambda (x y) (and x y)) #t
-                        (map is-natural-alteration? alterations)))
-               (begin
-                 (set! main-name (last alterations))
-                 (set! alterations '())))
-
-           (ignatzek-format-chord-name
-            root prefixes main-name alterations add-steps suffixes bass-note
-            lowercase-root?))))))
+        (ignatzek-format-exception root exception bass-note lowercase-root?)
+
+        (begin
+          ;; no exception.
+          ;; handle sus4 and sus2 suffix: if there is a 3 together with
+          ;; sus2 or sus4, then we explicitly say add3.
+          (for-each
+           (lambda (j)
+             (if (get-step j pitches)
+                 (begin
+                   (if (get-step 3 pitches)
+                       (begin
+                         (set! add-steps (cons (get-step 3 pitches) add-steps))
+                         (set! pitches (remove-step 3 pitches))))
+                   (set! suffixes (cons (get-step j pitches) suffixes)))))
+           '(2 4))
+
+          ;; do minor-3rd modifier.
+          (if (and (get-step 3 pitches)
+                   (= (ly:pitch-alteration (get-step 3 pitches)) FLAT))
+              (set! prefixes (cons (get-step 3 pitches) prefixes)))
+
+          ;; lazy bum. Should write loop.
+          (cond
+           ((get-step 7 pitches) (set! main-name (get-step 7 pitches)))
+           ((get-step 6 pitches) (set! main-name (get-step 6 pitches)))
+           ((get-step 5 pitches) (set! main-name (get-step 5 pitches)))
+           ((get-step 4 pitches) (set! main-name (get-step 4 pitches)))
+           ((get-step 3 pitches) (set! main-name (get-step 3 pitches))))
+
+          (let* ((3-diff? (lambda (x y)
+                            (= (- (pitch-step y) (pitch-step x)) 2)))
+                 (split (split-at-predicate
+                         3-diff? (remove-uptil-step 5 pitches))))
+            (set! alterations (append alterations (car split)))
+            (set! add-steps (append add-steps (cdr split)))
+            (set! alterations (delq main-name alterations))
+            (set! add-steps (delq main-name add-steps))
+
+
+            ;; chords with natural (5 7 9 11 13) or leading subsequence.
+            ;; etc. are named by the top pitch, without any further
+            ;; alterations.
+            (if (and
+                 (ly:pitch? main-name)
+                 (= 7 (pitch-step main-name))
+                 (is-natural-alteration? main-name)
+                 (pair? (remove-uptil-step 7 alterations))
+                 (every is-natural-alteration? alterations))
+                (begin
+                  (set! main-name (last alterations))
+                  (set! alterations '())))
+
+            (ignatzek-format-chord-name
+             root prefixes main-name alterations add-steps suffixes bass-note
+             lowercase-root?))))))