Create a gist now

Instantly share code, notes, and snippets.

What would you like to do?
(ns biomorph.designer
(:require
[cljs.core.async :as async]
[clojure.string :as str]
[dommy.core :refer [insert-after! set-text! add-class! remove-class!]]
[monet.canvas :refer [get-context begin-path close-path
clear-rect quadratic-curve-to
stroke-style stroke-width stroke-cap
line-join move-to line-to stroke]]
[enchilada :refer [canvas-size value-of]]
[inkspot.color :as inkspot]
[big-bang.core :refer [big-bang]]
[big-bang.components :refer [slider]])
(:require-macros
[dommy.macros :refer [sel1 node]]))
(def directions [
[ 0 -1] ; North
[ 1 -1] ; North-East
[ 1 0] ; East
[ 1 1] ; South-East
[ 0 1] ; South
[-1 1] ; South-West
[-1 0] ; West
[-1 -1]]) ; North-West
(def genes [:g0 :g1 :g2 :g3 :g4 :g5 :g6 :g7 ; order of these is important
:red :green :blue
:depth :width
:seg :sep])
(def size (second (canvas-size)))
(defn random-value []
(- 20 (rand-int 41)))
(defn random-gene []
(zipmap
genes
(repeatedly random-value)))
(def initial-state (random-gene))
(defn handle-incoming-msg [event world-state]
(merge world-state event))
; TODO - missing from monet
(defn stroke-join
"Can be set, to change the line join style. Possible values (as string or keyword):
bevel, round, and miter. Other values are ignored."
[ctx join]
(set! (.-lineJoin ctx) (name join))
ctx)
(defn draw-branch [ctx gene x y tree-depth growth-direction max-segment-len]
(let [dir (mod growth-direction (count directions))
[dx dy] (nth directions dir)
x-gene (nth genes (mod tree-depth 4))
y-gene (nth genes (+ 4 (mod tree-depth 4)))
i (+ x (Math/floor (* dx (Math/min (* tree-depth (gene x-gene)) max-segment-len))))
j (+ y (Math/floor (* dy (Math/min (* tree-depth (gene y-gene)) max-segment-len))))
red-scale (mod (Math/floor (* (gene :red) 577)) 255)
green-scale (mod (Math/floor (* (gene :green) 1297)) 255)
blue-scale (mod (Math/floor (* (gene :blue) 2089)) 255)
color (inkspot/coerce [
(mod (+ red-scale (* tree-depth 97)) 255)
(mod (+ green-scale (* tree-depth 97)) 255)
(mod (+ blue-scale (* tree-depth 97)) 255)
0.7])
width (Math/abs (inc (mod (* (gene :width) tree-depth) 5)))]
(when (pos? tree-depth)
(->
ctx
(draw-branch gene i j (dec tree-depth) (inc growth-direction) max-segment-len)
(draw-branch gene i j (dec tree-depth) (dec growth-direction) max-segment-len)))
(->
ctx
(begin-path)
(stroke-style color)
(stroke-width width)
(move-to x y)
(line-to i j)
(close-path)
(stroke))))
(defn render [{:keys [depth] :as world-state}]
(let [gene world-state
canvas (.getElementById js/document "cell-canvas")
ctx (get-context canvas "2d")
x (/ size 2)
y (/ size 2)
max-segment-len (Math/floor (/ size 2 8))
tree-depth (inc (mod depth 10))
growth-direction 0] ; North
(->
ctx
(clear-rect {:x 0 :y 0 :w size :h size})
(stroke-cap :round)
(stroke-join :round))
(loop [i (inc (mod (Math/abs (gene :seg)) 6))
y' y]
(if (zero? i)
ctx
(do
(draw-branch ctx gene x y' tree-depth growth-direction max-segment-len)
(recur
(dec i)
(+ y' 4 (gene :sep))))))))
(defn make-canvas [id size]
[:div.cell
[:canvas {:id (name id) :width size :height size}]])
(defn style [& styles ]
[:style (str/join \newline styles)])
(defn make-controls [chan]
[:div.controls
(for [id genes]
[:div
(slider
:id id
:label-text (str (name id) ":")
:min-value -20
:max-value 20
:initial-value (initial-state id)
:send-channel chan)])
[:div.links
[:span.permalink [:a {:href "#" :title "Generates a permalink for this Biomorph"} "Permalink"]]
[:span.evolve [:a {:href "#" :title "Evolves this Biomorph using cumulative selection"} "Evolve"]]
[:span.random [:a {:href "#" :title "Creates a new random Biomorph"} "Random"]]]])
(let [chan (async/chan)]
(->>
(sel1 :#canvas-area)
(insert-after!
(node
[:div#app
(style
"div#app {margin: 20px 0; width:850px}"
"#app .controls {float: right;}"
"#app .cell {-moz-border-radius: 10px; -webkit-border-radius: 10px; border-radius: 10px;"
" border: 1px #333 solid; background-color: #222; margin: 20px 0 0 20px; width: 600px;}"
"#app .slider {font-size: 14px; font-family: Helvetica,arial,freesans,clean,sans-serif; color: #666;"
" padding: 3px 10px 3px 10px; display: flex; border-top: 1px solid lightgray;"
" border-left: 1px solid lightgray; border-right: 1px solid lightgray;}"
"#app .slider label {width: 50px; display: inline-block; text-align: right;}"
"#app .links a {text-decoration: underline; font-family: sans-serif; margin-left: 15px;"
" font-size: 10pt; color: #4183C4; cursor: pointer;}"
)
(make-controls chan)
(make-canvas :cell-canvas size)])))
(big-bang
:initial-state initial-state
:receive-channel chan
:on-receive handle-incoming-msg
:to-draw render))
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment