;;;; This file is part of LilyPond, the GNU music typesetter.
;;;;
;;;; Copyright (C) 2000--2014 Han-Wen Nienhuys
;;;;
;;;; LilyPond is free software: you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by
;;;; the Free Software Foundation, either version 3 of the License, or
;;;; (at your option) any later version.
;;;;
;;;; LilyPond is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;;; GNU General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU General Public License
;;;; along with LilyPond. If not, see .
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; jazz-part 2
;;
;; after Klaus Ignatzek, Die Jazzmethode fuer Klavier 1.
;;
;; The idea is: split chords into
;;
;; ROOT PREFIXES MAIN-NAME ALTERATIONS SUFFIXES ADDITIONS
;;
;; and put that through a layout routine.
;;
;; the split is a procedural process, with lots of set!.
;;
;; todo: naming is confusing: steps (0 based) vs. steps (1 based).
(define (pitch-step p)
"Musicological notation for an interval. Eg. C to D is 2."
(+ 1 (ly:pitch-steps p)))
(define (get-step x ps)
"Does PS have the X step? Return that step if it does."
(if (null? ps)
#f
(if (= (- x 1) (ly:pitch-steps (car 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))))
(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))))
(if (= (- x 1) (ly:pitch-steps (car ps)))
t
(cons (car ps) t)))))
(define-public (ignatzek-chord-names
in-pitches bass inversion
context)
(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)))
(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
;; apparently sequence of defines is equivalent to let, not let* ? -hwn
(ly:context-property context 'chordRootNamer)
;; name-root
nn)))
(define (compact-name-root pitch scale)
(let* ((alt (ly:pitch-alteration pitch)))
(make-line-markup
(list
(make-bold-markup
(make-scale-markup '(0.5 . 1)
(make-simple-markup
(vector-ref #("C" "D" "E" "F" "G" "A" "B") (ly:pitch-notename
pitch)))))
(if (= alt 0)
(make-hspace-markup 0.1)
(make-line-markup
(list
(make-hspace-markup 0.1)
(make-fontsize-markup -7 (make-raise-markup 1.2 ;(* 1 scale)
(alteration->text-accidental-markup alt)))
(make-hspace-markup -0.5))))))))
(define (name-inversion pitch scale)
(let* ((alt (ly:pitch-alteration pitch)))
(make-line-markup
(list
(make-raise-markup 1;1.5
(make-scale-markup '(0.75 . 0.5)
(make-bold-markup (make-simple-markup "/"))))
(make-hspace-markup -0.3)
(make-raise-markup 0.5
(make-bold-markup
(make-scale-markup '(0.4 . 0.6)
(make-simple-markup
(vector-ref #("C" "D" "E" "F" "G" "A" "B") (ly:pitch-notename
pitch))))))
(make-raise-markup 0.5
(if (= alt NATURAL)
(make-hspace-markup 2)
(make-line-markup
(list
(make-hspace-markup 0.1)
(make-fontsize-markup -7
(if (= alt SHARP)
(make-raise-markup 0.1
(alteration->text-accidental-markup alt))
(make-raise-markup 0.2
(alteration->text-accidental-markup alt))))))))))))
(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?)
"Format for the given (lists of) pitches. This is actually more
work than classifying the pitches."
(define (filter-main-name 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))))
'()
(list (name-step p))))
(define (glue-word-to-step word x)
(make-line-markup
(list
(make-simple-markup word)
(name-step x))))
(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)))
(define (prefix-modifier->markup mod)
(if (and (= 3 (pitch-step mod))
(= 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)
(not (is-natural-alteration? p)))
(if
(null? alters)
'()
(let* ((lst (filter altered? 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))))
(define (name-step pitch)
(define (step-alteration pitch)
(- (ly:pitch-alteration pitch)
(natural-chord-alteration pitch)))
(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))))
(make-line-markup total)))
(define (markup-formatting sep root-markup prefixes to-be-raised-stuff bass-pitch)
(define bass-inv #f)
(define slashsep (ly:context-property context 'slashChordSeparator))
(define scale (ly:context-property context 'chordCompactScale))
(if (pair? scale)
(begin
(set! bass-inv (if (ly:pitch? bass-pitch)
(name-inversion bass-pitch scale)
empty-markup))
(make-with-dimensions-markup '(0 . 0) '(0 . 0) (make-scale-markup scale (make-combine-markup
(make-line-markup (list root-markup
(make-scale-markup '(0.4 . 0.6)
(make-bold-markup
(conditional-kern-before (markup-join prefixes sep)
(and (not (null? prefixes))
(= (ly:pitch-alteration root) NATURAL))
(ly:context-property context 'chordPrefixSpacer))))
(make-scale-markup '(0.4 . 0.6)
(make-bold-markup
to-be-raised-stuff))))
(make-raise-markup -2 bass-inv)))))
(begin
(set! bass-inv
(if (ly:pitch? bass-pitch)
(list slashsep (name-note bass-pitch #f))
'()))
(make-line-markup
(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))
bass-inv)))))
(let* ((sep (ly:context-property context 'chordNameSeparator))
(slashsep (ly:context-property context 'slashChordSeparator))
(scale (ly:context-property context 'chordCompactScale))
(root-markup (if (pair? scale) (compact-name-root root scale) (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)))
(markup-formatting sep root-markup prefixes to-be-raised-stuff bass-pitch)))
(define (ignatzek-format-exception
root
exception-markup
bass-pitch
lowercase-root?)
(define scale (ly:context-property context 'chordCompactScale))
(define bass-inv #f)
(if (pair? scale)
;;;compact:
(begin
(set! bass-inv (if (ly:pitch? bass-pitch)
(name-inversion bass-pitch scale)
empty-markup))
(make-with-dimensions-markup '(0 . 0) '(0 . 0) (make-scale-markup scale (make-combine-markup
(make-line-markup (list (compact-name-root root scale)
exception-markup))
(make-raise-markup -2 bass-inv)))))
;;; non compact:
(make-line-markup
`(
,(name-root root lowercase-root?)
,exception-markup
.
,(if (ly:pitch? bass-pitch)
(list (ly:context-property context 'slashChordSeparator)
(name-note bass-pitch #f))
'())))))
(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 '()))
(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.
(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?))))))