(* ;;-*-LISP-*- KEEP EMACS HAPPY ********************************
*
*     SPEECH -- COEFFICIENTS TO WAVE 
*
****************************************************************)

(* ****************************************************************
*
*     MEMORY
*
*() UGLOT = Sum of outputs from RGZ & RGS
*() UGLOT1 = Previous UGLOT
*() UASPIR = Aspiration
*() UFRIC = Frication
*() USUMC = Sum of UGLOT & UASPIR
*() UDIF = First difference of UGLOT (UGLOT - UGLOT1)
*() USUMP = Sum of UFRIC & UDIF
****************************************************************)

(RECORD REG (T1 T2))

(DATATYPE MEMORY
  (REG1P
   REG2P
   REG3P
   REG4P
   REG5P
   REG6P
   REGNP
   REGN
   REG1C
   REG2C
   REG3C
   REG4C
   REG5C
   REG6C
   REGNPC
   REGNZC
   REGGP
   REGGS1
   REGGS2
   REGGZ
   NPULSE
   MPULSE
   UGLOT
   UGLOT1
   USUMC
   UDIF
   USUMP
   PLSTEP
   AFRIC
   DFRIC
   UFRIC
   AASPIR
   DASPIR
   UASPIR
   UCASC
   UPAR
   ULIPS
   OUTPUT
))

(DEFEXPR (SPEECH.CREATE.MEMORY)
  (PROG (MEMORY)
    (SETQ MEMORY
	  (CREATE MEMORY
		  REG1P ← (CREATE REG)
		  REG2P ← (CREATE REG)
		  REG3P ← (CREATE REG)
		  REG4P ← (CREATE REG)
		  REG5P ← (CREATE REG)
		  REG6P ← (CREATE REG)
		  REGN ← (CREATE REG)
		  REGNP ← (CREATE REG)
		  REG1C ← (CREATE REG)
		  REG2C ← (CREATE REG)
		  REG3C ← (CREATE REG)
		  REG4C ← (CREATE REG)
		  REG5C ← (CREATE REG)
		  REG6C ← (CREATE REG)
		  REGNPC ← (CREATE REG)
		  REGNZC ← (CREATE REG)
		  REGGP ← (CREATE REG)
		  REGGS1 ← (CREATE REG)
		  REGGS2 ← (CREATE REG)
		  REGGZ ← (CREATE REG)))
    (RETURN MEMORY)
))

(DEFEXPR (SPEECH.INIT.MEMORY MEMORY)
  (PROG ()
    (SPEECH.INIT.REG (MEMORY.REG1P MEMORY))
    (SPEECH.INIT.REG (MEMORY.REG2P MEMORY))
    (SPEECH.INIT.REG (MEMORY.REG3P MEMORY))
    (SPEECH.INIT.REG (MEMORY.REG4P MEMORY))
    (SPEECH.INIT.REG (MEMORY.REG5P MEMORY))
    (SPEECH.INIT.REG (MEMORY.REG6P MEMORY))
    (SPEECH.INIT.REG (MEMORY.REGN MEMORY))
    (SPEECH.INIT.REG (MEMORY.REGNP MEMORY))
    (SPEECH.INIT.REG (MEMORY.REG1C MEMORY))
    (SPEECH.INIT.REG (MEMORY.REG2C MEMORY))
    (SPEECH.INIT.REG (MEMORY.REG3C MEMORY))
    (SPEECH.INIT.REG (MEMORY.REG4C MEMORY))
    (SPEECH.INIT.REG (MEMORY.REG5C MEMORY))
    (SPEECH.INIT.REG (MEMORY.REG6C MEMORY))
    (SPEECH.INIT.REG (MEMORY.REGNPC MEMORY))
    (SPEECH.INIT.REG (MEMORY.REGNZC MEMORY))
    (SPEECH.INIT.REG (MEMORY.REGGP MEMORY))
    (SPEECH.INIT.REG (MEMORY.REGGS1 MEMORY))
    (SPEECH.INIT.REG (MEMORY.REGGS2 MEMORY))
    (SPEECH.INIT.REG (MEMORY.REGGZ MEMORY))
    (SETF (MEMORY.NPULSE MEMORY) 1)
    (SETF (MEMORY.MPULSE MEMORY) 0)
    (SETF (MEMORY.PLSTEP MEMORY) 0.0)
    (SETF (MEMORY.AFRIC MEMORY) 0.0)
    (SETF (MEMORY.AASPIR MEMORY) 0.0)
    (SETF (MEMORY.DFRIC MEMORY) 0.0)
    (SETF (MEMORY.UFRIC MEMORY) 0.0)
    (SETF (MEMORY.DASPIR MEMORY) 0.0)
    (SETF (MEMORY.UASPIR MEMORY) 0.0)
    (SETF (MEMORY.UGLOT MEMORY) 0.0)
    (SETF (MEMORY.USUMC MEMORY) 0.0)
    (SETF (MEMORY.UDIF MEMORY) 0.0)
    (SETF (MEMORY.USUMP MEMORY) 0.0)
    (SETF (MEMORY.UCASC MEMORY) 0.0)
    (SETF (MEMORY.UPAR MEMORY) 0.0)
    (SETF (MEMORY.OUTPUT MEMORY) 0.0)
))

