(* ;;-*-LISP-*- KEEP EMACS HAPPY ********************************
*
*     PARAM.TO.COEF
*
*(1) SR = 10000
*(2) PLCONSTANT = .995 when SR = 10000
****************************************************************)

(DEFCONST PI 3.14159265)
(DEFVAR SR 10000)
(DEFVAR NWS 50)
(DEFVAR NSAMI .02)
(DEFVAR PERIODT .0001)
(DEFVAR PIT .0003141593)
(DEFVAR TWOPIT .0006283186)
(DEFVAR PLCONSTANT .995)

(DEFEXPR (SPEECH.SR (OPTIONAL SAMPLERATE 10000))
  (PROG ()
    (SETQ SR SAMPLERATE)
    (SETQ NWS (/ SR 200))
    (SETQ NSAMI (/$ 1.0 NWS))
    (SETQ PERIODT (/$ 1.0 SR))
    (SETQ PIT (x$ PI PERIODT))
    (SETQ TWOPIT (x$ 2.0 PIT))
    (SETQ PLCONSTANT (ANTILOG (x$ -50.13705 PERIODT)))
))

(* Parameters *)
(DATATYPE PARAM
  (AV ASV FGP BGP FGZ BGZ BGS SWITCH AFRIC AASPIR NCF
   F0 A1 B1 F1 A2 B2 F2 A3 B3 F3 A4 B4 F4 A5 B5 F5 A6 B6 F6
   FNZ BNZ ANP FNP BNP AB GAIN))

(DEFEXPR (SPEECH.CREATE.PARAM)
  (COPYALL USER.DEFAULT.PARAM)
)


(* ****************************************************************
*
*     SYNTHESIZER COEFFICIENTS
*
*(1) Amplitudes absolute, frequencies Hertz.
*
*() AB: Bypass amplitude
*() AFRIC: Frication amplitude
*() AFRIC1: Previous frication amplitude
*() AASPIR: Aspiration amplitude
*() AV: Voicing amplitude (IMPULSE)
*() PLSTEP: Plosive step
*() ASV: Sinusoidal voicing amplitude (SINAMP)
*() PULSN: Number of samples before a new glottal pulse may be
*generated.
*() SWITCH: CASCADE or PARALLEL
*() NCF: Number of cascaded formants
*() NTIMEP: Cumulative time counter.
*() NTIMED:
****************************************************************)

(DATATYPE COEFF
  (AV
   ASV
   AB
   AFRIC
   AFRIC1
   AASPIR
   A1
   ANP
   A2
   A3
   A4
   A5
   A6
   PLSTEP
   RESGP
   RESGZ
   RESGS
   RES1
   RES2
   RES3
   RES4
   RES5
   RES6
   RESNP
   RESNZ
   PULSN
   SWITCH
   NCF
   NTIMEP
   NTIMED
))

(* Difference Equation Constants *)

(RECORD RES (A B C)
  (ACCESSFNS
   ((BANDWIDTH (0-$ (/$ (LOG (0-$ (RES.C DATUM)))
		       TWOPIT)))
    (FREQUENCY (/$ (ARCCOS (/$ (RES.B DATUM) 
			      (x$ 2.0 (SQRT (0-$ (RES.C DATUM)))))
			  T)
		   TWOPIT)))
))

(DEFVAR NTIMPR -1)
(DEFVAR NPPBEG 1)
(DEFVAR NPPEND 39)

(DEFCONST DBSCA.A1 -58.0)
(DEFCONST DBSCA.A2 -65.0)
(DEFCONST DBSCA.A3 -73.0)
(DEFCONST DBSCA.A4 -78.0)
(DEFCONST DBSCA.A5 -79.0)
(DEFCONST DBSCA.A6 -80.0)
(DEFCONST DBSCA.ANP -58.0)
(DEFCONST DBSCA.AB -84.0)
(DEFCONST DBSCA.AV -72.0)
(DEFCONST DBSCA.AASPIR -102.0)
(DEFCONST DBSCA.AFRIC -72.0)
(DEFCONST DBSCA.ASV -44.0)

