	  (* ************************************************** *)
	  (*							*)
	  (* State Variable Filter Routines II, for percussion	*)
	  (*							*)
	  (* LC: December 27, 1988  	Simplified FILTER	*)
	  (* LC: December 28, 1988	3 Drums			*)
	  (* LC: December 29, 1988	Noise drum		*)
	  (* LC: December 31, 1988	Non-linear drum		*)
	  (*							*)
	  (* ************************************************** *)


	NEEDS -graphics

	REVISION -3drums " Drumming Demo       Version 1.01 "


    0 VALUE bandpass	-- Noise drum, state variable 1
    0 VALUE lowpass	-- state variable 2
    0 VALUE highpass
  #50 VALUE frequency	-- filter resonance at Fs*[50]/(1000*2*PI)
 #150 VALUE 1000/Q	-- filter Q = 1000/[150] = 6.6
#1600 VALUE init10 
    0 VALUE init00
    1 VALUE scale	-- impulse response is simulated for 720*scale samples

    0 VALUE bandpass1	-- drum 1
    0 VALUE lowpass1
  #50 VALUE frequency1	-- filter resonance at Fs*[50]/(1000*2*PI)
 #150 VALUE 1000/Q1	-- filter Q = 1000/[150] = 6.6
#1000 VALUE init11 
    0 VALUE init01
    1 VALUE scale1

    0 VALUE bandpass2	-- drum2
    0 VALUE lowpass2
  #50 VALUE frequency2
 #150 VALUE 1000/Q2
#2000 VALUE init12
    0 VALUE init02
    1 VALUE scale2

    0 VALUE bandpass3	-- drum3
    0 VALUE lowpass3
  #50 VALUE frequency3
 #150 VALUE 1000/Q3
#8000 VALUE init13
    0 VALUE init03
    1 VALUE scale3

    0 VALUE bandpass4	-- drum4
    0 VALUE lowpass4
    0 VALUE highpass4
 #150 VALUE frequency4
 #100 VALUE 1000/Q4
#3000 VALUE init14
    0 VALUE init04
    1 VALUE scale4

    0. DVALUE x		-- only for plotting


DOC drums
(*
	An infinite gain state variable filter's impulse response is simulated. 
	As only the low-pass output of this filter is useful in a musical sense, 
	we can simplify the equations and eliminate the high-pass variable 
	altogether. Three '*/' operations suffice for the simulation, resulting 
	in about 1 sample per 80 microseconds on an 12 Mhz AT running F-4TH 2.0.

	The vector >OUTPUT allows redirecting the samples to the screen for evaluation
	purposes.

	Because the sample rate is fixed, long impulse responses (e.g high-Q) need 
	more samples. In such a case the VALUE { scale } must be adjusted upward.
	(scale = 1 will compute 720 samples, this is the minimum per run).

	Between simulations, the program waits a few (hundred) milliseconds. This time
	is adjustable and can be manipulated to create a "beat". Note that fast beats
	and high-Q (==> long impulse responses) don't mix.

	The VALUEs { init0 init1 } influence the starting phase and amplitude of the 
	waveform. The phase you can observe on an oscilloscope, but it has no audible
	effect.

	The amplitude of the waveform should not be too low as only 8 bits are used.
	If the amplitude becomes too low, modulation noise is quite noticeable. 
	You will have to live with this. Sometimes the effect is useful (snare drums).

	Too high an amplitude is no problem, a few "instruments" gain realism by a 
	certain amount of clipping.

	A hardware problem: PC's run interrupts. In the close, fast loops used here,
	time taken by the clock interrupt is significant and we hear the 
	discontinuities unpleasantly well. We also can hear a key being pressed: the
	BIOS needs extra time then and the frequency goes down. 
	The remedy is turning off the clock bit in the interrupt controller mask.
	Now FORTH can be exited without worrying about an interrupt routine staying 
	behind (and being overwritten by DOS on the next occasion).
*)
ENDDOC


DEFER >OUTPUT


: .FORMAT	0 <#      # '.' HOLD #S #> TYPE SPACE ;	\ 0.5...1000.0 ---

: .FRAC		0 <#  # # # '.' HOLD #S #> TYPE SPACE ;	\ u ---

: (.FILTER)						\ n, n, n, n, id ---
		CR ."     ----  State-Variable Filter "  DEC. ." ----" CR
		CR ." 'frequency' = " 4 .R   
		   ."  '1000/Q'   = " 4 .R  
		CR ." Initial values: 'init1' = "  DEC. 
		   ." , 'init0' = " DEC. CR ;
		