(DEFEXPR (SPEECH.INIT.REG REG)
  (PROG ()
    (SETF (REG.T1 REG) 0.0)
    (SETF (REG.T2 REG) 0.0)
))

(DEFEXPR (SPEECH.COEFF.TO.WAVE MEMORY COEFF WAVE OFFSET PERIOD)
  (PROG (OUTPUT)
    (* Delta amplitudes of aspiration and frication. *)
    (SETF (MEMORY.DASPIR MEMORY)
	  (x$ NSAMI (-$ (COEFF.AASPIR COEFF) (MEMORY.AASPIR MEMORY))))
    (SETF (MEMORY.DFRIC MEMORY)
	  (x$ NSAMI (-$ (COEFF.AFRIC COEFF) (MEMORY.AFRIC MEMORY))))
    (* Plosive release. *)
    (SETF (MEMORY.PLSTEP MEMORY) (0-$ (COEFF.PLSTEP COEFF)))
    (* Main loop *)
    (FOR NTIME ← 1 TO PERIOD
     WHILE (<= (+ OFFSET NTIME) USER.TMAX)
     DO (SPEECH.CTW MEMORY COEFF WAVE)
     (* Form 8 bit waveform sample. *)
     (SETQ OUTPUT (MEMORY.OUTPUT MEMORY))
     (SETQ OUTPUT (SPEECH.RANGE.CHECK OUTPUT -127 127))
     (COND ((< OUTPUT 0)(SETQ OUTPUT (- 127 OUTPUT))))
     (SETF (ELT WAVE (+ OFFSET NTIME)) OUTPUT))
))

(DEFEXPR (SPEECH.CTW MEMORY COEFF WAVE)
  (PROG (RESGP RESGZ RESGS REGGP REGGZ REGGS1 REGGS2 AV ASV
	       UGLOTV UGLOT2)
    (SETQ RESGP (COEFF.RESGP COEFF))
    (SETQ RESGZ (COEFF.RESGZ COEFF))    
    (SETQ RESGS (COEFF.RESGS COEFF))
    (SETQ REGGP (MEMORY.REGGP MEMORY))
    (SETQ REGGZ (MEMORY.REGGZ MEMORY))    
    (SETQ REGGS1 (MEMORY.REGGS1 MEMORY))
    (SETQ REGGS2 (MEMORY.REGGS2 MEMORY))
    (SETF (MEMORY.NPULSE MEMORY) (1- (MEMORY.NPULSE MEMORY)))
    (SETF (MEMORY.MPULSE MEMORY) (1- (MEMORY.MPULSE MEMORY)))
    (COND ((AND (<= (MEMORY.NPULSE MEMORY) 0)
		(> (COEFF.PULSN COEFF) 1))
	   (* End of period.  F0 <> 0. *)
	   (SETF (MEMORY.NPULSE MEMORY) (COEFF.PULSN COEFF))
	   (SETF (MEMORY.MPULSE MEMORY) (/ (COEFF.PULSN COEFF) 2))
	   (SETQ AV (COEFF.AV COEFF))
	   (SETQ ASV (COEFF.ASV COEFF)))
	  (T (* Set AV to 0 between glottal impulses. *)
	     (SETQ AV 0.0)
	     (SETQ ASV 0.0)))
    (* Subtrackt out DC voltage. *)
    (SETQ AV (-$ AV (/$ (COEFF.AV COEFF) (COEFF.PULSN COEFF))))
    (SETQ ASV (-$ ASV (/$ (COEFF.ASV COEFF) (COEFF.PULSN COEFF))))
    (* GP, GZ, GP, GS. *)
    (SPEECH.UPDATE.RES AV RESGP REGGP)
    (SETQ UGLOTV (SPEECH.UPDATE.ANTIRES (REG.T1 REGGP) RESGZ REGGZ))
    (SPEECH.UPDATE.RES ASV RESGS REGGS1)
    (SPEECH.UPDATE.RES (REG.T1 REGGS1) RESGP REGGS2)
    (* Calc glottal volume velocity. *)
    (SETF (MEMORY.UGLOT1 MEMORY) (MEMORY.UGLOT MEMORY))
    (SETF (MEMORY.UGLOT MEMORY) (+$ UGLOTV (REG.T1 REGGS2)))
    (SPEECH.CTW.TURBULENCE MEMORY COEFF)
    (* Switch should feed signal to only one of CACADE and PARALLEL. *)
    (SELECTQ (COEFF.SWITCH COEFF)
      (CASCADE (SPEECH.CTW.CASCADE MEMORY COEFF))
      (PARALLEL (SPEECH.CTW.PARALLEL MEMORY COEFF))
      (SHOULDNT))
    (SPEECH.CTW.SUM MEMORY COEFF)
    (SPEECH.CTW.SCOPE MEMORY)
))