(DEFEXPR (SPEECH.CREATE.COEFF)
  (PROG (COEFF)
    (SETQ COEFF
	  (CREATE COEFF
		  RESGP ← (CREATE RES)
		  RESGZ ← (CREATE RES)
		  RESGS ← (CREATE RES)
		  RES1 ← (CREATE RES)
		  RES2 ← (CREATE RES)
		  RES3 ← (CREATE RES)
		  RES4 ← (CREATE RES)
		  RES5 ← (CREATE RES)
		  RES6 ← (CREATE RES)
		  RESNP ← (CREATE RES)
		  RESNZ ← (CREATE RES)))
    (RETURN COEFF)
))

(DEFEXPR (SPEECH.INIT.COEFF PARAM COEFF)
  (* Initialize synthesizer before computing waveform chunk. *)
  (PROG () 
    (SETF (COEFF.AV COEFF) 0.0)
    (SETF (COEFF.ASV COEFF) 0.0)
    (SETF (COEFF.AB COEFF) 0.0)
    (SETF (COEFF.AFRIC COEFF) 0.0)
    (SETF (COEFF.AFRIC1 COEFF) 0.0)
    (SETF (COEFF.AASPIR COEFF) 0.0)
    (SETF (COEFF.A1 COEFF) 0.0)
    (SETF (COEFF.ANP COEFF) 0.0)
    (SETF (COEFF.A2 COEFF) 0.0)
    (SETF (COEFF.A3 COEFF) 0.0)
    (SETF (COEFF.A4 COEFF) 0.0)
    (SETF (COEFF.A5 COEFF) 0.0)
    (SETF (COEFF.A6 COEFF) 0.0)
    (SPEECH.INIT.RES (COEFF.RESGP COEFF))
    (SPEECH.INIT.RES (COEFF.RESGZ COEFF))
    (SPEECH.INIT.RES (COEFF.RESGS COEFF))
    (SPEECH.INIT.RES (COEFF.RES1 COEFF))
    (SPEECH.INIT.RES (COEFF.RES2 COEFF))
    (SPEECH.INIT.RES (COEFF.RES3 COEFF))
    (SPEECH.INIT.RES (COEFF.RES4 COEFF))
    (SPEECH.INIT.RES (COEFF.RES5 COEFF))
    (SPEECH.INIT.RES (COEFF.RES6 COEFF))
    (SPEECH.INIT.RES (COEFF.RESNP COEFF))
    (SPEECH.INIT.RES (COEFF.RESNZ COEFF))
    (SETF (COEFF.PLSTEP COEFF) 0.0)
    (SETF (COEFF.PULSN COEFF) 0.0)
    (SETF (COEFF.SWITCH COEFF) (PARAM.SWITCH PARAM))
    (SETF (COEFF.NCF COEFF) (PARAM.NCF PARAM))
    (* Extra junk *)
    (SETF (COEFF.NTIMEP COEFF) 0.0)
    (SETF (COEFF.NTIMED COEFF) (/$ (x$ NWS 1000.0) SR))
))

(DEFEXPR (SPEECH.INIT.RES RES)
  (PROG ()
    (SETF (RES.A RES) 0.0)
    (SETF (RES.B RES) 0.0)
    (SETF (RES.C RES) 0.0)
))

(DEFEXPR (SPEECH.PARAM.TO.COEFF PARAM COEFF)
  (* Calculate synthesizer COEFFicients from PARAMeters. *)
  (PROG (CORRECTIONS)
    (SETF (COEFF.AB COEFF)
	  (SPEECH.GET.AMP (+$ (PARAM.AB PARAM) DBSCA.AB)))
    (SPEECH.PTC.ASPIRATION PARAM COEFF)
    (SPEECH.PTC.FRICATION PARAM COEFF)
    (SETQ CORRECTIONS (SPEECH.PTC.CORRECTIONS PARAM))
    (SPEECH.PTC.FORMANTS PARAM COEFF CORRECTIONS)
    (SPEECH.PTC.GLOTTAL PARAM COEFF)
    (SPEECH.PTC.NASAL PARAM COEFF)
    (SPEECH.PTC.VOICING PARAM COEFF)
))

