# [ʞ] ostinata.janet
# ~ lexi hale <lexi@hale.su>
# 🄯 AGPLv3
# ? a TUI mini-garageband that uses csound as
# a backend synthesizer. to add a new instrument,
# write it in ['ostinata.orc], then add it to
# [$orchestra] here
(import /tui)
(import /alg)
(def terminate (gensym))
(def teardown (gensym))
(def grammar (peg/compile ~{
:qlit (* `"` (% (any (+ (* `\"` (constant `"`))
(* (not `"`) '1))))
`"`)
:idchar (* (not :s) '1)
:term (% (some (+ :qlit :idchar)))
:seq (* :s* :term (? (* :s+ :seq)) :s*)
:main :seq
}))
(defmacro putfn [tbl id & dfn]
~(put ,tbl ,(keyword id) (fn ,(symbol tbl ":" id) ,;dfn)))
(def modes @{})
(def *trace?* (gensym))
(setdyn *trace?* true)
(def failure (gensym))
(defn fail! [code & arg]
(as-> (string/format ;arg) msg
(if-not (dyn *trace?*) msg
(debug/stacktrace (fiber/root) msg ""))
(return failure [code msg])))
(defn guard* [thunk fail]
(def [code result] (prompt failure
(def r (thunk))
[nil r]))
(if code (fail code result)
result))
(defmacro guard [body & conds]
(def $code (gensym))
~(,guard* (fn guard-thunk [] ,body)
(fn guard-catch [,$code msg]
(match ,$code
;conds
# fail upward if not caught
_ (return failure [code msg])))))
(defn score-marshal [score]
(marshal [:application/x.vt.ostinata 0
{:score score}]))
(defn score-unmarshal [bin]
(match (unmarshal bin)
[:application/x.vt.ostinata vers {:score score}]
score
_ (fail! :parse "not a valid score file")))
(defmacro enum [& vals]
(var idx 0)
(tabseq [:after (++ idx)
v :in vals]
v idx))
(def default-note-keys
# second col is half-tones
["a" "z"
"s" "x"
"d" "c"
"f" "v"
"g" "b"
"h" "n"
"j" "m"
"k" ","
"l"])
(def note-map {
:continuum (fn note-map:continuum [me f]
(seq [i :range [0 (me :n)]
:let [ncode ((get-in me [:keys i]) 0)
ncap (string/format "%c" ncode)
prog (/ i (me :n))]]
(f prog ncap ncode)))
})
(defn note-map-for [env chan]
(def km (or (chan :keymap)
(env :keymap)
default-note-keys))
(def nkeys (length km))
(def note-key-indices
(tabseq [i :range [0 nkeys]] ((km i) 0) i))
(struct/with-proto note-map
:keys km
:n nkeys
:key->index note-key-indices))
(def <instr>
{:start (fn <instr>start [me env note time]
[:i (:ident-note me note) time -1
;(:note me env note)])
:stop (fn <instr>stop [me env note time]
[:i (string (:ident-note me note)) time
(get-in me [:cfg :dwell] .2)])
:cfg {}
:for-chan (fn <instr>for-chan [me env chan]
(def cfg (merge (me :cfg) (chan :cfg)))
(def intermediate
(struct/with-proto me
:cfg cfg
:ampl (chan :ampl)))
(struct/with-proto me
;(kvs intermediate)
;(kvs (:setup intermediate env chan))))
:setup (fn <instr>setup [me env chan]
{:note-map (note-map-for env chan)})
:ident-note (fn <instr>ident-note [me n]
(def frac (reverse (string (n :id)))) # not a joke
(string (me :name) "." frac))})
(defn lerp [t a b]
(+ (* (- 1 t) a)
(* t b)))
(defn freq-spread-notes [me env chan]
(def super ((<instr> :setup) me env chan))
(defn cv [x &opt dflt] (get-in me [:cfg x] dflt))
(merge super
{:notes (:continuum (super :note-map)
(fn [p cap code]
(lerp p (cv :base)
(+ (cv :base) (cv :span)))))}))
(def orchestra {
:sine (struct/with-proto <instr>
:name "sine"
:cfg {:base 800 :span 600 :chime 1}
:setup freq-spread-notes
:note (fn sine:note [me env n]
(def freq (get-in me [:notes (n :index)]))
[(* (me :ampl) (n :vel)) freq (get-in me [:cfg :chime])]))
:string (struct/with-proto <instr>
:name "string"
:cfg {:base 500 # shortest frequency
:span 300 # range of frequencies
:decay 0}
:setup freq-spread-notes
:note (fn drum:note [me env n]
(def freq (get-in me [:notes (n :index)]))
(def c (me :cfg))
[(* (me :ampl) (n :vel)) freq (- 1 (* .1 (c :decay)))]))
})
(defn timecode→string [t]
(def μs (% t 1))
(def s (math/floor (% t 60)))
(def m (math/floor (% (/ t 60) 60)))
(def h (math/floor (% (/ t 60) (* 60 60))))
(string/format "%02u:%02u:%02u.%02u" h m s
(math/floor (* μs 100))))
(defn cmd→string [cmd]
(defn txl [val]
(cond (keyword? val) (string val)
:else (string/format "%q" val)))
(def str (string/join (map txl cmd) " ")))
(defn sort-score [env]
(sort-by |($ :at) (env :score)))
(defn over-score ``
iterates a score's notes, respecting mute flags
and the the current isolation mode
`` [env f]
(each n (env :score)
(def chan-id (n :chan))
(def chan (get-in env [:chans chan-id]))
(when (and (not (chan :mute))
(or (empty? (env :iso))
(has-value? (env :iso) chan-id)))
(f n))))
(defn write-score [env]
(def cmds @[])
(sort-score env)
(over-score env (fn [n]
(def chan (get-in env [:chans (n :chan)]))
(def ins (:instr-for-chan env chan))
(defn ins-cmd [method & args]
((ins method) ins env ;args))
(def cl [(ins-cmd :start n (n :at))
(ins-cmd :stop n (+ (n :at) (n :len)))])
(each c cl (array/push cmds c))))
(def score-text
(string/join (map |(string (cmd→string $) "\n") cmds)))
score-text)
(defn player [env]
(sort-score env)
(def chan-instrs
(tabseq [[chid chan] :pairs (env :chans)]
chid (:instr-for-chan env chan)))
(var last-time (env :time))
(protect (over-score env (fn [e]
(unless (< (e :at) last-time) #TODO cache last note id in play mode?
# (def chan (get-in env [:chans (e :chan)]))
(def ins (in chan-instrs (e :chan)))
(defn ins-cmd [method & args]
((ins method) ins env ;args))
# skip over notes we've already passed
(def t (e :at))
(ev/sleep (- t last-time))
(set last-time t)
#haack
(:send env ;(ins-cmd :start e 0))
(:send env ;(ins-cmd :stop e (e :len))))))))
(putfn modes play [env]
(defn ticks []
(os/clock :monotonic))
(var rec false)
(var cur-id (if (empty? (env :score)) 0
(+ 1 (extreme > (map |($ :id) (env :score))))))
(def start-time (env :time))
(var held @{})
(var last-time (ticks))
(def chan (get-in env [:chans (env :chan)]))
(var loud 1)
(def ins (:instr-for-chan env chan))
(defn note-key? [k]
(not (nil? (get-in ins [:note-map :key->index k]))))
(defn draw-stat-line [timecode]
(def sustain @[])
(defn clr [& r] (:color (env :tty) ;r))
# (defn vbar [& r] (:vbar (env :tty) ;r))
(each n (get-in ins [:note-map :keys])
(when-let [k (get held n nil)]
(def k (string/format "%c" n))
(array/push sustain k)))
(:msg env "\r\e[2K%s\r"
(string
(if rec "\e[91m⏺"
"\e[94m⏹") "\e[m"
(clr [.9 .95 1] [0.1 0.2 0.4]
(string " " (timecode→string timecode) " "))
(:vol-bar env (/ loud 11))
# (vbar (/ loud 11)
# [.5 1 .25]
# [1.0 1.0 0.25]
# [.8 0 0])
" " (chan :instr) "\e[96m@" (env :chan) "\e[m"
" \e[1m" (if rec "record" "play") "\e[m"
(string/join sustain))))
(def timewarp (get-in chan [:cfg :timewarp] 1.0))
(defn advance-clock [res]
(protect (forever
(def cur-time (ticks))
(draw-stat-line (+ (env :time)
(* (- cur-time last-time)
timewarp)))
(ev/sleep res))))
(var clock-fiber nil)
(var player-fiber nil)
(defn start-clock []
(set clock-fiber (fiber/new |(advance-clock 0.01)))
(set player-fiber (fiber/new |(player env)))
(ev/go clock-fiber)
(ev/go player-fiber))
(defn stop-clock []
(when clock-fiber
(ev/cancel clock-fiber nil)
(set clock-fiber nil))
(when player-fiber
(ev/cancel player-fiber nil)
(set player-fiber nil)))
(defn ins-cmd [method & args]
((ins method) ins env ;args))
(defn stop-all-notes []
(eachp [k v] held
(:send env ;(ins-cmd :stop v 0))))
(defn cleanup []
(stop-all-notes)
(stop-clock))
(def score-staging @[])
(defer (cleanup) (prompt teardown (forever
(draw-stat-line (env :time))
(def event (yield))
# get precise time unaffected by clock refresh rate
(def cur-time (ticks))
(def advance (- cur-time last-time))
(set last-time cur-time)
(when rec (+= (env :time) (* advance timewarp)))
(def next-id cur-id)
(++ cur-id)
(defn store-note [b]
(def stored (alg/qrec b
:at :mods :vel :id :index :chan))
(def len (- cur-time (b :t)))
(array/push score-staging
(merge stored {:chan (env :chan)
:len len})))
(defn commit-score []
(unless (empty? score-staging)
(array/concat (env :score) score-staging)
(array/clear score-staging)
(sort-score env)))
(defn commit-unless-shift []
(unless (string/check-set (event :mods) :s)
(commit-score)))
(match event
{:how :press :key (@ (comptime ("q" 0)))}
(do (stop-all-notes)
(:set-mode env :cmd)
(commit-unless-shift))
{:how :press :key (@ (comptime ("r" 0)))}
(do (stop-all-notes)
(toggle rec)
(if rec (start-clock) (stop-clock))
(commit-unless-shift))
{:how :press :key :shift-l} (+= loud 1)
{:how :release :key :shift-l} (-= loud 1)
{:how :press :key :shift-r} (-= loud .5)
{:how :release :key :shift-r} (+= loud .5)
{:how :press :key :tab}
(do (put env :time start-time)
(stop-clock) (start-clock))
({:how :press :key n}
(<= 0x31 n 0x39))
(set loud (- n 0x30))
({:how :press :key k}
(note-key? k)
(nil? (held k)))
(do (def note {:id cur-id :vel loud
:t cur-time :at (env :time)
:index (get-in ins [:note-map :key->index k])
:mods (get event :mods :)})
(put held k note)
(:send env ;(ins-cmd :start note 0)))
({:how :release :key k} (note-key? k))
(when (has-key? held k)
(def b (held k))
(:send env ;(ins-cmd :stop b 0))
(when rec (store-note b))
(put held k nil)
)
)))))
(putfn modes ev [env]
(prompt teardown (forever
(def event (yield))
(match event
{:how :press :text "q"}
(:set-mode env :cmd)
_ (:msg env "event packet: %P\r\n"
(struct/proto-flatten event))
))))
(defn mk-channel []
@{:instr :sine
:ampl 1
:cfg @{}
:mute false})
(defn present-file [env text]
(def lines (string/split "\n" text))
(defn c [& r] (:color (env :tty) ;r))
(var idx 0)
(def out-lines @[])
(each line lines (++ idx)
(array/push out-lines
(string (c [.6 .2 .3] nil
(string/format "% 04d" idx))
" " line "\n")))
(string/join out-lines))
(defn do-cmd [str env]
(def argv (peg/match grammar str))
(defn say [fmt & args]
(:write (env :tty) (string/format fmt ;args)))
(def chan (get-in env [:chans (env :chan)]))
(defn bad-cmd []
(:msg env "bad command\n"))
(match argv
@["q"] (return terminate)
@["t" time] (put env :time (scan-number time))
@["f" path] (put env :file path)
@["t"] (:msg env "time is %f\n" (env :time))
@["f"] (if (= "" (env :file))
(:msg env "no file\n")
(:msg env "file is %s\n" (env :file)))
@["ch" "ls"] (do (defn c [& r] (:color (env :tty) ;r))
(def tpl (string
(c [.8 .3 .4] nil
"% 3i ") #idx
"%s%s " #iso-state volume
(c [.5 .5 1] [0 0 .1] " %s ") #name
(c [1 .5 .5] [.1 0 0] " %s ") #instr
"\n"))
(def max-ampl (extreme >
(map (fn [(_ ch)] (ch :ampl))
(pairs (env :chans)))))
(defn iso-state [id ch]
(def colors {:iso [.2 1 .1]
:uniso [1 .2 .1]
:mute [.1 .4 1]
:on [1 1 1]
:blank [0 0 0]})
(def states @[])
(when (ch :mute) (array/push states :mute))
(unless (empty? (env :iso))
(array/push states
(if (has-value? (env :iso) id)
:iso :uniso)))
(def leds (string
(if (ch :mute) "m" " ")
(if (has-value? states :iso) "i" " ")))
# (unless (or (ch :mute)
# (has-value? states :uniso))
# (array/push states :on))
(when (empty? states)
(array/push states :blank))
(def base (let [n (/ 1 (length states))]
(alg/vect * [n n n]
(alg/vect + ;(map |(colors $) states)))))
(defn vlerp [t a b]
(alg/vect |(lerp t $ $1) a b))
(c (vlerp 0.5 base [1 1 1])
(vlerp 0.5 base [0 0 0])
leds))
(var idx 0)
(each [id ch] (pairs (env :chans))
(++ idx)
(:msg env tpl
idx
(iso-state id ch)
(:vol-bar env (/ (ch :ampl) max-ampl))
id (ch :instr))
(unless (empty? (ch :cfg))
(:msg env " %s\n" (string/join
(map |(string/format
(string (c [.2 .4 1] nil "\e[1m%s")
"="
(c [.6 .3 1] nil "%q"))
;$)
(pairs (ch :cfg))) " ")))))
(@["ch" "mv" f op t]
(has-value? ["to" "clobber" "merge"] op))
(do (def (from to) (map keyword [f t]))
(cond
(and (not= op "clobber") (has-key? (env :chans) to))
(:msg env "cannot clobber existing channel")
(and (= op "merge") (has-key? (env :chans) to))
(put-in env [:chans from] nil)
:else # valid move
(do (put-in env [:chans to ] (get-in env [:chans from]))
(put-in env [:chans from] nil)))
(when (= (env :chan) from)
(put env :chan to))
(each s (env :score)
(when (= from (s :chan))
(put s :chan to))))
@["ch" "set" c] (let [kc (keyword c)]
(put env :chan kc)
(unless (has-key? (env :chans) kc)
(put-in env [:chans kc] (mk-channel))))
@["ch" _] (bad-cmd)
@["ch"] (:msg env "current channel is %s\n" (env :chan))
@["perf"] (:msg env "performing score\n"
(ev/write (get-in env [:cs-in 1])
(write-score env)))
@["iso" "set" & chans] (put env :iso (map keyword chans))
@["iso" "add" & chans] (array/concat (env :iso) (map keyword chans))
@["iso" "del" & chans]
(put env :iso (filter |(not (has-value? chans (string $)))
(env :iso)))
@["iso" "off"] (array/clear (env :iso))
@["iso" _] (bad-cmd)
@["iso"] (:msg env "isolating channels %s\n"
(string/join (map string (env :iso)) " "))
@["amp" x] (put chan :ampl (scan-number x))
@["amp"] (:msg env "channel %s amp is %f\n" (env :chan) (chan :ampl))
@["mute" "on"] (put chan :mute true)
@["mute" "off"] (put chan :mute false)
@["mute"] (do (toggle (chan :mute))
(:msg env "%s channel %s\n"
(if (chan :mute) "muting" "unmuting")
(env :chan)))
@["cfg" key val] (put-in chan [:cfg (keyword key)]
(scan-number val))
@["cfg" key] (:msg env "%s = %s\n" key
(string (get-in chan [:cfg (keyword key)]
"\e[3m<unset>\e[m")))
@["cfg"] (each [k v] (pairs (chan :cfg))
(:msg env "\e[1m%s\e[m = %s\n" k (string v)))
@["sc" "from" t] (:msg env "printing score from %f\n" (env :time))
@["sc" "to" t] (:msg env "printing score to %f\n" (env :time))
@["sc" "erase" "all"] (array/clear (env :score))
@["sc" "erase"] nil
@["sc" "comp" path] (do (:msg env "writing score to %s\n" path)
(spit path (write-score env)))
@["sc" "comp"] (:msg env "composing score\n%s\n"
(present-file env (write-score env)))
@["sc"] (:msg env "printing score\n%P\n" (env :score))
@["pl"] (:set-mode env :play)
@["in" inst] (let [ik (keyword inst)]
(if (has-key? orchestra ik) (put chan :instr ik)
(:msg env "no such instrument %s\n" inst)))
@["in"] (:msg env "instrument is %s\n" (chan :instr))
@["st" "pid"] (:msg env "csound process is pid %i\n"
(get-in env [:cs-proc :pid]))
@["st" "ev"] (:set-mode env :ev)
(x (or (nil? x) (empty? x))) nil
(:msg env "bad cmd\n")))
(putfn modes cmd [env]
(var cmd-line @"")
(def history @[])
(var histidx nil)
(prompt teardown (forever
(:msg env "\r\e[2K\e[1m:%s\e[m" cmd-line)
(def event (yield))
(defn go-history [n]
(def lastidx (- (length history) 1))
(label give-up
(cond (empty? history) (return give-up)
(and (nil? histidx)
(< n 0)) (set histidx (+ n (length history)))
(nil? histidx) (return give-up)
(> (+ n histidx) lastidx)
(do (set histidx nil)
(set cmd-line @"")
(return give-up))
(<= (+ n histidx) lastidx)
(set histidx (max 0 (+ n histidx)))
:else (return give-up))
(set cmd-line (buffer (history histidx)))))
(when (or (= (event :how) :press)
(= (event :how) :repeat))
(match event
{:key :bksp} (buffer/popn cmd-line 1)
{:key :tab} (do)
{:key :up} (go-history -1)
{:key :dn} (go-history 1)
{:key :enter} (do
(:msg env "\r\n")
(set histidx nil)
(do-cmd cmd-line env)
(array/push history (string cmd-line))
(buffer/clear cmd-line))
{:text t} (buffer/push cmd-line t)
)))))
(defn task-cmd [env]
"command input handling"
(def {:tty tty} env)
(var mode nil)
(defn new-mode [x & args]
(def m (fiber/new x :yi))
(resume m env ;args)
(fn resume-mode [& args] (resume m ;args)))
(put env :set-mode (fn env:set-mode [_ x & args]
(set mode (new-mode (modes x) ;args))
(return teardown)
))
# this is silly
(prompt teardown (:set-mode env :cmd))
(prompt terminate
(loop [e :iterate (:await tty)
:while mode]
(mode e)))
(os/proc-kill (env :cs-proc) true :term))
(defn main [& argv]
(def cs-in (os/pipe :R))
(def cs-out (os/pipe :W))
(def cs (os/spawn ["csound" "-Lstdin" "--orc" "ostinata.orc" "-odac"] :p
{:in (cs-in 0) :out (cs-out 1) :err (cs-out 1)}))
(def tty (tui/init (os/open "/dev/tty" :rw)))
(def doc @{})
(def env @{:tty tty
:score @[]
:chans @{:root (mk-channel)}
:iso []
:chan :root
:file ""
:pause false
:time 0.0
:cs-proc cs
:cs-in cs-in
:cs-out cs-out
:vol-bar (fn [me fac] (:vbar (me :tty) fac
[.5 1 .25]
[1.0 1.0 0.25]
[1 .2 .1]))
:instr-for-chan (fn [me c]
(:for-chan (orchestra (c :instr)) me c))
:send (fn env:send [me & args]
(def cmd (cmd→string args))
# (print "cmd = " cmd)
(ev/write (cs-in 1) (string cmd "\n")))
:msg (fn env:msg [me fmt & args]
(:write (me :tty) (string/format fmt ;args)))
})
(ev/call |(do (defer (:close tty)
(task-cmd env)))))