"Fossies" - the Fresh Open Source Software Archive

Member "snd-20.9/sndins/samples/agn.fth" (19 Nov 2014, 4176 Bytes) of package /linux/misc/snd-20.9.tar.gz:


As a special service "Fossies" has tried to format the requested text file into HTML format (style: standard) with prefixed line numbers. Alternatively you can here view or download the uninterpreted source code file.

    1 #! /usr/bin/env fth
    2 \ agn.fth -- Bill Schottstaedt's agn.cl
    3 \     (see clm-2/clm-example.clm and clm-2/bess5.cl)
    4 
    5 \ Translator/Author: Michael Scholz <mi-scholz@users.sourceforge.net>
    6 \ Created: 04/12/15 23:30:43
    7 \ Changed: 14/11/17 23:06:11
    8 
    9 \ Type do-agn
   10 \ or start the script in a shell.
   11 
   12 #t value *clm-c-version*
   13 
   14 dl-load sndlib Init_sndlib
   15 *clm-c-version* [if]
   16 	dl-load sndins Init_sndins
   17 [else]
   18 	require clm-ins
   19 [then]
   20 require clm
   21 require env
   22 
   23 *argc* 2 > [if]
   24 	*argv* 2 array-ref
   25 [else]
   26 	"agn.fsm"
   27 [then] value agn-test-file
   28 60.0 value agn-time
   29 
   30 #t		to *clm-play*
   31 #t		to *clm-statistics*
   32 #t		to *clm-verbose*
   33 44100		to *clm-srate*
   34 2		to *clm-channels*
   35 <'> jc-reverb	to *clm-reverb*
   36 '( :volume 0.8 ) to *clm-reverb-data*
   37 2		to *clm-reverb-channels*
   38 #t		to *clm-delete-reverb*
   39 mus-next	to *clm-header-type*
   40 mus-bfloat	to *clm-sample-type*
   41 
   42 : rbell ( x -- r )
   43 	100 f* '( 0 0 10 0.25 90 1 100 1 ) 1.0 envelope-interp
   44 ;
   45 
   46 : tune ( x -- r )
   47 	{ x }
   48 	#( 1 256/243 9/8 32/27 81/64 4/3
   49 	   1024/729 3/2 128/81 27/16 16/9 243/128 2 ) x 12.0 fmod f>s array-ref
   50 	   2.0 x 12.0 f/ floor f**
   51 	   f*
   52 ;
   53 
   54 #( 0 0 2 4 11 11 5 6 7 9 2 0 0 ) constant agn-mode
   55 256 constant agn-lim
   56 
   57 #f value agn-octs
   58 #f value agn-pits
   59 #f value agn-rhys
   60 #f value agn-amps
   61 #f value agn-begs
   62 
   63 : agn-init ( -- )
   64 	agn-lim make-array map!
   65 		1.0 random rbell f2* 4.0 f+ floor
   66 	end-map to agn-octs
   67 	agn-lim make-array map!
   68 		agn-mode 1.0 random 12.0 f* floor f>s array-ref
   69 	end-map to agn-pits
   70 	agn-lim make-array map!
   71 		1.0 random 6.0 f* 4.0 f+
   72 	end-map to agn-rhys
   73 	agn-lim make-array map!
   74 		1.0 random rbell 8.0 f* 1.0 f+
   75 	end-map to agn-amps
   76 	agn-lim make-array map!
   77 		1.0 random 0.9 f<
   78 		if
   79 			1.0 random f2* 4.0 f+
   80 		else
   81 			4.0 random 6.0 f*
   82 		then
   83 	end-map to agn-begs
   84 ;
   85 
   86 : agn ( fname -- )
   87 	( fname ) io-open-write { io }
   88 	io "\\ from agn.cl (clm-2/clm-example.clm, clm-2/bess5.cl)\n" io-write
   89 	io "\\\n" io-write
   90 	io "%s\n" '( make-default-comment ) io-write-format
   91 	#( '( 0 0 40 0.1 60 0.2 75 0.4 82 1 90 1 100 0 )
   92 	   '( 0 0 60 0.1 80 0.2 90 0.4 95 1 100 0 )
   93 	   '( 0 0 10 1 16 0 32 0.1 50 1 56 0 60 0 90 0.3 100 0 )
   94 	   '( 0 0 30 1 56 0 60 0 90 0.3 100 0 )
   95 	   '( 0 0 50 1 80 0.3 100 0 )
   96 	   '( 0 0 40 0.1 60 0.2 75 0.4 82 1 90 1 100 0 )
   97 	   '( 0 0 40 0.1 60 0.2 75 0.4 82 1 90 1 100 0 )
   98 	   '( 0 0 10 1 32 0.1 50 1 90 0.3 100 0 )
   99 	   '( 0 0 60 0.1 80 0.3 95 1 100 0 )
  100 	   '( 0 0 80 0.1 90 1 100 0 ) ) { wins }
  101 	agn-init
  102 	4 1 do
  103 		0 4 0 { cellbeg cellsiz cellctr }
  104 		1 i s>f i 1- s>f 0.2 { whichway base mi mytempo }
  105 		0.0 0.0 { nextbeg beg }
  106 		begin
  107 			beg agn-time f< cellctr agn-lim < and
  108 		while
  109 			beg nextbeg f+ to beg
  110 			mytempo 1.0 random 0.2 f* 0.9 f+ f* ( r )
  111 			agn-rhys cellctr array-ref f*  0.25 fmax to nextbeg
  112 			16.352 2.0 mi f** f/ ( r1 )
  113 			agn-pits cellctr array-ref tune f* ( r1 r2 )
  114 			2.0 agn-octs cellctr array-ref f** f* { freq } ( r1 )
  115 			freq 100.0 f< if
  116 				nextbeg f2*
  117 			else
  118 				nextbeg
  119 			then { dur } ( r1 )
  120 			agn-amps cellctr array-ref 60.0 base f* 1/f f*
  121 			    0.003 fmax { amp } ( r1 )
  122 			1.0 random f2* base f* { ind } ( r1 )
  123 			base 0.1 f* { revamt } ( r1 )
  124 			10.0 beg beg floor f- f* floor f>s { winnum } ( r1 )
  125 			0.00001 freq 2.0 flogn 4.0 f- 4.0 f**
  126 			    ( r1 r2 ) f* { ranamt }
  127 			io
  128 			"
  129 %f %f %f %f :fm-index %f
  130 	:amp-env %S
  131 	:reverb-amount %f :noise-amount %f fm-violin"
  132 			    '( beg dur freq amp ind
  133 			       wins
  134 			       winnum array-ref revamt ranamt ) io-write-format
  135 			cellctr 1+ to cellctr
  136 			cellctr cellsiz cellbeg + > if
  137 				cellbeg 1+ to cellbeg
  138 				1.0 random 0.5 f> if
  139 					cellsiz whichway + to cellsiz
  140 				then
  141 				cellsiz 16 >
  142 				1.0 random 0.99 f> && if
  143 					-2 to whichway
  144 				else
  145 					cellsiz 12 >
  146 					1.0 random 0.999 f> && if
  147 						-1 to whichway
  148 					else
  149 						cellsiz 4 < if
  150 							1 to whichway
  151 						then
  152 					then
  153 				then
  154 				cellbeg 3 + to cellbeg
  155 				cellbeg to cellctr
  156 			then
  157 		repeat
  158 	loop
  159 	io "\n\n\\ %s ends here\n" '( agn-test-file ) io-write-format
  160 	io io-close
  161 ;
  162 
  163 : do-agn ( -- )
  164 	agn-test-file undef file-basename ".snd" $+ { sndfile }
  165 	"\\ writing \"%s\"\n" '( agn-test-file ) fth-print
  166 	agn-test-file agn
  167 	:output sndfile agn-test-file clm-load
  168 ;
  169 
  170 'snd provided? [unless] do-agn [then]
  171 
  172 \ agn.fth ends here