util  Check-in [908662f1b1]

# [ʞ] alg.janet
#  ~ lexi hale <lexi@hale.su>
#  🄯 AGPLv3
#  ? basic algorithms inexplicably missing from std

(defn vect ``
	vectorize primitive operations

		`(vect + [1 2 3] [3 2 1]) #→ [4 4 4]`

		`(vect * [1 2  ] [2 2 5]) #→ [2 4 5]`
	`` [op & vecs]

	(def a @[])
	(var col 0)
	(forever 
		# theoretically this should be as simple as ;(map idx v)
		# but we want to handle missing columns sanely, which is
		# more complicated.
		(def args
			(mapcat (fn [v]
						(if (>= col (length v)) []
							[(get v col)]))
					vecs))
		(when (empty? args) (break))
		(put a col (apply op args))
		(++ col))
	(freeze a))

(defn clamp [v &opt m x]
	(min (or x 1) (max (or m 0) v)))

(defn xlerp [t a b]
	  (+ (* a (- 1 t))
		 (* b      t)))

(defn lerp [t a b]
	(xlerp (clamp t) a b))

(defn sel "return a record filtered by a key predicate"
	[rec p]
	(def r @{})
	(eachp (k v) rec
		(when (p k) (put r k v)))
	(if (table? rec) r (freeze r)))

(defn qrec "query a record by key names, returning a matching sub-record"
	[rec & ks]
	(def r @{})
	(each k ks
		(put r k (get rec k)))
	(if (table? rec) r (freeze r)))

(defn llut "get the lerp halves for a linear lookup table"
	[t lut]
	(def t (clamp t))
	(case t
		0 [0 (first lut) (first lut)]
		1 [1 (last  lut) (last  lut)]
		(do (def q (- (length lut) 1))
			(def n (* q t))
			(def idx (math/trunc n))
			(def frac (- n idx))
			[frac
			 (lut      idx)
			 (lut (+ 1 idx))])))

(defn ilut "interpolate a linear lookup table"
	[t lut]
	(lerp ;(llut t lut)))

(defn vlut "interpolate a linear vector lookup table"
	[t lut]
	(def [fac a b] (llut t lut))
	(vect |(lerp fac ;$&) a b))

(defn lut-bake "bake a lut from a function"
	[res f]
	(def t (array/ensure @[] res 1))
	(loop [i :range [0 res] :let [fac (/ i res)]]
		(put t i (f fac)))
	t)

# [ʞ] 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)))))

0dbfs = 100
nchnls = 2
sr = 44100

; p2 when
; p3 dur
; p4 vol
; p5 freq

givol ftgen 1, 0, 10000, 25, \
	500, 60, \
	1000, 20, \
	7000, 3, \
	10000, 5

instr sine
	tigoto skipinit
	kt init 0
	al init 1.0
	ifreq = p5
	ichime = p6

	ivol = 30 * p4 * table(ifreq, givol)

	aw oscils ivol, ifreq, 0
	af oscils ivol, ifreq * ichime, 0
	skipinit:
	kt = kt + (1/kr)
	kv bpf kt, 0,0, 0.5,0.8, .1,1, 1,.6
	at linseg 0, p3, 1

	if p3 >= 0 then
		aw = aw * (1 - at)
		aw = aw + (af * at)
		aw = aw * (1-at)
	endif

	out aw*al
endin

instr string
	tigoto skipinit
	; initialize
	ivol = 30*p4
	ifreq = p5

	aw pluck ivol, ifreq, ifreq, 0, 3, p6
	skipinit:
	at linseg 1, p3, 0

	if p3 >= 0 then
		aw = aw * at
	endif
	out aw
endin

# [ʞ] tui.janet
#  ~ lexi hale <lexi@hale.su>
#  🄯 AGPLv3
#  ? quick and extremely dirty rawterm interface

(use /alg)

# FIXME use ffi to directly munge termios where feasible
(defn raw [fd] 
	(os/execute ["stty" "raw" "-echo" "opost"] :p))

(defn unraw [fd]
	(os/execute ["stty" "-raw" "echo"] :p))

(defmacro use-raw [fd]
	~(upscope
		 (,raw ,fd)
		 (,defer ,unraw ,fd)))

(defmacro with-raw [fd & x]
	~(do (,raw ,fd)
		 ,;x
		 (,unraw ,fd)))

(def- capq-resp (peg/compile ~{
	:lst (* '(+ (some (range "09"))
				(constant "0"))
			  (? (* ";" :lst)))
	:resp "\e[?"
	:seq (* :resp (group :lst))
	:tc (* :seq "c")
	:pg (* :resp (number (any (range "09"))) "u")
	:main (* (+ :pg (constant false))
			  :tc)
}))
(def- pg-flags {0x01 :E # disambig events
			    0x02 :e # report evt types
			    0x04 :k # keycode alts
			    0x08 :K # all keys as alts
			    0x16 :t}) # text
