-
Notifications
You must be signed in to change notification settings - Fork 0
/
clm.fs
1223 lines (1164 loc) · 42.8 KB
/
clm.fs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
\ clm.fs -- clm related base words, with-sound and friends -*- snd-forth -*-
\ Author: Michael Scholz <mi-scholz@users.sourceforge.net>
\ Created: Mon Mar 15 19:25:58 CET 2004
\ Changed: Fri Jun 26 23:04:01 CEST 2009
\ Commentary:
\
\ clm-print ( fmt args -- )
\ clm-message ( fmt args -- )
\
\ now@ ( -- secs )
\ now! ( secs -- )
\ step ( secs -- )
\ tempo@ ( -- secs )
\ tempo! ( secs -- )
\ interval->hertz ( n -- r )
\ keynum->hertz ( n -- r )
\ hertz->keynum ( n -- r )
\ bpm->seconds ( bpm -- secs )
\ rhythm->seconds ( rhy -- secs )
\
\ tempnam ( -- name )
\ fth-tempnam ( -- name )
\ make-default-comment ( -- str )
\ times->samples ( start dur -- len beg )
\ normalize-partials ( parts1 -- parts2 )
\
\ ws-local-variables ( -- )
\ ws-interrupt? ( -- )
\ ws-info ( start dur -- )
\ run ( start dur -- )
\ run-instrument ( start dur args -- )
\ end-run ( sample -- )
\ reverb-info ( caller in-chans out-chans -- )
\ instrument: ( -- )
\ ;instrument ( -- )
\ event: ( -- )
\ ;event ( -- )
\
\ find-file ( file -- fname|#f )
\ snd-info ( output :key reverb-file-name scaled? timer -- )
\ play-sound ( input :key verbose dac-size audio-format -- )
\ record-sound ( output keyword-args -- )
\
\ clm-mix ( infile :key output output-frame frames input-frame scaler -- )
\ with-sound ( body-xt keyword-args -- ws )
\ clm-load ( fname keyword-args -- ws )
\ with-current-sound ( :key offset scaled-to scaled-by -- )
\ scaled-to ( body-xt scl -- )
\ scaled-by ( body-xt scl -- )
\ with-offset ( body-xt secs -- )
\ with-mix ( body-str args fname beg -- )
\ sound-let ( ws-xt-lst body-xt -- )
$" fth 26-Jun-2009" value *clm-version*
\ defined in snd/snd-xen.c
[ifundef] snd-print : snd-print ( str -- str ) dup .string ; [then]
[ifundef] clm-print : clm-print ( fmt args -- ) format snd-print drop ; [then]
[ifundef] clm-message : clm-message ( fmt args -- str ) ." \ " fth-print cr ; [then]
[ifundef] flog10
<'> flog alias flog10
<'> fln alias flog
<'> flnp1 alias flogp1
[then]
dl-load sndlib Init_sndlib
'snd provided? [unless]
<'> noop alias main-widgets
<'> noop alias sounds
<'> noop alias set-selected-sound
<'> noop alias sound?
<'> noop alias open-sound
<'> noop alias find-sound
<'> noop alias update-sound
<'> noop alias save-sound
<'> noop alias close-sound
<'> noop alias close-sound-extend
<'> noop alias channels
<'> noop alias play
<'> noop alias play-and-wait
<'> noop alias maxamp
<'> noop alias frames
<'> noop alias scale-channel
<'> noop alias snd-tempnam
<'> noop alias snd-version
: c-g? ( -- f ) #f ;
[then]
\ Also defined in examp.fs.
[ifundef] close-sound-extend
\ 5 == notebook widget
: close-sound-extend <{ snd -- }>
main-widgets 5 array-ref false? unless
0 { idx }
sounds empty? unless sounds snd array-index to idx then
snd close-sound drop
sounds empty? unless
sounds length 1 = if
sounds 0 array-ref
else
idx sounds length < if
sounds idx array-ref
else
sounds -1 array-ref
then
then set-selected-sound drop
then
else
snd close-sound drop
then
;
[then]
\ === Notelist ===
hide
0.00 value *clm-current-time*
60.0 value *clm-tempo*
0.25 value *clm-beat*
set-current
: now@ ( -- secs ) *clm-current-time* ;
: now! ( secs -- ) to *clm-current-time* ;
: step ( secs -- ) now@ f+ now! ;
: tempo@ ( -- secs ) *clm-tempo* ;
: tempo! ( secs -- ) to *clm-tempo* ;
previous
\ --- Pitches ---
6.875 constant lowest-freq
: interval->hertz ( n -- r ) { n } 2.0 12.0 n 3.0 f+ f+ 12.0 f/ f** lowest-freq f* ;
: keynum->hertz ( n -- r ) { n } 2.0 n 3.0 f+ 12.0 f/ f** lowest-freq f* ;
: hertz->keynum ( r -- n ) lowest-freq f/ 2.0 flogn 12.0 f* 3.0 f- f>s ;
hide
: pitch ( interval octave "name" --; self -- freq )
{ interval octave }
2.0 octave 1.0 f+ 12.0 f* interval 3.0 f+ f+ 12.0 f/ f** lowest-freq f*
create ,
does> ( self -- freq )
@
;
set-current
0 0 pitch |C0 1 0 pitch |Cs0 1 0 pitch |Df0
2 0 pitch |D0 3 0 pitch |Ds0 3 0 pitch |Ef0
4 0 pitch |E0 4 0 pitch |Ff0 5 0 pitch |Es0
5 0 pitch |F0 6 0 pitch |Fs0 6 0 pitch |Gf0
7 0 pitch |G0 8 0 pitch |Gs0 8 0 pitch |Af0
9 0 pitch |A0 10 0 pitch |As0 10 0 pitch |Bf0
11 0 pitch |B0 11 0 pitch |Cf0 12 0 pitch |Bs0
0 1 pitch |C1 1 1 pitch |Cs1 1 1 pitch |Df1
2 1 pitch |D1 3 1 pitch |Ds1 3 1 pitch |Ef1
4 1 pitch |E1 4 1 pitch |Ff1 5 1 pitch |Es1
5 1 pitch |F1 6 1 pitch |Fs1 6 1 pitch |Gf1
7 1 pitch |G1 8 1 pitch |Gs1 8 1 pitch |Af1
9 1 pitch |A1 10 1 pitch |As1 10 1 pitch |Bf1
11 1 pitch |B1 11 1 pitch |Cf1 12 1 pitch |Bs1
0 2 pitch |C2 1 2 pitch |Cs2 1 2 pitch |Df2
2 2 pitch |D2 3 2 pitch |Ds2 3 2 pitch |Ef2
4 2 pitch |E2 4 2 pitch |Ff2 5 2 pitch |Es2
5 2 pitch |F2 6 2 pitch |Fs2 6 2 pitch |Gf2
7 2 pitch |G2 8 2 pitch |Gs2 8 2 pitch |Af2
9 2 pitch |A2 10 2 pitch |As2 10 2 pitch |Bf2
11 2 pitch |B2 11 2 pitch |Cf2 12 2 pitch |Bs2
0 3 pitch |C3 1 3 pitch |Cs3 1 3 pitch |Df3
2 3 pitch |D3 3 3 pitch |Ds3 3 3 pitch |Ef3
4 3 pitch |E3 4 3 pitch |Ff3 5 3 pitch |Es3
5 3 pitch |F3 6 3 pitch |Fs3 6 3 pitch |Gf3
7 3 pitch |G3 8 3 pitch |Gs3 8 3 pitch |Af3
9 3 pitch |A3 10 3 pitch |As3 10 3 pitch |Bf3
11 3 pitch |B3 11 3 pitch |Cf3 12 3 pitch |Bs3
0 4 pitch |C4 1 4 pitch |Cs4 1 4 pitch |Df4
2 4 pitch |D4 3 4 pitch |Ds4 3 4 pitch |Ef4
4 4 pitch |E4 4 4 pitch |Ff4 5 4 pitch |Es4
5 4 pitch |F4 6 4 pitch |Fs4 6 4 pitch |Gf4
7 4 pitch |G4 8 4 pitch |Gs4 8 4 pitch |Af4
9 4 pitch |A4 10 4 pitch |As4 10 4 pitch |Bf4
11 4 pitch |B4 11 4 pitch |Cf4 12 4 pitch |Bs4
0 5 pitch |C5 1 5 pitch |Cs5 1 5 pitch |Df5
2 5 pitch |D5 3 5 pitch |Ds5 3 5 pitch |Ef5
4 5 pitch |E5 4 5 pitch |Ff5 5 5 pitch |Es5
5 5 pitch |F5 6 5 pitch |Fs5 6 5 pitch |Gf5
7 5 pitch |G5 8 5 pitch |Gs5 8 5 pitch |Af5
9 5 pitch |A5 10 5 pitch |As5 10 5 pitch |Bf5
11 5 pitch |B5 11 5 pitch |Cf5 12 5 pitch |Bs5
0 6 pitch |C6 1 6 pitch |Cs6 1 6 pitch |Df6
2 6 pitch |D6 3 6 pitch |Ds6 3 6 pitch |Ef6
4 6 pitch |E6 4 6 pitch |Ff6 5 6 pitch |Es6
5 6 pitch |F6 6 6 pitch |Fs6 6 6 pitch |Gf6
7 6 pitch |G6 8 6 pitch |Gs6 8 6 pitch |Af6
9 6 pitch |A6 10 6 pitch |As6 10 6 pitch |Bf6
11 6 pitch |B6 11 6 pitch |Cf6 12 6 pitch |Bs6
0 7 pitch |C7 1 7 pitch |Cs7 1 7 pitch |Df7
2 7 pitch |D7 3 7 pitch |Ds7 3 7 pitch |Ef7
4 7 pitch |E7 4 7 pitch |Ff7 5 7 pitch |Es7
5 7 pitch |F7 6 7 pitch |Fs7 6 7 pitch |Gf7
7 7 pitch |G7 8 7 pitch |Gs7 8 7 pitch |Af7
9 7 pitch |A7 10 7 pitch |As7 10 7 pitch |Bf7
11 7 pitch |B7 11 7 pitch |Cf7 12 7 pitch |Bs7
0 8 pitch |C8 1 8 pitch |Cs8 1 8 pitch |Df8
2 8 pitch |D8 3 8 pitch |Ds8 3 8 pitch |Ef8
4 8 pitch |E8 4 8 pitch |Ff8 5 8 pitch |Es8
5 8 pitch |F8 6 8 pitch |Fs8 6 8 pitch |Gf8
7 8 pitch |G8 8 8 pitch |Gs8 8 8 pitch |Af8
9 8 pitch |A8 10 8 pitch |As8 10 8 pitch |Bf8
11 8 pitch |B8 11 8 pitch |Cf8 12 8 pitch |Bs8
previous
\ --- Note length ---
: bpm->seconds ( bpm -- secs ) 60.0 swap f/ ;
: rhythm->seconds ( rhy -- secs ) 4.0 tempo@ bpm->seconds f* f* ;
: notelength ( scale "name" --; self -- r )
rhythm->seconds create ,
does> ( self -- r )
@
;
1.0 notelength |W \ whole
2.0 1/f notelength |H \ half
4.0 1/f notelength |Q \ quarter
8.0 1/f notelength |A \ eighth
16.0 1/f notelength |S \ sixteenth
32.0 1/f notelength |T \ thirty-second
1.0 2.0 1/f f+ notelength |W.
2.0 1/f 4.0 1/f f+ notelength |H.
4.0 1/f 8.0 1/f f+ notelength |Q.
8.0 1/f 16.0 1/f f+ notelength |A.
16.0 1/f 32.0 1/f f+ notelength |S.
\ === Global User Variables (settable in ~/.snd_forth or ~/.fthrc) ===
#f value *output*
#f value *reverb*
#f value *locsig*
mus-lshort value *clm-audio-format*
#f value *clm-comment*
1.0 value *clm-decay-time*
#f value *clm-delete-reverb*
"test.snd" value *clm-file-name*
#f value *clm-notehook*
#f value *clm-play*
#f value *clm-player*
#f value *clm-reverb*
1 value *clm-reverb-channels*
#() value *clm-reverb-data*
"test.reverb" value *clm-reverb-file-name*
#f value *clm-statistics*
#f value *clm-verbose*
#f value *clm-debug*
#() value *clm-search-list* \ array of sound directories
#() value *clm-instruments* \ array of arrays #( ins-name start dur local-vars )
'snd provided? [unless]
1 constant default-output-chans
44100 constant default-output-srate
mus-next constant default-output-header-type
mus-lfloat constant default-output-data-format
mus-audio-default constant audio-output-device
512 constant dac-size
0.0 constant clm-default-frequency
[then]
default-output-chans value *clm-channels*
default-output-srate value *clm-srate*
locsig-type value *clm-locsig-type*
default-output-header-type value *clm-header-type*
default-output-data-format value *clm-data-format*
audio-output-device value *clm-output-device*
dac-size value *clm-rt-bufsize*
mus-file-buffer-size value *clm-file-buffer-size*
mus-clipping value *clm-clipped*
mus-array-print-length value *clm-array-print-length*
clm-table-size value *clm-table-size*
clm-default-frequency value *clm-default-frequency*
\ internal global variables
*clm-channels* value *channels*
*clm-verbose* value *verbose*
*clm-notehook* value *notehook*
hide
user *fth-file-number*
set-current
: tempnam ( -- name )
doc" Looks for environment variables TMP, TEMP, or TMPDIR, otherwise \
uses /tmp as temporary path and produces something like:\n\
/tmp/fth-12345-1.snd\n\
/tmp/fth-12345-2.snd\n\
/tmp/fth-12345-3.snd\n\
[...]"
1 *fth-file-number* +!
"%s/fth-%d-%d.snd"
environ "TMP" array-assoc-ref ?dup-if
1 object-ref
else
environ "TEMP" array-assoc-ref ?dup-if
1 object-ref
else
environ "TMPDIR" array-assoc-ref ?dup-if
1 object-ref
else
"/tmp"
then
then
then ( tmp ) getpid *fth-file-number* @ 3 >array string-format
;
previous
: fth-tempnam ( -- fname )
'snd provided? if
snd-tempnam
else
tempnam
then
;
: make-default-comment ( -- str )
$" Written %s by %s at %s using clm (%s)" _
#( $" %a %d-%b-%y %H:%M %Z" current-time strftime
getlogin
gethostname
*clm-version* ) string-format
;
: times->samples ( start dur -- limit begin )
{ start dur }
start seconds->samples { beg }
dur seconds->samples { len }
beg len b+ beg
;
: normalize-partials ( parts1 -- parts2 )
{ parts1 }
0.0 ( sum ) parts1 object-length 1 ?do parts1 i object-ref fabs f+ 2 +loop
dup f0= if
$" all parts have 0.0 amplitude: %s" #( parts1 ) string-format warning
( sum ) drop parts1
else
( sum ) 1/f { scl }
parts1 map i 2 mod if *key* scl f* else *key* then end-map ( parts2 )
then
;
\ === With-Sound Run-Instrument ===
$" with-sound error" create-exception with-sound-error
$" with-sound interrupt" create-exception with-sound-interrupt
#() value *ws-args* \ array for recursive with-sound calls
#f value *clm-current-instrument* \ current instrument set in INSTRUMENT:
: ws-local-variables ( -- )
*clm-instruments* empty? if
$" *clm-instruments* is empty" #() clm-message
else
nil { vals }
"" #() clm-message
*clm-instruments* each to vals
$" === %s [%.3f-%.3f] ===" #( vals 0 array-ref vals 1 array-ref vals 2 array-ref ) clm-message
vals 3 array-ref each ( var ) $" %s = %s" swap clm-message end-each
"" #() clm-message
end-each
then
;
: ws-interrupt? ( -- )
c-g? if
'with-sound-interrupt #( "interrupted" ) fth-throw
then
;
: ws-info ( start dur vars -- start dur )
{ start dur vars }
*clm-instruments* #( *clm-current-instrument* start dur vars ) array-push to *clm-instruments*
*notehook* dup xt? swap proc? || if
*clm-current-instrument* start dur *notehook* dup proc? if proc->xt then execute stack-reset
then
ws-interrupt?
start dur
;
hide
: (run) ( start dur vars -- limit begin ) ws-info times->samples ;
: (run-instrument) ( start dur args vars -- limit begin )
{ start dur args vars }
args hash? unless #{} to args then
:degree args :degree hash-ref 0.0 ||
:distance args :distance hash-ref 1.0 ||
:reverb args :reverb hash-ref 0.05 ||
:channels args :channels hash-ref *channels* ||
:output args :output hash-ref *output* ||
:revout args :revout hash-ref *reverb* ||
:type args :type hash-ref locsig-type || make-locsig to *locsig*
\ we set channel 3/4 if any to 0.5 * channel 1/2
*output* mus-output? if
*output* mus-channels 2 > if
*locsig* 2 *locsig* 0 locsig-ref f2/ locsig-set! drop
*output* mus-channels 3 > if
*locsig* 3 *locsig* 1 locsig-ref f2/ locsig-set! drop
then
then
then
*reverb* mus-output? if
*reverb* mus-channels 2 > if
*locsig* 2 *locsig* 0 locsig-reverb-ref f2/ locsig-reverb-set! drop
*reverb* mus-channels 3 > if
*locsig* 3 *locsig* 1 locsig-reverb-ref f2/ locsig-reverb-set! drop
then
then
then
start dur vars (run)
;
: (end-run) { val idx -- } *locsig* idx val locsig drop ;
set-current
\ RUN/LOOP is only a simple replacement of
\ start dur TIMES->SAMPLES ?DO ... LOOP
\
\ RUN-INSTRUMENT/END-RUN requires at least an opened *output*
\ generator (file->sample), optional an opened *reverb* generator. It
\ uses LOCSIG to set samples in output file. At the end of the loop a
\ sample value must remain on top of stack!
\
\ instrument: foo
\ 0 0.1 nil run-instrument 0.2 end-run
\ ;instrument
\ <'> foo with-sound
\
\ fills a sound file of length 0.1 seconds with 2205 samples (srate
\ 22050) with 0.2.
\
\ 0.0 1.0 RUN ... LOOP
\ 0.0 1.0 #{ :degree 45.0 } RUN-INSTRUMENT ... END-RUN
: run ( start dur -- )
postpone local-variables postpone (run) postpone ?do
; immediate compile-only
: run-instrument ( start dur locsig-args -- )
postpone local-variables postpone (run-instrument) postpone ?do
; immediate compile-only
: end-run ( sample -- )
postpone r@ postpone (end-run) postpone loop
; immediate compile-only
previous
: reverb-info ( caller in-chans out-chans -- )
{ caller in-chans out-chans }
$" %s on %d in and %d out channels" #( caller in-chans out-chans ) clm-message
;
\ === Helper functions for instruments ===
hide
: ins-info ( ins-name -- ) to *clm-current-instrument* ;
: event-info ( ev-name -- ) *clm-verbose* if #() clm-message else drop then ;
set-current
: instrument: ( -- )
>in @ parse-word $>string { ins-name } >in !
:
ins-name postpone literal <'> ins-info compile,
;
: event: ( -- )
>in @ parse-word $>string { ev-name } >in !
:
ev-name postpone literal <'> event-info compile,
;
: ;instrument ( -- ) postpone ; ; immediate
<'> ;instrument alias ;event immediate
previous
\ === Playing and Recording Sound Files ===
: find-file ( file -- fname|#f )
doc" Returns the possibly full path name of FILE if FILE exists or \
if FILE was found in *CLM-SEARCH-LIST*, otherwise returns #f."
{ file }
file file-exists? if
file
else
#f { fname }
file string? *clm-search-list* array? && if
*clm-search-list* each ( dir )
"/" $+ file $+ dup file-exists? if to fname leave else drop then
end-each
then
fname
then
;
hide
: .maxamps ( fname name sr scl? -- )
{ fname name sr scl? }
fname file-exists? if
fname mus-sound-maxamp { vals }
vals length 0 ?do
$" %6s %c: %.3f (near %.3f secs)%s"
#( name
[char] A i 2/ +
vals i 1+ array-ref
vals i array-ref sr f/
scl? if $" (before scaling)" else "" then ) clm-message
2 +loop
then
;
: .timer ( obj -- )
{ obj }
$" %*s: %.3f (utime %.3f, stime %.3f)"
#( 8 $" real" obj real-time@ obj user-time@ obj system-time@ ) clm-message
;
: .timer-ratio ( srate frames obj -- )
{ sr frms obj }
frms 0> if
sr frms f/ { m }
$" %*s: %.2f (uratio %.2f)"
#( 8 $" ratio" obj real-time@ m f* obj user-time@ m f* ) clm-message
else
$" %*s: no ratio" #( 8 $" ratio" ) clm-message
then
;
set-current
: snd-info <{ output :key reverb-file-name #f scaled? #f timer #f -- }>
output mus-sound-duration { dur }
output mus-sound-frames { frames }
output mus-sound-chans { channels }
output mus-sound-srate { srate }
$" filename: %S" #( output ) clm-message
$" chans: %d, srate: %d" #( channels srate f>s ) clm-message
$" format: %s [%s]"
#( output mus-sound-data-format mus-data-format-name
output mus-sound-header-type mus-header-type-name ) clm-message
$" length: %.3f (%d frames)" #( dur frames ) clm-message
timer timer? if
timer .timer
srate frames timer .timer-ratio
then
output $" maxamp" srate scaled? .maxamps
reverb-file-name ?dup-if $" revamp" srate #f .maxamps then
output mus-sound-comment { comm }
comm empty? unless $" comment: %S" #( comm ) clm-message then
;
previous
\ === Playing and Recording one or two Channel Sounds ===
: play-sound <{ input
:key
verbose *clm-verbose*
dac-size *clm-rt-bufsize*
audio-format *clm-audio-format* -- }>
doc" Plays sound file INPUT.\n\
\"bell.snd\" :verbose #t play-sound"
input find-file to input
input false? if 'no-such-file #( get-func-name input ) fth-throw then
input mus-sound-frames { frames }
input mus-sound-srate { srate }
input mus-sound-chans { chans }
chans 2 > if
$" %s: we can only handle 2 chans, not %d" _ #( get-func-name chans ) string-format warning
2 to chans
then
verbose if input snd-info then
dac-size frames min { bufsize }
bufsize 0> if
chans bufsize make-sound-data { data }
input mus-sound-open-input { snd-fd }
snd-fd 0< if 'forth-error #( get-func-name $" cannot open %s" _ input ) fth-throw then
mus-audio-default srate chans 2 min audio-format bufsize mus-audio-open-output { dac-fd }
dac-fd 0< if 'forth-error #( get-func-name $" cannot open dac" _ ) fth-throw then
frames 0 ?do
i bufsize + frames > if frames i - to bufsize then
snd-fd 0 bufsize 1- chans data mus-sound-read drop
dac-fd data bufsize mus-audio-write drop
bufsize +loop
snd-fd mus-sound-close-input drop
dac-fd mus-audio-close drop
else
$" nothing to play for %S (%d frames)" #( input bufsize ) string-format warning
then
;
: record-sound ( output keyword-args -- )
<{ output :key
duration 10.0
verbose *clm-verbose*
output-device *clm-output-device*
dac-size *clm-rt-bufsize*
srate *clm-srate*
channels *clm-channels*
audio-format *clm-audio-format*
data-format *clm-data-format*
header-type *clm-header-type*
comment *clm-comment* -- }>
doc" Records from dac output device to the specified OUTPUT file."
duration seconds->samples { frames }
dac-size frames min { bufsize }
channels 2 min { chans }
mus-srate { old-srate }
srate set-mus-srate drop
comment empty? if $" written %s by %s" _ #( date get-func-name ) string-format to comment then
chans bufsize make-sound-data { data }
chans 0.25 make-vct { vals }
vals each drop mus-audio-mixer mus-audio-reclev i vals mus-audio-mixer-write drop end-each
vals 0.75 vct-fill! drop
vals each drop output-device mus-audio-amp i vals mus-audio-mixer-write drop end-each
output srate chans data-format header-type comment mus-sound-open-output { snd-fd }
snd-fd 0< if 'forth-error #( get-func-name $" cannot open %S" _ output ) fth-throw then
output-device srate chans audio-format bufsize mus-audio-open-input { dac-fd }
dac-fd 0< if 'forth-error #( get-func-name $" cannot open dac" _ ) fth-throw then
verbose if
$" filename: %s" #( output ) clm-message
$" device: %d" #( output-device ) clm-message
$" chans: %d, srate: %d" #( chans srate ) clm-message
$" r format: %s [Dac]" #( audio-format mus-data-format-name ) clm-message
$" w format: %s [%s]"
#( data-format mus-data-format-name header-type mus-header-type-name ) clm-message
$" length: %.3f (%d frames)" #( duration frames ) clm-message
$" comment: %S" #( comment ) clm-message
then
frames 0 ?do
i bufsize + frames > if frames i - to bufsize then
dac-fd data bufsize mus-audio-read drop
snd-fd 0 bufsize 1- chans data mus-sound-write drop
bufsize +loop
dac-fd mus-audio-close drop
snd-fd frames chans * data-format mus-bytes-per-sample * mus-sound-close-output drop
old-srate set-mus-srate drop
;
: clm-mix <{ infile :key output #f output-frame 0 frames #f input-frame 0 scaler 1.0 -- }>
doc" Mixes files in with-sound's *output* generator.\n\
\"oboe.snd\" clm-mix\n\
Mixes oboe.snd in *output* at *output*'s location 0 from oboe.snd's location 0 on. \
The whole oboe.snd file will be mixed in because :frames is not specified."
0 { chans }
#f { mx }
*output* mus-output? { outgen }
output unless
outgen if
*output* mus-channels to chans
*output* mus-file-name to output
else
'with-sound-error $" %s: *output* gen or :output required" #( get-func-name ) fth-raise
then
then
infile find-file to infile
infile false? if 'file-not-found $" %s: cannot find %S" #( get-func-name infile ) fth-raise then
frames infile mus-sound-frames || dup unless drop undef then to frames
outgen if *output* mus-close drop then
chans 0>
scaler f0<> &&
scaler 1.0 f<> && if
save-stack { s }
chans chans dup * 0 ?do scaler loop make-mixer to mx
s restore-stack
then
output ( outfile )
infile ( infile )
output-frame ( outloc )
frames ( frames )
input-frame ( inloc )
mx ( mixer )
#f ( envs ) mus-mix drop
outgen if output continue-sample->file to *output* then
;
hide
: ws-get-snd ( ws -- snd )
{ ws }
ws :output array-assoc-ref find-file { fname }
fname 0 find-sound dup sound? if ( snd ) save-sound then drop
fname open-sound ( snd )
;
: ws-scaled-to ( ws -- )
{ ws }
ws :scaled-to array-assoc-ref { scale }
'snd provided? if
ws ws-get-snd { snd }
0.0 snd #t #f maxamp each fmax end-each { mx }
mx f0<> if
scale mx f/ to scale
snd #f #f frames { len }
ws :channels array-assoc-ref 0 ?do scale 0 len snd i ( chn ) #f scale-channel drop loop
then
snd save-sound drop
else
ws :output array-assoc-ref mus-sound-maxamp { smax }
0.0 smax length 1 ?do smax i array-ref fabs fmax 2 +loop { mx }
mx f0<> if
ws :output array-assoc-ref :scaler scale mx f/ clm-mix
then
then
;
: ws-scaled-by ( ws -- )
{ ws }
ws :scaled-by array-assoc-ref { scale }
'snd provided? if
ws ws-get-snd { snd }
snd #f #f frames { len }
ws :channels array-assoc-ref 0 ?do scale 0 len snd i ( chn ) #f scale-channel drop loop
snd save-sound drop
else
ws :output array-assoc-ref :scaler scale clm-mix
then
;
: ws-before-output ( ws -- )
{ ws }
ws :old-table-size clm-table-size array-assoc-set!
( ws ) :old-file-buffer-size mus-file-buffer-size array-assoc-set!
( ws ) :old-array-print-length mus-array-print-length array-assoc-set!
( ws ) :old-clipping mus-clipping array-assoc-set!
( ws ) :old-srate mus-srate array-assoc-set!
( ws ) :old-locsig-type locsig-type array-assoc-set!
( ws ) :old-*output* *output* array-assoc-set!
( ws ) :old-*reverb* *reverb* array-assoc-set!
( ws ) :old-verbose *verbose* array-assoc-set!
( ws ) :old-debug *clm-debug* array-assoc-set!
( ws ) :old-channels *channels* array-assoc-set!
( ws ) :old-notehook *notehook* array-assoc-set!
( ws ) :old-decay-time *clm-decay-time* array-assoc-set! to ws
ws :verbose array-assoc-ref to *verbose*
ws :debug array-assoc-ref to *clm-debug*
ws :channels array-assoc-ref to *channels*
ws :notehook array-assoc-ref to *notehook*
ws :decay-time array-assoc-ref to *clm-decay-time*
*clm-table-size* set-clm-table-size drop
*clm-file-buffer-size* set-mus-file-buffer-size drop
*clm-array-print-length* set-mus-array-print-length drop
*clm-clipped* boolean? if *clm-clipped* else #f then set-mus-clipping drop
ws :srate array-assoc-ref set-mus-srate drop
ws :locsig-type array-assoc-ref set-locsig-type drop
;
: ws-after-output ( ws -- ws )
{ ws }
ws :old-table-size array-assoc-ref set-clm-table-size drop
ws :old-file-buffer-size array-assoc-ref set-mus-file-buffer-size drop
ws :old-array-print-length array-assoc-ref set-mus-array-print-length drop
ws :old-clipping array-assoc-ref set-mus-clipping drop
ws :old-srate array-assoc-ref set-mus-srate drop
ws :old-locsig-type array-assoc-ref set-locsig-type drop
ws :old-*output* array-assoc-ref to *output*
ws :old-*reverb* array-assoc-ref to *reverb*
ws :old-verbose array-assoc-ref to *verbose*
ws :old-debug array-assoc-ref to *clm-debug*
ws :old-channels array-assoc-ref to *channels*
ws :old-notehook array-assoc-ref to *notehook*
ws :old-decay-time array-assoc-ref to *clm-decay-time*
*ws-args* array-pop
;
: ws-statistics ( ws -- )
{ ws }
ws :output array-assoc-ref
:reverb-file-name ws :reverb-file-name array-assoc-ref
:scaled? ws :scaled-to array-assoc-ref ws :scaled-by array-assoc-ref ||
:timer ws :timer array-assoc-ref
snd-info
;
\ player can be one of xt, proc, string, or #f.
\
\ xt: output player execute
\ proc: player #( output ) run-proc
\ string: "player output" system
\ else snd: output play-and-wait
\ clm: output play-sound
\
\ A player may look like this:
\
\ : play-3-times ( output -- )
\ { output }
\ 3 0 ?do output play-and-wait drop loop
\ ;
\ <'> play-3-times to *clm-player*
: ws-play-it ( ws -- )
{ ws }
ws :output array-assoc-ref { output }
ws :player array-assoc-ref { player }
player proc? if
player #( output ) run-proc drop
else
player string? if
$" %s %s" #( player output ) string-format file-shell drop
else
'snd provided? if
output find-file play-and-wait drop
else
output :verbose #f play-sound
then
then
then
;
: set-args ( key def ws -- )
{ key def ws }
key def get-optkey ws key rot array-assoc-set! to ws
;
set-current
: with-sound-default-args ( keyword-args -- ws )
#() to *clm-instruments*
#() { ws }
*ws-args* ws array-push to *ws-args*
:play *clm-play* ws set-args
:statistics *clm-statistics* ws set-args
:verbose *clm-verbose* ws set-args
:debug *clm-debug* ws set-args
:continue-old-file #f ws set-args
:output *clm-file-name* ws set-args
:channels *clm-channels* ws set-args
:srate *clm-srate* ws set-args
:locsig-type *clm-locsig-type* ws set-args
:header-type *clm-header-type* ws set-args
:data-format *clm-data-format* ws set-args
:comment *clm-comment* ws set-args
:notehook *clm-notehook* ws set-args
:scaled-to #f ws set-args
:scaled-by #f ws set-args
:delete-reverb *clm-delete-reverb* ws set-args
:reverb *clm-reverb* ws set-args
:reverb-data *clm-reverb-data* ws set-args
:reverb-channels *clm-reverb-channels* ws set-args
:reverb-file-name *clm-reverb-file-name* ws set-args
:player *clm-player* ws set-args
:decay-time *clm-decay-time* ws set-args
ws
;
: with-sound-args ( keyword-args -- ws )
#() { ws }
*ws-args* -1 array-ref { ws1 }
*ws-args* ws array-push to *ws-args*
:play #f ws set-args
:player #f ws set-args
:statistics #f ws set-args
:continue-old-file #f ws set-args
:verbose ws1 :verbose array-assoc-ref ws set-args
:debug ws1 :debug array-assoc-ref ws set-args
:output ws1 :output array-assoc-ref ws set-args
:channels ws1 :channels array-assoc-ref ws set-args
:srate ws1 :srate array-assoc-ref ws set-args
:locsig-type ws1 :locsig-type array-assoc-ref ws set-args
:header-type ws1 :header-type array-assoc-ref ws set-args
:data-format ws1 :data-format array-assoc-ref ws set-args
:comment $" with-sound level %d" #( *ws-args* length ) string-format ws set-args
:notehook ws1 :notehook array-assoc-ref ws set-args
:scaled-to ws1 :scaled-to array-assoc-ref ws set-args
:scaled-by ws1 :scaled-by array-assoc-ref ws set-args
:delete-reverb ws1 :delete-reverb array-assoc-ref ws set-args
:reverb ws1 :reverb array-assoc-ref ws set-args
:reverb-data ws1 :reverb-data array-assoc-ref ws set-args
:reverb-channels ws1 :reverb-channels array-assoc-ref ws set-args
:reverb-file-name ws1 :reverb-file-name array-assoc-ref ws set-args
:decay-time ws1 :decay-time array-assoc-ref ws set-args
ws
;
: with-sound-main ( body-xt ws -- ws )
{ body-xt ws }
body-xt xt? body-xt proc? || body-xt 1 $" a proc or xt" assert-type
ws array? ws 2 $" an associative array" assert-type
ws ws-before-output
ws :reverb array-assoc-ref { reverb-xt }
reverb-xt if
reverb-xt xt? reverb-xt proc? || reverb-xt 3 $" a proc or xt" assert-type
#t
else
#f
then { rev? }
ws :output array-assoc-ref { output }
ws :reverb-file-name array-assoc-ref { revput }
ws :continue-old-file array-assoc-ref { cont? }
cont? if
output continue-sample->file
else
output file-delete
output
ws :channels array-assoc-ref
ws :data-format array-assoc-ref
ws :header-type array-assoc-ref
ws :comment array-assoc-ref dup empty? if drop make-default-comment then
make-sample->file
then to *output*
*output* sample->file? unless
'with-sound-error #( get-func-name $" cannot open sample->file" _ ) fth-throw
then
cont? if
output mus-sound-srate set-mus-srate drop
'snd provided? if output 0 find-sound dup sound? if close-sound-extend else drop then then
then
rev? if
cont? if
revput continue-sample->file
else
revput file-delete
revput
ws :reverb-channels array-assoc-ref
ws :data-format array-assoc-ref
ws :header-type array-assoc-ref
$" with-sound temporary reverb file" make-sample->file
then to *reverb*
*reverb* sample->file? unless
'with-sound-error #( get-func-name $" cannot open reverb sample->file" _ ) fth-throw
then
then
ws :timer make-timer array-assoc-set! to ws
\ compute ws body
*clm-debug* if
\ EXECUTE provides probably a more precise backtrace than FTH-CATCH.
body-xt dup proc? if proc->xt then execute
else
body-xt 'with-sound-interrupt #t fth-catch if
stack-reset
*output* mus-close drop
*reverb* if *reverb* mus-close drop then
$" body-xt interrupted by C-g" #() clm-message
ws ws-after-output ( ws )
exit
then
then
reverb-xt if
*reverb* mus-close drop
ws :reverb-file-name array-assoc-ref undef make-file->sample to *reverb*
*reverb* file->sample? unless
'with-sound-error #( get-func-name $" cannot open file->sample" _ ) fth-throw
then
\ compute ws reverb
*clm-debug* if
\ push reverb arguments on stack
ws :reverb-data array-assoc-ref each end-each reverb-xt dup proc? if proc->xt then execute
else
reverb-xt 'with-sound-interrupt #t fth-catch if
stack-reset
*output* mus-close drop
*reverb* mus-close drop
$" reverb-xt interrupted by C-g" #() clm-message
ws ws-after-output ( ws )
exit
then
then
*reverb* mus-close drop
then
*output* mus-close drop
ws :timer array-assoc-ref stop-timer
ws ws-get-snd drop
ws :statistics array-assoc-ref if ws ws-statistics then
ws :delete-reverb array-assoc-ref reverb-xt && if ws :reverb-file-name array-assoc-ref file-delete then
ws :scaled-to array-assoc-ref if ws ws-scaled-to then
ws :scaled-by array-assoc-ref if ws ws-scaled-by then
ws :play array-assoc-ref if ws ws-play-it then
ws ws-after-output ( ws )
;
previous
\ Usage: <'> resflt-test with-sound drop
\ <'> resflt-test :play #f :channels 2 with-sound .g
\ lambda: resflt-test ; :output "resflt.snd" with-sound drop
: with-sound ( body-xt keyword-args -- ws )
doc" \\ keywords and default values:\n\
:play *clm-play* (#f)\n\
:statistics *clm-statistics* (#f)\n\
:verbose *clm-verbose* (#f)\n\
:debug *clm-debug* (#f)\n\
:continue-old-file (#f)\n\
:output *clm-file-name* (\"test.snd\")\n\
:channels *clm-channels* (1)\n\
:srate *clm-srate* (44100)\n\
:locsig-type *clm-locsig-type* (mus-interp-linear)\n\
:header-type *clm-header-type* (mus-next)\n\
:data-format *clm-data-format* (mus-lfloat)\n\
:comment *clm-comment* (#f)\n\
:notehook *clm-notehook* (#f)\n\
:scaled-to (#f)\n\
:scaled-by (#f)\n\
:delete-reverb *clm-delete-reverb* (#f)\n\
:reverb *clm-reverb* (#f)\n\
:reverb-data *clm-reverb-data* (#())\n\
:reverb-channels *clm-reverb-channels* (1)\n\
:reverb-file-name *clm-reverb-file-name* (\"test.reverb\")\n\
:player *clm-player* (#f)\n\
:decay-time *clm-decay-time* (1.0)\n\
Executes BODY-XT, a proc object or an xt, and returns an assoc array with with-sound arguments.\n\
<'> resflt-test with-sound .g cr\n\
<'> resflt-test :play #t :channels 2 :srate 44100 with-sound drop"
*ws-args* empty? if
with-sound-default-args
else
with-sound-args
then ( ws )
with-sound-main ( ws )
;
: clm-load ( fname keyword-args -- ws )
doc" Loads and evals the CLM instrument call file FNAME. \
See with-sound for a full keyword list.\n\
\"test.fsm\" :play #t :player \"sndplay\" clm-load drop"
*ws-args* empty? if
with-sound-default-args
else
with-sound-args
then
{ fname ws }
fname file-exists? if
ws :verbose array-assoc-ref if $" loading %S" _ #( fname ) clm-message then
fname <'> file-eval ws with-sound-main ( ws )
else
'no-such-file $" %s: %S not found" #( get-func-name fname ) fth-raise