>From 8a3569e75d1fdff5318497051bb840e330162e47 Mon Sep 17 00:00:00 2001 From: Richard Shann Date: Mon, 6 Oct 2014 18:09:51 +0100 Subject: [PATCH] Allow creation of compact chord symbols Compact chord symbols have the elements of the chord (the root name, quality and bass-inversion) packed tightly together so as to allow the creation of fakebooks. Nowadays these will often be stored on hand held devices. This patch allows the default chord symbols to be drawn in such a manner, by defining the context property chordCompactScale. Where this is not defined, the default behavior is maintained. --- scm/chord-ignatzek-names.scm | 125 ++++++++++++++++++++++++++++++-------- scm/define-context-properties.scm | 1 + 2 files changed, 100 insertions(+), 26 deletions(-) diff --git a/scm/chord-ignatzek-names.scm b/scm/chord-ignatzek-names.scm index 22f54fe..c7671cb 100644 --- a/scm/chord-ignatzek-names.scm +++ b/scm/chord-ignatzek-names.scm @@ -88,6 +88,46 @@ (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 + (make-scale-markup '(0.75 . 0.5) + (make-bold-markup (make-simple-markup "/")))) + (make-bold-markup + (make-scale-markup '(0.5 . 0.75) + (make-simple-markup + (vector-ref #("C" "D" "E" "F" "G" "A" "B") (ly:pitch-notename + pitch))))) + (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))) @@ -169,9 +209,42 @@ work than classifying the pitches." (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-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)) - (root-markup (name-root root lowercase-root?)) + (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)) @@ -185,37 +258,37 @@ work than classifying the pitches." main-markups alterations suffixes - add-markups) sep)) - (base-stuff (if (ly:pitch? bass-pitch) - (list slashsep (name-note bass-pitch #f)) - '()))) - - (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)) - (make-line-markup base-stuff))) + 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?) - - (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)) - '())))) + (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-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))) diff --git a/scm/define-context-properties.scm b/scm/define-context-properties.scm index f694a67..0b787f9 100644 --- a/scm/define-context-properties.scm +++ b/scm/define-context-properties.scm @@ -197,6 +197,7 @@ exceptions. Contains @code{(@var{chord} . (@var{prefix-markup} (chordNameFunction ,procedure? "The function that converts lists of pitches to chord names.") (chordNameLowercaseMinor ,boolean? "Downcase roots of minor chords?") + (chordCompactScale ,number-pair? "Draw chord symbols scaled by this amount") (chordNameSeparator ,markup? "The markup object used to separate parts of a chord name.") (slashChordSeparator ,markup? "The markup object used to separate -- 1.9.1