-
-(use-modules
- (ice-9 debug)
- (ice-9 format)
- (ice-9 regex)
- (ice-9 string-fun)
- )
-
-"
-
-TODO:
-
-- Use lilypond Pitch objects -- SCM pitch objects leads to duplication.
-
-- Pitches are musical objects. The pitches -> markup step should
-happen earlier (during interpreting), brew-molecule () should only
-dump reinterpret the markup as a molecule.
-
-
-"
-
-;; pitch = (octave notename alteration)
-;;
-;; note = (notename . alteration)
-;;
-;; text = scm markup text -- see font.scm and input/test/markup.ly
-
-
-;; TODO
-
-;; Ugh : naming chord::... ; this is scheme not C++
-;;
-;; * easier tweakability:
-;; - split chord::names-alists up into logical bits,
-;; such as chord::exceptions-delta, exceptions-oslash
-;; - iso just the 'style parameter, use a list, eg:
-;; \property ChordNames.ChordName \set
-;; #'style = #'(jazz delta oslash german-tonic german-Bb)
-;;
-;; * fix FIXMEs
-;;
-;; * clean split/merge of bass/banter/american stuff
-;;
-;; * doc strings
-
-(define-public chord::names-alist-banter '())
-(set! chord::names-alist-banter
- (append
- `(
- ; C iso C.no3.no5
- (((0 . 0)) . (,simple-markup ""))
- ; C iso C.no5
- (((0 . 0) (2 . 0)) . (,simple-markup ""))
- ; Cm iso Cm.no5
- (((0 . 0) (2 . -1)) . (,simple-markup "m"))
- ; C2 iso C2.no3
- (((0 . 0) (1 . 0) (4 . 0)) . (,super-markup (,simple-markup "2 ")))
- ; C4 iso C4.no3
- (((0 . 0) (3 . 0) (4 . 0)) . (,super-markup (,simple-markup "4 ")))
- ;; Cdim iso Cm5-
- (((0 . 0) (2 . -1) (4 . -1)) . (,simple-markup "dim"))
- ; URG: Simply C:m5-/maj7 iso Cdim maj7
- (((0 . 0) (2 . -1) (4 . -1) (6 . 0)) . (,line-markup ((,simple-markup "m") (,super-markup (,simple-markup "5-/maj7 ")))))
- ; URG: Simply C:m5-/7 iso Cdim7
- (((0 . 0) (2 . -1) (4 . -1) (6 . -1)) . (,line-markup ((,simple-markup "m") (,super-markup (,simple-markup "5-/7 ")))))
- ; Co iso C:m5-/7-
- (((0 . 0) (2 . -1) (4 . -1) (6 . -2)) . (,super-markup (,simple-markup "o ")))
- ; Cdim9
- (((0 . 0) (2 . -1) (4 . -1) (6 . -2) (1 . -1)) . (,line-markup ((,simple-markup "dim")
- (,simple-markup "9 "))))
- (((0 . 0) (2 . -1) (4 . -1) (6 . -2) (1 . -1) (3 . -1))
- . (,line-markup ((,simple-markup "dim")
- (,super-markup (,simple-markup "11 ")))))
-
- )
- chord::names-alist-banter))
-
-;;;;;;;;;;
-
-(define (pitch->note-name pitch)
- (cons (cadr pitch) (caddr pitch)))
-
-(define (accidental-markup acc)
- "ACC is an int, return a markup making an accidental."
- (if (= acc 0)
- `(,simple-markup "")
- `(,smaller-markup (,musicglyph-markup ,(string-append "accidentals-" (number->string acc))))
- ))
-
-(define (pitch->markup pitch)
- (list line-markup
- (list
- (list simple-markup
- (make-string 1 (integer->char (+ (modulo (+ (cadr pitch) 2) 7) 65))))
- (list normal-size-superscript-markup
- (accidental-markup (caddr pitch))))))
-
-;;; Hooks to override chord names and note names,
-;;; see input/tricks/german-chords.ly
-
-(define pitch->markup-banter pitch->markup)
-
-;; We need also steps, to allow for Cc name override,
-;; see input/test/Cc-chords.ly
-(define (pitch->chord-name-markup-banter pitch steps)
- (pitch->markup-banter pitch))
-
-(define pitch->note-name-markup-banter pitch->markup-banter)
-
-(define (step->markup pitch)
- (string-append
- (number->string (+ (cadr pitch) (if (= (car pitch) 0) 1 8)))
- (case (caddr pitch)
- ((-2) "--")
- ((-1) "-")
- ((0) "")
- ((1) "+")
- ((2) "++"))))
-
-(define (step->markup-banter pitch)
- (list simple-markup
- (if (= (cadr pitch) 6)
- (case (caddr pitch)
- ((-2) "7-")
- ((-1) "7")
- ((0) "maj7")
- ((1) "7+")
- ((2) "7+"))
- (step->markup pitch))))
-
-(define pitch::semitone-vec #(0 2 4 5 7 9 11))
-
-(define (pitch::semitone pitch)
- (+ (* (car pitch) 12)
- (vector-ref pitch::semitone-vec (modulo (cadr pitch) 7))
- (caddr pitch)))
-
-(define (pitch::< l r)
- (< (pitch::semitone l) (pitch::semitone r)))
-
-(define (pitch::transpose pitch delta)
- (let ((simple-octave (+ (car pitch) (car delta)))
- (simple-notename (+ (cadr pitch) (cadr delta))))
- (let ((octave (+ simple-octave (quotient simple-notename 7)))
- (notename (modulo simple-notename 7)))
- (let ((accidental (- (+ (pitch::semitone pitch) (pitch::semitone delta))
- (pitch::semitone `(,octave ,notename 0)))))
- `(,octave ,notename ,accidental)))))
-
-(define (pitch::diff pitch tonic)
- (let ((simple-octave (- (car pitch) (car tonic)))
- (simple-notename (- (cadr pitch) (cadr tonic))))
- (let ((octave (+ simple-octave (quotient simple-notename 7)
- (if (< simple-notename 0) -1 0)))
- (notename (modulo simple-notename 7)))
- (let ((accidental (- (pitch::semitone pitch)
- (pitch::semitone tonic)
- (pitch::semitone `(,octave ,notename 0)))))
- `(,octave ,notename ,accidental)))))
-
-(define (pitch::note-pitch pitch)
- (+ (* (car pitch) 7) (cadr pitch)))
-
-;; markup: list of word
-;; word: string + optional list of property
-;; property: axis, kern, font (?), size
-
-(define chord::minor-major-vec (list->vector '(0 -1 -1 0 -1 -1 0)))
-
-;; FIXME: unLOOP
-;; compute the relative-to-tonic pitch that goes with 'step'
-(define (chord::step-pitch tonic step)
- ;; urg, we only do this for thirds
- (if (= (modulo step 2) 0)
- '(0 0 0)
- (let loop ((i 1) (pitch tonic))
- (if (= i step) pitch
- (loop (+ i 2)
- (pitch::transpose
- pitch `(0 2 ,(vector-ref chord::minor-major-vec
- ;; -1 (step=1 -> vector=0) + 7 = 6
- (modulo (+ i 6) 7)))))))))
-
-(define (chord::additions steps)
-" Return:
- * any even step (2, 4, 6)
- * any uneven step that is chromatically altered,
- (where 7-- == -1, 7- == 0, 7 == +1)
- * highest step
-
-?and jazz needs also:
-
- * TODO: any uneven step that's lower than an uneven step which is
- chromatically altered
- "
- (let ((evens (filter-list (lambda (x) (!= 0 (modulo (cadr x) 2))) steps))
- (altered-unevens
- (filter-list (lambda (x)
- (let ((n (cadr x)) (a (caddr x)))
- (or (and (= 6 n) (!= -1 a))
- (and (!= 6 n)
- (= 0 (modulo n 2))
- (!= 0 a)))))
- steps))
- (highest (let ((h (car (last-pair steps))))
- (if (and (not (null? h))
- (or (> 4 (cadr h))
- (!= 0 (caddr h))))
- (list (list h))
- '()))))
- ;; Hmm, what if we have a step twice, can we ignore that?
- (uniq-list (sort (apply append evens altered-unevens highest)
- pitch::<))))
-
-
-;; FIXME: unLOOP, see ::additions
-;; find the pitches that are missing from `normal' chord
-(define (chord::subtractions chord-pitches)
- (let ((tonic (car chord-pitches)))
- (let loop ((step 1) (pitches chord-pitches) (subtractions '()))
- (if (pair? pitches)
- (let* ((pitch (car pitches))
- (p-step (+ (- (pitch::note-pitch pitch)
- (pitch::note-pitch tonic))
- 1)))
- ;; pitch is an subtraction if
- ;; a step is missing or
- (if (> p-step step)
- (loop (+ step 2) pitches
- (cons (chord::step-pitch tonic step) subtractions))
- ;; there are no pitches left, but base thirds are not yet done and
- (if (and (<= step 5)
- (= (length pitches) 1))
- ;; present pitch is not missing step
- (if (= p-step step)
- (loop (+ step 2) pitches subtractions)
- (loop (+ step 2) pitches
- (cons (chord::step-pitch tonic step) subtractions)))
- (if (= p-step step)
- (loop (+ step 2) (cdr pitches) subtractions)
- (loop step (cdr pitches) subtractions)))))
- (reverse subtractions)))))
-
-(define (chord::additions->markup-banter additions subtractions)
- (if (pair? additions)
- (list line-markup
- (list
- (let ((step (step->markup-banter (car additions))))
- (if (or (pair? (cdr additions))
- (pair? subtractions))
- (list line-markup
- (list step (list simple-markup "/")))
- step))
-
- (chord::additions->markup-banter (cdr additions) subtractions)))
- (list simple-markup "")
-
- ))
-
-(define (chord::subtractions->markup-banter subtractions)
- (if (pair? subtractions)
- (list line-markup
- (list simple-markup "no")
- (let ((step (step->markup-jazz (car subtractions))))
- (if (pair? (cdr subtractions))
- (list line-markup (list step (list simple-markup "/")))
- step))
- (chord::subtractions->markup-banter (cdr subtractions)))
- (list simple-markup "")
- ))
-
-(define (chord::bass-and-inversion->markup-banter bass-and-inversion)
- (if (and (pair? bass-and-inversion)
- (or (car bass-and-inversion)
- (cdr bass-and-inversion)))
- (list
- line-markup
- (list
- (list simple-markup "/")
- (pitch->note-name-markup-banter
- (if (car bass-and-inversion)
- (car bass-and-inversion)
- (cdr bass-and-inversion)))
- ))
- (list simple-markup "")
- ))
-
-;; FIXME: merge this function with inner-name-jazz, -american
-;; iso using chord::bass-and-inversion->markup-banter,
-;; call (chord::restyle 'chord::bass-and-inversion->markup- style)
-;; See: chord::exceptions-lookup
-(define (chord::inner-name-banter tonic exception-part additions subtractions
- bass-and-inversion steps)
-
- "
-
- Banter style
- Combine tonic, exception-part of chord name,
- additions, subtractions and bass or inversion into chord name
-
-"
- (let* ((tonic-markup (pitch->chord-name-markup-banter tonic steps))
- (except-markup exception-part)
- (sep-markup (list simple-markup
- (if (and (string-match "super" (format "~s" except-markup))
- (or (pair? additions)
- (pair? subtractions)))
- "/" "")
- ))
- (adds-markup (chord::additions->markup-banter additions subtractions))
- (subs-markup (chord::subtractions->markup-banter subtractions))
- (b+i-markup (chord::bass-and-inversion->markup-banter bass-and-inversion)))
-
- `(,line-markup
- (,tonic-markup
- ,except-markup
- ,sep-markup
- (,raise-markup 0.3
- (,line-markup (,adds-markup ,subs-markup))
- )
- ,b+i-markup
- ))
- ))
-
-(define (c++-pitch->scm p)
- (if (ly:pitch? p)
- (list (ly:pitch-octave p) (ly:pitch-notename p) (ly:pitch-alteration p))
- #f))
-
-(define-public (chord::name-banter tonic exception-part unmatched-steps
- bass-and-inversion steps)
- (let ((additions (chord::additions unmatched-steps))
- (subtractions (chord::subtractions unmatched-steps)))
-
- (chord::inner-name-banter tonic exception-part additions subtractions
- bass-and-inversion steps)))
-
-
-(define (chord::restyle name style)
- (primitive-eval ;; "UGGHGUGHUGHG"
-
- (string->symbol
- (string-append (symbol->string name)
- (symbol->string style)))))
-
-;; check exceptions-alist for biggest matching part of try-steps
-;; return (MATCHED-EXCEPTION . UNMATCHED-STEPS)
-(define (chord::exceptions-lookup-helper
- exceptions-alist try-steps unmatched-steps exception-part)
- (if (pair? try-steps)
- ;; FIXME: junk '(0 . 0) from exceptions lists?
- ;; if so: how to handle first '((0 . 0) . #f) entry?
- ;;
- ;; FIXME: either format exceptions list as real pitches, ie,
- ;; including octave '((0 2 -1) ..), or drop octave
- ;; from rest of calculations,
- (let ((entry (assoc
- (map (lambda (x) (pitch->note-name x))
- (append '((0 0 0)) try-steps))
- exceptions-alist)))
- (if entry
- (chord::exceptions-lookup-helper
- #f '() unmatched-steps (cdr entry))
- (let ((r (reverse try-steps)))
- (chord::exceptions-lookup-helper
- exceptions-alist
- (reverse (cdr r))
- (cons (car r) unmatched-steps) #f))))
- (cons exception-part unmatched-steps)))
-
-;; return (MATCHED-EXCEPTION . BASE-CHORD-WITH-UNMATCHED-STEPS)
-;; BASE-CHORD-WITH-UNMATCHED-STEPS always includes (tonic 3 5)
-(define (chord::exceptions-lookup style steps)
- (let* ((result (chord::exceptions-lookup-helper
- (chord::restyle 'chord::names-alist- style)
- steps '() #f))
- (exception-part (car result))
- (unmatched-steps (cdr result))
- (matched-steps (if (= (length unmatched-steps) 0)
- 3
- (+ 1 (- (length steps)
- (length unmatched-steps)))))
- (unmatched-with-1-3-5
- (append (do ((i matched-steps (- i 1))
- (base '() (cons `(0 ,(* (- i 1) 2) 0) base)))
- ((= i 0) base)
- ())
- unmatched-steps)))
- (list exception-part unmatched-with-1-3-5)))
-
-
-(define (chord::name->markup style tonic steps bass-and-inversion)
- (let* ((lookup (chord::exceptions-lookup style steps))
- (exception-part (car lookup))
- (unmatched-steps (cadr lookup))
- (func (chord::restyle 'chord::name- style))
-
- )
-
-
- (func tonic exception-part unmatched-steps bass-and-inversion steps)))
-
-;; C++ entry point