Skip to content

Instantly share code, notes, and snippets.

@blinks
Created July 11, 2013 21:47
Show Gist options
  • Save blinks/5979545 to your computer and use it in GitHub Desktop.
Save blinks/5979545 to your computer and use it in GitHub Desktop.
Four-part chorale algorithmic composer. Caveat emptor; this needs some major work, which is coming.
(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)])))
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment