-;;;; double-plus-new-chord-name.scm -- Compile chord names
+;;;; chord-generic-names.scm -- Compile chord names
;;;;
;;;; source file of the GNU LilyPond music typesetter
-;;;;
-;;;; (c) 2003 Jan Nieuwenhuizen <janneke@gnu.org>
+;;;;
+;;;; (c) 2003--2008 Jan Nieuwenhuizen <janneke@gnu.org>
;;;; NOTE: this is experimental code
(define-public (banter-chord-names pitches bass inversion context)
(ugh-compat-double-plus-new-chord->markup
- 'banter pitches bass inversion context '())
- )
-
+ 'banter pitches bass inversion context '()))
(define-public (jazz-chord-names pitches bass inversion context)
(ugh-compat-double-plus-new-chord->markup
- 'jazz pitches bass inversion context '())
- )
-
+ 'jazz pitches bass inversion context '()))
(define-public (ugh-compat-double-plus-new-chord->markup
style pitches bass inversion context options)
input/test/dpncnt.ly).
"
-
(define (step-nr pitch)
(let* ((pitch-nr (+ (* 7 (ly:pitch-octave pitch))
(ly:pitch-notename pitch)))
(root-nr (+ (* 7 (ly:pitch-octave (car pitches)))
(ly:pitch-notename (car pitches)))))
(+ 1 (- pitch-nr root-nr))))
-
+
(define (next-third pitch)
(ly:pitch-transpose pitch
(ly:make-pitch 0 2 (if (or (= (step-nr pitch) 3)
(= (step-nr pitch) 5))
- -1 0))))
+ FLAT 0))))
(define (step-alteration pitch)
(let* ((diff (ly:pitch-diff (ly:make-pitch 0 0 0) (car pitches)))
(normalized-pitch (ly:pitch-transpose pitch diff))
(alteration (ly:pitch-alteration normalized-pitch)))
- (if (= (step-nr pitch) 7) (+ alteration 1) alteration)))
-
+ (if (= (step-nr pitch) 7) (+ alteration SEMI-TONE) alteration)))
+
(define (pitch-unalter pitch)
(let ((alteration (step-alteration pitch)))
(if (= alteration 0)
(make-simple-markup (number->string (step-nr pitch)))
(make-simple-markup
(case (step-alteration pitch)
- ((-2) "--")
- ((-1) "-")
- ((0) "")
- ((1) "+")
- ((2) "++"))))))
-
+ ((DOUBLE-FLAT) "--")
+ ((FLAT) "-")
+ ((NATURAL) "")
+ ((SHARP) "+")
+ ((DOUBLE-SHARP) "++"))))))
+
(define (step->markup-accidental pitch)
(make-line-markup
(list (accidental->markup (step-alteration pitch))
(make-line-markup
(if (and (= (step-nr pitch) 7)
(= (step-alteration pitch) 1))
- (list (ly:get-context-property context 'majorSevenSymbol))
+ (list (ly:context-property context 'majorSevenSymbol))
(list (accidental->markup (step-alteration pitch))
(make-simple-markup (number->string (step-nr pitch)))))))
-
+
;; tja, kennok
(define (make-sub->markup step->markup)
(lambda (pitch)
(make-line-markup (list (make-simple-markup "no")
(step->markup pitch)))))
-
+
(define (step-based-sub->markup step->markup pitch)
(make-line-markup (list (make-simple-markup "no") (step->markup pitch))))
-
+
(define (get-full-list pitch)
(if (<= (step-nr pitch) (step-nr (last pitches)))
(cons pitch (get-full-list (next-third pitch)))
(if (pair? exceptions)
(let* ((e (car exceptions))
(e-pitches (car e)))
- (if (equal? e-pitches (take pitches (length e-pitches) ))
+ (if (equal? e-pitches (take pitches (length e-pitches)))
e
(partial-match (cdr exceptions))))
#f))
- (if #f (begin
+ (if #f (begin
(write-me "pitches: " pitches)))
(let* ((full-exceptions
- (ly:get-context-property context 'chordNameExceptionsFull))
+ (ly:context-property context 'chordNameExceptionsFull))
(full-exception (full-match full-exceptions))
(full-markup (if full-exception (cadr full-exception) '()))
(partial-exceptions
- (ly:get-context-property context 'chordNameExceptionsPartial))
+ (ly:context-property context 'chordNameExceptionsPartial))
(partial-exception (partial-match partial-exceptions))
(partial-pitches (if partial-exception (car partial-exception) '()))
(partial-markup-prefix
;; kludge alert: replace partial matched lower part of all with
;; 'normal' pitches from full
;; (all pitches)
- (all (append (take full (length partial-pitches) )
- (drop pitches (length partial-pitches) )))
-
+ (all (append (take full (length partial-pitches))
+ (drop pitches (length partial-pitches))))
+
(highest (last all))
(missing (list-minus full (map pitch-unalter all)))
(consecutive (get-consecutive 1 all))
(altered (filter step-even-or-altered? all))
(cons-alt (filter step-even-or-altered? consecutive))
(base (list-minus consecutive altered)))
-
+
(if #f (begin
(write-me "full:" full)
;; root
;; + steps:altered + (highest all -- if not altered)
;; + subs:missing
-
- (let* ((root->markup (assoc-get-default
+
+ (let* ((root->markup (assoc-get
'root->markup options note-name->markup))
- (step->markup (assoc-get-default
+ (step->markup (assoc-get
'step->markup options step->markup-plusminus))
- (sub->markup (assoc-get-default
+ (sub->markup (assoc-get
'sub->markup options
(lambda (x)
(step-based-sub->markup step->markup x))))
- (sep (assoc-get-default
+ (sep (assoc-get
'separator options (make-simple-markup "/"))))
-
+
(if
(pair? full-markup)
(make-line-markup (list (root->markup root) full-markup))
-
+
(make-line-markup
(list
(root->markup root)
(list partial-markup-suffix)
(list (map sub->markup missing)))
sep)))))))
-
-
+
+
((jazz)
;; root
;; + steps:(highest base) + cons-alt
;; + 'add'
;; + steps:rest
- (let* ((root->markup (assoc-get-default
+ (let* ((root->markup (assoc-get
'root->markup options note-name->markup))
(step->markup
- (assoc-get-default
+ (assoc-get
;; FIXME: ignatzek
;;'step->markup options step->markup-accidental))
'step->markup options step->markup-ignatzek))
- (sep (assoc-get-default
+ (sep (assoc-get
'separator options (make-simple-markup " ")))
- (add-prefix (assoc-get-default 'add-prefix options
+ (add-prefix (assoc-get 'add-prefix options
(make-simple-markup " add"))))
-
+
(if
(pair? full-markup)
(make-line-markup (list (root->markup root) full-markup))
-
+
(make-line-markup
(list
(root->markup root)
(make-normal-size-super-markup
(make-line-markup
(list
-
+
;; kludge alert: omit <= 5
;;(markup-join (map step->markup
;; (cons (last base) cons-alt)) sep)
-
+
;; This fixes:
;; c C5 -> C
;; c:2 C5 2 -> C2
(if (> (step-nr tb) 5)
(cons tb cons-alt)
cons-alt))) sep)
-
+
(if (pair? rest)
add-prefix
empty-markup)
(markup-join (map step->markup rest) sep)
partial-markup-suffix))))))))
-
+
(else empty-markup))))
projects / lilypond.git / blobdiff