(defn release [env]
	(defn send [& x] (ev/write (env :fd) (string ;x)))
	(when (string/check-set (env :caps) :p)
		(send "\e[<1u"))
	(unraw (env :fd))
	(:close (env :fd)))

(defn- read-until [pred fd]
	(def buf @"")
	(label matched
		   (forever
			   # (ev/write fd (string/format "buf: %j\r\n" buf))
			   (ev/read fd 1 buf)
			   (spit "dbgkeys" buf)
			   (def p (pred buf))
			   (when p (return matched p)))))

(defn- text-key [c & args]
	(struct :text c
			:key ((string/ascii-lower c) 0)
			:case (c 0)
			:base (c 0)
			:how :press
			;args))

(def- event-code-ptn (peg/compile ~{
	:csi "\e["
	:ss3 "\e\x4f"
	:cs3 (+ :csi :ss3)
	:key-basic (cmt (* :csi :keycode :keyev "~" )
				,(fn [kc ks kb mods how]
					(def basis
						(case kc
						   2 :ins
						   3 :del
						   5 :pgup
						   6 :pgdn
						   7 :home
						   8 :end
						   (cond (<= 11 kc 24) (keyword :f (- kc 11))
							     :else :unknown)))
					 {:key  basis
					  :mods mods
					  :how how}))
	:key-magic (cmt (* :csi "1" :keyev '(+ (range "AF") "H" "P" "Q" "S"))
					,(fn [mods how cue]
						{:mods mods
						 :how how
						 :key (case cue
								  "A" :up "C" :rt
								  "B" :dn "D" :lf
								  "H" :home "F" :end
								  "E" :kp-begin )}))
	:legacy-ctl (cmt '(range "\x01\x07" "\x0b\x0c" "\x0e\x1a")
			        ,(fn [ccode]
						(def code (+ 0x60 (ccode 0)))
						(def lc (string/format "%c" code))
						{ :text lc
						  :key code
						  :case code
						  :base code
						  :how :press
						  :mods :c }))
	:key (+ (* "\x0D"            (constant {:key :enter :how :press}))
	        (* (+ "\x7F" "\x08") (constant {:key :bksp  :how :press}))
			(* "\x09"            (constant ,(text-key "\t" :key :tab)))
			(* "\x00"            (constant ,(text-key " "  :key :sp :mods :c)))
			:legacy-ctl
	        (* :cs3 "A"          (constant {:key :up :how :press}))
	        (* :cs3 "B"          (constant {:key :dn :how :press}))
	        (* :cs3 "C"          (constant {:key :rt :how :press}))
	        (* :cs3 "D"          (constant {:key :lf :how :press}))
	        (* :cs3 "E"          (constant {:key :kp-begin :how :press}))
			(+ (* :csi :keyspec "u")
			   (* "\e"  (cmt :legacy-ctl
						,(fn [c] (struct/with-proto c
									:mods (keyword (get c :mods :) :a)))))
			   (* "\e" (not "[") (cmt '1 ,|(text-key $ :mods :a)))
			   (*     (not "\e") (cmt '1 ,|(text-key $)))))
	:ctl (cmt :num0 ,(fn [c]
			(defn b [n k]
				(if (not= 0 (band (- c 1) n)) k :))
			(keyword (b 0x01 :s) (b 0x10 :H)
			         (b 0x02 :a) (b 0x20 :m)
			         (b 0x04 :c) (b 0x40 :C)
			         (b 0x08 :S) (b 0x80 :N))))
	:keyev (+ (* ";" :ctl
	             (+ (* ":1" (constant :press))
	                (* ":2" (constant :repeat))
	                (* ":3" (constant :release))
	                (constant :press)))
			   (* ";" (constant :) (constant :press))
	           (* (constant :) (constant :press)))
	:text (+ (cmt (group (some (* ";" :num0)))
				 ,(fn [chars] #FIXME
					(string ;(map |(string/format "%c" $) chars))))
			 (constant false))
	:keycode (+ (* :num0 ":" :num0 ":" :num0)
	            (* :num0 ":" :num0 (constant false))
	            (* :num0 (constant false) (constant false)))
	:keyspec (cmt (* :keycode :keyev :text)
				,(fn keyspec-translate [kc ks kb mods how t]
					(def basis
						(case kc
						   9 {:key :tab }
						   13 {:key :enter }
						   127 {:key :bksp }

						   57358 {:key :lock-caps }
						   57360 {:key :lock-num }
						   57414 {:key :kp-enter }
						   57413 {:key :kp-plus  :text "+"}
						   57412 {:key :kp-minus :text "-"}
						   57411 {:key :kp-mul   :text "*"}
						   57410 {:key :kp-div   :text "/"}
						   43    {:key :add :text "+"}
						   8722  {:key :sub :text "−"}
						   215   {:key :mul :text "×" }
						   243   {:key :div :text "÷" }
						   57441 {:key :shift-l} 57447 {:key :shift-r}
						   57443 {:key :alt-l}   57449 {:key :alt-r}
						   57444 {:key :super-l} 57450 {:key :super-r}
						   57445 {:key :hyper-l} 57451 {:key :hyper-r}
						   57442 {:key :ctl-l}   57448 {:key :ctl-r}
						   57453 {:key :lvl3}
						   57454 {:key :lvl5}
						   (cond (<= 57376 kc 57398) {:key (keyword :f (- kc 57363))}
								:else {:key kc
									   :text (or t (string/format "%c" (or ks kc)))})))
					 {:text (get basis :text nil)
					  :key  (get basis :key nil)
					  :case (or ks kc)
					  :base (or kb kc)
					  :mods mods
					  :how how}))
	:main (* (+ :key-basic :key-magic :key) -1)

	:num (some (range "09"))
	:num0 (+ (number :num)
	         (constant 0))
}))

(def- color-cmd
	(do (def env (os/environ))
		(def ct (env "COLORTERM"))
		(def term (env "TERM"))
		(defn mode-char [mode]
			(case mode :fg    "3" :bg    "4"
				       :fg-br "9" :bg-br "10"
				(error "bad mode")))

		(cond (or (= ct "truecolor")
				  (= term "xterm")) # modern xterm supports tc
				(fn colorize-tc [mode rgb]
					(as-> rgb v
						(map |(math/floor (* 255 (clamp $))) v)
						(string/join (map string v) ";")
						(string "\e[" (mode-char mode) "8;2;" v "m")))

			(or (string/has-suffix? "256color" term)
				(not (nil? ct)))
				(fn colorize-256 [mode rgb]
					(def code (math/floor
						(cond (= 0 ;rgb) 0
						      (=   ;rgb) (lerp (rgb 0) 232 255)
						      :else      (+ 16 ;(vect * [36 6 1]
													  (map clamp rgb))))))
					(string "\e[" (mode-char mode) "8;5;" code "m"))

			:else
				(fn colorize-8 [mode rgb] "")))) #FIXME

(defn- vbar [tty f & grad]
	(def c [ " " "▁" "▂" "▃" "▄" "▅" "▆" "▇" "█" ])
	# (def fg (vect |(lerp f ;$&) bright dim))
	(def fg (vlut f grad))
	(def bg (vect |(lerp .5 ;$&) fg [0 0 0]))
	(def idx (math/floor (* (max 0 (min 1 f))
							(dec (length c)))))
	(:color tty fg bg (c idx)))

(def- <env> {:close release
			 :write |(ev/write ($ :fd) $1)
			 :read  |(ev/read  ($ :fd) $1)
			 :color (fn tui:color [me fg bg str]
				(as-> str cmd
					(if fg (string (color-cmd :fg fg) cmd) cmd)
					(if bg (string (color-cmd :bg bg) cmd) cmd)
					(if (or fg bg) (string cmd "\e[m"))))
			 :vbar vbar
			 :await (fn tui:await [me]
			 # (print "awaiting")
				(def [evt] (read-until |(peg/match event-code-ptn $) (me :fd)))
				evt)})

# (def- chord-pat (peg/compile ~{
# 	:wd (some (* (not "-") wd))
# }))

(defn- subset [a b]
	(var matches true)
	(loop [[k v] :pairs a :while matches]
		(when (not= v (get b k nil))
			(set matches false)))
	matches)
(defn chord [& fm]
	(def ksym (last fm))
	(def mods (keyword ;(slice fm 0 -2)))
	(merge {:mods mods
		    :how :press}
		(cond
			(keyword? ksym) {:key ksym}
			(string?  ksym)
				{#:text ksym
				 :key (in (string/ascii-lower ksym) 0)
				 :case (in ksym 0)})))
(defn event<chord? [evt & fm]
	(subset evt (chord ;fm)))

(defn init [fd]
	(raw fd)
	(defn send [& x] (ev/write fd (string ;x)))
	(defn recv [n &opt buf] (string (ev/read fd n buf)))
	(var caps :)
	(send "\e[?u\e[c") # query caps
	(def lists (label done
					  (def buf @"")
					  (forever
						  (recv 1 buf)
						  (def m (peg/match capq-resp buf))
						  (when m
							  (return done m)))))
	(defn set-caps! [which tbl]
		(each e which
			(when (has-key? tbl e)
				(set caps (keyword caps (tbl e))))))
	(set-caps! (lists 1) {
	   "4" :6 # sixel
	})

	(when (lists 0)
		(set caps (keyword caps :p))
		(each [c f] (pairs pg-flags)
			(when (not= 0 (band c (lists 0)))
				(set caps (keyword caps f)))))

	(when (string/check-set caps :p)
		(def fmap (invert pg-flags))
		(def f (bor (lists 0) (fmap :k) (fmap :e) (fmap :K)))
		(send "\e[>" (string (inc f) "u")))

	(struct/with-proto <env>
					   :fd fd
					   :caps caps))