(* ;;-*-LISP-*- KEEP EMACS HAPPY ********************************
*
*     PVECTOR.TO.COEF
*
****************************************************************)

(* ****************************************************************
*
*     PVECTORs -- PARAMETER VECTORS
*
*(1) SLICE consists of values
*(2) SEGMENT consists of abstract PATHs
*(3) TRAJ consists of real PATHs
*(4) PATH consists of TVPOINTs
****************************************************************)

(DATATYPE PVECTOR
  (* Parameter Vector *)
  (TYPE SOUND CV COMMENT DURATION
   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))

(SETQ PVECTOR.FIELDNAMES
  (KTH (RECLOOK 'PVECTOR) 4))

(* The PVECTOR fieldnames which are also pnames *)
(SETQ PVECTOR.PNAMES
  (MEMB 'AV PVECTOR.FIELDNAMES))

(DEFEXPR (PVECTOR.GET PVECTOR FIELDNAME)
  (PROG (DESCRIPTOR INDEX ANSWER)
    (SETQ DESCRIPTOR '(PVECTOR INDEX POINTER))
    (SETQ INDEX (PVECTOR.INDEX FIELDNAME))
    (RPLACA (CDR DESCRIPTOR) INDEX)
    (SETQ ANSWER (FETCHFIELD DESCRIPTOR PVECTOR))
    (RETURN ANSWER)
))

(DEFEXPR (PVECTOR.PUT PVECTOR FIELDNAME VALUE)
  (PROG (DESCRIPTOR INDEX ANSWER)
    (SETQ DESCRIPTOR '(PVECTOR INDEX POINTER))
    (SETQ INDEX (PVECTOR.INDEX FIELDNAME))
    (RPLACA (CDR DESCRIPTOR) INDEX)
    (SETQ ANSWER (REPLACEFIELD DESCRIPTOR PVECTOR VALUE))
    (RETURN ANSWER)
))

(DEFEXPR (PVECTOR.INDEX FIELDNAME)
  (FOR I _ 0 BY (+ I 2)
   AS F IN PVECTOR.FIELDNAMES
   WHEN (EQ F FIELDNAME)
   DO (RETURN I)))

(DEFVAR DEFAULT.SLICE)
(DEFVAR OW.SLICE)
(DEFEXPR (PARCOE.INIT)
  (PROG ()
    (SETQ DEFAULT.SLICE
	  (CREATE PVECTOR
		 TYPE _ 'SLICE
		 SOUND _ 'DEFAULT
		 CV _ ""
		 COMMENT _ '(* DEFAULT.SLICE *)
		 DURATION _ 0
		 AV _ 0
		 ASV _ 0
		 AASPIR _ 0
		 AFRIC _ 0
		 F0 _ 0
		 FGP _ 0
		 BGP _ 400
		 FGZ _ 1500
		 BGZ _ 6000
		 FNP _ 250
		 BNP _ 100
		 FNZ _ 250
		 BNZ _ 100
		 BGS _ 200
		 F1 _ 450
		 B1 _ 50
		 F2 _ 1450
		 B2 _ 70
		 F3 _ 2450
		 B3 _ 110
		 F4 _ 3300
		 B4 _ 250
		 F5 _ 3850
		 B5 _ 200
		 F6 _ 4900
		 B6 _ 1000
		 A1 _ 0
		 ANP _ 0
		 A2 _ 0
		 A3 _ 0
		 A4 _ 0
		 A5 _ 0
		 A6 _ 0
		 AB _ 0
		 SWITCH _ 'CASCADE
		 GAIN _ 36
		 NCF _ 5))
    (SETQ OW.SLICE
	  (CREATE PVECTOR
		 TYPE _ 'SLICE
		 SOUND _ 'DEFAULT
		 CV _ ""
		 COMMENT _ '(* OW.SLICE *)
		 DURATION _ NIL
		 AV _ 60.0
		 ASV _ 0.0
		 AASPIR _ 0.0
		 AFRIC _ 0.0
		 F0 _ 118.0
		 FGP _ 0.0
		 BGP _ 400.0
		 FGZ _ 1500.0
		 BGZ _ 6000.0
		 FNP _ 250.0
		 BNP _ 100.0
		 FNZ _ 250.0
		 BNZ _ 100.0
		 BGS _ 200.0
		 F1 _ 510.0
		 B1 _ 80.0
		 F2 _ 1033.333
		 B2 _ 70.0
		 F3 _ 2300.0
		 B3 _ 70.0
		 F4 _ 3300.0
		 B4 _ 250.0
		 F5 _ 3850.0
		 B5 _ 200.0
		 F6 _ 4900.0
		 B6 _ 1000.0
		 A1 _ 0.0
		 ANP _ 0.0
		 A2 _ 0.0
		 A3 _ 0.0
		 A4 _ 0.0
		 A5 _ 0.0
		 A6 _ 0.0
		 AB _ 0.0
		 SWITCH _ 'CASCADE
		 GAIN _ 36.0
		 NCF _ 5))
))

(* ****************************************************************
*
*     INTERPOLATION
*
****************************************************************)

(RECORD TVPOINT (TIME VALUE M B))
(RECORD TVPOINT2 (TIME VALUE))

(DEFEXPR (PARCOE.INTERPOLATE 
	  TIME TRAJ (OPTIONAL OLDSLICE (CREATE PVECTOR)))
  (PROG ()
    (FOR PNAME IN PVECTOR.PNAMES
     DO (PARCOE.INTERPOLATE.PNAME PNAME TIME TRAJ OLDSLICE))
    (RETURN OLDSLICE)
))

(DEFEXPR (PARCOE.INTERPOLATE.PNAME PNAME TIME TRAJ PVECTOR)
  (PROG (PATH LEFTPOINT RIGHTPOINT LTIME RTIME LVALUE RVALUE K VALUE)
    (SETQ PATH (PVECTOR.GET TRAJ PNAME))
    (FOR L IN PATH
     AS R IN (CDR PATH)
     WHEN (AND (<= (TVPOINT.TIME L) TIME)
	       (> (TVPOINT.TIME R) TIME))
     DO (SETQ LEFTPOINT L)
     (SETQ RIGHTPOINT R)
     (RETURN))
    (SETQ LTIME (TVPOINT.TIME LEFTPOINT))
    (SETQ RTIME (TVPOINT.TIME RIGHTPOINT))
    (SETQ LVALUE (TVPOINT.VALUE LEFTPOINT))
    (SETQ RVALUE (TVPOINT.VALUE RIGHTPOINT))
    (COND ((MEMB PNAME '(SWITCH NCF))
	   (SETQ VALUE LVALUE))
	  (T (SETQ K (/$ (-$ TIME LTIME) (-$ RTIME LTIME)))
	     (SETQ VALUE (+$ (x$ K RVALUE) (x$ (-$ 1.0 K) LVALUE)))))
    (PVECTOR.PUT PVECTOR PNAME VALUE)
))

(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 (PARCOE.PTC PVECTOR COEFF)
  (* Calculate synthesizer COEFFicients from PVECTOReters. *)
  (PROG ()
    (PARCOE.GLOTTAL PVECTOR COEFF)
    (PARCOE.VOICING PVECTOR COEFF)
    (PARCOE.ASPIRATION PVECTOR COEFF)
    (PARCOE.FRICATION PVECTOR COEFF)
    (PARCOE.BYPASS PVECTOR COEFF)
    (PARCOE.FORMANTS PVECTOR COEFF)
    (PARCOE.NASAL PVECTOR COEFF)
))

(DEFEXPR (PARCOE.GLOTTAL PVECTOR COEFF)
  (* Glottal resonators and antiresonator. *)
  (PROG (F0 AV PULSN)
    (SETQ F0 (PVECTOR.F0 PVECTOR))
    (* Get voicing amplitude. *)
    (SETQ AV 
	  (PARCOE.GET.AMP
	   (+$ (PVECTOR.AV PVECTOR) (PVECTOR.GAIN PVECTOR) DBSCA.AV)))
    (COND ((OR (=$ F0 0.0)
	       (AND (=$ (PVECTOR.AV PVECTOR) 0.0)
		    (=$ (PVECTOR.ASV PVECTOR) 0.0)))
	   (* No pulse issued. *)    
	   (SETQ PULSN 1))
	  (T (* Waveform more sinusoidal at high fundamental
		frequency. *)
	     (PARCOE.SET.RES 
	      (COEFF.RESGP COEFF)
	      (PVECTOR.FGP PVECTOR)
	      (/$ (x$ 100.0 (PVECTOR.BGP PVECTOR)) F0))
	     (PARCOE.SET.RES 
	      (COEFF.RESGS COEFF)
	      0.0
	      (PVECTOR.BGS PVECTOR))
	     (PARCOE.SET.ANTIRES
	      (COEFF.RESGZ COEFF)
	      (PVECTOR.FGZ PVECTOR)
	      (PVECTOR.BGZ PVECTOR))
	     (* Set gain to constant in mid-frequency region for 
		RESGP. *)
	     (SETF (RES.A (COEFF.RESGP COEFF)) 0.007)
	     (* 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 (PARCOE.VOICING PVECTOR COEFF)
  (* Get amplitude of quasi-sinusoidal voicing source. *)
  (PROG ()
    (SETF (COEFF.ASV COEFF)
	  (x$ 10.0 (PARCOE.GET.AMP 
		    (+$ (PVECTOR.ASV PVECTOR) 
			(PVECTOR.GAIN PVECTOR)
			DBSCA.ASV))))
))

(DEFEXPR (PARCOE.ASPIRATION PVECTOR COEFF)
  (* Get aspiration amplitude. *)
  (PROG ()
    (SETF (COEFF.AASPIR COEFF) 
	  (PARCOE.GET.AMP 
	   (+$ (PVECTOR.AASPIR PVECTOR) 
	       (PVECTOR.GAIN PVECTOR)
	       DBSCA.AASPIR)))
))

(DEFEXPR (PARCOE.FRICATION PVECTOR COEFF)
  (* Get frication amplitude. *)
  (PROG (AFRIC AFRIC1 GAIN PLSTEP)
    (* AFRIC1 = frication amplitude from previous PARCOE *)
    (SETQ AFRIC (PVECTOR.AFRIC PVECTOR))
    (SETQ AFRIC1 (COEFF.AFRIC1 COEFF))
    (SETQ GAIN (PVECTOR.GAIN PVECTOR))
    (SETF (COEFF.AFRIC COEFF)
	  (PARCOE.GET.AMP (+$ GAIN AFRIC DBSCA.AFRIC)))
    (SETF (COEFF.AFRIC1 COEFF) AFRIC)
    (* Add a step to waveform at a plosive relase. *)
    (COND ((<$ (-$ AFRIC AFRIC1) 49)
	   (SETQ PLSTEP 0.0))
	  (T (SETQ PLSTEP (PARCOE.GET.AMP (+$ GAIN DBSCA.AFRIC 44)))))
    (SETF (COEFF.PLSTEP COEFF) PLSTEP)
))

(DEFEXPR (PARCOE.BYPASS PVECTOR COEFF)
  (* Bypass Amplitude *)
  (PROG ()
    (SETF (COEFF.AB COEFF)
	  (PARCOE.GET.AMP (+$ (PVECTOR.AB PVECTOR) DBSCA.AB)))
))

(DEFEXPR (PARCOE.FORMANTS PVECTOR COEFF)
  (* Set up resonators for formants F1-F6. *)
  (PROG ()
    (PARCOE.SET.RES
     (COEFF.RES1 COEFF)
     (PVECTOR.F1 PVECTOR)
     (PVECTOR.B1 PVECTOR))
    (PARCOE.SET.RES
     (COEFF.RES2 COEFF)
     (PVECTOR.F2 PVECTOR)
     (PVECTOR.B2 PVECTOR))
    (PARCOE.SET.RES
     (COEFF.RES3 COEFF)
     (PVECTOR.F3 PVECTOR)
     (PVECTOR.B3 PVECTOR))
    (PARCOE.SET.RES
     (COEFF.RES4 COEFF)
     (PVECTOR.F4 PVECTOR) 
     (PVECTOR.B4 PVECTOR))
    (PARCOE.SET.RES
     (COEFF.RES5 COEFF)
     (PVECTOR.F5 PVECTOR)
     (PVECTOR.B5 PVECTOR))
    (PARCOE.SET.RES
     (COEFF.RES6 COEFF)
     (PVECTOR.F6 PVECTOR)
     (PVECTOR.B6 PVECTOR))
))

(DEFEXPR (PARCOE.NASAL PVECTOR COEFF)
  (* Nasal resonator and antiresonator. *)
  (PROG ()
    (PARCOE.SET.RES
     (COEFF.RESNP COEFF)
     (PVECTOR.FNP PVECTOR)
     (PVECTOR.BNP PVECTOR))
    (PARCOE.SET.ANTIRES 
     (COEFF.RESNZ COEFF)
     (PVECTOR.FNZ PVECTOR)
     (PVECTOR.BNZ PVECTOR))
    (SETF (COEFF.ANP COEFF)
	  (PARCOE.GET.AMP (+$ (PVECTOR.ANP PVECTOR) DBSCA.ANP)))
))

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

(DEFEXPR (PARCOE.GET.AMP DB)
  (* Convert DB attenuation to linear scale factor *)
  (EXPT 2.0 (/$ DB 6.0)))

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

(DEFEXPR (RANGECHECK VALUE MIN MAX)
  (* Coerce VALUE to lie in interval (MIN,MAX) *)
  (COND ((<$ VALUE MIN) MIN)
	((>$ VALUE MAX) MAX)
	(T VALUE)))

(DEFEXPR (PARCOE.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)))
    (* Update RES. *)
    (SETF (RES.A RES) A)
    (SETF (RES.B RES) B)
    (SETF (RES.C RES) C)
    (RETURN RES)
))

(DEFEXPR (PARCOE.SET.ANTIRES ANTIRES FREQUENCY BANDWIDTH)
  (* Set up ANTIRES 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 (0-$ (x$ TWOPIT FREQUENCY)) T)))
    (SETQ A (+$ 1.0 (0-$ B) (0-$ C)))
    (SETQ A (/$ 1.0 A))
    (SETQ B (0-$ (x$ A B)))
    (SETQ C (0-$ (x$ A C)))
    (* Update ANTIRES. *)
    (SETF (RES.A ANTIRES) A)
    (SETF (RES.B ANTIRES) B)
    (SETF (RES.C ANTIRES) C)
    (RETURN ANTIRES)
))

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

STOP