# [ʞ] 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 200 # shortest frequency
					  :span 600 # range of frequencies
					  :decay 0}
				:setup freq-spread-notes
				:note (fn string: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)))]))
	:piano (struct/with-proto <instr>
				:name "piano"
				:cfg {:base 400 # shortest frequency
					  :span 600} # range of frequencies
				:setup freq-spread-notes
				:note (fn piano:note [me env n]
						  (def freq (get-in me [:notes (n :index)]))
						  [(* (me :ampl) (n :vel)) freq]))
	:warbulator (struct/with-proto <instr>
				:name "warbulator"
				:cfg {:base 400 # shortest frequency
					  :span 600 # range of frequencies
					  :range 3}
				:setup freq-spread-notes
				:note (fn warbulator:note [me env n]
						  (def freq (get-in me [:notes (n :index)]))
						  (def c (me :cfg))
						  [(* (me :ampl) (n :vel)) freq (c :range) (c :range)]))
})


(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))
		(def key-color-lut
			[[0.8 0.0 0.2]
			 [0.2 0.5 1.0]
			 [0.3 1.0 0.2]
			 ])
		(let [nm (ins :note-map)]
			(defn key->fac [k]
				(def ki (get-in nm [:key->index (k 0)]))
				(/ ki (nm :n)))
			(each n (nm :keys)
				(when-let [k (held (n 0))]
					(array/push sustain
						(clr (alg/vlut (key->fac n) key-color-lut) [0 0 0] n)))))
		(: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 maybe-restart-clock []
		(def restart? (not= nil clock-fiber))
		(stop-clock)
		(when restart? (start-clock)))

	(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)
					(maybe-restart-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 :string
	  :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))
			(defn execute []
				(:msg env "\r\n")
				(set histidx nil)
				(do-cmd cmd-line env)
				(array/push history (string cmd-line))
				(buffer/clear cmd-line))
			(defn complete [])
			(match event
				{:key :bksp} (buffer/popn cmd-line 1)
				{:key :tab} (complete)
				{:key :up} (go-history -1)
				{:key :dn} (go-history  1)
				{:key    :enter} (execute)
				{:key :kp-enter} (execute)
				{: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)))))
