Four-part chorale algorithmic composer. Caveat emptor; this needs some major work, which is coming.

core.clj

(ns bgm.core
  (:use [overtone.inst sampled-piano])
  (:require [clojure.set]
            [overtone.core :as overtone])
  (:gen-class))

(def golden-ratio 1.61803398875)
(def golden-ratio-conjugate (/ 1.61803398875))

;;; COMPOSITION

(defn binomial-nth
  "Randomly choose an item from the list."
  [[car & cdr] p]
  (if (or (nil? car) (nil? cdr) (< (rand) p)) car (binomial-nth cdr p)))

(defn rand-groove
  ; Come up with a random 4/4 groove.
  ([] (rand-groove 8))
  ; Come up with a random groove for [dur] beats.
  ([dur]
   (let [nu (if (ratio? dur) (numerator dur) dur)
         de (if (ratio? dur) (denominator dur) 1)]
     (case de
       ; Still reducing:
       1 (let [subgrooves (binomial-nth [2 4] golden-ratio-conjugate)
               subdurs (/ dur subgrooves)]
           (apply concat (for [i (range subgrooves)]
                           (let [[car & cdr :as groove] (rand-groove subdurs)]
                             ; Apply accents to the first beat of each.
                             (let [v (+ 0.2 (/ (- 2 (mod i 2)) 3))]
                               (cons (assoc car :v v) cdr))))))
       ; Into rational numbers, return 1/de sections.
       (map (fn [_] (zipmap [:d :v] [(/ de) 0.5])) (range nu))))))

(defn simple-chord-degree
  [degree root mode]
  (let [ds (range degree (+ 6 degree))]
    (take-nth 2 (drop 1 (scale root mode ds)))))

