Hi all,
> I've attached the beginning of an automatic partwriter.
Here's an improved version of the partwriter which adds a few
constraints to get smoother results.
The four voices may not all move in the same direction, and upper
parts must move to the closest available chord member (in the
direction of movement). Bass leaps are handled more sensibly, and
bass and tenor are kept within a 10th of each other.
The partwriter still only works with root-position triads. Baby steps.
David
\version "2.18.2"
%%% Pitch Utility
#(define (pitch>=? a b)
(not (ly:pitch<? a b)))
#(define (pitch=? a b)
(and (not (ly:pitch<? a b))
(not (ly:pitch<? b a))))
#(define (same-pc? a b)
(eqv?
(modulo (ly:pitch-semitones (ly:pitch-diff a b)) 12)
0))
#(define (enharmonic? a b)
(and (same-pc? a b)
(eqv? (ly:pitch-octave a) (ly:pitch-octave b))))
% Convert a pitch object into a music expression with duration
#(define (make-note pitch dur)
(make-music
'NoteEvent
'duration
dur
'pitch
pitch))
%%% Interval Utility
#(define (ordered-pitch-interval p1 p2)
; pitches are exchanged so result is positive when p2 is higher than p1
(ly:pitch-semitones (ly:pitch-diff p2 p1)))
#(define (unordered-pitch-interval p1 p2)
(abs (ordered-pitch-interval p1 p2)))
#(define interval unordered-pitch-interval)
#(define (base-interval n1 n2)
(modulo (interval n1 n2) 12))
#(define (interval->interval-class interval)
(let ((iv (calc-base-interval interval)))
(if (< iv 6)
iv
(- 12 iv))))
#(define (interval=? iv1 iv2)
(eqv? (interval (car iv1) (cadr iv1))
(interval (car iv2) (cadr iv2))))
#(define (semitone? p1 p2)
(eqv? 1 (interval p1 p2)))
#(define half-step? semitone?)
#(define (whole-tone? p1 p2)
(eqv? 2 (interval p1 p2)))
#(define whole-step? whole-tone?)
#(define (step? p1 p2)
(or (half-step? p1 p2)
(whole-step? p1 p2)))
%% Intervals specified as a pitch (relative to middle C)
#(define disallowed-intervals
`(
,#{ dis' #} ; A2
,#{ fis' #} ; A4
,#{ ges' #} ; d5
,#{ bes' #} ; m7
,#{ b' #} ; M7
))
%%% List utility
% permute, for example, (1 3 5)
% Procedure:
% Put one to end: (3 5 1), put 5 to end (3 1 5)
% Put three to end: (5 1 3), put 1 to end: (5 3 1)
% Put five to end: (1 3 5), put 3 to end: (1 5 3)
% '(1 2 3) => '(2 3 1)
#(define (rotate-list ls)
(append (cdr ls) (list (car ls))))
% '(1 2 3) => '((1 2 3) (2 3 1) (3 1 2))
#(define (all-rotations ls)
(define (helper cp ls)
(if (null? cp)
'()
(cons ls
(helper (cdr cp) (rotate-list ls)))))
(helper ls ls))
% All possible orderings of a list
% '(1 2 3) => '((1 2 3) (2 3 1) (3 1 2) (1 3 2) (3 2 1) (2 1 3))
#(define (permute-list ls)
(define (helper head tail)
(map (lambda (t) (append head t))
(all-rotations tail)))
(let loop ((idx (1- (length ls))) (res (list ls)))
(if (< idx 0)
res
(loop
(1- idx)
(append-map
(lambda (r) (helper (list-head r idx) (list-tail r idx)))
res)))))
% return list of lists of every ordered combination of single elements
% from a list of lists
% '((1 2) (a b) (100) (x)) ==> '((1 a 100 x) (1 b 100 x) (2 a 100 x) (2 b 100 x))
#(define (every-one-of-each ls)
(define (helper ls1 ls2)
(append-map
(lambda (x)
(map (lambda (y) (cons y x))
ls2))
ls1))
(let loop ((ls ls) (seed '(())))
(if (null? ls)
(map reverse seed)
(loop (cdr ls) (helper seed (car ls))))))
%%% Ranges
#(define full-ranges
`(
("bass" . (,#{ e, #} . ,#{ d' #}))
("tenor" . (,#{ c #} . ,#{ g' #}))
("alto" . (,#{ g #} . ,#{ d'' #}))
("soprano" . (,#{ c' #} . ,#{ g'' #}))
))
#(define moderate-ranges
`(
("bass" . (,#{ g, #} . ,#{ b #}))
("tenor" . (,#{ e #} . ,#{ e' #}))
("alto" . (,#{ b #}. ,#{ b' #}))
("soprano" . (,#{ e' #} . ,#{ e'' #}))
))
% Locate every pitch expression of a chord member within a voice's range
% `mem' is a pitch derived from a \chordmode expression.
% (The octave of this input pitch is discarded.)
#(define (voice-member-possibilities mem range)
(filter-map
(lambda (p)
(and (pitch>=? p (car range))
(pitch>=? (cdr range) p)
p))
(map
(lambda (o)
(ly:make-pitch o
(ly:pitch-notename mem)
(ly:pitch-alteration mem)))
(iota (1+ (- (ly:pitch-octave (cdr range))
(ly:pitch-octave (car range))))
(ly:pitch-octave (car range))))))
% Find every pitch expression of a chord's members for a voice type.
% `voice-str' identifies the voice type: "bass" "tenor" "alto" "soprano"
% `chord' is an alist of (member . pitch) pairs. For example,
% ((root . #<Pitch f' >) (third . #<Pitch a' >) (fifth . #<Pitch c'' >))
% The octave representations are straight from Lily's chordmode processing
% Return is a list of lists structured as (member (list-of-all-possible-octave-expressions))
% for the particular voice type. For example,
% ((root (#<Pitch gis, > #<Pitch gis >)) (third (#<Pitch b, > #<Pitch b >)) (fifth (#<Pitch dis >)))
% TODO: range should be a parameter!
#(define (voice-all-member-possibilities voice-str chord)
(let ((range (ly:assoc-get voice-str full-ranges)))
(map (lambda (mem)
(cons (car mem)
(list
(voice-member-possibilities
(cdr mem)
range))))
chord)))
%%% Voicing utility
% Check that each voice is in unison with or higher than next lower voice
% `ls' is a chord voicing, from bass up. For example,
% (#<Pitch gis, > #<Pitch gis > #<Pitch b > #<Pitch dis'' >)
#(define (ascending? ls)
(let loop ((l ls) (good #f))
(cond
((null? (cdr l)) good)
((ly:pitch<? (cadr l) (car l))
#f)
(else (loop (cdr l) #t)))))
% Check that adjacent upper parts are no more than an octave apart
#(define (T-A-S-well-spaced? ls)
(let ((TAS (cdr ls)))
(let loop ((l TAS) (good #f))
(cond
((null? (cdr l)) good)
((< 12 (ly:pitch-semitones (ly:pitch-diff (cadr l) (car l))))
#f)
(else (loop (cdr l) #t))))))
% Restrict bass and tenor to no more than a tenth apart
#(define (B-T-tenth-or-less? ls)
(< (unordered-pitch-interval (car ls) (cadr ls)) 17))
% `p-lists' is a list of lists representing all voicings of a chord, ordered
% from bass up. For example,
% ((#<Pitch gis, > #<Pitch gis > #<Pitch b > #<Pitch dis'' >)
% (#<Pitch gis, > #<Pitch gis > #<Pitch b' > #<Pitch dis'' >)
% [...] )
% Remove bad arrangements.
#(define (filter-pitch-lists p-lists)
(filter T-A-S-well-spaced?
(filter B-T-tenth-or-less?
(filter ascending? p-lists))))
% correlation of inversion and bass member
% TODO: calculate this from \chordmode expression
#(define inversion-lookup
'(
("root" . "root")
("first" . "third")
("second" . "fifth")
("third" . "seventh")
))
% Returns a list of lists of possible chord voicings.
% Pitches are arranged from lowest to highest, corresponding
% to an uncrossed SATB arrangement.
% `chord' is an alist of (member . pitch) pairs
% `inversion' is a symbol: 'root 'first 'second 'third
% `upper-members' is a list representing unordered chord-member content in T-A-S
% for example, '("root" "third" "fifth")
#(define (make-pitch-lists chord inversion upper-members)
(let* (; First find every chord tone within range of part
(bass (voice-all-member-possibilities "bass" chord))
(tenor (voice-all-member-possibilities "tenor" chord))
(alto (voice-all-member-possibilities "alto" chord))
(soprano (voice-all-member-possibilities "soprano" chord))
; all dispositions of chord members (strings) in upper voices
; for example, ((root third fifth) (third fifth root) [...])
(arrangements (permute-list upper-members))
; add bass member string
; ((root root third fifth) (root third fifth root) [,,,])
(bass-member
(ly:assoc-get
(symbol->string inversion) inversion-lookup))
(arrangements
(map
(lambda (a) (cons bass-member a))
arrangements))
; substitute lists of available pitches for each member name
(pitched-arrangements
(map (lambda (arr)
(list
(ly:assoc-get (first arr) bass)
(ly:assoc-get (second arr) tenor)
(ly:assoc-get (third arr) alto)
(ly:assoc-get (fourth arr) soprano)))
arrangements))
;; YUCK. Shouldn't need to unnest like this.
(pitched-arrangements
(map (lambda (arr)
(map (lambda (a) (car a)) arr))
pitched-arrangements))
; now convert lists of pitch possibilities into all possible combinations
(pitched-arrangements (map every-one-of-each pitched-arrangements))
; unnest
(pitched-arrangements
(append-map identity pitched-arrangements)))
; Get rid of bad arrangements. (Wide spacing in upper voices,
; crossed parts)
(filter-pitch-lists pitched-arrangements)))
%%% \chordmode input processing
% Analyze chords for root, third, fifth, seventh ...
% Return a sequence of thirds which encompasses all chord members
% (The shortest such sequence should represent the chord in root position)
#(define (get-chord-member-sequence members)
(let loop
((ls (circular-list 0 2 4 6 1 3 5))
(return '())
(our-chord members)
(collect #f))
(cond
((null? our-chord)
(reverse return))
((eqv? (car ls) (car our-chord))
(loop (cdr ls) (cons (car ls) return) (cdr our-chord) #t))
(collect
(loop (cdr ls) (cons (car ls) return) our-chord collect))
(else
(loop (cdr ls) return our-chord collect)))))
#(define (find-root-position members)
(let* ((rotations (all-rotations members))
(seqs (map get-chord-member-sequence rotations)))
(reduce
(lambda (elem prev)
(if (< (length elem) (length prev))
elem
prev))
'()
seqs)))
% Convert a member of a \chordmode expression into
% an alist pairing chord member names with pitches. For example,
%((root . #<Pitch f' >) (third . #<Pitch aes' >) (fifth . #<Pitch ces'' >))
#(define (parse-chord mus)
(let* ((note-events (extract-named-music mus 'NoteEvent))
(pitches (map (lambda (n) (ly:music-property n 'pitch))
note-events))
(names (map (lambda (p) (ly:pitch-notename p))
pitches))
(root-map (find-root-position names))
(root-map
(map (lambda (a b) (cons a b))
root-map
(list "root" "third" "fifth" "seventh" "ninth" "eleventh" "thirteenth"))))
(map (lambda (m)
(cons
(ly:assoc-get (ly:pitch-notename m) root-map)
m))
pitches)))
% Build a list of chord member/pitch alists for all the chords in a \chordmode expression
#(define (parse-progression mus)
(let ((ev-ch (extract-named-music mus 'EventChord)))
(map parse-chord ev-ch)))
% extract rhythm from a \chordmode expression
#(define (get-rhythm mus)
(let* ((ev-chs (extract-named-music mus 'EventChord))
(n-evs (map (lambda (ne) (extract-named-music ne 'NoteEvent))
ev-chs))
(durations (map (lambda (ne) (ly:music-property (car ne) 'duration))
n-evs)))
durations))
%%% Building spacing output
#(define (get-voice-contents chord inversion members duration)
(let* ((arr (make-pitch-lists chord inversion members))
(zipped (apply zip arr)))
(map (lambda (z)
(map (lambda (n)
(make-note n duration))
z))
zipped)))
allSpacings =
#(define-music-function (parser location keey chord inversion members)
(ly:music? ly:music? symbol? list?)
(let* ((duration (car (get-rhythm chord)))
(chord-contents (parse-chord chord))
(voice-contents
(get-voice-contents chord-contents inversion members duration)))
#{
<<
\context Staff = "top" <<
\context Voice = "1" {
#keey
\voiceOne
#@(last voice-contents)
}
\context Voice = "2" {
\voiceTwo
#@(third voice-contents)
}
>>
\context Staff = "bottom" <<
\context Voice = "3" {
#keey
\voiceOne
\clef bass
#@(second voice-contents)
}
\context Voice = "4" {
\voiceTwo
#@(first voice-contents)
}
>>
>>
#}))
%%% Voice-leading utility
#(define (octave-equivalent? p1 p2)
(and (eqv? (ly:pitch-notename p1) (ly:pitch-notename p2))
(eqv? (ly:pitch-alteration p1) (ly:pitch-alteration p2))))
#(define (tonic? p keey)
(octave-equivalent? (ly:music-property keey 'tonic) p))
% There is currently no property in 'KeychangeEvent to identify
% major vs. minor. 'pitch-alist gives degree 7 of natural minor.
% Thus, we derive leading tone as note m2 below tonic.
#(define (leading-tone? p keey)
(let* ((tonic (ly:music-property keey 'tonic))
(leading-tone (ly:pitch-transpose tonic #{ b, #})))
(octave-equivalent? p leading-tone)))
#(define (dominant? p keey)
(let ((dominant (list-ref (ly:music-property keey 'pitch-alist) 4)))
(and (eqv? (ly:pitch-notename p) (car dominant))
(eqv? (ly:pitch-alteration p) (cdr dominant)))))
% TODO: Take into consideration enharmonic spellings. D#-A# -> Eb-Bb is not motion.
#(define (both-parts-same-direction? iv1 iv2)
(or
(and (ly:pitch<? (car iv1) (car iv2))
(ly:pitch<? (cadr iv1) (cadr iv2)))
(and (ly:pitch<? (car iv2) (car iv1))
(ly:pitch<? (cadr iv2) (cadr iv1)))))
#(define (parallel-motion? iv1 iv2)
(and (interval=? iv1 iv2)
(both-parts-same-direction? iv1 iv2)))
#(define (similar-motion? iv1 iv2)
(and (not (interval=? iv1 iv2))
(both-parts-same-direction? iv1 iv2)))
#(define (oblique-motion? iv1 iv2)
(or
(and (pitch=? (car iv1) (car iv2))
(not (pitch=? (cadr iv1) (cadr iv2))))
(and (pitch=? (cadr iv1) (cadr iv2))
(not (pitch=? (car iv1) (car iv2))))))
#(define (contrary-motion? iv1 iv2)
(or
(and (ly:pitch<? (car iv1) (car iv2))
(ly:pitch<? (cadr iv2) (cadr iv1)))
(and (ly:pitch<? (car iv2) (car iv1))
(ly:pitch<? (cadr iv1) (cadr iv2)))))
#(define (line-direction p1 p2)
(cond
((ly:pitch<? p1 p2) UP)
((ly:pitch<? p2 p1) DOWN)
(else CENTER)))
% Given two chords, expressed as
% '(bass-pitch tenor-pitch alto-pitch soprano-pitch),
% check for various voice-leading problems
% Return #f if all clear, #t if any errors found
#(define (parallel-perfects-or-perfects-by-contrary-motion? iv1 iv2)
(and (or (not (pitch=? (car iv1) (car iv2))) ; octave leap? enharmonic?
(not (pitch=? (cadr iv1) (cadr iv2))))
(let ((s1 (base-interval (cadr iv1) (car iv1)))
(s2 (base-interval (cadr iv2) (car iv2))))
(or
(and (= 7 s1)(= 7 s2))
(and (= 0 s1)(= 0 s2))))))
#(define (any-parallel-perfects-or-perfects-by-contrary-motion? c1 c2)
(let loop ((c1 c1) (c2 c2))
(cond
((null? (cdr c1)) #f)
(else
(let inner ((top1 (cdr c1)) (top2 (cdr c2)))
(cond
((null? top1)
(loop (cdr c1) (cdr c2)))
((parallel-perfects-or-perfects-by-contrary-motion?
(list (car c1) (car top1))
(list (car c2) (car top2)))
#t)
(else
(inner (cdr top1) (cdr top2)))))))))
#(define (outer-voice-direct-fifths-or-octaves? c1 c2)
(let* ((outer1 (list (first c1) (last c1)))
(outer2 (list (first c2) (last c2)))
(outer-iv2 (apply base-interval outer2))
(similar? (similar-motion? outer1 outer2)))
(and similar?
(or (eqv? outer-iv2 0)
(eqv? outer-iv2 7))
(not (step? (last c1) (last c2))))))
#(define (voice-overlap? iv1 iv2)
(or (ly:pitch<? (second iv1) (first iv2))
(ly:pitch<? (second iv2) (first iv1))))
#(define (any-overlapping-voices? c1 c2)
(let loop ((v1 c1) (v2 c2))
(cond
((null? (cdr v1)) #f)
((voice-overlap?
(list (first v1) (second v1))
(list (first v2) (second v2)))
#t)
(else (loop (cdr v1) (cdr v2))))))
% TODO: allow tripled root
% TODO: ^7 moving down in iii->IV
% TODO: leading-tone to chord seventh
% TODO: possibility of delayed resolution
% TODO: LT in sequences
#(define (unresolved-leading-tone? p1 p2 keey inner-voice?)
(cond
((not (leading-tone? p1 keey)) #f)
((and (tonic? p2 keey)
(semitone? p1 p2))
#f)
((and inner-voice?
(eqv? -4 (ordered-pitch-interval p1 p2)))
#f)
(else #t)))
#(define (any-poorly-handled-leading-tone? c1 c2 keey)
(let* ((inner-vv
(map (lambda (p1 p2)
(unresolved-leading-tone? p1 p2 keey #t))
(list-head (cdr c1) 2)
(list-head (cdr c2) 2)))
(outer-vv
(map (lambda (p1 p2)
(unresolved-leading-tone? p1 p2 keey #f))
(list (first c1) (last c1))
(list (first c2) (last c2)))))
(or (any identity inner-vv)
(any identity outer-vv))))
#(define (disallowed-melodic-interval? p1 p2)
(let* ((asc (sort (list p1 p2) ly:pitch<?))
(diff (ly:pitch-diff (cadr asc) (car asc))))
(any (lambda (p) (octave-equivalent? p diff)) disallowed-intervals)))
#(define (any-disallowed-melodic-interval? c1 c2)
(any identity
(map (lambda (p1 p2) (disallowed-melodic-interval? p1 p2))
c1 c2)))
#(define (all-voices-similar-motion? c1 c2)
(define (inner result c1 c2)
(if (null? (cdr c1))
result
(inner
(cons
(both-parts-same-direction? (list-head c1 2) (list-head c2 2))
result)
(cdr c1) (cdr c2))))
(every identity (inner '() c1 c2)))
#(define (bass-leap-over-octave? c1 c2)
(< 12 (interval (first c1) (first c2))))
#(define (voice-all-chord-tones-within-range voice-str chord)
(let* ((range (ly:assoc-get voice-str full-ranges))
(pitches
(append-map
(lambda (mem)
(voice-member-possibilities mem range))
chord)))
(sort pitches ly:pitch<?)))
% Are `p1' and `p2' non-adjacent chord members?
% `possible-members' is a list of all chord tones available to the voice part
% in the second chord.
#(define (non-adjacent-chord-members? p1 p2 possible-members)
(if (pitch=? p1 p2) ; common tones
#f
(let ((above-or-below
(if (ly:pitch<? p1 p2)
(filter (lambda (p) (ly:pitch<? p1 p)) possible-members)
(filter (lambda (p) (ly:pitch<? p p1)) possible-members))))
(cond
((and (ly:pitch<? p1 p2) (pitch=? (car above-or-below) p2))
#f)
((and (ly:pitch<? p2 p1) (pitch=? (car (reverse above-or-below)) p2))
#f)
(else #t)))))
% returns #t if any upper voice could move to a closer chord member in
% the direction of movement
% Only T-A-S considered
#(define (any-move-to-nonadjacent-chord-member? c1 c2)
(let (; use cdr because need to omit bass
; c1 and c2 store chords in _bottom-up_ ordering
(tenor (voice-all-chord-tones-within-range "tenor" (cdr c2)))
(alto (voice-all-chord-tones-within-range "alto" (cdr c2)))
(sop (voice-all-chord-tones-within-range "soprano" (cdr c2))))
(any identity
(map (lambda (p1 p2 m) (non-adjacent-chord-members? p1 p2 m))
(cdr c1) (cdr c2) (list tenor alto sop)))))
%%% Building progressions
% Progressions are built from linked two-chord progressions
% (1) All acceptable possibilities for the pairing of the first and second chords are found
% (2) These are joined with all acceptable possibilites for the second and third chords
% (3) Process continues until the progression is complete
% #t = disallow
#(define the-rules
(list
(cons 'successive-fifths-octaves #t)
(cons 'outer-voice-direct-fifths-octaves #t)
(cons 'voice-overlap #t)
(cons 'certain-melodic-intervals #t)
(cons 'badly-handled-leading-tone #t)
(cons 'bass-leap-over-octave #t)
(cons 'move-to-nonadjacent-chord-member #t)
(cons 'all-voices-similar-motion #t)
))
#(define (check-for-errors iv1 iv2 keey)
(or
(and (ly:assoc-get 'successive-fifths-octaves the-rules)
(any-parallel-perfects-or-perfects-by-contrary-motion? iv1 iv2))
(and (ly:assoc-get 'outer-voice-direct-fifths-octaves the-rules)
(outer-voice-direct-fifths-or-octaves? iv1 iv2))
(and (ly:assoc-get 'voice-overlap the-rules)
(any-overlapping-voices? iv1 iv2))
(and (ly:assoc-get 'certain-melodic-intervals the-rules)
(any-disallowed-melodic-interval? iv1 iv2))
(and (ly:assoc-get 'badly-handled-leading-tone the-rules)
(any-poorly-handled-leading-tone? iv1 iv2 keey))
(and (ly:assoc-get 'all-voices-similar-motion the-rules)
(all-voices-similar-motion? iv1 iv2))
(and (ly:assoc-get 'bass-leap-over-octave the-rules)
(bass-leap-over-octave? iv1 iv2))
(and (ly:assoc-get 'move-to-nonadjacent-chord-member the-rules)
(any-move-to-nonadjacent-chord-member? iv1 iv2))))
% Awkward way of setting/unsetting rule. Need interface.
%#(set! the-rules (assoc-set! the-rules 'successive-fifths-octaves #f))
% Discover all ways of writing a two-chord progression. Throw out any
% that break certain voice-leading rules.
#(define (two-chord-progression-possibilities p-list1 p-list2 keey)
(let loop ((result '()) (p-ls1 p-list1) (p-ls2 p-list2))
(cond
((null? p-ls1) (reverse result))
(else
(let inner ((result result) (p-l2 p-ls2))
(cond
((null? p-l2)
(loop result (cdr p-ls1) p-list2))
((check-for-errors (car p-ls1) (car p-l2) keey)
(inner result (cdr p-l2)))
(else
(inner
(cons (list (car p-ls1) (car p-l2))
result)
(cdr p-l2)))))))))
%% TODO: allow variable doublings, inversions
#(define (get-two-chord-realizations c1 c2 keey)
(let ((prog-lists
(two-chord-progression-possibilities
(make-pitch-lists c1 'root '("root" "third" "fifth"))
(make-pitch-lists c2 'root '("root" "third" "fifth"))
keey)))
prog-lists))
% For linking chord pairs
#(define (same-chord? c1 c2)
(every identity (map (lambda (x y) (pitch=? x y)) c1 c2)))
% Return #f if not a match
#(define (get-chord-pair-beginning-with chord chord-list)
(and (same-chord? chord (car chord-list))
chord-list))
% Generate pitch lists representing every allowed variant of progression
#(define (realize-progression pr keey)
(let* ((prog (parse-progression pr))
(all-starting-pairs
(get-two-chord-realizations (car prog) (cadr prog) keey)))
(let crawler ((result all-starting-pairs) (p (cdr prog)))
(cond
((null? (cdr p)) result)
(else
(let ((all-next-pairs
(get-two-chord-realizations (car p) (cadr p) keey)))
(crawler
; branch every existing chord path to add any new chord pair which connects
(append-map
(lambda (r)
(let (; all the possibilities for continuation
(linked-pairs
(filter-map
(lambda (x) (get-chord-pair-beginning-with (last r) x))
all-next-pairs)))
(filter-map
(lambda (lp)
; if linked-pairs is the empty list (no continuation
; available), that path is discarded
(and (pair? lp)
(append r (list (cadr lp)))))
linked-pairs)))
result)
(cdr p))))))))
%%%%%%%% Filter progressions for issues involving larger spans %%%%%%%%%
% Handle large leaps
% If a leap is >= threshold (say P4), motion afterwards has to be in
% the opposite direction or stepwise.
% We could be more strict: a leap must be prepared and resolved by stepwise
% motion in the opposite direction. (This could not apply to the bass.)
% Currently, only the bass is considered. (It isn't subject to proximity
% restrictions, so some directional constraint has to be put on leaping.)
#(define (get-directed-intervals line)
(define (inner line seed)
(if (null? (cdr line))
(reverse seed)
(inner (cdr line)
(cons (ordered-pitch-interval (car line) (cadr line)) seed))))
(inner line '()))
% `threshold': size in semitones at which leap requires special handling
% 'voice-contents': voice part for a progression realization
#(define (leaps-well-handled? iv-contents threshold)
(cond
((null? (cdr iv-contents))
#t)
((and (>= (abs (car iv-contents)) threshold)
; movement in same direction
(or (and (< (car iv-contents) 0) (< (cadr iv-contents) 0))
(and (> (car iv-contents) 0) (> (cadr iv-contents) 0)))
; leap followed by stepwise motion in same direction OK
; possibly should be disallowed in upper voices
(> (abs (cadr iv-contents)) 2))
#f)
(else (leaps-well-handled? (cdr iv-contents) threshold))))
#(define (check-bass-leap-handling chord-ls threshold)
(let* ((bass-part (map car chord-ls))
(iv-list (get-directed-intervals bass-part)))
(leaps-well-handled? iv-list threshold)))
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Build lists of music expressions for each voice part from chord list
% `chord-ls' is structured like so:
% (
% (( ) ( ) ( ) ( )) ; first realization
% (( ) ( ) ( ) ( )) ; second realization
% [...}
% )
#(define (build-voice-contents chord-ls keey rhythm)
(let* ((chord-ls (apply append chord-ls)) ; unnest
(zipped (apply zip chord-ls)))
(map (lambda (zl)
(map (lambda (p d)
(make-note p d))
zl rhythm))
zipped)))
allRealizations =
#(define-music-function (parser location keey prog)
(ly:music? ly:music?)
(let* ((rhythm (apply circular-list (get-rhythm prog)))
(chord-ls (realize-progression prog keey))
(chord-ls
(filter-map
(lambda (r) (and (check-bass-leap-handling r 5) r))
chord-ls))
(voice-contents (build-voice-contents chord-ls keey rhythm)))
#{
<<
\context Staff = "top" <<
\context Voice = "1" {
\voiceOne
#keey
#@(last voice-contents)
}
\context Voice = "2" {
\voiceTwo
#@(third voice-contents)
}
>>
\context Staff = "bottom" <<
\context Voice = "3" {
\voiceOne
\clef bass
#keey
#@(second voice-contents)
}
\context Voice = "4" {
\voiceTwo
#@(first voice-contents)
}
>>
>>
#}))
%%%%%%%%%%%%%%%%%%%%%%%%%% EXAMPLE %%%%%%%%%%%%%%%%%%%%%%%%%%
\markup \bold \huge {
vi-ii-V-I:
}
setup = \new PianoStaff <<
\new Staff = "top" {
\time 4/2
}
\new Staff = "bottom" {
\time 4/2
}
>>
{
\setup
\allRealizations \key b \major \chordmode {
gis2:m cis:m fis b
}
}
\markup \bold \huge {
V-I:
}
\new PianoStaff {
\allRealizations \key f \major \chordmode { c2 f }
}
\markup \bold \huge {
i-iv-V-i:
}
\new PianoStaff {
\allRealizations \key c \minor \chordmode { c4:m f:m g c:m }
}
\markup \bold \huge {
Show available spacings
}
\markup \underline "F half-dim7, first inversion:"
\new PianoStaff {
\allSpacings \key es \minor \chordmode { f1:m7.5- } first #'("root" "fifth" "seventh")
}
\layout {
\context {
\Score
defaultBarType = #"||"
}
}
#(set-default-paper-size "letter")
\header {
title = "SATB Progressions"
}
\paper {
top-margin = 1\in
bottom-margin = 1\in
left-margin = 0.75\in
right-margin = 0.75\in
markup-markup-spacing.padding = 3
markup-system-spacing.padding = 3
top-markup-spacing.padding = 3
%page-breaking = #ly:optimal-breaking
tagline = ##f
}
_______________________________________________
lilypond-user mailing list
lilypond-user@gnu.org
https://lists.gnu.org/mailman/listinfo/lilypond-user