(DEFVAR SPEECH.*SIGNAL* 'ULIPS)
(DEFEXPR (SPEECH.TRACE SIGNAL)
  (PROG ()
    (COND ((NOT (MEMB SIGNAL
		      '(REG1P REG2P REG3P REG4P REG5P REG6P REGNP REGN
			      REG1C REG2C REG3C REG4C REG5C REG6C
			      REGNPC REGNZC REGGP REGGS1 REGGS2 REGGZ
			      NPULSE MPULSE UGLOT UGLOT1 USUMC UDIF
			      USUMP PLSTEP AFRIC DFRIC UFRIC AASPIR
			      DASPIR UASPIR UCASC UPAR ULIPS OUTPUT)))
	   (LISPERROR "Can't trace " SIGNAL)))
    (WINDOWPROP SCOPE.WINDOW 
		'TITLE
		(CONCAT "Oscillosope Window: " SIGNAL))
    (SETQ SPEECH.*SIGNAL* SIGNAL)
))

(DEFEXPR (SPEECH.CTW.SCOPE MEMORY)
  (PROG (Y)
   (SETQ Y
    (SELECTQ SPEECH.*SIGNAL*
      (REG1P (REG.T1 (MEMORY.REG1P MEMORY)))
      (REG2P (REG.T1 (MEMORY.REG2P MEMORY)))
      (REG3P (REG.T1 (MEMORY.REG3P MEMORY)))
      (REG4P (REG.T1 (MEMORY.REG4P MEMORY)))
      (REG5P (REG.T1 (MEMORY.REG5P MEMORY)))
      (REG6P (REG.T1 (MEMORY.REG6P MEMORY)))
      (REGNP (REG.T1 (MEMORY.REGNP MEMORY)))
      (REGN (REG.T1 (MEMORY.REGN MEMORY)))
      (REG1C (REG.T1 (MEMORY.REG1C MEMORY)))
      (REG2C (REG.T1 (MEMORY.REG2C MEMORY)))
      (REG3C (REG.T1 (MEMORY.REG3C MEMORY)))
      (REG4C (REG.T1 (MEMORY.REG4C MEMORY)))
      (REG5C (REG.T1 (MEMORY.REG5C MEMORY)))
      (REG6C (REG.T1 (MEMORY.REG6C MEMORY)))
      (REGNPC (REG.T1 (MEMORY.REGNPC MEMORY)))
      (REGNZC (REG.T1 (MEMORY.REGNZC MEMORY)))
      (REGGP (REG.T1 (MEMORY.REGGP MEMORY)))
      (REGGS1 (REG.T1 (MEMORY.REGGS1 MEMORY)))
      (REGGS2 (REG.T1 (MEMORY.REGGS2 MEMORY)))
      (REGGZ (REG.T1 (MEMORY.REGGZ MEMORY)))
      (NPULSE (MEMORY.NPULSE MEMORY))
      (MPULSE (MEMORY.MPULSE MEMORY))
      (UGLOT (MEMORY.UGLOT MEMORY))
      (UGLOT1 (MEMORY.UGLOT1 MEMORY))
      (USUMC (MEMORY.USUMC MEMORY))
      (UDIF (MEMORY.UDIF MEMORY))
      (USUMP (MEMORY.USUMP MEMORY))
      (PLSTEP (MEMORY.PLSTEP MEMORY))
      (AFRIC (MEMORY.AFRIC MEMORY))
      (DFRIC (MEMORY.DFRIC MEMORY))
      (UFRIC (MEMORY.UFRIC MEMORY))
      (AASPIR (MEMORY.AASPIR MEMORY))
      (DASPIR (MEMORY.DASPIR MEMORY))
      (UASPIR (MEMORY.UASPIR MEMORY))
      (UCASC (MEMORY.UCASC MEMORY))
      (UPAR (MEMORY.UPAR MEMORY))
      (ULIPS (MEMORY.ULIPS MEMORY))
      (OUTPUT (MEMORY.OUTPUT MEMORY))
      (SHOULDNT)))
    (SCOPE.DRAWTO Y)
    (SETF (MEMORY.OUTPUT MEMORY) Y)
))