: .FILTER0	0      0      1000/Q  frequency   0 (.FILTER) ;
: .FILTER1	init01 init11 1000/Q1 frequency1  1 (.FILTER) ;
: .FILTER2	init02 init12 1000/Q2 frequency2  2 (.FILTER) ;
: .FILTER3	init03 init13 1000/Q3 frequency3  3 (.FILTER) ;
: .FILTER4	init04 init14 1000/Q4 frequency4  4 (.FILTER) ;

: INITIALIZE0	init10 TO bandpass  			\ ---
		init00 TO lowpass ;
: INITIALIZE1	init11 TO bandpass1  			\ ---
		init01 TO lowpass1 ;
: INITIALIZE2	init12 TO bandpass2  			\ ---
		init02 TO lowpass2 ;
: INITIALIZE3	init13 TO bandpass3  			\ ---
		init03 TO lowpass3 ;
: INITIALIZE4	init14 TO bandpass4  			\ ---
		init04 TO lowpass4 ;


: NOISE-FILTER						\ i --- n
		lowpass  bandpass  frequency  #1000 */  + DUP TO lowpass
		       - bandpass  1000/Q #1000 */  - DUP DUP TO highpass
		frequency #1000 */  +TO bandpass
		1000/Q #2000 */ ;


: FILTER1  						\ --- n
		lowpass1  bandpass1  frequency1  #1000 */  + DUP TO lowpass1
		( new lowpass1 ) bandpass1  1000/Q1 #1000 */  + NEGATE  
		frequency1 #1000 */  +TO bandpass1
		lowpass1  1000/Q1 #2000 */ ;


: FILTER2  						\ --- n
		lowpass2  bandpass2  frequency2  #1000 */  + DUP TO lowpass2
		( new lowpass2 ) bandpass2  1000/Q2 #1000 */  + NEGATE  
		frequency2 #1000 */  +TO bandpass2
		lowpass2  1000/Q2 #2000 */ ;


: FILTER3					   	\ --- n
		lowpass3  bandpass3  frequency3  #1000 */  + DUP TO lowpass3
		( new lowpass3 ) bandpass3  1000/Q3 #1000 */  + NEGATE  
		frequency3 #1000 */  +TO bandpass3
		lowpass3  1000/Q3 #2000 */ ;


: NON-LINEAR	DUP 0< >S ABS				\ i --- i^2/100
		1000/Q4 #2000 */ DUP DUP #100 */
		#2000 1000/Q4 */ +
		S> IF NEGATE ENDIF ;


: NL-FILTER						\ i --- n
		lowpass4  bandpass4  frequency4  #1000 */  + DUP TO lowpass4
		NON-LINEAR - bandpass4  1000/Q4 #1000 */  - DUP TO highpass4
		frequency4 #1000 */  +TO bandpass4
		lowpass4  1000/Q4 #2000 */ ;

Ymax #128 / VALUE Gain
          0 VALUE Tloupe

0 VALUE scrinit PRIVATE

: >SCREEN ( y -- )
	 	scrinit 0= IF	Ymax #128 / TO Gain
				1 TO Tloupe
				0 Ymax 2/ MOVE  
				CLEAR x  1 TO Pen
				1 TO scrinit
			ENDIF
		x TLoupe DLSHIFT  Xmax 2* UM/MOD DROP
		SWAP Gain *  Ymax 2/ + 	DRAWTO 
		1. +TO x ;

: VCA		Xmax */ ;				\ n, "time" --- n'

$FF VALUE noiseamp

: CALCULATE 	0 Ymax 2/ MOVE
		scale1 scale2 MAX scale3 MAX Xmax UM*  
		CLEAR x
		BEGIN	FILTER1 FILTER2 FILTER3 
			 + + 3 / ( y )  >OUTPUT
			1. D- 2DUP D0=
		UNTIL	2DROP ;


