Created
July 11, 2013 21:47
-
-
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.
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
(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