(DEFEXPR (SPEECH.CTW.TURBULENCE MEMORY COEFF)
  (* Turbulence noise of aspiration and fircation. *)
  (PROG (NOISE)
    (SETQ NOISE (SPEECH.CTW.GAUSSIAN))
    (* Modulate noise during second half of a glottal period. *)
    (COND ((<= (MEMORY.MPULSE MEMORY) 0)
	   (SETQ NOISE (/$ NOISE 2.0))))
    (* Glottal AND frication source volume velocities. *)
    (SETF (MEMORY.AASPIR MEMORY) 
	  (+$ (MEMORY.AASPIR MEMORY) (MEMORY.DASPIR MEMORY)))
    (SETF (MEMORY.UASPIR MEMORY) (x$ (MEMORY.AASPIR MEMORY) NOISE))
    (SETF (MEMORY.AFRIC MEMORY)
	  (+$ (MEMORY.AFRIC MEMORY) (MEMORY.DFRIC MEMORY)))
    (SETF (MEMORY.UFRIC MEMORY) (x$ (MEMORY.AFRIC MEMORY) NOISE))
))

(DEFEXPR (SPEECH.CTW.CASCADE MEMORY COEFF)
  (PROG (RES1 RES2 RES3 RES4 RES5 RES6 RESNP RESNZ
	 REG1C REG2C REG3C REG4C REG5C REG6C 
	 REGNPC REGNZC REG5P REG6P UCASC)
    (SETQ RES1 (COEFF.RES1 COEFF))
    (SETQ RES2 (COEFF.RES2 COEFF))    
    (SETQ RES3 (COEFF.RES3 COEFF))
    (SETQ RES4 (COEFF.RES4 COEFF))
    (SETQ RES5 (COEFF.RES5 COEFF))
    (SETQ RES6 (COEFF.RES6 COEFF))
    (SETQ RESNP (COEFF.RESNP COEFF))
    (SETQ RESNZ (COEFF.RESNZ COEFF))
    (SETQ REG1C (MEMORY.REG1C MEMORY))
    (SETQ REG2C (MEMORY.REG2C MEMORY))    
    (SETQ REG3C (MEMORY.REG3C MEMORY))
    (SETQ REG4C (MEMORY.REG4C MEMORY))
    (SETQ REG5C (MEMORY.REG5C MEMORY))
    (SETQ REG6C (MEMORY.REG6C MEMORY))
    (SETQ REGNPC (MEMORY.REGNPC MEMORY))
    (SETQ REGNZC (MEMORY.REGNZC MEMORY))
    (SETQ REG5P (MEMORY.REG5P MEMORY))
    (SETQ REG6P (MEMORY.REG6P MEMORY))
    (SETF (MEMORY.USUMC MEMORY)
	  (+$ (MEMORY.UGLOT MEMORY) (MEMORY.UASPIR MEMORY)))
    (* Formants. *)
    (COND ((< (COEFF.NCF COEFF) 6)
	   (SETF (REG.T1 REG6C) (MEMORY.USUMC MEMORY)))
	  (T (SPEECH.UPDATE.RES (MEMORY.USUMC MEMORY) RES6 REG6C)))
    (COND ((< (COEFF.NCF COEFF) 5)
	   (SETF (REG.T1 REG5C) (MEMORY.USUMC MEMORY)))
	  (T (SPEECH.UPDATE.RES (REG.T1 REG6C) RES5 REG5C)))
    (SPEECH.UPDATE.RES (REG.T1 REG5C) RES4 REG4C)
    (SPEECH.UPDATE.RES (REG.T1 REG4C) RES3 REG3C)
    (SPEECH.UPDATE.RES (REG.T1 REG3C) RES2 REG2C)
    (SPEECH.UPDATE.RES (REG.T1 REG2C) RES1 REG1C)
    (* Nasal. *)
    (SETQ UCASC (SPEECH.UPDATE.ANTIRES (REG.T1 REG1C) RESNZ REGNZC))
    (SETQ UCASC (SPEECH.UPDATE.RES UCASC RESNP REGNPC))
    (SETF (MEMORY.UCASC MEMORY) UCASC)
    (* Excite formant resonators F5-F6 with fric noise. *)
    (SPEECH.UPDATE.RES (MEMORY.UFRIC MEMORY) RES5 REG5P)
    (SPEECH.UPDATE.RES (MEMORY.UFRIC MEMORY) RES6 REG6P)
))

