Program TVSA3;  { Simple VSA Lie Detector In Turbo Pascal}

{$N+,E+} {this line makes tvsa2.exe, remove it to make tvsa2fpu.exe}

uses Crt, Dos;

Const

  NumSamples     = 16*1024;           {Must be a power of two}
  NumSamplesDiv2 = NumSamples div 2;

  SegmentLength  = 2048;

  SamplingRate   = 11025;

  MagnifyIndexes = 8;

  Volume         = 8000;

  Scale : Array[0..40] Of Word = (

   { A    A#     B     C    C#     D    D#     E     F    F#     G    G# }
    220,  233,  247,  262,  277,  294,  311,  330,  349,  370,  392,  415,
    440,  466,  494,  523,  554,  587,  622,  659,  698,  740,  784,  831,
    880,  932,  987, 1047, 1109, 1175, 1245, 1329, 1397, 1480, 1568, 1661,
   1760, 1865, 1976, 2093, 2217);

type

  RealType      = array[0..NumSamplesDiv2   -1] of real;
  AudioType     = array[0..NumSamples       -1] of integer;
  AudioByteType = array[0..NumSamples*2     -1] of byte;

  AD_type       = array[0..NumSamples div 8 -1] of integer;

  FreqVolType   = array[0..32000]               of word;

var

  InputFile, OutputFile    : file;

  FileNameIn,FileNameOut   : string;

  FileInfo                 : SearchRec;

  RealData1                : ^RealType; {These arrays are broken in two}
  RealData2                : ^RealType; {because of the 64K limit in TP}
  BellCurve1               : ^RealType;
  BellCurve2               : ^RealType;

  AudioData                : ^AudioType;
  AudioByte                : ^AudioByteType;
  AD1,AD2,AD3,AD4          : ^AD_type;
  AD5,AD6,AD7,AD8          : ^AD_type;

  FT,VT                    : ^FreqVolType;

  DataSegments             : word;
  FileSizeRead             : word;
  FileCount                : word;
  InPath,OutPath,HomePath  : string;

  StatusString,ps1,ps2,ps3 : string;

  Threshold                : word;
  Threshold_p              : boolean;

  ValidSegmentCount        : word;
  HighestFrequency         : word;
  LowestFrequency          : word;
  AverageFrequency         : word;

{\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/}
{                                                                          }
{                           FFT Math Engine                                }
{               Customized from Don Cross' Fourier Unit at:                }
{             http://www.intersrv.com/~dcross/fft.html#pascal              }
{                                                                          }
{       Other FFT engines can be found on the web in the "swag files,"     }
{         as well as public domain wave players that might be handy.       }
{                http://www.aimsweb.com/SWAG/downloads.html                }

Function CalcFrequencyMagnitude( FrequencyIndex: word): Real;

var

  k: word;

  RO, IO, cos1, cos2, cos3, sin1, sin2, sin3, beta, theta: Real;

begin

  theta:= 2*PI * FrequencyIndex / (NumSamples * MagnifyIndexes);

  sin1:= sin(-2 * theta);
  sin2:= sin(    -theta);
  cos1:= cos(-2 * theta);
  cos2:= cos(    -theta);

  beta:= 2 * cos2;

  RO:= 0.0;  IO:= 0.0;

  for k := 0 to NumSamplesDiv2 - 1 do begin

    sin3:= beta*sin2 - sin1;   sin1:= sin2;   sin2:= sin3;
    cos3:= beta*cos2 - cos1;   cos1:= cos2;   cos2:= cos3;

    RO:=RO + RealData1^[k] * cos3;
    IO:=IO + RealData1^[k] * sin3;
  end;

  for k := 0 to NumSamplesDiv2 - 1 do begin

    sin3:= beta*sin2 - sin1;   sin1:= sin2;   sin2:= sin3;
    cos3:= beta*cos2 - cos1;   cos1:= cos2;   cos2:= cos3;

    RO:=RO + RealData2^[k] * cos3;
    IO:=IO + RealData2^[k] * sin3;
  end;

  CalcFrequencyMagnitude:=sqrt(RO*RO + IO*IO);
end;

{                                                                          }
{\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/}


FUNCTION IsDir( Dir: STRING ) : BOOLEAN; {from the swag files}
VAR
   fHandle: FILE;
   wAttr: WORD;
BEGIN
     WHILE Dir[LENGTH(Dir)] = '\' DO DEC( Dir[0] );
     Dir := Dir + '\.';
     ASSIGN( fHandle, Dir );
     GETFATTR( fHandle, wAttr );
     IsDir := ( (wAttr AND DIRECTORY) = DIRECTORY );
END;

{\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/}

Procedure GetMemory;

begin

  GetMem(AudioData , SizeOf(AudioType));
  GetMem(RealData1 , SizeOf(RealType));
  GetMem(RealData2 , SizeOf(RealType));
  GetMem(BellCurve1, SizeOf(RealType));
  GetMem(BellCurve2, SizeOf(RealType));
  GetMem(FT        , SizeOf(FreqVolType));
  GetMem(VT        , SizeOf(FreqVolType));

  AudioByte:=@AudioData^;
end;

{--------------------------------------------------------------------------}

Procedure FreeMemory;

begin

  FreeMem(VT        , SizeOf(FreqVolType));
  FreeMem(FT        , SizeOf(FreqVolType));
  FreeMem(BellCurve2, SizeOf(RealType));
  FreeMem(BellCurve1, SizeOf(RealType));
  FreeMem(RealData2 , SizeOf(RealType));
  FreeMem(RealData1 , SizeOf(RealType));
  FreeMem(AudioData , SizeOf(AudioType));
end;

{--------------------------------------------------------------------------}

Procedure Waitkey;

var junk: char;

begin  junk:=readkey;  end;

{--------------------------------------------------------------------------}

Procedure Beep;

begin sound(800); delay(100);  nosound; delay(100); end;

{--------------------------------------------------------------------------}

Procedure DisplayFrequencyIndexes;

var
  w: word;
  FreqIndex: real;

begin { This formula derives the frequencies represented in the FFT indexes,}
      { used as constants in FindTruth. This proc isn't used by the program.}

  clrscr;

  for w := 101 to 137 do begin

    FreqIndex:=w;

    writeln('Index = ',w,

  ' Frequency = ', (SamplingRate * FreqIndex) / (NumSamples*MagnifyIndexes));
  end;

  waitkey; halt;
end;

{--------------------------------------------------------------------------}

Procedure CheckExit;

var ch: char;

begin

  if keypressed then begin

    ch:=readkey;

    if ord(ch) = 27 then begin

      beep; beep; beep;

      writeln('');  writeln('');

      writeln('Program halted by user.');   writeln('');

      FreeMemory;

      halt;
    end;
  end;
end;

{--------------------------------------------------------------------------}

Procedure CommandLineError(ErrorType: string);

begin

  writeln(ErrorType);
  writeln('');
  writeln('');
  writeln('Press any key to exit program...');

  beep; beep; beep; waitkey; halt;
end;

{--------------------------------------------------------------------------}

Procedure CheckCommandLine;

var  err: integer;

begin

  ps1:=ParamStr(1);  ps2:=ParamStr(2);  ps3:=ParamStr(3);

  if ps3 = '' then CommandLineError('Incomplete Command Line.');


  threshold_p:=false;

  if ps3[length(ps3)] = '%' then begin

    ps3:=copy(ps3,1,length(ps3)-1); threshold_p:=true;
  end;

  val(ps3,Threshold,err);

  if (err <> 0) then      CommandLineError('Non-numeric Threshold Value.');

  if threshold_p then begin

    if (Threshold < 1) or (Threshold > 99) then

                          CommandLineError('Invalid Threshold Value.');
   end
  else

    if (Threshold < 80) or (Threshold > 120) then

                          CommandLineError('Invalid Threshold Value.');

  if not threshold_p then Threshold:=Threshold-80;


  FindFirst(ps1, Archive, FileInfo);

  if DosError <> 0 then   CommandLineError('Can''t Find Input Files.');



  if ps2[length(ps2)] = '\' then ps2:=copy(ps2,1,length(ps2)-1);


  if not IsDir(ps2) then  CommandLineError('Invalid Ouput Path.');
end;

{--------------------------------------------------------------------------}

Procedure Initialize;

var  w,x: word;
     fn : text;
     s  : string;
begin

  clrscr;
{
  writeln('Warning! If your computer has a math coprocessor,');
  writeln('you should use TVSA3.EXE for much greater speed.');
}
  writeln('Warning! If your computer doesn''t have a math coprocessor,');
  writeln('you should use TVSA3FPU.EXE for much greater speed.');

  writeln('');
  writeln('TVSA3:  A freeware Voice Stress Analysis lie detector.');
  writeln('        See TruthVSA.txt or .htm for details.');
  writeln('');
  writeln('Command line:  tvsa3  InputFiles  OutputPath  StressThreshold');
  writeln('');
  writeln('StressThreshold as a percentage: 1 - 99%');
  writeln('');
  writeln('  Example for top 20%: tvsa3 c:\vsa\in\*.mp3 c:\vsa\out 80%');
  writeln('');
  writeln('StressThreshold as absolute, in Hz x 10, 80 - 120');
  writeln('');
  writeln('  Example for 10 Hz:   tvsa3 c:\vsa\in\*.mp3 c:\vsa\out 100');
  writeln('');
  writeln('You typed: '
    +ParamStr(0)+' '+ParamStr(1)+' '+ParamStr(2)+' '+ParamStr(3));
  writeln('');

  CheckCommandLine;

  writeln('Working... Press ESC to abort. (It may take a few seconds to exit.)');
  writeln('');


  x:=0; s:=ParamStr(0);

  for w:=1 to length(s) do if s[w] = '\' then x:=w;

  HomePath:=copy(s,1,x);

  x:=0; s:=ps1;

  for w:=1 to length(s) do if s[w] = '\' then x:=w;

  InPath:=copy(s,1,x);

  OutPath:=ps2+'\';


  FindFirst(HomePath+'tvsa-log.txt', Archive, FileInfo);

  if DosError <> 0 then begin

    assign(fn,HomePath+'tvsa-log.txt');  rewrite(fn);  close(fn);
  end;


  getmemory;

  for w:=0 to NumSamplesDiv2 - 1 do begin

    BellCurve1^[w] := -cos(2*pi* w                / NumSamples)+1;

    BellCurve2^[w] := -cos(2*pi*(w+NumSamplesDiv2)/ NumSamples)+1;
  end;

  { The bellcurve is a fancy volume fade that reduces distortion
    of the FFT output, and allows the use of MagnifyIndex to more
    accurately define the target frequencies. }

  AD1:=@AudioData^[SegmentLength * 0]; {These pointers are used to shuttle  }
  AD2:=@AudioData^[SegmentLength * 1]; {the sample 1/8 forward in the buffer}
  AD3:=@AudioData^[SegmentLength * 2];
  AD4:=@AudioData^[SegmentLength * 3];
  AD5:=@AudioData^[SegmentLength * 4];
  AD6:=@AudioData^[SegmentLength * 5];
  AD7:=@AudioData^[SegmentLength * 6];
  AD8:=@AudioData^[SegmentLength * 7];
end;

{--------------------------------------------------------------------------}

Procedure Read8Segments;

var x: word;

begin

  BlockRead( InputFile, AudioData^, NumSamples * 2, FileSizeRead);

  if FileSizeRead = NumSamples * 2 then

    for x:=0 to NumSamplesDiv2 - 1 do begin

      RealData1^[x]:=AudioData^[x]                * BellCurve1^[x];

      RealData2^[x]:=AudioData^[x+NumSamplesDiv2] * BellCurve2^[x];
    end;
end;

{--------------------------------------------------------------------------}

Procedure ReadRealSegment;

var x: word;

begin

  AD1^:=AD2^;  AD2^:=AD3^;  AD3^:=AD4^;
  AD4^:=AD5^;  AD5^:=AD6^;  AD6^:=AD7^;  AD7^:=AD8^;

  BlockRead( InputFile, AD8^, SegmentLength * 2, FileSizeRead);

  if FileSizeRead = SegmentLength * 2 then

    for x:=0 to NumSamplesDiv2 - 1 do begin

      RealData1^[x]:=AudioData^[x]                * BellCurve1^[x];

      RealData2^[x]:=AudioData^[x+NumSamplesDiv2] * BellCurve2^[x];
    end;
end;

{--------------------------------------------------------------------------}

Procedure ReadSegment;

begin

  BlockRead( InputFile, AudioData^, SegmentLength * 2, FileSizeRead);
end;

{--------------------------------------------------------------------------}

Procedure Read3point5Segments;

begin

  BlockRead( InputFile, AudioData^,SegmentLength * 7, FileSizeRead);
end;

{--------------------------------------------------------------------------}

Procedure Write3point5Segments;

begin

  BlockWrite(OutputFile,AudioData^,SegmentLength * 7);
end;

{--------------------------------------------------------------------------}

Procedure WriteSegment;

begin

  BlockWrite(OutputFile,AudioData^,SegmentLength*2);
end;

{--------------------------------------------------------------------------}

Procedure WriteLastSamples;

begin

  BlockRead ( InputFile,  AudioData^, NumSamples * 2, FileSizeRead);

  If FileSizeRead > 1 then

    BlockWrite( OutputFile, AudioData^, FileSizeRead);
end;

{--------------------------------------------------------------------------}

Function FreqStr(F:word): string;

var  s: string;

begin

  str(f+80,s);

  FreqStr:=copy(s,1,length(s)-1) +'.'+ copy(s,length(s),1);

end;

{--------------------------------------------------------------------------}

Procedure WriteLogFile;

var w,Y,M,D,DW,Hr,Mn,Sc,Sc100 : word;

    fn: text;

begin

  for w:=1 to length(StatusString) do write(chr(8));

  writeln('File Out            = ',OutPath + FileNameOut);

  write(  'Threshold           = ',FreqStr(Threshold),' Hz');
  if threshold_p then  write(' = '+paramstr(3));
  writeln;

  writeln('Highest Frequency   = ',FreqStr(HighestFrequency),' Hz');
  writeln('Lowest  Frequency   = ',FreqStr(LowestFrequency ),' Hz');
  writeln('Average Frequency   = ',FreqStr(AverageFrequency),' Hz');

  GetDate(Y, M, D, DW);  GetTime(Hr, Mn, Sc, Sc100);

  assign(fn,HomePath+'tvsa-log.txt');

  append(fn);

  writeln(fn,'');
  writeln(fn,'Date  M/D/Y Hr.Min  = ',M,'/',D,'/',Y,' ',Hr,'.',Mn);
  writeln(fn,'File In             = ',InPath  + FileNameIn);
  writeln(fn,'File Out            = ',OutPath + FileNameOut);

  write(fn,  'Threshold           = ',FreqStr(Threshold),' Hz');
  if threshold_p then  write(fn,' = '+paramstr(3));
  writeln(fn);

  writeln(fn,'Highest Frequency   = ',FreqStr(HighestFrequency),' Hz');
  writeln(fn,'Lowest  Frequency   = ',FreqStr(LowestFrequency ),' Hz');
  writeln(fn,'Average Frequency   = ',FreqStr(AverageFrequency),' Hz');

  close(fn);
end;

{--------------------------------------------------------------------------}

Procedure ShowStatus;

var

  w    : word;
  s1,s2: string;

begin

  if length(StatusString) > 0 then

    for w:=1 to length(StatusString) do write(chr(8));

  str((DataSegments+3) * 4  ,s1);
  str(FileInfo.size div 1024,s2);

  StatusString:= '   ' + s1 + ' of ' + s2 + ' K... ';

  write(StatusString);
end;

{--------------------------------------------------------------------------}

Function GetAverageFrequency(rx: array of Real): word;

var ry: array[0..40] of real;

    x,y   : word;

    r,t,t2: real;

begin

  for x:=0 to 7 do begin

    if rx[x+1] <> rx[x] then begin

      r:=(rx[x+1]-rx[x]) / 5;

          for y:=0 to 4 do  ry[x*5 +y]:=rx[x] + y*r;
     end
    else  for y:=0 to 4 do  ry[x*5 +y]:=rx[x];
  end;

  ry[40]:=rx[8];

  t :=0;  for x:=0 to 40 do t:=t+ry[x];

  t:=t/2;

  t2:=0; x:=0;

  repeat

    t2:=t2+ry[x];  inc(x);

  until t2 > t;

  GetAverageFrequency:=x-1;
end;

{--------------------------------------------------------------------------}

Function FindTruth: word;

var  rx: array[0..8] of Real;

begin

  rx[0]:=CalcFrequencyMagnitude( 95); {  8.0 Hz}
  rx[1]:=CalcFrequencyMagnitude(101); {  8.5}
  rx[2]:=CalcFrequencyMagnitude(107); {  9.0}
  rx[3]:=CalcFrequencyMagnitude(113); {  9.5}
  rx[4]:=CalcFrequencyMagnitude(119); { 10.0}
  rx[5]:=CalcFrequencyMagnitude(125); { 10.5}
  rx[6]:=CalcFrequencyMagnitude(131); { 11.0}
  rx[7]:=CalcFrequencyMagnitude(137); { 11.5}
  rx[8]:=CalcFrequencyMagnitude(143); { 12.0}

  FindTruth:=GetAverageFrequency(rx);
end;

{--------------------------------------------------------------------------}

Procedure AddFrequency(F: word);

var PI2,PiT   : real;
    Freq,T,dt : real;
    i,y       : word;
    L         : longint;

begin

  Freq:=scale[F];

  dt:= 1.0 / SamplingRate;

  T := 0.0;

  PI2:=Freq*2*PI;

  for i := 0 to NumSamples div 8 - 1 do begin

    PiT:=PI2*T;

    T := T + dt;

    L:=AudioData^[i] + round( Volume * (sin(PiT) + cos(PiT)));

    if      L >  32767 then L:=  32767
    else if L < -32768 then L:= -32768;

    AudioData^[i]:=L;
  end;
end;

{--------------------------------------------------------------------------}

Function GetVolume: word;

var  T: Real;
     x: word;

begin

  T:=1;

  for x:=7168 to 8191 do  T:=T + abs(RealData1^[x]);
  for x:=   0 to 1023 do  T:=T + abs(RealData2^[x]);

  T:=T / (8192);

  GetVolume:=round(T);
end;

{--------------------------------------------------------------------------}

Procedure ProcessStats;

var

  T              : longint;
  R              : real;
  w,AverageVolume: word;

begin

  T:=0;  for w:=0 to DataSegments-1 do T:=T + VT^[w];

  AverageVolume:= T div DataSegments;

  ValidSegmentCount:=DataSegments;

  AverageFrequency:= 0;
  HighestFrequency:= 0;
  LowestFrequency :=40;

  for w:=0 to DataSegments-1 do

    if VT^[w] < AverageVolume then begin

      FT^[w]:=0;

      dec(ValidSegmentCount);
     end
    else begin

      AverageFrequency:=AverageFrequency + FT^[w];

      if FT^[w] > HighestFrequency then HighestFrequency:=FT^[w];

      if FT^[w] < LowestFrequency  then LowestFrequency :=FT^[w];
    end;

  AverageFrequency:=round(AverageFrequency/ValidSegmentCount);

  r:=HighestFrequency - LowestFrequency;

  r:=(((r * threshold)+1) / 100) + LowestFrequency;

  if threshold_p then threshold:=round(r);
end;

{--------------------------------------------------------------------------}

Procedure ProcessFile;

var  w: word;

begin

  CheckExit;

  assign(InputFile, InPath  + FileNameIn);
  assign(OutputFile,OutPath + FileNameOut);

  Reset(InputFile,1);

  DataSegments:=0;  StatusString:='';

  Read8Segments;

  FileSizeRead:= SegmentLength * 2;

  While (FileSizeRead = SegmentLength * 2) and (DataSegments < 32000) do

  begin

    ShowStatus;

    FT^[DataSegments]:=FindTruth;

    VT^[DataSegments]:=GetVolume;

    ReadRealSegment;

    inc(DataSegments);

    CheckExit;
  end;


  Close(InputFile);


  ProcessStats;

  CheckExit;

  Reset(InputFile,1);  Rewrite(OutputFile,1);

  Read3point5Segments; Write3point5Segments; {advance to first reading}

  for w:=0 to DataSegments-1 do begin

    ReadSegment;

    if FT^[w] >= Threshold then  AddFrequency(FT^[w]);

    WriteSegment;

    CheckExit;
  end;

  WriteLastSamples;

  Close(InputFile);  Close(OutputFile);
end;

{--------------------------------------------------------------------------}

{                              Main                                        }

var  x,w: word;  k:char;

begin

  Initialize;

  FileCount:=0;

  FindFirst(ParamStr(1), Archive, FileInfo);

  while DosError = 0 do begin

    FileNameIn :=FileInfo.Name;

    x:=pos('.',FileNameIn);

    if x = 0 then FileNameOut:=FileNameIn+'.vsa'

    else          FileNameOut:=copy(FileNameIn,1,x) + 'vsa';

    writeln('');
    writeln(     'Analysing: ',FileNameIn);
    writeln('');

    ProcessFile;  WriteLogFile;

    inc(FileCount);

    FindNext(FileInfo);
  end;

  freememory;

  writeln('');

  writeln(FileCount,' files analysed.');

  Beep; Beep; Beep;
end.