On Sat, Jul 15, 2023 at 1:26 AM Richard Shann <[email protected]>
wrote:
> On Fri, 2023-07-14 at 21:08 +0000, Eef Weenink wrote:
> > Maybe somebody already made a script for this:
> >
> > In figured bass there are two fundamental rules: Avoid parallell
> > octaves and or fifhts.
> > So it would be nice to have some scipts what checks for this.
>
I converted the file that Jean suggested to 2.24 and ran it several times.
It seems to work fine. I've attached the file here.
\version "2.24.0"
%%% File: partwriter7.ly
%%% 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 ;(ly:make-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' #}
,#{ fis' #}
; ,#{ ges' #}
))
%%% 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 chord member within a voice range
#(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.
#(define (voice-all-member-possibilities voice-str chord)
(let ((range (ly:assoc-get voice-str moderate-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
#(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 upper parts are no more than an octave apart
#(define (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))))))
#(define (filter-pitch-lists p-lists)
(filter well-spaced?
(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.
#(define (make-pitch-lists chord inversion upper-members)
(let* ((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 in upper voices
(arrangements (permute-list upper-members))
; add bass note
(bass-member
(ly:assoc-get
(symbol->string inversion) inversion-lookup))
(arrangements
(map
(lambda (a) (cons bass-member a))
arrangements))
(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))
(pitched-arrangements (map every-one-of-each pitched-arrangements))
(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
% Convert a member of a \chordmode expression into
% an alist pairing chord member names with pitches
% This will only handle triads and seventh chords.
#(define (parse-chord mus)
(let* ((note-events (extract-named-music mus 'NoteEvent))
(pitches (map (lambda (n) (ly:music-property n 'pitch))
note-events))
(chord (list
(cons "root" (first pitches))
(cons "third" (second pitches))
(cons "fifth" (third pitches))))
(chord (if (= 4 (length pitches))
(append
chord
(list (cons "seventh" (last pitches))))
chord)))
chord))
% Borrowed from definition of \table
#(define (split-lst initial-lst lngth result-lst)
;; split a list into a list of sublists of length lngth
;; eg. (split-lst '(1 2 3 4 5 6) 2 '())
;; -> ((1 2) (3 4) (5 6))
(cond ((not (integer? (/ (length initial-lst) lngth)))
(ly:warning
"Can't split list of length ~a into ~a parts, returning empty list"
(length initial-lst) lngth)
'())
((null? initial-lst)
(reverse result-lst))
(else
(split-lst
(drop initial-lst lngth)
lngth
(cons (take initial-lst lngth) result-lst)))))
#(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))
% Build a list of voice/pitch alists for all the elements in a
% \chordmode expression
#(define (parse-progression mus)
(let ((ev-ch (extract-named-music mus 'EventChord)))
(map parse-chord ev-ch)))
%%% 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 (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)))))
% Given two chords, expressed as
% '(bass-pitch tenor-pitch alto-pitch soprano-pitch),
% check for various voice-leading problems
#(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))))))
% Return #f if all clear, #t if any errors found
#(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: leading tone 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 (bass-leap-over-octave? c1 c2)
(< 12 (interval (first c1) (first c2))))
%%% 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
% 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))
((or
(any-parallel-perfects-or-perfects-by-contrary-motion? (car p-ls1) (car p-l2))
(outer-voice-direct-fifths-or-octaves? (car p-ls1) (car p-l2))
(any-overlapping-voices? (car p-ls1) (car p-l2))
(bass-leap-over-octave? (car p-ls1) (car p-l2))
(any-disallowed-melodic-interval? (car p-ls1) (car p-l2))
(any-poorly-handled-leading-tone? (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))
% Create a random path through all possibilities
% This can hang when no viable continuation is found.
#(let ((time (gettimeofday)))
(set! *random-state*
(seed->random-state (+ (car time)
(cdr time)))))
#(define (randomly-realize-progression pr keey)
(let* ((prog (parse-progression pr))
(all-starting-pairs (get-two-chord-realizations (car prog) (cadr prog) keey)))
(define (get-starting-pair)
(list-ref all-starting-pairs (random (length all-starting-pairs))))
(let crawler ((result (get-starting-pair)) (p (cdr prog)))
(cond
((null? (cdr p)) result)
(else
(let* ((all-next-pairs (get-two-chord-realizations (car p) (cadr p) keey))
(linked-pairs
(filter-map
(lambda (x) (get-chord-pair-beginning-with (last result) x))
all-next-pairs)))
(if (null? linked-pairs)
;result ; opt out at failure
(crawler (get-starting-pair) (cdr prog))
(let ((next-pair (list-ref linked-pairs (random (length linked-pairs)))))
(crawler (append result (list (cadr next-pair))) (cdr p))))))))))
% 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))
(apply append 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))))))))
% Build lists of music expressions for each voice part from chord list
#(define (build-voice-contents chord-ls keey rhythm)
(let ((zipped (apply zip chord-ls)))
(map (lambda (zl)
(map (lambda (n d)
(make-note n d))
zl rhythm))
zipped)))
allRealizations =
#(define-music-function (keey prog)
(ly:music? ly:music?)
(let* ((rhythm (apply circular-list (get-rhythm prog)))
(chord-ls (realize-progression prog keey))
(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)
}
>>
>>
#}))
blindRealization =
#(define-music-function (keey prog)
(ly:music? ly:music?)
(let* ((rhythm (get-rhythm prog))
(chord-ls (randomly-realize-progression prog keey))
(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, moderate range:
}
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 \underline { Random realization: }
{
\setup
\blindRealization \key b \major \chordmode { gis2:m cis:m fis b }
}
\markup \bold \huge {
i-iv-V-i, moderate range:
}
\new PianoStaff {
\allRealizations \key c \minor \chordmode { c4:m f:m g c:m }
}
\markup \underline "F half-dim7, first inversion:"
\new PianoStaff {
\allSpacings \key es \minor \chordmode { f1:m7.5- } first #'("root" "fifth" "seventh")
}
\layout {
\context {
\Score
measureBarType = #"||"
}
}
#(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
%page-breaking = #ly:optimal-breaking
tagline = ##f
}