(DEFEXPR (SPEECH.CTW.PARALLEL MEMORY COEFF)
  (* Send voicing and frication noise thru parallel resonators.
     Increment resonator amplitudes gradually. *)
  (PROG (RES1 RES2 RES3 RES4 RES5 RES6 RESNP
         REG1P REG2P REG3P REG4P REG5P REG6P REGN UGLOT1)
    (SETQ RES1 (COEFF.RES1 COEFF))
    (SETQ RES2 (COEFF.RES2 COEFF))    
    (SETQ RES3 (COEFF.RES3 COEFF))
    (SETQ RES4 (COEFF.RES4 COEFF))
    (SETQ RES5 (COEFF.RES5 COEFF))
    (SETQ RES6 (COEFF.RES6 COEFF))
    (SETQ RESNP (COEFF.RESNP COEFF))
    (SETQ REG1P (MEMORY.REG1P MEMORY))
    (SETQ REG2P (MEMORY.REG2P MEMORY))    
    (SETQ REG3P (MEMORY.REG3P MEMORY))
    (SETQ REG4P (MEMORY.REG4P MEMORY))
    (SETQ REG5P (MEMORY.REG5P MEMORY))
    (SETQ REG6P (MEMORY.REG6P MEMORY))
    (SETQ REGN (MEMORY.REGN MEMORY))
    (* First formant F1.  Excited by voicing only. *)
    (SPEECH.UPDATE.RES (x$ (COEFF.A1 COEFF) (MEMORY.UGLOT MEMORY))
		       RES1 REG1P)
    (* Nasal pole NP.  Excited by first diff of voicing source. *)
    (SETF (MEMORY.UDIF MEMORY)
	  (-$ (MEMORY.UGLOT MEMORY) (MEMORY.UGLOT1 MEMORY)))
    (SPEECH.UPDATE.RES (x$ (COEFF.ANP COEFF) (MEMORY.UDIF MEMORY))
		       RESNP REGN)
    (* Excite formants F2-F4 with fric noise plus first diff 
       voicing. *)
    (SETF (MEMORY.USUMP MEMORY)
	  (+$ (MEMORY.UDIF MEMORY) (MEMORY.UFRIC MEMORY)))
    (SPEECH.UPDATE.RES (x$ (COEFF.A2 COEFF) (MEMORY.USUMP MEMORY))
		       RES2 REG2P)
    (SPEECH.UPDATE.RES (x$ (COEFF.A3 COEFF) (MEMORY.USUMP MEMORY))
		       RES3 REG3P)
    (SPEECH.UPDATE.RES (x$ (COEFF.A4 COEFF) (MEMORY.USUMP MEMORY))
		       RES4 REG4P)
    (* Excite formant resonators F5-F6 with fric noise. *)
    (SPEECH.UPDATE.RES (x$ (COEFF.A5 COEFF) (MEMORY.UFRIC MEMORY))
		       RES5 REG5P)
    (SPEECH.UPDATE.RES (x$ (COEFF.A6 COEFF) (MEMORY.UFRIC MEMORY))
		       RES6 REG6P)
))