(RECORD CORRECTIONS (A2COR A3COR N12COR N23COR N34COR))

(DEFEXPR (SPEECH.PTC.CORRECTIONS PARAM)
  (PROG (F1 F2 F3 F4 A2COR DELF2 A3COR N12COR N23COR N34COR
	    F21 F32 F43 CORRECTIONS)
    (SETQ F1 (PARAM.F1 PARAM))
    (SETQ F2 (PARAM.F2 PARAM))
    (SETQ F3 (PARAM.F3 PARAM))
    (SETQ F4 (PARAM.F4 PARAM))
    (* Compute amplitude corrections. *)
    (SETQ A2COR (EXPT (/$ (FLOAT F1) 500.0) 2.0))
    (SETQ DELF2 (/$ (FLOAT F2) 1500.0))
    (SETQ A3COR (x$ A2COR (x$ DELF2 DELF2)))
    (SETQ A2COR (/$ A2COR DELF2))
    (* Compute amplitude corrections due to proximity of 2 formants. *)
    (SETQ N12COR 0.0)
    (SETQ N23COR 0.0)
    (SETQ N34COR 0.0)
    (SETQ F21 (-$ F2 F1))
    (COND ((<$ F21 50.0)(GO EXIT))
	  ((<$ F21 550.0)
	   (SETQ N12COR (SPEECH.DBCOR F21))))
    (SETQ F32 (+$ F3 (0-$ F2) -50.0))
    (COND ((<$ F32 50.0)(GO EXIT))
	  ((<$ F32 550.0)
	   (SETQ N23COR (SPEECH.DBCOR F32))))
    (SETQ F43 (+$ F4 (0-$ F3) -50.0))
    (COND ((<$ F43 50.0)(GO EXIT))
	  ((<$ F43 550.0)
	   (SETQ N34COR (SPEECH.DBCOR F43))))
   EXIT
    (SETQ CORRECTIONS
	  (CREATE CORRECTIONS
		  A2COR ← A2COR
		  A3COR ← A3COR
		  N12COR ← N12COR
		  N23COR ← N23COR
		  N34COR ← N34COR))
    (RETURN CORRECTIONS)
))

(DEFEXPR (SPEECH.PTC.ASPIRATION PARAM COEFF)
  (* Get aspiration amplitude. *)
  (PROG ()
    (SETF (COEFF.AASPIR COEFF) 
	  (SPEECH.GET.AMP 
	   (+$ (PARAM.GAIN PARAM) (PARAM.AV PARAM) DBSCA.AASPIR)))
))

