Overview
| Comment: | initial ostinata commit |
|---|---|
| Downloads: | Tarball | ZIP archive | SQL archive |
| Timelines: | family | ancestors | descendants | both | trunk |
| Files: | files | file ages | folders |
| SHA3-256: |
908662f1b1236804a95053889be0fae1 |
| User & Date: | lexi on 2025-03-12 06:46:14 |
| Other Links: | manifest | tags |
Context
|
2025-03-14
| ||
| 17:35 | add some instruments, fix some bugs (piano is not real yet) check-in: 5422ffcfca user: lexi tags: trunk | |
|
2025-03-12
| ||
| 06:46 | initial ostinata commit check-in: 908662f1b1 user: lexi tags: trunk | |
|
2024-07-10
| ||
| 19:11 | ave julianus imperator check-in: e02ae59ffd user: lexi tags: trunk | |
Changes
Added ostinata/alg.janet version [ca434a4824].
1 +# [ʞ] alg.janet 2 +# ~ lexi hale <lexi@hale.su> 3 +# 🄯 AGPLv3 4 +# ? basic algorithms inexplicably missing from std 5 + 6 +(defn vect `` 7 + vectorize primitive operations 8 + 9 + `(vect + [1 2 3] [3 2 1]) #→ [4 4 4]` 10 + 11 + `(vect * [1 2 ] [2 2 5]) #→ [2 4 5]` 12 + `` [op & vecs] 13 + 14 + (def a @[]) 15 + (var col 0) 16 + (forever 17 + # theoretically this should be as simple as ;(map idx v) 18 + # but we want to handle missing columns sanely, which is 19 + # more complicated. 20 + (def args 21 + (mapcat (fn [v] 22 + (if (>= col (length v)) [] 23 + [(get v col)])) 24 + vecs)) 25 + (when (empty? args) (break)) 26 + (put a col (apply op args)) 27 + (++ col)) 28 + (freeze a)) 29 + 30 +(defn clamp [v &opt m x] 31 + (min (or x 1) (max (or m 0) v))) 32 + 33 +(defn xlerp [t a b] 34 + (+ (* a (- 1 t)) 35 + (* b t))) 36 + 37 +(defn lerp [t a b] 38 + (xlerp (clamp t) a b)) 39 + 40 +(defn sel "return a record filtered by a key predicate" 41 + [rec p] 42 + (def r @{}) 43 + (eachp (k v) rec 44 + (when (p k) (put r k v))) 45 + (if (table? rec) r (freeze r))) 46 + 47 +(defn qrec "query a record by key names, returning a matching sub-record" 48 + [rec & ks] 49 + (def r @{}) 50 + (each k ks 51 + (put r k (get rec k))) 52 + (if (table? rec) r (freeze r))) 53 + 54 +(defn llut "get the lerp halves for a linear lookup table" 55 + [t lut] 56 + (def t (clamp t)) 57 + (case t 58 + 0 [0 (first lut) (first lut)] 59 + 1 [1 (last lut) (last lut)] 60 + (do (def q (- (length lut) 1)) 61 + (def n (* q t)) 62 + (def idx (math/trunc n)) 63 + (def frac (- n idx)) 64 + [frac 65 + (lut idx) 66 + (lut (+ 1 idx))]))) 67 + 68 +(defn ilut "interpolate a linear lookup table" 69 + [t lut] 70 + (lerp ;(llut t lut))) 71 + 72 +(defn vlut "interpolate a linear vector lookup table" 73 + [t lut] 74 + (def [fac a b] (llut t lut)) 75 + (vect |(lerp fac ;$&) a b)) 76 + 77 +(defn lut-bake "bake a lut from a function" 78 + [res f] 79 + (def t (array/ensure @[] res 1)) 80 + (loop [i :range [0 res] :let [fac (/ i res)]] 81 + (put t i (f fac))) 82 + t)
Added ostinata/ostinata.janet version [ec4176d797].
1 +# [ʞ] ostinata.janet 2 +# ~ lexi hale <lexi@hale.su> 3 +# 🄯 AGPLv3 4 +# ? a TUI mini-garageband that uses csound as 5 +# a backend synthesizer. to add a new instrument, 6 +# write it in ['ostinata.orc], then add it to 7 +# [$orchestra] here 8 + 9 +(import /tui) 10 +(import /alg) 11 + 12 +(def terminate (gensym)) 13 +(def teardown (gensym)) 14 + 15 +(def grammar (peg/compile ~{ 16 + :qlit (* `"` (% (any (+ (* `\"` (constant `"`)) 17 + (* (not `"`) '1)))) 18 + `"`) 19 + :idchar (* (not :s) '1) 20 + :term (% (some (+ :qlit :idchar))) 21 + :seq (* :s* :term (? (* :s+ :seq)) :s*) 22 + :main :seq 23 +})) 24 + 25 +(defmacro putfn [tbl id & dfn] 26 + ~(put ,tbl ,(keyword id) (fn ,(symbol tbl ":" id) ,;dfn))) 27 + 28 +(def modes @{}) 29 + 30 +(def *trace?* (gensym)) 31 +(setdyn *trace?* true) 32 + 33 +(def failure (gensym)) 34 +(defn fail! [code & arg] 35 + (as-> (string/format ;arg) msg 36 + (if-not (dyn *trace?*) msg 37 + (debug/stacktrace (fiber/root) msg "")) 38 + (return failure [code msg]))) 39 + 40 +(defn guard* [thunk fail] 41 + (def [code result] (prompt failure 42 + (def r (thunk)) 43 + [nil r])) 44 + (if code (fail code result) 45 + result)) 46 + 47 +(defmacro guard [body & conds] 48 + (def $code (gensym)) 49 + ~(,guard* (fn guard-thunk [] ,body) 50 + (fn guard-catch [,$code msg] 51 + (match ,$code 52 + ;conds 53 + # fail upward if not caught 54 + _ (return failure [code msg]))))) 55 + 56 +(defn score-marshal [score] 57 + (marshal [:application/x.vt.ostinata 0 58 + {:score score}])) 59 + 60 +(defn score-unmarshal [bin] 61 + (match (unmarshal bin) 62 + [:application/x.vt.ostinata vers {:score score}] 63 + score 64 + _ (fail! :parse "not a valid score file"))) 65 + 66 +(defmacro enum [& vals] 67 + (var idx 0) 68 + (tabseq [:after (++ idx) 69 + v :in vals] 70 + v idx)) 71 + 72 +(def default-note-keys 73 + # second col is half-tones 74 + ["a" "z" 75 + "s" "x" 76 + "d" "c" 77 + "f" "v" 78 + "g" "b" 79 + "h" "n" 80 + "j" "m" 81 + "k" "," 82 + "l"]) 83 + 84 +(def note-map { 85 + :continuum (fn note-map:continuum [me f] 86 + (seq [i :range [0 (me :n)] 87 + :let [ncode ((get-in me [:keys i]) 0) 88 + ncap (string/format "%c" ncode) 89 + prog (/ i (me :n))]] 90 + (f prog ncap ncode))) 91 +}) 92 + 93 +(defn note-map-for [env chan] 94 + (def km (or (chan :keymap) 95 + (env :keymap) 96 + default-note-keys)) 97 + (def nkeys (length km)) 98 + (def note-key-indices 99 + (tabseq [i :range [0 nkeys]] ((km i) 0) i)) 100 + (struct/with-proto note-map 101 + :keys km 102 + :n nkeys 103 + :key->index note-key-indices)) 104 + 105 +(def <instr> 106 + {:start (fn <instr>start [me env note time] 107 + [:i (:ident-note me note) time -1 108 + ;(:note me env note)]) 109 + :stop (fn <instr>stop [me env note time] 110 + [:i (string (:ident-note me note)) time 111 + (get-in me [:cfg :dwell] .2)]) 112 + :cfg {} 113 + :for-chan (fn <instr>for-chan [me env chan] 114 + (def cfg (merge (me :cfg) (chan :cfg))) 115 + (def intermediate 116 + (struct/with-proto me 117 + :cfg cfg 118 + :ampl (chan :ampl))) 119 + (struct/with-proto me 120 + ;(kvs intermediate) 121 + ;(kvs (:setup intermediate env chan)))) 122 + :setup (fn <instr>setup [me env chan] 123 + {:note-map (note-map-for env chan)}) 124 + :ident-note (fn <instr>ident-note [me n] 125 + (def frac (reverse (string (n :id)))) # not a joke 126 + (string (me :name) "." frac))}) 127 + 128 +(defn lerp [t a b] 129 + (+ (* (- 1 t) a) 130 + (* t b))) 131 + 132 +(defn freq-spread-notes [me env chan] 133 + (def super ((<instr> :setup) me env chan)) 134 + (defn cv [x &opt dflt] (get-in me [:cfg x] dflt)) 135 + (merge super 136 + {:notes (:continuum (super :note-map) 137 + (fn [p cap code] 138 + (lerp p (cv :base) 139 + (+ (cv :base) (cv :span)))))})) 140 +(def orchestra { 141 + :sine (struct/with-proto <instr> 142 + :name "sine" 143 + :cfg {:base 800 :span 600 :chime 1} 144 + :setup freq-spread-notes 145 + :note (fn sine:note [me env n] 146 + (def freq (get-in me [:notes (n :index)])) 147 + [(* (me :ampl) (n :vel)) freq (get-in me [:cfg :chime])])) 148 + :string (struct/with-proto <instr> 149 + :name "string" 150 + :cfg {:base 500 # shortest frequency 151 + :span 300 # range of frequencies 152 + :decay 0} 153 + :setup freq-spread-notes 154 + :note (fn drum:note [me env n] 155 + (def freq (get-in me [:notes (n :index)])) 156 + (def c (me :cfg)) 157 + [(* (me :ampl) (n :vel)) freq (- 1 (* .1 (c :decay)))])) 158 +}) 159 + 160 + 161 +(defn timecode→string [t] 162 + (def μs (% t 1)) 163 + (def s (math/floor (% t 60))) 164 + (def m (math/floor (% (/ t 60) 60))) 165 + (def h (math/floor (% (/ t 60) (* 60 60)))) 166 + (string/format "%02u:%02u:%02u.%02u" h m s 167 + (math/floor (* μs 100)))) 168 + 169 +(defn cmd→string [cmd] 170 + (defn txl [val] 171 + (cond (keyword? val) (string val) 172 + :else (string/format "%q" val))) 173 + (def str (string/join (map txl cmd) " "))) 174 + 175 +(defn sort-score [env] 176 + (sort-by |($ :at) (env :score))) 177 + 178 +(defn over-score `` 179 + iterates a score's notes, respecting mute flags 180 + and the the current isolation mode 181 + `` [env f] 182 + (each n (env :score) 183 + (def chan-id (n :chan)) 184 + (def chan (get-in env [:chans chan-id])) 185 + (when (and (not (chan :mute)) 186 + (or (empty? (env :iso)) 187 + (has-value? (env :iso) chan-id))) 188 + (f n)))) 189 + 190 +(defn write-score [env] 191 + (def cmds @[]) 192 + (sort-score env) 193 + (over-score env (fn [n] 194 + (def chan (get-in env [:chans (n :chan)])) 195 + (def ins (:instr-for-chan env chan)) 196 + (defn ins-cmd [method & args] 197 + ((ins method) ins env ;args)) 198 + (def cl [(ins-cmd :start n (n :at)) 199 + (ins-cmd :stop n (+ (n :at) (n :len)))]) 200 + (each c cl (array/push cmds c)))) 201 + (def score-text 202 + (string/join (map |(string (cmd→string $) "\n") cmds))) 203 + score-text) 204 + 205 +(defn player [env] 206 + (sort-score env) 207 + (def chan-instrs 208 + (tabseq [[chid chan] :pairs (env :chans)] 209 + chid (:instr-for-chan env chan))) 210 + (var last-time (env :time)) 211 + (protect (over-score env (fn [e] 212 + (unless (< (e :at) last-time) #TODO cache last note id in play mode? 213 + # (def chan (get-in env [:chans (e :chan)])) 214 + (def ins (in chan-instrs (e :chan))) 215 + (defn ins-cmd [method & args] 216 + ((ins method) ins env ;args)) 217 + 218 + # skip over notes we've already passed 219 + (def t (e :at)) 220 + (ev/sleep (- t last-time)) 221 + (set last-time t) 222 + 223 + #haack 224 + (:send env ;(ins-cmd :start e 0)) 225 + (:send env ;(ins-cmd :stop e (e :len)))))))) 226 + 227 +(putfn modes play [env] 228 + (defn ticks [] 229 + (os/clock :monotonic)) 230 + (var rec false) 231 + (var cur-id (if (empty? (env :score)) 0 232 + (+ 1 (extreme > (map |($ :id) (env :score)))))) 233 + (def start-time (env :time)) 234 + 235 + (var held @{}) 236 + (var last-time (ticks)) 237 + (def chan (get-in env [:chans (env :chan)])) 238 + (var loud 1) 239 + (def ins (:instr-for-chan env chan)) 240 + (defn note-key? [k] 241 + (not (nil? (get-in ins [:note-map :key->index k])))) 242 + (defn draw-stat-line [timecode] 243 + (def sustain @[]) 244 + (defn clr [& r] (:color (env :tty) ;r)) 245 + # (defn vbar [& r] (:vbar (env :tty) ;r)) 246 + (each n (get-in ins [:note-map :keys]) 247 + (when-let [k (get held n nil)] 248 + (def k (string/format "%c" n)) 249 + (array/push sustain k))) 250 + (:msg env "\r\e[2K%s\r" 251 + (string 252 + (if rec "\e[91m⏺" 253 + "\e[94m⏹") "\e[m" 254 + (clr [.9 .95 1] [0.1 0.2 0.4] 255 + (string " " (timecode→string timecode) " ")) 256 + (:vol-bar env (/ loud 11)) 257 + # (vbar (/ loud 11) 258 + # [.5 1 .25] 259 + # [1.0 1.0 0.25] 260 + # [.8 0 0]) 261 + " " (chan :instr) "\e[96m@" (env :chan) "\e[m" 262 + " \e[1m" (if rec "record" "play") "\e[m" 263 + (string/join sustain)))) 264 + 265 + (def timewarp (get-in chan [:cfg :timewarp] 1.0)) 266 + 267 + (defn advance-clock [res] 268 + (protect (forever 269 + (def cur-time (ticks)) 270 + (draw-stat-line (+ (env :time) 271 + (* (- cur-time last-time) 272 + timewarp))) 273 + (ev/sleep res)))) 274 + 275 + (var clock-fiber nil) 276 + (var player-fiber nil) 277 + (defn start-clock [] 278 + (set clock-fiber (fiber/new |(advance-clock 0.01))) 279 + (set player-fiber (fiber/new |(player env))) 280 + (ev/go clock-fiber) 281 + (ev/go player-fiber)) 282 + (defn stop-clock [] 283 + (when clock-fiber 284 + (ev/cancel clock-fiber nil) 285 + (set clock-fiber nil)) 286 + (when player-fiber 287 + (ev/cancel player-fiber nil) 288 + (set player-fiber nil))) 289 + 290 + (defn ins-cmd [method & args] 291 + ((ins method) ins env ;args)) 292 + (defn stop-all-notes [] 293 + (eachp [k v] held 294 + (:send env ;(ins-cmd :stop v 0)))) 295 + (defn cleanup [] 296 + (stop-all-notes) 297 + (stop-clock)) 298 + (def score-staging @[]) 299 + 300 + 301 + (defer (cleanup) (prompt teardown (forever 302 + (draw-stat-line (env :time)) 303 + (def event (yield)) 304 + 305 + # get precise time unaffected by clock refresh rate 306 + (def cur-time (ticks)) 307 + (def advance (- cur-time last-time)) 308 + (set last-time cur-time) 309 + 310 + (when rec (+= (env :time) (* advance timewarp))) 311 + (def next-id cur-id) 312 + (++ cur-id) 313 + 314 + (defn store-note [b] 315 + (def stored (alg/qrec b 316 + :at :mods :vel :id :index :chan)) 317 + 318 + (def len (- cur-time (b :t))) 319 + (array/push score-staging 320 + (merge stored {:chan (env :chan) 321 + :len len}))) 322 + 323 + (defn commit-score [] 324 + (unless (empty? score-staging) 325 + (array/concat (env :score) score-staging) 326 + (array/clear score-staging) 327 + (sort-score env))) 328 + 329 + (defn commit-unless-shift [] 330 + (unless (string/check-set (event :mods) :s) 331 + (commit-score))) 332 + 333 + (match event 334 + {:how :press :key (@ (comptime ("q" 0)))} 335 + (do (stop-all-notes) 336 + (:set-mode env :cmd) 337 + (commit-unless-shift)) 338 + {:how :press :key (@ (comptime ("r" 0)))} 339 + (do (stop-all-notes) 340 + (toggle rec) 341 + (if rec (start-clock) (stop-clock)) 342 + (commit-unless-shift)) 343 + {:how :press :key :shift-l} (+= loud 1) 344 + {:how :release :key :shift-l} (-= loud 1) 345 + {:how :press :key :shift-r} (-= loud .5) 346 + {:how :release :key :shift-r} (+= loud .5) 347 + {:how :press :key :tab} 348 + (do (put env :time start-time) 349 + (stop-clock) (start-clock)) 350 + ({:how :press :key n} 351 + (<= 0x31 n 0x39)) 352 + (set loud (- n 0x30)) 353 + ({:how :press :key k} 354 + (note-key? k) 355 + (nil? (held k))) 356 + (do (def note {:id cur-id :vel loud 357 + :t cur-time :at (env :time) 358 + :index (get-in ins [:note-map :key->index k]) 359 + :mods (get event :mods :)}) 360 + (put held k note) 361 + (:send env ;(ins-cmd :start note 0))) 362 + ({:how :release :key k} (note-key? k)) 363 + (when (has-key? held k) 364 + (def b (held k)) 365 + (:send env ;(ins-cmd :stop b 0)) 366 + 367 + (when rec (store-note b)) 368 + 369 + (put held k nil) 370 + ) 371 + 372 + ))))) 373 + 374 +(putfn modes ev [env] 375 + (prompt teardown (forever 376 + (def event (yield)) 377 + (match event 378 + {:how :press :text "q"} 379 + (:set-mode env :cmd) 380 + _ (:msg env "event packet: %P\r\n" 381 + (struct/proto-flatten event)) 382 + 383 + )))) 384 + 385 +(defn mk-channel [] 386 + @{:instr :sine 387 + :ampl 1 388 + :cfg @{} 389 + :mute false}) 390 + 391 +(defn present-file [env text] 392 + (def lines (string/split "\n" text)) 393 + (defn c [& r] (:color (env :tty) ;r)) 394 + (var idx 0) 395 + (def out-lines @[]) 396 + (each line lines (++ idx) 397 + (array/push out-lines 398 + (string (c [.6 .2 .3] nil 399 + (string/format "% 04d" idx)) 400 + " " line "\n"))) 401 + (string/join out-lines)) 402 + 403 +(defn do-cmd [str env] 404 + (def argv (peg/match grammar str)) 405 + (defn say [fmt & args] 406 + (:write (env :tty) (string/format fmt ;args))) 407 + (def chan (get-in env [:chans (env :chan)])) 408 + (defn bad-cmd [] 409 + (:msg env "bad command\n")) 410 + (match argv 411 + @["q"] (return terminate) 412 + @["t" time] (put env :time (scan-number time)) 413 + @["f" path] (put env :file path) 414 + @["t"] (:msg env "time is %f\n" (env :time)) 415 + @["f"] (if (= "" (env :file)) 416 + (:msg env "no file\n") 417 + (:msg env "file is %s\n" (env :file))) 418 + 419 + @["ch" "ls"] (do (defn c [& r] (:color (env :tty) ;r)) 420 + (def tpl (string 421 + (c [.8 .3 .4] nil 422 + "% 3i ") #idx 423 + 424 + "%s%s " #iso-state volume 425 + (c [.5 .5 1] [0 0 .1] " %s ") #name 426 + (c [1 .5 .5] [.1 0 0] " %s ") #instr 427 + "\n")) 428 + (def max-ampl (extreme > 429 + (map (fn [(_ ch)] (ch :ampl)) 430 + (pairs (env :chans))))) 431 + (defn iso-state [id ch] 432 + (def colors {:iso [.2 1 .1] 433 + :uniso [1 .2 .1] 434 + :mute [.1 .4 1] 435 + :on [1 1 1] 436 + :blank [0 0 0]}) 437 + (def states @[]) 438 + (when (ch :mute) (array/push states :mute)) 439 + (unless (empty? (env :iso)) 440 + (array/push states 441 + (if (has-value? (env :iso) id) 442 + :iso :uniso))) 443 + (def leds (string 444 + (if (ch :mute) "m" " ") 445 + (if (has-value? states :iso) "i" " "))) 446 + # (unless (or (ch :mute) 447 + # (has-value? states :uniso)) 448 + # (array/push states :on)) 449 + (when (empty? states) 450 + (array/push states :blank)) 451 + 452 + (def base (let [n (/ 1 (length states))] 453 + (alg/vect * [n n n] 454 + (alg/vect + ;(map |(colors $) states))))) 455 + (defn vlerp [t a b] 456 + (alg/vect |(lerp t $ $1) a b)) 457 + (c (vlerp 0.5 base [1 1 1]) 458 + (vlerp 0.5 base [0 0 0]) 459 + leds)) 460 + 461 + (var idx 0) 462 + (each [id ch] (pairs (env :chans)) 463 + (++ idx) 464 + (:msg env tpl 465 + idx 466 + (iso-state id ch) 467 + (:vol-bar env (/ (ch :ampl) max-ampl)) 468 + id (ch :instr)) 469 + (unless (empty? (ch :cfg)) 470 + (:msg env " %s\n" (string/join 471 + (map |(string/format 472 + (string (c [.2 .4 1] nil "\e[1m%s") 473 + "=" 474 + (c [.6 .3 1] nil "%q")) 475 + ;$) 476 + (pairs (ch :cfg))) " "))))) 477 + (@["ch" "mv" f op t] 478 + (has-value? ["to" "clobber" "merge"] op)) 479 + (do (def (from to) (map keyword [f t])) 480 + (cond 481 + (and (not= op "clobber") (has-key? (env :chans) to)) 482 + (:msg env "cannot clobber existing channel") 483 + (and (= op "merge") (has-key? (env :chans) to)) 484 + (put-in env [:chans from] nil) 485 + :else # valid move 486 + (do (put-in env [:chans to ] (get-in env [:chans from])) 487 + (put-in env [:chans from] nil))) 488 + 489 + (when (= (env :chan) from) 490 + (put env :chan to)) 491 + (each s (env :score) 492 + (when (= from (s :chan)) 493 + (put s :chan to)))) 494 + 495 + @["ch" "set" c] (let [kc (keyword c)] 496 + (put env :chan kc) 497 + (unless (has-key? (env :chans) kc) 498 + (put-in env [:chans kc] (mk-channel)))) 499 + @["ch" _] (bad-cmd) 500 + @["ch"] (:msg env "current channel is %s\n" (env :chan)) 501 + 502 + @["perf"] (:msg env "performing score\n" 503 + (ev/write (get-in env [:cs-in 1]) 504 + (write-score env))) 505 + @["iso" "set" & chans] (put env :iso (map keyword chans)) 506 + @["iso" "add" & chans] (array/concat (env :iso) (map keyword chans)) 507 + @["iso" "del" & chans] 508 + (put env :iso (filter |(not (has-value? chans (string $))) 509 + (env :iso))) 510 + @["iso" "off"] (array/clear (env :iso)) 511 + @["iso" _] (bad-cmd) 512 + @["iso"] (:msg env "isolating channels %s\n" 513 + (string/join (map string (env :iso)) " ")) 514 + 515 + @["amp" x] (put chan :ampl (scan-number x)) 516 + @["amp"] (:msg env "channel %s amp is %f\n" (env :chan) (chan :ampl)) 517 + 518 + @["mute" "on"] (put chan :mute true) 519 + @["mute" "off"] (put chan :mute false) 520 + @["mute"] (do (toggle (chan :mute)) 521 + (:msg env "%s channel %s\n" 522 + (if (chan :mute) "muting" "unmuting") 523 + (env :chan))) 524 + 525 + @["cfg" key val] (put-in chan [:cfg (keyword key)] 526 + (scan-number val)) 527 + @["cfg" key] (:msg env "%s = %s\n" key 528 + (string (get-in chan [:cfg (keyword key)] 529 + "\e[3m<unset>\e[m"))) 530 + @["cfg"] (each [k v] (pairs (chan :cfg)) 531 + (:msg env "\e[1m%s\e[m = %s\n" k (string v))) 532 + @["sc" "from" t] (:msg env "printing score from %f\n" (env :time)) 533 + @["sc" "to" t] (:msg env "printing score to %f\n" (env :time)) 534 + @["sc" "erase" "all"] (array/clear (env :score)) 535 + @["sc" "erase"] nil 536 + @["sc" "comp" path] (do (:msg env "writing score to %s\n" path) 537 + (spit path (write-score env))) 538 + @["sc" "comp"] (:msg env "composing score\n%s\n" 539 + (present-file env (write-score env))) 540 + @["sc"] (:msg env "printing score\n%P\n" (env :score)) 541 + 542 + @["pl"] (:set-mode env :play) 543 + @["in" inst] (let [ik (keyword inst)] 544 + (if (has-key? orchestra ik) (put chan :instr ik) 545 + (:msg env "no such instrument %s\n" inst))) 546 + @["in"] (:msg env "instrument is %s\n" (chan :instr)) 547 + @["st" "pid"] (:msg env "csound process is pid %i\n" 548 + (get-in env [:cs-proc :pid])) 549 + @["st" "ev"] (:set-mode env :ev) 550 + (x (or (nil? x) (empty? x))) nil 551 + (:msg env "bad cmd\n"))) 552 + 553 +(putfn modes cmd [env] 554 + (var cmd-line @"") 555 + (def history @[]) 556 + (var histidx nil) 557 + (prompt teardown (forever 558 + (:msg env "\r\e[2K\e[1m:%s\e[m" cmd-line) 559 + (def event (yield)) 560 + (defn go-history [n] 561 + (def lastidx (- (length history) 1)) 562 + (label give-up 563 + (cond (empty? history) (return give-up) 564 + (and (nil? histidx) 565 + (< n 0)) (set histidx (+ n (length history))) 566 + (nil? histidx) (return give-up) 567 + (> (+ n histidx) lastidx) 568 + (do (set histidx nil) 569 + (set cmd-line @"") 570 + (return give-up)) 571 + (<= (+ n histidx) lastidx) 572 + (set histidx (max 0 (+ n histidx))) 573 + :else (return give-up)) 574 + (set cmd-line (buffer (history histidx))))) 575 + (when (or (= (event :how) :press) 576 + (= (event :how) :repeat)) 577 + (match event 578 + {:key :bksp} (buffer/popn cmd-line 1) 579 + {:key :tab} (do) 580 + {:key :up} (go-history -1) 581 + {:key :dn} (go-history 1) 582 + {:key :enter} (do 583 + (:msg env "\r\n") 584 + (set histidx nil) 585 + (do-cmd cmd-line env) 586 + (array/push history (string cmd-line)) 587 + (buffer/clear cmd-line)) 588 + {:text t} (buffer/push cmd-line t) 589 + ))))) 590 + 591 +(defn task-cmd [env] 592 + "command input handling" 593 + (def {:tty tty} env) 594 + (var mode nil) 595 + 596 + (defn new-mode [x & args] 597 + (def m (fiber/new x :yi)) 598 + (resume m env ;args) 599 + (fn resume-mode [& args] (resume m ;args))) 600 + 601 + (put env :set-mode (fn env:set-mode [_ x & args] 602 + (set mode (new-mode (modes x) ;args)) 603 + (return teardown) 604 + )) 605 + 606 + # this is silly 607 + (prompt teardown (:set-mode env :cmd)) 608 + 609 + (prompt terminate 610 + (loop [e :iterate (:await tty) 611 + :while mode] 612 + (mode e))) 613 + 614 + (os/proc-kill (env :cs-proc) true :term)) 615 + 616 +(defn main [& argv] 617 + (def cs-in (os/pipe :R)) 618 + (def cs-out (os/pipe :W)) 619 + (def cs (os/spawn ["csound" "-Lstdin" "--orc" "ostinata.orc" "-odac"] :p 620 + {:in (cs-in 0) :out (cs-out 1) :err (cs-out 1)})) 621 + (def tty (tui/init (os/open "/dev/tty" :rw))) 622 + (def doc @{}) 623 + (def env @{:tty tty 624 + :score @[] 625 + :chans @{:root (mk-channel)} 626 + :iso [] 627 + :chan :root 628 + :file "" 629 + :pause false 630 + :time 0.0 631 + :cs-proc cs 632 + :cs-in cs-in 633 + :cs-out cs-out 634 + :vol-bar (fn [me fac] (:vbar (me :tty) fac 635 + [.5 1 .25] 636 + [1.0 1.0 0.25] 637 + [1 .2 .1])) 638 + :instr-for-chan (fn [me c] 639 + (:for-chan (orchestra (c :instr)) me c)) 640 + :send (fn env:send [me & args] 641 + (def cmd (cmd→string args)) 642 + # (print "cmd = " cmd) 643 + (ev/write (cs-in 1) (string cmd "\n"))) 644 + :msg (fn env:msg [me fmt & args] 645 + (:write (me :tty) (string/format fmt ;args))) 646 + }) 647 + (ev/call |(do (defer (:close tty) 648 + (task-cmd env)))))
Added ostinata/ostinata.orc version [fcb089814a].
1 +0dbfs = 100 2 +nchnls = 2 3 +sr = 44100 4 + 5 +; p2 when 6 +; p3 dur 7 +; p4 vol 8 +; p5 freq 9 + 10 +givol ftgen 1, 0, 10000, 25, \ 11 + 500, 60, \ 12 + 1000, 20, \ 13 + 7000, 3, \ 14 + 10000, 5 15 + 16 +instr sine 17 + tigoto skipinit 18 + kt init 0 19 + al init 1.0 20 + ifreq = p5 21 + ichime = p6 22 + 23 + ivol = 30 * p4 * table(ifreq, givol) 24 + 25 + aw oscils ivol, ifreq, 0 26 + af oscils ivol, ifreq * ichime, 0 27 + skipinit: 28 + kt = kt + (1/kr) 29 + kv bpf kt, 0,0, 0.5,0.8, .1,1, 1,.6 30 + at linseg 0, p3, 1 31 + 32 + if p3 >= 0 then 33 + aw = aw * (1 - at) 34 + aw = aw + (af * at) 35 + aw = aw * (1-at) 36 + endif 37 + 38 + out aw*al 39 +endin 40 + 41 +instr string 42 + tigoto skipinit 43 + ; initialize 44 + ivol = 30*p4 45 + ifreq = p5 46 + 47 + aw pluck ivol, ifreq, ifreq, 0, 3, p6 48 + skipinit: 49 + at linseg 1, p3, 0 50 + 51 + if p3 >= 0 then 52 + aw = aw * at 53 + endif 54 + out aw 55 +endin 56 +
Added ostinata/tui.janet version [02341fd427].
1 +# [ʞ] tui.janet 2 +# ~ lexi hale <lexi@hale.su> 3 +# 🄯 AGPLv3 4 +# ? quick and extremely dirty rawterm interface 5 + 6 +(use /alg) 7 + 8 +# FIXME use ffi to directly munge termios where feasible 9 +(defn raw [fd] 10 + (os/execute ["stty" "raw" "-echo" "opost"] :p)) 11 + 12 +(defn unraw [fd] 13 + (os/execute ["stty" "-raw" "echo"] :p)) 14 + 15 +(defmacro use-raw [fd] 16 + ~(upscope 17 + (,raw ,fd) 18 + (,defer ,unraw ,fd))) 19 + 20 +(defmacro with-raw [fd & x] 21 + ~(do (,raw ,fd) 22 + ,;x 23 + (,unraw ,fd))) 24 + 25 +(def- capq-resp (peg/compile ~{ 26 + :lst (* '(+ (some (range "09")) 27 + (constant "0")) 28 + (? (* ";" :lst))) 29 + :resp "\e[?" 30 + :seq (* :resp (group :lst)) 31 + :tc (* :seq "c") 32 + :pg (* :resp (number (any (range "09"))) "u") 33 + :main (* (+ :pg (constant false)) 34 + :tc) 35 +})) 36 +(def- pg-flags {0x01 :E # disambig events 37 + 0x02 :e # report evt types 38 + 0x04 :k # keycode alts 39 + 0x08 :K # all keys as alts 40 + 0x16 :t}) # text 41 +(defn release [env] 42 + (defn send [& x] (ev/write (env :fd) (string ;x))) 43 + (when (string/check-set (env :caps) :p) 44 + (send "\e[<1u")) 45 + (unraw (env :fd)) 46 + (:close (env :fd))) 47 + 48 +(defn- read-until [pred fd] 49 + (def buf @"") 50 + (label matched 51 + (forever 52 + # (ev/write fd (string/format "buf: %j\r\n" buf)) 53 + (ev/read fd 1 buf) 54 + (spit "dbgkeys" buf) 55 + (def p (pred buf)) 56 + (when p (return matched p))))) 57 + 58 +(defn- text-key [c & args] 59 + (struct :text c 60 + :key ((string/ascii-lower c) 0) 61 + :case (c 0) 62 + :base (c 0) 63 + :how :press 64 + ;args)) 65 + 66 +(def- event-code-ptn (peg/compile ~{ 67 + :csi "\e[" 68 + :ss3 "\e\x4f" 69 + :cs3 (+ :csi :ss3) 70 + :key-basic (cmt (* :csi :keycode :keyev "~" ) 71 + ,(fn [kc ks kb mods how] 72 + (def basis 73 + (case kc 74 + 2 :ins 75 + 3 :del 76 + 5 :pgup 77 + 6 :pgdn 78 + 7 :home 79 + 8 :end 80 + (cond (<= 11 kc 24) (keyword :f (- kc 11)) 81 + :else :unknown))) 82 + {:key basis 83 + :mods mods 84 + :how how})) 85 + :key-magic (cmt (* :csi "1" :keyev '(+ (range "AF") "H" "P" "Q" "S")) 86 + ,(fn [mods how cue] 87 + {:mods mods 88 + :how how 89 + :key (case cue 90 + "A" :up "C" :rt 91 + "B" :dn "D" :lf 92 + "H" :home "F" :end 93 + "E" :kp-begin )})) 94 + :legacy-ctl (cmt '(range "\x01\x07" "\x0b\x0c" "\x0e\x1a") 95 + ,(fn [ccode] 96 + (def code (+ 0x60 (ccode 0))) 97 + (def lc (string/format "%c" code)) 98 + { :text lc 99 + :key code 100 + :case code 101 + :base code 102 + :how :press 103 + :mods :c })) 104 + :key (+ (* "\x0D" (constant {:key :enter :how :press})) 105 + (* (+ "\x7F" "\x08") (constant {:key :bksp :how :press})) 106 + (* "\x09" (constant ,(text-key "\t" :key :tab))) 107 + (* "\x00" (constant ,(text-key " " :key :sp :mods :c))) 108 + :legacy-ctl 109 + (* :cs3 "A" (constant {:key :up :how :press})) 110 + (* :cs3 "B" (constant {:key :dn :how :press})) 111 + (* :cs3 "C" (constant {:key :rt :how :press})) 112 + (* :cs3 "D" (constant {:key :lf :how :press})) 113 + (* :cs3 "E" (constant {:key :kp-begin :how :press})) 114 + (+ (* :csi :keyspec "u") 115 + (* "\e" (cmt :legacy-ctl 116 + ,(fn [c] (struct/with-proto c 117 + :mods (keyword (get c :mods :) :a))))) 118 + (* "\e" (not "[") (cmt '1 ,|(text-key $ :mods :a))) 119 + (* (not "\e") (cmt '1 ,|(text-key $))))) 120 + :ctl (cmt :num0 ,(fn [c] 121 + (defn b [n k] 122 + (if (not= 0 (band (- c 1) n)) k :)) 123 + (keyword (b 0x01 :s) (b 0x10 :H) 124 + (b 0x02 :a) (b 0x20 :m) 125 + (b 0x04 :c) (b 0x40 :C) 126 + (b 0x08 :S) (b 0x80 :N)))) 127 + :keyev (+ (* ";" :ctl 128 + (+ (* ":1" (constant :press)) 129 + (* ":2" (constant :repeat)) 130 + (* ":3" (constant :release)) 131 + (constant :press))) 132 + (* ";" (constant :) (constant :press)) 133 + (* (constant :) (constant :press))) 134 + :text (+ (cmt (group (some (* ";" :num0))) 135 + ,(fn [chars] #FIXME 136 + (string ;(map |(string/format "%c" $) chars)))) 137 + (constant false)) 138 + :keycode (+ (* :num0 ":" :num0 ":" :num0) 139 + (* :num0 ":" :num0 (constant false)) 140 + (* :num0 (constant false) (constant false))) 141 + :keyspec (cmt (* :keycode :keyev :text) 142 + ,(fn keyspec-translate [kc ks kb mods how t] 143 + (def basis 144 + (case kc 145 + 9 {:key :tab } 146 + 13 {:key :enter } 147 + 127 {:key :bksp } 148 + 149 + 57358 {:key :lock-caps } 150 + 57360 {:key :lock-num } 151 + 57414 {:key :kp-enter } 152 + 57413 {:key :kp-plus :text "+"} 153 + 57412 {:key :kp-minus :text "-"} 154 + 57411 {:key :kp-mul :text "*"} 155 + 57410 {:key :kp-div :text "/"} 156 + 43 {:key :add :text "+"} 157 + 8722 {:key :sub :text "−"} 158 + 215 {:key :mul :text "×" } 159 + 243 {:key :div :text "÷" } 160 + 57441 {:key :shift-l} 57447 {:key :shift-r} 161 + 57443 {:key :alt-l} 57449 {:key :alt-r} 162 + 57444 {:key :super-l} 57450 {:key :super-r} 163 + 57445 {:key :hyper-l} 57451 {:key :hyper-r} 164 + 57442 {:key :ctl-l} 57448 {:key :ctl-r} 165 + 57453 {:key :lvl3} 166 + 57454 {:key :lvl5} 167 + (cond (<= 57376 kc 57398) {:key (keyword :f (- kc 57363))} 168 + :else {:key kc 169 + :text (or t (string/format "%c" (or ks kc)))}))) 170 + {:text (get basis :text nil) 171 + :key (get basis :key nil) 172 + :case (or ks kc) 173 + :base (or kb kc) 174 + :mods mods 175 + :how how})) 176 + :main (* (+ :key-basic :key-magic :key) -1) 177 + 178 + :num (some (range "09")) 179 + :num0 (+ (number :num) 180 + (constant 0)) 181 +})) 182 + 183 +(def- color-cmd 184 + (do (def env (os/environ)) 185 + (def ct (env "COLORTERM")) 186 + (def term (env "TERM")) 187 + (defn mode-char [mode] 188 + (case mode :fg "3" :bg "4" 189 + :fg-br "9" :bg-br "10" 190 + (error "bad mode"))) 191 + 192 + (cond (or (= ct "truecolor") 193 + (= term "xterm")) # modern xterm supports tc 194 + (fn colorize-tc [mode rgb] 195 + (as-> rgb v 196 + (map |(math/floor (* 255 (clamp $))) v) 197 + (string/join (map string v) ";") 198 + (string "\e[" (mode-char mode) "8;2;" v "m"))) 199 + 200 + (or (string/has-suffix? "256color" term) 201 + (not (nil? ct))) 202 + (fn colorize-256 [mode rgb] 203 + (def code (math/floor 204 + (cond (= 0 ;rgb) 0 205 + (= ;rgb) (lerp (rgb 0) 232 255) 206 + :else (+ 16 ;(vect * [36 6 1] 207 + (map clamp rgb)))))) 208 + (string "\e[" (mode-char mode) "8;5;" code "m")) 209 + 210 + :else 211 + (fn colorize-8 [mode rgb] "")))) #FIXME 212 + 213 +(defn- vbar [tty f & grad] 214 + (def c [ " " "▁" "▂" "▃" "▄" "▅" "▆" "▇" "█" ]) 215 + # (def fg (vect |(lerp f ;$&) bright dim)) 216 + (def fg (vlut f grad)) 217 + (def bg (vect |(lerp .5 ;$&) fg [0 0 0])) 218 + (def idx (math/floor (* (max 0 (min 1 f)) 219 + (dec (length c))))) 220 + (:color tty fg bg (c idx))) 221 + 222 +(def- <env> {:close release 223 + :write |(ev/write ($ :fd) $1) 224 + :read |(ev/read ($ :fd) $1) 225 + :color (fn tui:color [me fg bg str] 226 + (as-> str cmd 227 + (if fg (string (color-cmd :fg fg) cmd) cmd) 228 + (if bg (string (color-cmd :bg bg) cmd) cmd) 229 + (if (or fg bg) (string cmd "\e[m")))) 230 + :vbar vbar 231 + :await (fn tui:await [me] 232 + # (print "awaiting") 233 + (def [evt] (read-until |(peg/match event-code-ptn $) (me :fd))) 234 + evt)}) 235 + 236 +# (def- chord-pat (peg/compile ~{ 237 +# :wd (some (* (not "-") wd)) 238 +# })) 239 + 240 +(defn- subset [a b] 241 + (var matches true) 242 + (loop [[k v] :pairs a :while matches] 243 + (when (not= v (get b k nil)) 244 + (set matches false))) 245 + matches) 246 +(defn chord [& fm] 247 + (def ksym (last fm)) 248 + (def mods (keyword ;(slice fm 0 -2))) 249 + (merge {:mods mods 250 + :how :press} 251 + (cond 252 + (keyword? ksym) {:key ksym} 253 + (string? ksym) 254 + {#:text ksym 255 + :key (in (string/ascii-lower ksym) 0) 256 + :case (in ksym 0)}))) 257 +(defn event<chord? [evt & fm] 258 + (subset evt (chord ;fm))) 259 + 260 +(defn init [fd] 261 + (raw fd) 262 + (defn send [& x] (ev/write fd (string ;x))) 263 + (defn recv [n &opt buf] (string (ev/read fd n buf))) 264 + (var caps :) 265 + (send "\e[?u\e[c") # query caps 266 + (def lists (label done 267 + (def buf @"") 268 + (forever 269 + (recv 1 buf) 270 + (def m (peg/match capq-resp buf)) 271 + (when m 272 + (return done m))))) 273 + (defn set-caps! [which tbl] 274 + (each e which 275 + (when (has-key? tbl e) 276 + (set caps (keyword caps (tbl e)))))) 277 + (set-caps! (lists 1) { 278 + "4" :6 # sixel 279 + }) 280 + 281 + (when (lists 0) 282 + (set caps (keyword caps :p)) 283 + (each [c f] (pairs pg-flags) 284 + (when (not= 0 (band c (lists 0))) 285 + (set caps (keyword caps f))))) 286 + 287 + (when (string/check-set caps :p) 288 + (def fmap (invert pg-flags)) 289 + (def f (bor (lists 0) (fmap :k) (fmap :e) (fmap :K))) 290 + (send "\e[>" (string (inc f) "u"))) 291 + 292 + (struct/with-proto <env> 293 + :fd fd 294 + :caps caps)) 295 +