(DEFEXPR (SPEECH.CTW.SUM MEMORY COEFF)
  (* Sum up outputs. *)
  (PROG (REG1P REG2P REG3P REG4P REG5P REG6P REGN REGNPC OUTPUT UCASC
	       UPAR) 
    (SETQ REG1P (MEMORY.REG1P MEMORY))
    (SETQ REG2P (MEMORY.REG2P MEMORY))    
    (SETQ REG3P (MEMORY.REG3P MEMORY))
    (SETQ REG4P (MEMORY.REG4P MEMORY))
    (SETQ REG5P (MEMORY.REG5P MEMORY))
    (SETQ REG6P (MEMORY.REG6P MEMORY))
    (SETQ REGN (MEMORY.REGN MEMORY))
    (SETQ REGNPC (MEMORY.REGNPC MEMORY))
    (* Cascade output. *)
    (SETQ UCASC (MEMORY.UCASC MEMORY))
    (* Add up outputs from NP, F1-F6, and bypass path. *)
    (SETQ UPAR (+$ (REG.T1 REG1P)
		    (0-$ (REG.T1 REG2P))
		    (REG.T1 REG3P)
		    (0-$ (REG.T1 REG4P))
		    (REG.T1 REG5P)
		    (0-$ (REG.T1 REG6P))
		    (REG.T1 REGN)
		    (0-$ (x$ (COEFF.AB COEFF) (MEMORY.UFRIC MEMORY)))))
    (SETF (MEMORY.UPAR MEMORY) UPAR)
    (* Add cascade and parallel vocal tract outputs. *)
    (SETF (MEMORY.ULIPS MEMORY) (+$ UCASC UPAR (MEMORY.PLSTEP MEMORY)))
    (SETQ OUTPUT (FIXR (MEMORY.ULIPS MEMORY)))
    (SETF (MEMORY.PLSTEP MEMORY) (x$ PLCONSTANT (MEMORY.PLSTEP MEMORY)))
    (SETF (MEMORY.OUTPUT MEMORY) OUTPUT)
))

(DEFEXPR (SPEECH.UPDATE.RES INPUT RES REG)
  (* Update memory REG. *)
  (PROG (T1 T2 A B C UPDATE)
    (SETQ T1 (REG.T1 REG))
    (SETQ T2 (REG.T2 REG))
    (SETQ A (RES.A RES))
    (SETQ B (RES.B RES))
    (SETQ C (RES.C RES))
    (SETQ UPDATE (+$ (x$ A INPUT) (x$ B T1) (x$ C T2)))
    (SETF (REG.T2 REG) T1)
    (SETF (REG.T1 REG) UPDATE)
    (RETURN UPDATE)
))

(DEFEXPR (SPEECH.UPDATE.ANTIRES INPUT RES REG)
  (* Update memory REG. *)
  (PROG (T1 T2 A B C UPDATE)
    (SETQ T1 (REG.T1 REG))
    (SETQ T2 (REG.T2 REG))
    (SETQ A (RES.A RES))
    (SETQ B (RES.B RES))
    (SETQ C (RES.C RES))
    (SETQ UPDATE (+$ (x$ A INPUT) (x$ B T1) (x$ C T2)))
    (SETF (REG.T2 REG) T1)
    (SETF (REG.T1 REG) INPUT)
    (RETURN UPDATE)
))

(DEFEXPR (SPEECH.CTW.GAUSSIAN)
  (* Pseudo GAUSSIAN *)
  (PROG (GAUSSIAN)
    (SETQ GAUSSIAN 0.0)
    (FOR I FROM 1 TO 16
     DO (SETQ GAUSSIAN (+$ GAUSSIAN (RAND -0.5 0.5))))
    (RETURN GAUSSIAN)))

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

STOP