: .GRAPH	INITIALIZE1 INITIALIZE2 INITIALIZE3
		['] >SCREEN [IS] >OUTPUT CALCULATE ;

4 VALUE waits

: WAIT-HW	waits MS ;


: BLAST		INITIALIZE0 
		scale Xmax UM*  
		CLEAR x  0 Ymax 2/ MOVE
		BEGIN OVER >S
		      RANDOM noiseamp AND NOISE-FILTER S> VCA >OUTPUT
		      D1- 2DUP D0=
		UNTIL 2DROP
		WAIT-HW ;


: HIT		CALCULATE  WAIT-HW ;			\ ---
		

: BOING		INITIALIZE4 
		scale4 Xmax UM* 
		CLEAR x  0 Ymax 2/ MOVE
		BEGIN 0 NL-FILTER >OUTPUT
		      D1- 2DUP D0=
		UNTIL 2DROP WAIT-HW ;


: SETBASS	#500 TO 1000/Q1	#75   TO frequency1 ;

: SETTOMS	#24  TO 1000/Q2	#500  TO frequency2 ;

: SETBLOCKS	#12  TO 1000/Q3	#1600 TO frequency3 
		#10000 TO init13 ; 

: SETSNARE	#100 TO 1000/Q	#115  TO frequency 
		$FF TO noiseamp #1600 TO init10 ; 

: BASS		INITIALIZE1 ;
: TOMS		INITIALIZE2 ;
: BLOCKS	INITIALIZE3 ;
: SNARE		INITIALIZE0 ;

: NOHIT		init10 init11 init12 init13 noiseamp
		0TO init10  0TO init11  0TO init12  0TO init13 
		 0TO noiseamp
		  HIT
		 TO noiseamp
		TO init13 TO init12 TO init11 TO init10 ;

: R0		BASS HIT  3 0 DO BLOCKS  HIT LOOP ;
: R1		BASS HIT  3 0 DO TOMS    HIT LOOP ;
: R1a		BASS HIT  3 0 DO SNARE BLAST LOOP ;

: R2		3 0 DO R1  LOOP  R0 ;
: R2a		3 0 DO R1a LOOP  R0 ;

: R3		BASS HIT TOMS HIT
		waits DUP 2/ TO waits 
		BLOCKS HIT NOHIT 2 0 DO BLOCKS HIT LOOP NOHIT
		TO waits ;

: R4		BASS HIT TOMS HIT
		waits DUP 2/ TO waits 
		TOMS HIT   NOHIT 2 0 DO   TOMS HIT LOOP NOHIT
		TO waits ;

: R5		BASS HIT TOMS HIT
		waits DUP 2/ TO waits 
		BASS HIT   NOHIT 2 0 DO   BASS HIT LOOP NOHIT
		TO waits ;	\ tempo doubles

: R2b		3 0 DO R4 LOOP R3 ;
: R2c		4 0 DO R3 LOOP ;
: R2d		4 0 DO R5 LOOP ;
 
DEFER RHYTHM

: set.R6	R2b R3	R2b  R4 ;
: set.R7	R2d R2  R2   R2a ;
: set.R8	R2b R2c R2d  R2b ;

: set.R9	R2d R2  R2   R2a
		R2b R3	R2b  R4
		R2b R2c R2d  R2b 
		R2d R2  R2   R2a ;

: HOEMPA	BEGIN RHYTHM
		      EKEY?
		UNTIL ELEY DROP ;

:ABOUT	CR ." 			* Command Overview *" 
	CR
	CR ." HOEMPA		-- starts drum machine (Alt-key to stop)."
	CR ." set.Ri IS RHYTHM	-- where i in {6,7,8,9}. Sets pattern."
	CR ." Ri		-- where i in {0..5} : single break."
	CR ." BASS | TOMS | BLOCKS  HIT	-- strike instrument"
	CR ." SNARE BLAST		-- hit snare drum"
	CR ." BOING			-- hit non-linear drum"
	CR ." NOHIT			-- a pause"
	CR ." SETSNARE | SETBASS | SETTOMS | SETBLOCKS  reset an instrument"
	CR
	CR ." Important global VALUE's : "
	CR ."   speed		-- the lower, the faster the overall beat (12000)"
	CR ."   noise		-- controls noise content of snare drum"
	CR ."	waits		-- basic note length (4)"
	CR
	CR ." Important local VALUE's  (i is <nothing> 1 2 3 or 4"
	CR ."	frequencyi	-- resonance frequency"
	CR ."	1000/Qi		-- Quality Factor (Q) of impulse"
	CR ."   scalei		-- affects length of response"
	CR ."   .FILTERi	-- prints setup of filter i"
	CR ;

		' >SCREEN IS >OUTPUT

		Or! TO Pen

		SETBASS SETTOMS SETBLOCKS SETSNARE	-- default instruments

		' set.R7 IS RHYTHM 			-- nicest, has snare and tempo doubling in it

		.ABOUT -3drums

			(* End of Information *)