From 60972eafba7f58fc0792529efc4e7b5f269f4cd1 Mon Sep 17 00:00:00 2001
From: Carl Sorensen <c_sorensen@byu.edu>
Date: Fri, 22 Jul 2011 03:52:28 -0600
Subject: [PATCH] Add capo chord names

Got capo-handler working properly
---
 lily/chord-name-engraver.cc       |    4 ++--
 scm/chord-name.scm                |   28 ++++++++++++++++++++++++++++
 scm/define-context-properties.scm |    2 ++
 3 files changed, 32 insertions(+), 2 deletions(-)

diff --git a/lily/chord-name-engraver.cc b/lily/chord-name-engraver.cc
index d0ced5a..2442cdb 100644
--- a/lily/chord-name-engraver.cc
+++ b/lily/chord-name-engraver.cc
@@ -124,8 +124,8 @@ Chord_name_engraver::process_music ()
 
       pitches = scm_sort_list (pitches, Pitch::less_p_proc);
 
-      SCM name_proc = get_property ("chordNameFunction");
-      markup = scm_call_4 (name_proc, pitches, bass, inversion,
+      SCM capo_proc = ly_lily_module_constant ("capo-handler");
+      markup = scm_call_4 (capo_proc, pitches, bass, inversion,
           context ()->self_scm ());
     }
   /*
diff --git a/scm/chord-name.scm b/scm/chord-name.scm
index 79b0189..98506d0 100644
--- a/scm/chord-name.scm
+++ b/scm/chord-name.scm
@@ -170,3 +170,31 @@ FOOBAR-MARKUP) if OMIT-ROOT is given and non-false.
 	 (alist (map chord-to-exception-entry elts)))
     (filter (lambda (x) (cdr x)) alist)))
 
+(define-public (capo-handler pitches bass inversion context)
+  (let ((chord-function
+          (ly:context-property context 'chordNameFunction 'jazz-chord-names))
+        (capo-pitch (ly:context-property context 'capoPitch '())))
+    (if (not capo-pitch)
+        (chord-function pitches bass inversion context)  ;; call the chordNameFunction as of old
+        (let* ((new-pitches   ;; else transpose the pitches and do the chord twice
+                (map (lambda (p)
+                       (ly:pitch-transpose p capo-pitch))
+                     pitches))
+               (new-bass
+                 (if (ly:pitch? bass)
+                     (ly:pitch-transpose bass capo-pitch)
+                     '()))
+               (new-inversion
+                 (if (ly:pitch? inversion)
+                     (ly:pitch-transpose inversion capo-pitch)
+                     '()))
+               (capo-markup
+                 (make-parenthesize-markup
+                   (chord-function new-pitches new-bass new-inversion context)))
+               (name-markup (chord-function pitches bass  inversion context))
+              (capo-vertical (ly:context-property context 'capoVertical #f)))
+          (if capo-vertical
+              (make-column-markup (list name-markup capo-markup))
+              (make-line-markup (list name-markup
+                                      (make-hspace-markup 1)
+                                      capo-markup)))))))
diff --git a/scm/define-context-properties.scm b/scm/define-context-properties.scm
index dab5211..d17f72f 100644
--- a/scm/define-context-properties.scm
+++ b/scm/define-context-properties.scm
@@ -135,6 +135,8 @@ that normally end on beats.")
      (beatStructure ,list? "List of @code{baseMoment}s that are combined
 to make beats.")
 
+     (capoPitch ,ly:pitch? "The pitch to transpose chords down by when using the capo.")
+     (capoVertical ,boolean? "Whether to display actual and transposed pitches above each other or not.")
      (chordChanges ,boolean? "Only show changes in chords scheme?")
      (chordNameExceptions ,list? "An alist of chord exceptions.
 Contains @code{(@var{chord} . @var{markup})} entries.")
-- 
1.7.2.2