(DEFEXPR (SPEECH.PTC.FRICATION PARAM COEFF)
  (* Get frication amplitude. *)
  (PROG (AASPIR AFRIC GAIN SWITCH PLSTEP)
    (SETQ AASPIR (PARAM.AASPIR PARAM))
    (SETQ AFRIC (PARAM.AFRIC PARAM))
    (SETQ GAIN (PARAM.GAIN PARAM))
    (SETQ SWITCH (PARAM.SWITCH PARAM))
    (COND ((AND (>$ AASPIR AFRIC) (EQ SWITCH 'PARALLEL))
	   (SETQ AFRIC AASPIR)))
    (* Add a step to waveform at a plosive relase. *)
    (COND ((<$ (-$ AFRIC (COEFF.AFRIC1 COEFF)) 49)
	   (SETQ PLSTEP 0.0))
	  (T (SETQ PLSTEP (SPEECH.GET.AMP (+$ GAIN DBSCA.AFRIC 44)))))
    (SETF (COEFF.AFRIC COEFF) (SPEECH.GET.AMP (+$ GAIN AFRIC DBSCA.AFRIC)))
    (SETF (COEFF.AFRIC1 COEFF) AFRIC)
    (SETF (COEFF.PLSTEP COEFF) PLSTEP)
))

(DEFEXPR (SPEECH.PTC.FORMANTS PARAM COEFF CORRECTIONS)
  (* Set up resonators for formants F1-F6. *)
  (PROG (A2COR A3COR N12COR N23COR N34COR)
    (* Unpack CORRECTIONS. *)
    (SETQ A2COR (CORRECTIONS.A2COR CORRECTIONS))
    (SETQ A3COR (CORRECTIONS.A3COR CORRECTIONS))
    (SETQ N12COR (CORRECTIONS.N12COR CORRECTIONS))
    (SETQ N23COR (CORRECTIONS.N23COR CORRECTIONS))
    (SETQ N34COR (CORRECTIONS.N34COR CORRECTIONS))
    (* Set up resonators. *)
    (SPEECH.SET.RES
     (COEFF.RES1 COEFF)
     (PARAM.F1 PARAM)
     (PARAM.B1 PARAM))
    (SPEECH.SET.RES
     (COEFF.RES2 COEFF)
     (PARAM.F2 PARAM)
     (PARAM.B2 PARAM))
    (SPEECH.SET.RES
     (COEFF.RES3 COEFF)
     (PARAM.F3 PARAM)
     (PARAM.B3 PARAM))
    (SPEECH.SET.RES
     (COEFF.RES4 COEFF)
     (PARAM.F4 PARAM) 
     (PARAM.B4 PARAM))
    (SPEECH.SET.RES
     (COEFF.RES5 COEFF)
     (PARAM.F5 PARAM)
     (PARAM.B5 PARAM))
    (SPEECH.SET.RES
     (COEFF.RES6 COEFF)
     (PARAM.F6 PARAM)
     (PARAM.B6 PARAM))
    (SETF (COEFF.A1 COEFF)
	  (SPEECH.GET.AMP (+$ (PARAM.A1 PARAM) N12COR DBSCA.A1)))
    (SETF (COEFF.A2 COEFF)
	  (x$ A2COR 
	      (SPEECH.GET.AMP
	       (+$ (PARAM.A2 PARAM) (x$ 2 N12COR) N23COR DBSCA.A2))))
    (SETF (COEFF.A3 COEFF)
	  (x$ A3COR 
	      (SPEECH.GET.AMP
	       (+$ (PARAM.A3 PARAM) (x$ 2 N23COR) N34COR DBSCA.A3))))
    (SETF (COEFF.A4 COEFF)
	  (x$ A3COR
	      (SPEECH.GET.AMP
	       (+$ (PARAM.A4 PARAM) (x$ 2 N34COR) DBSCA.A4))))
    (SETF (COEFF.A5 COEFF)
	  (x$ A3COR
	      (SPEECH.GET.AMP (+$ (PARAM.A5 PARAM) DBSCA.A5))))
    (SETF (COEFF.A6 COEFF)
	  (x$ A3COR
	      (SPEECH.GET.AMP (+$ (PARAM.A6 PARAM) DBSCA.A6))))
))

(DEFEXPR (SPEECH.PTC.NASAL PARAM COEFF)
  (* Nasal resonator and antiresonator. *)
  (PROG ()
    (SPEECH.SET.RES
     (COEFF.RESNP COEFF)
     (PARAM.FNP PARAM)
     (PARAM.BNP PARAM))
    (SPEECH.SET.RES 
     (COEFF.RESNZ COEFF)
     (SPEECH.RANGE.CHECK
      (0-$ (PARAM.FNZ PARAM)) MIN.FIXP -1)
     (PARAM.BNZ PARAM))
    (SETF (COEFF.ANP COEFF)
	  (SPEECH.GET.AMP (+$ (PARAM.ANP PARAM) DBSCA.ANP)))
))

(DEFEXPR (SPEECH.PTC.GLOTTAL PARAM COEFF)
  (* Glottal resonators and antiresonator. *)
  (PROG (F0 AV PULSN)
    (SETQ F0 (PARAM.F0 PARAM))
    (* Get voicing amplitude. *)
    (SETQ AV 
	  (SPEECH.GET.AMP
	   (+$ (PARAM.GAIN PARAM) (PARAM.AV PARAM) DBSCA.AV)))
    (COND ((OR (<=$ F0 0.0)
	       (AND (<=$ (PARAM.AV PARAM) 0.0)
		    (<=$ (PARAM.ASV PARAM) 0.0)))
	   (* No pulse issued. *)    
	   (SETQ PULSN 1))
	  (T (* Waveform more sinusoidal at high fundamental
		frequency. *)
	     (SPEECH.SET.RES 
	      (COEFF.RESGP COEFF)
	      (PARAM.FGP PARAM)
	      (/$ (x$ 100.0 (PARAM.BGP PARAM)) F0))
	     (SPEECH.SET.RES 
	      (COEFF.RESGS COEFF)
	      0.0 (PARAM.BGS PARAM))
	     (SPEECH.SET.RES 
	      (COEFF.RESGZ COEFF)
	      (0-$ (PARAM.FGZ PARAM))
	      (PARAM.BGZ PARAM))
	     (* Set gain to constant in mid-frequency region for 
		RESGP. *)
	     (SETF (RES.A (COEFF.RESGP COEFF)) 0.007)
	     (* Do not let F0 drop below 40HZ. *)
	     (SETQ F0 (SPEECH.RANGE.CHECK F0 40 MAX.FIXP))
	     (* Make AMP of AV increase with increasing 
		F0. *)
	     (SETQ AV (x$ AV F0))
	     (* Number of samples before a new glottal pulse may be
		generated. *)
	     (SETQ PULSN (/$ SR F0))))
    (SETF (COEFF.AV COEFF) AV)
    (SETF (COEFF.PULSN COEFF) PULSN)
))

(DEFEXPR (SPEECH.PTC.VOICING PARAM COEFF)
  (* Get amplitude of quasi-sinusoidal voicing source. *)
  (PROG ()
    (SETF (COEFF.ASV COEFF)
	  (x$ 10.0 (SPEECH.GET.AMP 
		    (+$ (PARAM.GAIN PARAM) (PARAM.ASV PARAM) DBSCA.ASV))))
))

(DEFEXPR (SPEECH.DBCOR DB)
  (* Increment in DB to adjust formant AMPs of parallel 
     branch. *) 
  (-$ 11.0 (/$ DB 50.0)))

(* ****************************************************************
*
*     SET.RES
*
****************************************************************)

(DEFEXPR (SPEECH.GET.AMP DB)
  (* Convert DB attenuation to linear scale factor *)
  (EXPT 2.0 (/$ (SPEECH.RANGE.CHECK DB -72.0 96.0) 6.0)))

(DEFEXPR (SPEECH.RANGE.CHECK VALUE MIN MAX)
  (* Coerce VALUE to lie in interval (MIN,MAX) *)
  (COND ((<$ VALUE MIN) MIN)
	((>$ VALUE MAX) MAX)
	(T VALUE)))

(DEFEXPR (LOG10 X)
  (/$ (LOG X) (CONSTANT (LOG 10.0))))

(DEFEXPR (SPEECH.SET.RES RES FREQUENCY BANDWIDTH)
  (* Set up RES coefficients. *)
  (PROG (A B C R)
    (* Calc difference equation coefficients A, B, C. *)
    (SETQ R (ANTILOG (0-$ (x$ PIT BANDWIDTH))))
    (SETQ C (0-$ (x$ R R)))
    (SETQ B (x$ 2.0 R (COS (x$ TWOPIT FREQUENCY) T)))
    (SETQ A (+$ 1.0 (0-$ B) (0-$ C)))
    (COND ((<$ FREQUENCY 0.0)
	   (SETQ A (/$ 1.0 A))
	   (SETQ B (0-$ (x$ A B)))
	   (SETQ C (0-$ (x$ A C)))))
    (* Update RES. *)
    (SETF (RES.A RES) A)
    (SETF (RES.B RES) B)
    (SETF (RES.C RES) C)
    (RETURN RES)
))

(* ****************************************************************
*STOP
****************************************************************)

STOP