#!/usr/local/bin/perl

#Vocale - a semi-automatic tool for the prosodic annotation of speech
#developed by Dr. Jesus Garcia, Sao Paulo, and Dr. Ulrike Gut, Bielefeld
#we are grateful to Dr. Arnaldo Mandel, Sao Paulo, for his help
#
#This tool takes a wav file at 11025 Hz as input and runs on Windows
#
# Read in the data file
# Print out a HTML formatted lines
#

$file = @ARGV[0]; 
open ( REP, ">praatscript" );
printf( REP "Read from file... $file.WAV
To Spectrogram... 0.005 5000 0.002 50 Gaussian
To Matrix
Transpose
Write to text file... $file.Matrix");
  close(REP);

# call praatcon, the console version of Praat (Windows 95, 98, ME)
# for linux or unix replace for " system('praat praatscript');"

system('praatcon praatscript');

print ("xxxxxxxxxxx \n");

$f0=100; 
$f1=1000; #entropy is calculated for freq lower than $f1 
$fubl=3200; #nasals band lower value
$fubu=4200; #nasals band upper value
$c2=5.5;    #threshold for vowels
$c3=6;    #threshold for consonants
$c4=.0002; #threshold for nasals, energy above 1 kHz
$c5=.002; #threshold for pauses, total energy (between 0 and 5000 Hz)
$c6=.06; #energy of fricatives (0-1000)
$mpl=10;  #minimal pause length 
$mvl=7;   #minimal vowel length 
$mcl=4;   #minimal consonant length


open(INFO, "<$file.Matrix") ;                

open ( REP, ">track.txt" ) ;

 print ("$y0 ");

$k=0;
$kk=0;


 while( $linea=<INFO>) {
   last if $linea =~ /:/;
print $linea;   
   @l_sep= split ( /=/ , $linea ) ;
     if($l_sep[0] eq 'xmin '){$xmin =$l_sep[1];}
     if($l_sep[0] eq 'xmax '){$xmax =$l_sep[1];}
     if($l_sep[0] eq 'nx '){$nx =$l_sep[1]; $nx--;}
     if($l_sep[0] eq 'dx '){$dx =$l_sep[1];
			    $y0=int($f0/$dx);
			    $y2=int($f1/$dx);
			    $yubl=int($fubl/$dx);
			    $yubu=int($fubu/$dx);
			}
    if($l_sep[0] eq 'x1 '){$x1 =$l_sep[1];}
    if($l_sep[0] eq 'ymin '){$ymin =$l_sep[1];}
    if($l_sep[0] eq 'ymax '){$ymax =$l_sep[1];}
    if($l_sep[0] eq 'ny '){$ny =$l_sep[1];}
    if($l_sep[0] eq 'dy '){$dy =$l_sep[1];;}
    if($l_sep[0] eq 'y1 '){$y1 =$l_sep[1];}
}
@meanenergy = 0 x $ny;
@energyl = 0 x $ny;
@energy = 0 x $ny;
 @buf0 = 0 x $nx;
 @buf1 = 0 x $nx;
 @buf2 = 0 x $nx;
 @buf3 = 0 x $nx;
 $pk0 = \@buf0;
 $pk1 = \@buf1;
 $pk2 = \@buf2;
 $pk3 = \@buf3;

# reading four initial columns from the spectrogram wich is in INFO
$linea = <INFO>;
&readcol($pk0);
&normalize ($pk0);
$linea = <INFO>;
&readcol($pk1);
&normalize ($pk1);
$linea = <INFO>;
&readcol($pk2);
&normalize ($pk2);
$linea = <INFO>;
&readcol($pk3);
&normalize ($pk3);

$yy = 3;
START: while (1) {
  $ent1 = $ent2 = $ent3 = 0;
  for ($i=$y0; $i < $y2; $i++){

#  Calculation of the relative entropy

    $ent1 += $pk0->[$i]*log($pk0->[$i]/$pk1->[$i]);
    $ent2 += $pk0->[$i]*log($pk0->[$i]/$pk2->[$i]);
    $ent3 += $pk0->[$i]*log($pk0->[$i]/$pk3->[$i]);
  }
# mean value of those 3 rel. entr. 
  
$rse123 = 10*($ent1+$ent2+$ent3)/3;

# smoothing
 
  $suave[$yy]=($seviejo3+$seviejo2+$seviejo+$rse123)/4;

# classification of each column of the spectrogram as either consonant (2) or vowel (1)

  if($clase[$yy-2]==1){
		    if ($suave[$yy-1]<$c3){$clase[$yy-1]=1+0;}
		    if ($suave[$yy-1]>=$c3){
			if  ($suave[$yy]>=$c3){ $clase[$yy-1]=2+0;}
			if  ($suave[$yy]<$c3){ $clase[$yy-1]=1+0;}
		    }}
  if($clase[$yy-2]==2){
		    if ($suave[$yy-1]>$c2){$clase[$yy-1]=2+0;}
		    if ($suave[$yy-1]<=$c2){
			if  ($suave[$yy]<=$c2){ $clase[$yy-1]=1+0;}
			if  ($suave[$yy]>$c2){ $clase[$yy-1]=2+0;}
		    }}
# identification of nasals and fricatives

  if($uenergy[$yy-1]<=$c4){$clase[$yy-1]=2+0;}
  if($lenergy[$yy-1]<=$c6){$clase[$yy-1]=2+0;}

  $seviejo3=$seviejo2;
  $seviejo2=$seviejo;
  $seviejo=$rse123;

  printf (REP "$kk $clase[$yy-2] $suave[$yy-2] \n");

  ($pk0, $pk1, $pk2, $pk3) =  ($pk1, $pk2, $pk3, $pk0);
  last START unless defined ($linea = <INFO>);
  &readcol($pk0);
  &normalize ($pk0);
  $yy++;
}


close(REP);


# Identification of pauses

for($k=3;$k<=$ny-3;$k++){ 
$meanenergy[$k]=($energy[$k]+$energy[$k-3]+$energy[$k-1]+$energy[$k-2])/4;

if($meanenergy[$k]<=$c5){$pclase[$k]=0+0;}
			  else{$pclase[$k]=1+0;}
		      }

# classification of pauses (0) for each column of the spectrogram

$ca=$pclase[$3];

# checking that pauses are longer than $mpl (20ms)

for($k=4;$k<=$ny-3;$k++)
{
if($pclase[$k]==$ca){$consec=$consec+1;}
if($pclase[$k] ne $ca)
{
    if($ca==0){
	if($consec<=$mpl){
	    for($ind=$k-$consec;$ind<=$k-1;$ind++){$pclase[$ind]=1+0;}
	}
    }

    $ca=$pclase[$k];
    $consec=1;
}
}

# checking that non-pause intervals are longer than 40ms

$ca=$pclase[$3];
for($k=4;$k<=$ny-3;$k++)
{
if($pclase[$k]==$ca){$consec=$consec+1;}
if($pclase[$k] ne $ca)
{
    if($ca==1){
	if($consec<=20){ 
	    for($ind=$k-$consec;$ind<=$k-1;$ind++){$pclase[$ind]=0+0;}
	}
    }

    $ca=$pclase[$k];
    $consec=1;
}
}

# checking that vowels are longer than $mvl (14ms)

for($k=3;$k<=$ny-3;$k++){ if($pclase[$k]==0){$clase[$k]=0+0;}}

$ca=$clase[3];
for($k=4;$k<=$ny-3;$k++)
{
if($clase[$k]==$ca){$consec=$consec+1;}
if($clase[$k] ne $ca)
{
    if($ca==1){
	if($consec<=$mvl){
	    for($ind=$k-$consec;$ind<=$k-1;$ind++){$clase[$ind]=2+0;}
	}
    }

    $ca=$clase[$k];
    $consec=1;
}
}

# checking that consonants are longer than $mvl (14ms)

$ca=$clase[3];
for($k=4;$k<=$ny-3;$k++)
{
if($clase[$k]==$ca){$consec=$consec+1;}
if($clase[$k] ne $ca)
{
    if($ca==2){
	if($consec<=$mcl){
	    for($ind=$k-$consec;$ind<=$k-1;$ind++){$clase[$ind]=1+0;}
	}
    }
    $ca=$clase[$k];
    $consec=1;
}
}


# deleting pause-consonant-pause sequences on the final labeling

$ca=$clase[3];
@label[0]=$ca;
for($k=4;$k<=$ny-7;$k++)
{
if($clase[$k]==$ca){$consec=$consec+1;}
if($clase[$k] ne $ca)
{
    $nclases++;
    @label[$nclases]=$clase[$k];
    if($nclases>=2 &&  @label[$nclases-2]==0 &&  @label[$nclases-1]==2 &&  @label[$nclases]==0 ){  
	for($ind=$k-$consec;$ind<=$k-1;$ind++){$clase[$ind]=0+0;}
	$label[$nclases-1]=0+0;

    }

    $ca=$clase[$k];
    $consec=1;
}
}

for($k=1;$k<=$ny;$k++){$tvocal=$tvocal+$clase[$k];}

$pvocal=$tvocal/$nx;

$nc=-1;
open ( REP, ">>clas.txt" ) ;
open ( REV, ">>dvog.txt" ) ;
open ( REC, ">>dcon.txt" ) ;
$ca=$clase[3];
$kk=0;
$inter[$kk]=0;
for($k=4;$k<=$ny-10;$k++)
{
$kd=2*$k/1000;



# Creating the textgrid Praat file

if(@clase[$k]!=$ca){
    if (@clase[$k]==1){	

	if(@clase[$k-1]==0){
	    $np++;
	    @pau[$np]=$kd-$nlast;
	    $nlast=$kd;
	    printf (REP "$kd $np @pau[$np] p \n");
	    $kk++;
	    @inter[$kk]=$kd;
	    @interclas[$kk]='"p"';
            if($nv>=1){printf (REPAU "@pau[$nc] \n");}
	}
	if(@clase[$k-1]==2){
	    $nc++;
	    @con[$nc]=$kd-$nlast;
	    $nlast=$kd;
	    printf (REP "$kd $nc @con[$nc] c \n");
	    $kk++;
	    @inter[$kk]=$kd;
	    @interclas[$kk]='"c"';
	    if($nc>=1){printf (REC "@con[$nc] \n");}
	}
    }
    if (@clase[$k]==2){	
	if(@clase[$k-1]==1){
	    $nv++;
	    @vog[$nv]=$kd-$nlast;
	    $nlast=$kd;
	    printf (REP "$kd $nv @vog[$nv] v \n");
	    $kk++;
	    @inter[$kk]=$kd;;
	    @interclas[$kk]='"v"';;
	    printf (REV "@vog[$nv] \n");
	}	              
	if(@clase[$k-1]==0){
	    $np++;
	    @pau[$np]=$kd-$nlast;
	    $nlast=$kd;
	    printf (REP "$kd $np @pau[$np] p \n");
	    $kk++;
	    @inter[$kk]=$kd;
	    @interclas[$kk]='"p"';
            if($nv>=1){printf (REPAU "@pau[$nc] \n");}
	}
	
    }

    if (@clase[$k]==0){	



	if(@clase[$k-1]==1){
	    $nv++;
	    @vog[$nv]=$kd-$nlast;
	    $nlast=$kd;
	    printf (REP "$kd $nv @vog[$nv] v \n");
	    $kk++;
	    @inter[$kk]=$kd;;
	    @interclas[$kk]='"v"';;
	    printf (REV "@vog[$nv] \n");
		       }       
	if(@clase[$k-1]==2){
	    $nc++;
	    @con[$nc]=$kd-$nlast;
	    $nlast=$kd;
	    printf (REP "$kd $nc @con[$nc] c \n");
	    $kk++;
	    @inter[$kk]=$kd;
	    @interclas[$kk]='"c"';
	    if($nc>=1){printf (REC "@con[$nc] \n");}

	}

    }
    $ca=@clase[$k];
    }
}
close(REC);
close(REV);
close(REP);




# Writing the textgrid Praat file

open ( REP0, ">$file.TextGrid" ) ;
$premarc1='File type = "ooTextFile"
Object class = "TextGrid"

xmin = 0 ';

$premarc2='tiers? <exists> 
size = 1
item []: 
    item [1]:
        class = "IntervalTier" 
        name = "Intervalos" 
        xmin = 0 ';

printf (REP0 "$premarc1
xmax = $kd 
$premarc2
xmax = $kd 
 intervals: size = $kk \n");
for ($k=1;$k<=$kk;$k++){
    $km=$k-1;
printf (REP0 "       intervals [$k]:
            xmin = $inter[$km]
            xmax = $inter[$k] 
            text = $interclas[$k] \n");
}


close(REPO);

close(INFO) ; 

$nxr=$ny-3;

# Subroutine that reads the columns of the spectrogram

sub readcol {
  my $buf = shift;
  my $dummy = <INFO>; # drop first term
  for (my $i=0;$i<$nx;$i++){
    $dummy = <INFO>;
    ($nada, $tudo) = split ('=',$dummy);
    $buf->[$i] = 0+$tudo;
  }
}

# Re-normalization of the columns of the spectrogram

sub normalize {
  my $buf = shift;
  my $sum, $sum2, $i;
  $sum =0;
  for ($i=$y0; $i<$y2;$i++){ $sum += $buf->[$i];}
  @lenergy [$yy]=$sum;
   $sum2=0;
  $ulysum=0;
  for ($i=$yubl; $i<$yubu;$i++){ $ulysum += $buf->[$i];}
  @uenergy[$yy]= $ulysum;
  for ($i=$y2; $i<$nx;$i++){ $sum2 += $buf->[$i];}

  for ($i=$y0; $i<$y2; $i++) {$buf->[$i] /= $sum;}

  @energy[$yy]=($sum+$sum2);

}






















