\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
}