blinks · July 11, 2013 21:47 · Jul 11, 2013
diff --git a/core.clj b/core.clj
@@ -0,0 +1,185 @@
+(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)])))