Permalink
Browse files

messy core.clj, needs more organization before submission

  • Loading branch information...
1 parent ab21898 commit d6a5c57c9ebbe4a94408897c51fcd5e7fa00aeb0 Damion Junk committed Dec 4, 2011
View
@@ -2,4 +2,6 @@
:description "Project for i601 - Bioinspired Computing"
:dependencies [[org.clojure/clojure "1.3.0"]
[overtone "0.5.0"]
- [org.clojure/tools.cli "0.2.1"]])
+ [org.clojure/tools.cli "0.2.1"]
+ [incanter "1.3.0-SNAPSHOT"]]
+ :dev-dependencies [[lein-marginalia "0.6.1"]])
View
@@ -1,9 +1,78 @@
(ns i601-project.core
- (:use [overtone.live]
- [overtone.inst synth]))
-
+ (:require [incanter.distributions :as dist])
+ (:use [i601-project.evalgo]
+ [i601-project.lsystem]
+ [i601-project.strings]
+ [i601-project.music]
+ [i601-project.turtle]
+ [overtone.live :only (stop)]))
;; REPL session
-(in-ns 'i601-project.core)
+(defn play-it
+ [s]
+ (let [t (music-turtle :dur (/ 1 8) :bpm 89)]
+ (println "Playing..." s)
+ (doseq [x s]
+ ((trans-map x) t))
+ (tp (metro) (:notes-stack @t))))
+
+;; Test the turtle without L-System
+(play-it "NNN++NN++++NNN")
+;; Polyphony Turtle bracketed test
+(play-it ">>>>>>[NNN][<<<<<N++N++N++N][<<<<<+++N++N++N++N][----NNN]")
+
+
+;; REPL / Evo-Algs
+(def eap {:bs-len 3
+ :rmap revmap
+ :bmap binmap
+ :mutations #(dist/roulette-wheel [0.90 0.08 0.01 0.01])
+ :m-fn #(char (+ (quot 1 (- (inc (int %)) 48)) 48))})
+
+(def koch {:v "N+-"
+ :omega "N++N++N"
+ :productions {
+ \N "N-N++N-N"
+ }})
+
+(def tweedle-boop {:v "RN+-"
+ :omega "NRNNRR"
+ :productions {
+ \N "N++[-----------N]N"
+ \R "RR[R+++NRN]--"
+ }})
+
+(def tocker {:v "RN+-"
+ :omega "++N--"
+ :productions {
+ \N "R[+++++N]NN[-----R]R"
+ \R "[-----NR+++N]"
+ }})
+
+(play-it (apply str (lsys-run 3 koch)))
+(play-it (apply str (lsys-run 3 tweedle-boop)))
+(play-it (apply str (lsys-run 3 tocker)))
+(stop)
+
+(defn breed
+ ""
+ [m f nc eap]
+ (for [x (breed-lsystems (lsys-to-bins revmap m) (lsys-to-bins revmap f) nc eap)]
+ x))
+
+(def gen1 (breed tocker tweedle-boop 9 eap))
+(defn play-from-gen
+ [& {:keys [pop pos ls-gens] :or {ls-gens 1 pos 0}}]
+ (play-it (apply str (lsys-run ls-gens (nth pop pos)))))
+;; Play, altering Runlen and Child element
+;; Find the ones you like
+;; (stop)
+(play-from-gen :pos 8 :pop gen1 :ls-gens 3)
+(nth gen1 8)
+(nth gen1 4)
+;;{:v "RN+-", :omega "++NNRR", :productions {\R "[----++NRN]--", \N "R[+++++N]NN[---N]N"}}
+;; Sounds great at 3 L-System Generations
+;; "Digger"
+;;{:v "RN+-", :omega "++N-RR", :productions {\R "[-----NR++]--", \N "R[+++++N]NN[---N]N"}}
@@ -0,0 +1,67 @@
+(ns i601-project.evalgo
+ (:require [incanter.distributions :as dist])
+ (:use [i601-project.lsystem]
+ [i601-project.strings]
+ [i601-project.utils]))
+
+;; The idea in this simple EA selective breeding system is:
+;; 1. Generate an initial random population
+;; 2. Select two parents (subjective fitness function)
+;; 3. Generate Offspring w/Mutation,Crossover
+
+(defn gen-pop
+ [p ls-params]
+ (take p (repeatedly #(genr-lsystem ls-params))))
+
+
+;; We're defining a simple string cross-over function
+;; that selects a crossover point at a valid point given
+;; a binary string 'atom' length.
+;;
+;; Refactor into Better crossover outcomes.
+(defn crossover
+ [s1 s2 clen]
+ (let [idx (* clen (quot (rand-int (min (count s1) (count s2))) clen))]
+ (apply str (concat (take idx s1) (drop idx s2)))))
+;;(crossover "100100100" "001001001" 3)
+
+(defn seq-r-b-flip
+ [seq m-fn clen]
+ (let [s (apply str seq) c (count s)]
+ (apply str (update-in (vec seq) [(rand-int c)] m-fn))))
+;;(seq-r-b-flip "000000000" #(char (+ (quot 1 (- (inc (int %)) 48)) 48)) 3)
+;;=> ("000" "010" "000")
+
+(defn mutate
+ [seq eap]
+ (let [mutations ((:mutations eap)) clen (:bs-len eap)]
+ (nth (take (inc mutations)
+ (iterate #(seq-r-b-flip % (eap :m-fn) clen) seq))
+ mutations)))
+
+;;(mutate "000000000" eap)
+;;=> "111000000"
+
+
+;; Given a mother and father, produce a set of offspring.
+;;
+(defn make-baby
+ [m f eap]
+ (let [axiom (crossover (:omega m) (:omega f) (:bs-len eap))]
+ {:v (:v m)
+ :omega (mutate axiom eap)
+ :productions (reduce (fn [mp k]
+ (assoc mp k (mutate (crossover ((:productions m) k) ((:productions f) k) (:bs-len eap)) eap)))
+ {}
+ (keys (:productions m)))}))
+
+;; Breed our organisms producing a specifiable number of offspring.
+;; Produces binary string l-systems.
+(defn breed-to-bin
+ "Returns a sequence of n children bred from the mother and father."
+ [m f nchildren eap]
+ (repeatedly nchildren #(make-baby m f eap)))
+
+(defn breed-lsystems
+ [m f nchildren eap]
+ (map #(bins-to-lsys (:bmap eap) (:bs-len eap) %) (breed-to-bin m f nchildren eap)))
@@ -1,119 +1,65 @@
-(ns i601-project.lsystem)
+(ns i601-project.lsystem
+ (:use [i601-project.strings]
+ [i601-project.utils]))
-(defn pad
- [num len]
- (if (> len (.length (str num)))
- (pad (str 0 num) len)
- (str num)))
-
-(defn bin-string
- "Generates a 0 padded binary string from the given Integer to fit.
- Padding matches the width set by the maximum Integer."
- [x max]
- (pad (Integer/toString x 2) (count (Integer/toString max 2))))
-
-;; Swap keys and values.
-(defn map-invert [m] (reduce #(assoc %1 (val %2) (key %2)) {} binmap))
-
-(defn parse-int [s]
- (Integer. (re-find #"[0-9]*" s)))
-
-
-
-;; 6 elements, 2 branching
-;; 8 total.
-;; 000 001 010 011 100 101 110 111
-(def alphabet "NR+-<>[]")
-(def binmap (zipmap (for [x (range 0 (count alphabet))] (bin-string x (dec (count alphabet)))) alphabet))
-(def revmap (map-invert binmap))
-;;revmap
-;;{\N "000", \R "001", \+ "010", \- "011", \< "100", \> "101", \[ "110", \] "111"}
-;;binmap
-;;{"111" \], "110" \[, "101" \>, "100" \<, "011" \-, "010" \+, "001" \R, "000" \N}
-
-
-(defn bins-vec
- [num-elems bin-map]
- ;; generate 'num-elems' elements from the binmap.
- ;; bracketing syntax may not be correct here.
- (reduce #(conj %1 (bin-string (parse-int (str %2)) (dec (count bin-map)))) []
- (loop [pos num-elems bstr ""]
- (if (pos? pos)
- (recur
- (dec pos)
- (str (rand-int (count bin-map)) bstr))
- bstr))
- ))
-;;(bins-vec 5 binmap)
-;;["001" "111" "000" "100" "100"]
-
-(defn bins-seq [n binmap]
- (repeatedly n #(bin-string (rand-int (count binmap)) (dec (count binmap)))))
-;;(bins-seq 5 binmap)
-;;("001" "100" "110" "111" "101")
-
-
-(defn n-bins-vecs
- "Provides an n element seq of binary string vectors."
- [n maxt binmap]
- (take n (repeatedly #(bins-vec (inc (rand-int maxt)) binmap))))
-
- ;;
- (n-bins-vecs 2 3 binmap)
-;; (["100" "100" "010"] ["001" "101"])
-
-
-
-
-
-(defn gen-lsys-genotype
- [olen maxp bsmap]
- (let [alphabet (reduce #(conj %1 (key %2)) [] bsmap)
- initial (repeatedly (inc (rand-int olen)) #(rand-nth (keys bsmap)))]
- {:v alphabet
- :omega (vec initial)
- :productions (reduce (fn [m k] (assoc m k (vec (bins-seq (inc (rand-int maxp)) bsmap)))) {} alphabet)
+;; Method to generate a random L-System based on the
+;; provided parameters.
+;;
+;; - alen The max axiom length
+;; - rmap The key to binstring map of the desired alphabet
+;; - prodkeys A string representing the keys we want to allow
+;; production rule generation for
+;; - plen The max production rule length
+(defn genr-lsystem
+ "Returns a 'randomly' generated L-System."
+ [{:keys [alen rmap prodkeys plen]}]
+ (let [alphabet (vec (keys rmap))
+ axiom (rand-bal-string alen (keys rmap))]
+ {:v (apply str alphabet)
+ :omega axiom
+ :productions (reduce
+ (fn [agm k]
+ (assoc agm k (rand-bal-string plen alphabet)))
+ {}
+ prodkeys)
}))
-;; Maps from binstrings to production characters
-;;
-(defn gen-lsys-phenotype
- [geno bsmap]
- {:v (vec (for [x (geno :v)] (bsmap x)))
- :omega (vec (for [x (geno :omega)] (bsmap x)))
- :productions (reduce (fn [m [k v]] (assoc m (bsmap k) (for [x v] (bsmap x)))) {} (geno :productions))
+(defn lsys-to-bins
+ "Returns a binary string version of the provided L-System map."
+ [rmap {:keys [v omega productions]}]
+ {:v (apply str (xlate-map v rmap))
+ :omega (apply str (xlate-map omega rmap))
+ :productions (reduce
+ (fn [agm [k v]]
+ (assoc agm (rmap k) (apply str (xlate-map v rmap))))
+ {}
+ productions)
+ })
+;;(lsys-to-bins revmap (genr-lsystem {:alen 5 :rmap revmap :prodkeys "NR+-<>" :plen 7}))
+
+(defn bins-to-lsys
+ "Returns our standard L-System from the provided binary string representation."
+ [rmap clen {:keys [v omega productions]}]
+ {:v (apply str (xlate-map (bchunked v clen) rmap))
+ :omega (str-b-balance (apply str (xlate-map (bchunked omega clen) rmap)))
+ :productions (reduce
+ (fn [agm [k v]]
+ (assoc agm (rmap k) (str-b-balance (apply str (xlate-map (bchunked v clen) rmap)))))
+ {}
+ productions)
})
-;;(gen-lsys-phenotype (gen-lsys-genotype 3 3 binmap) binmap)
-;; {:v [\] \[ \> \< \- \+ \R \N],
-;; :omega [\[ \< \]],
-;; :productions {\] (\[ \<),
-;; \[ (\]),
-;; \> (\N \R),
-;; \< (\> \+ \>),
-;; \- (\N),
-;; \+ (\[ \[ \<),
-;; \R (\[), \N (\>)}}
-
-
-;;(gen-lsys-genotype 3 3 binmap)
-;; {:v ["111" "110" "101" "100" "011" "010" "001" "000"],
-;; :omega ["010" "110"],
-;; :productions {
-;; "000" ["110" "110"],
-;; "001" ["000" "011" "000"],
-;; "010" ["101" "101" "111"],
-;; "011" ["001" "001" "011"],
-;; "100" ["000" "011" "101"],
-;; "101" ["011"],
-;; "110" ["101" "000"],
-;; "111" ["011"] }}
-
-(defn D0L-system
- ""
- [productions pos omega]
- (loop [d pos s omega]
- (if (zero? d)
- s
- (recur (dec d) (mapcat productions s)))))
-
+;; Runs the L-System generator. Uses reduce + (range generations)
+;; to control the number of generations.
+(defn lsys-run
+ "Returns the results of running the L-System for the specified number of generations."
+ [generations {:keys [v omega productions]}]
+ (reduce
+ (fn [st n] (mapcat productions st))
+ omega
+ (range generations)))
+
+;;(lsys-run 3 {:v "NR" :omega "NR" :productions {\N "NN" \R "RR"}})
+;;=> (\N \N \N \N \N \N \N \N \R \R \R \R \R \R \R \R)
+;;(lsys-run 0 (genr-lsystem {:alen 5 :rmap revmap :prodkeys "NR+-<>" :plen 7}))
+;;=> "-N"
View
@@ -0,0 +1,20 @@
+(ns i601-project.music
+ (:use [overtone.live]
+ [overtone.inst synth]
+ [overtone.inst drum]))
+
+(def metro (metronome 89))
+
+(definst tone [note 60 amp 0.3 dur 0.4]
+ (let [snd (sin-osc (midicps note))
+ env (env-gen (perc 0.01 dur) :action FREE)]
+ (* env snd amp)))
+
+(definst squarez [note 60 amp 0.3 dur 0.4 width 0.5]
+ (* (env-gen (perc 0.2 dur) 1 1 0 1 FREE)
+ (pulse (midicps note) width)))
+
+(defn tp
+ [tick stack]
+ (for [sn stack]
+ (at (metro (+ (:time sn) tick)) (tone (:note sn) 1 (:dur-secs sn)))))
Oops, something went wrong.

0 comments on commit d6a5c57

Please sign in to comment.