\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 ;(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 (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)))))

% 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 (parser location 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 (parser location 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
    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
  %page-breaking = #ly:optimal-breaking
  tagline = ##f
}