(defn chord-seq
  []
  (let [{r :root m :mode} @fantasia-key
        r' (mk-midi-string r 2)]
    (filter #(not= :diminished (:chord-type (find-chord %)))
            (for [i (range 7)]
              (simple-chord-degree i r' m)))))

(defn chord-nearness
  [a b]
  (let [na (set (map #(mod % 12) a))
        nb (set (map #(mod % 12) b))]
    (count (clojure.set/intersection na nb))))

(defn progress
  [{:keys [root mode]}]
  (let [r (mk-midi-string root 2)
        cs (group-by #(chord-nearness % (chord r mode)) (chord-seq))
        ch (binomial-nth
             (mapcat cs (reverse (range 3)))
             (- 1 golden-ratio-conjugate))
        {r' :root m' :chord-type} (find-chord ch)]
    {:root r' :mode m'}))

;;; SOPRANO

(defn soprano-voice
  [ps] (->> ps (drop-while #(< % (note :c4))) (take-while #(<= % (note :a5)))))

(defn soprano-melody
  ([groove root mode]
   (let [ps (soprano-voice (scale-field (:root @fantasia-key)
                                        (:mode @fantasia-key)))
         roots (filter #(= root (find-pitch-class-name %)) ps)
         st (rand-chord (find-note-name (first roots)) mode 4
                        (- (note :a5) (first roots)))]
     (soprano-melody groove root mode
                 (.indexOf ps (first (shuffle st)))
                 (rand-nth [-1 1]))))
  ([[car & cdr :as groove] root mode i di]
   (if (nil? car) nil
     (let [ps (soprano-voice (scale-field (:root @fantasia-key) (:mode @fantasia-key)))
           p (if (> (Math/pow (rand) 2) (:v car)) nil (nth ps i))
           i' (+ di i)
           di' (if (zero? di) (rand-nth [-1 0 1])
                 (binomial-nth [di di (- di) 0] golden-ratio-conjugate))]
       (cons (-> car (assoc :p p))
             (if (nil? cdr) nil
               (lazy-seq
                 (if (and (> 0.5 (:v (first cdr))) (< -1 i' (count ps)))
                   (soprano-melody cdr root mode i' di')
                   (soprano-melody cdr root mode)))))))))

(defn alto-voice
  [ps] (->> ps (drop-while #(< % (note :g3))) (take-while #(<= % (note :f5)))))

(defn alto-melody
  ([groove root mode]
   (let [ps (alto-voice (scale-field (:root @fantasia-key)
                                     (:mode @fantasia-key)))
         roots (filter #(= root (find-pitch-class-name %)) ps)
         st (rand-chord (find-note-name (first roots)) mode 4
                        (- (note :f5) (first roots)))]
     (alto-melody groove root mode
                  (.indexOf ps (first (shuffle st)))
                  (rand-nth [-1 1]))))
  ([[car & cdr :as groove] root mode i di]
   (if (nil? car) nil
     (let [ps (alto-voice (scale-field (:root @fantasia-key) (:mode @fantasia-key)))
           p (if (> (Math/pow (rand) 2) (:v car)) nil (nth ps i))
           i' (+ di i)
           di' (if (zero? di) (rand-nth [-1 0 1])
                 (binomial-nth [di di (- di) 0] golden-ratio-conjugate))]
       (cons (-> car (assoc :p p))
             (if (nil? cdr) nil
               (lazy-seq
                 (if (and (> 0.5 (:v (first cdr))) (< -1 i' (count ps)))
                   (alto-melody cdr root mode i' di')
                   (alto-melody cdr root mode)))))))))

(defn tenor-voice
  [ps] (->> ps (drop-while #(< % (note :c3))) (take-while #(<= % (note :a4)))))

(defn tenor-melody
  [groove root mode]
  (let [ps (tenor-voice (scale-field root mode))
        roots (filter #(= root (find-pitch-class-name %)) ps)
        ch (rand-chord (find-note-name (first roots)) mode 4
                       (- (note :a4) (first roots)))]
    (map (fn [n p] (assoc n :p p)) groove (cycle (shuffle ch)))))

;;; BASS

(defn bass-voice
  [ps] (->> ps (drop-while #(< % (note :e2))) (take-while #(<= % (note :e4)))))


(defn bass-melody
  [groove root mode]
  (let [ps (bass-voice (scale-field root mode))
        roots (filter #(= root (find-pitch-class-name %)) ps)
        ch (rand-chord (find-note-name (first roots)) mode 4
                       (- (note :e4) (first roots)))]
    (map (fn [n p] (assoc n :p p)) groove (cycle (shuffle ch)))))

;;; SUPPORT / SYNTH

(def m (metronome 80))

(defmulti play-note :part)
(defmethod play-note :default
  [{:keys [t p v] :or {v 0.8}}]
  (if (nil? p) nil
    (at (m t) (sampled-piano p v))))

(defn duration->absolute
  "Turn notes with durations into absolute time notes."
  ([notes] (duration->absolute 0 notes))
  ([t [{:keys [d] :as car} & cdr]]
   (if (nil? car) nil
     (cons (assoc car :t t)
           (lazy-seq (duration->absolute (+ d t) cdr))))))

(defn play-notes
  "Play a sequence of notes."
  ([note-seq] (play-notes (m) (duration->absolute note-seq)))
  ([start-beat [note & note-seq]]
   (play-note note)
   (if (nil? note-seq) nil
     (let [t' (+ start-beat (:t (first note-seq)))]
       (apply-at (m t') #'play-notes [start-beat note-seq])))))

(def fantasia-key (ref {:root :Bb :mode :major}))

(defn -main
  "Compose and perform a fantasia."
  [& args]
  (let [prog (iterate progress {:root :Bb :mode :major})]
    (pmap #(-> % play-notes)
          [(mapcat #(soprano-melody (rand-groove 8) (:root %) (:mode %)) prog)
           (mapcat #(alto-melody (rand-groove 8) (:root %) (:mode %)) prog)
           (mapcat #(let [g (rand-groove 4)]
                      (tenor-melody (concat g g) (:root %) (:mode %))) prog)
           (mapcat #(let [g (rand-groove 2)]
                      (bass-melody (concat g g g g) (:root %) (:mode %))) prog)])))