#!/usr/bin/perl
#
# BNCweb: A user-friendly interface to the British National Corpus - Version 4.3
# Copyright (C) 2005-10 Hoffmann/Evert/Lehmann
#
# Updates and information available at http://www.bncweb.info
#
# This file is part of BNCweb.
# 
# BNCweb is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 3 of the License, or
# (at your option) any later version.
# 
# BNCweb is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
# 
# You should have received a copy of the GNU General Public License
# along with this program.  If not, see <http://www.gnu.org/licenses/>.

#
# based on BNCweb Version 2.0:
# © 1996/2004 Lehmann/Hoffmann/Schneider
#

use lib "../lib_files";
use bncLibCQPXML;
use DBI;

#SETTINGS
$thisProg  = "freqList.pl";
$newQuery  = "BNCquery.pl";
$main      = "processQuery.pl";

$username = $ENV{'REMOTE_USER'};
$thisProg  = "freqList.pl";
	
unless (getParams($ENV{'QUERY_STRING'})) {
	barkFull("incomplete transmition of URL<BR>This problem is likely to occur in combination with proxy servers<BR>turn off your web-proxy and try again");
}

#setParam("spowri", &decURL($params{spowri}));


$theQuery= $ENV{'QUERY_STRING'};
$theQuery = "&" . $theQuery . "&";
$theInput = $theQuery;

if ($params{freqType} eq "word") {
	$theTags="";
	$tagLink="";
	$Text = "Words tagged as ";
	while ($theQuery =~ m/&tag=([^&]+)/g) {
		$tag=$1;
		$tagLink .= $&;
		$tag =~ s/%([\dA-Fa-f][\dA-Fa-f])/pack ("C", hex ($1))/eg;

 		# This list implements some rather odd decisions in the BNC!
		$check = 0;
		if ($tag eq "VERB") {
			$Text .= "any verb, ";
			$theTag = "V..";
		} elsif ($tag eq "SUBST") {
			$Text .= "any noun, ";
			$theTag = "(N[NP].|ZZ0)";
		} elsif ($tag eq "CONJ") {
			$Text .= "any conjunction, ";
			$theTag = "CJ.";
		} elsif ($tag eq "ADJ") {
			$Text .= "any adjective, ";
			$theTag = "(AJ.|CRD|DT0|ORD)";
		} elsif ($tag eq "ADV") {
			$Text .= "any adverb, ";
			$theTag = "(AV.|XX0)";
		} elsif ($tag eq "PRON") {
			$Text .= "any pronoun, ";
			$theTag = "(DPS|DT[SQ]|EX0|PN.)";
		} elsif ($tag eq "STOP") {
			$Text .= "any punctuation, ";
			$theTag = "(POS|PU.)";
		} elsif ($tag eq "ART") {
			$Text .= "any article, ";
			$theTag = "AT0";
		} elsif ($tag eq "PREP") {
			$Text .= "any preposition, ";
			$theTag = "(PR.|TO0)";
		} elsif ($tag eq "INTERJ") {
			$Text .= "any interjection, ";
			$theTag = "(ITJ)";
		} elsif ($tag eq "CONJ") {
			$Text .= "any conjunction, ";
			$theTag = "(CJ.)";
		} else {
			$Text .= "$tag, ";
			$theTag = $tag;
			$check++;
		}

		if ($check) {
			$theTags .="\|\^_$theTag\$";
			$simplified = 0;
		} else {
			$theTags .="\|\^_$theTag";
			$simplified = 1;
		}
		
	}
	if ($theTags=~m/\|/) {
		$Text =~ s/, \Z/Û/;
		$theTags =~ s/\A\|//;
		$theTags = "tag REGEXP '" . $theTags . "' ";
	} else {
		$Text = "WordsÛ";
	}
	
} else {
	$theLemma="";
	$lemmaLink="";
	$Text = "Lemmas of type ";
	while ($theQuery =~ m/&lemma=([^&]+)/g) {
		$lemma=$1;
		$lemmaLink .= $&;
		$lemma =~ s/%([\dA-Fa-f][\dA-Fa-f])/pack ("C", hex ($1))/eg;
		$theLemma .= "OR lemma regexp '_$lemma' ";
		$Text .= "$lemma, ";
		$countLemma++;
	}
	$Text=~s/type/types/ if ($countLemma > 1);
	if ($theLemma=~m/OR/) {
		$Text =~ s/, \Z/Û/;
	}
	#$Text = "LemmataÛ" if ($Text=~/allÛ/);
	$Text = "HeadwordsÛ" if (($Text=~/allÛ/) || (!$countLemma));
	$theLemma =~ s/\AOR //;
	$showLemma = 1;
}

if ((!$params{minValue}) && ($params{maxValue})) {
	setParam("minValue", "$params{maxValue}");
	setParam("maxValue", "");
}


if (($params{minValue} > $params{maxValue}) && ($params{maxValue})) {
	$check=$params{minValue};
	setParam("minValue", "$params{maxValue}");
	setParam("maxValue", "$check");
}

$range = "";
if (($params{minValue}) && (!$params{maxValue}) && ($params{direction} eq "asc")) {
	$range = "HAVING bla >= $params{minValue}";
	$Text .= " occurring at least $params{minValue} times ";
}
if (($params{minValue}) && (!$params{maxValue}) && ($params{direction} eq "desc")) {
	$range = "HAVING bla <= $params{minValue}";
	$Text .= " occurring not more than $params{minValue} times ";
}
if (($params{minValue}) && ($params{maxValue})) {
	$range = "HAVING bla BETWEEN $params{minValue} AND $params{maxValue}";
	$Text .= " occurring between $params{minValue} and $params{maxValue} times ";
}

# connect to mysql
if (($params{spowri} eq "s") || ($params{spowri} eq "w") || ($params{spowri} eq "all")) {
	$bncHandle = DBI->connect("DBI:mysql:$bwMYSQLtable:$bwMYSQLhost:$bwMysqlPort", "$bwMysqlUser", "$bwMysqlPwd");
} else {
	$bncHandle = DBI->connect("DBI:mysql:$bwMYSQLfrequency:$bwMYSQLhost:$bwMysqlPort", "$bwMysqlUser", "$bwMysqlPwd") or bark("Can't connect to mysql on $bwMYSQLhost at port: $bwMysqlPort <BR>" . $frequencyHandle::errstr);
}


if ($params{spowri} ne "all") {
	
	if ($params{spowri} eq "s") {
		$spowri = 2;
		$Text .= "in the spoken component ";
		
		$wordTable = "allWordsS";
		$wordTaggedTable = "allWordsTS";
		$lemmaTable = "allLemmaS";


	} elsif ($params{spowri} eq "w") {
		$spowri = 1;
		$Text .= " in the written component ";

		$wordTable = "allWordsW";
		$wordTaggedTable = "allWordsTW";
		$lemmaTable = "allLemmaW";


	} else {
		# subcorpus frequency list display
		($theName, $subcorpus) = split(/###/, $params{spowri});
		$Text .= " in subcorpus \"$subcorpus\" ";

		$wordTable = "allWords_" . $theName;
		$wordTaggedTable = "allWordsT_" . $theName;
		$lemmaTable = "allLemma_" . $theName;
		$spowri = $subcorpus;
		
		# update timestamp in cache
		$theTime = int(time);
		$sqlQuery = "UPDATE $bwMYSQLtable.frequencyLists set time_of_creation=$theTime where theName='$theName'";
		$bncHandle->do($sqlQuery) or bark("Can't $sqlQuery: " . $bncHandle::errstr);
	}
} else {
	$sw="";
	$spowri = 0;
	$Text .= " in the whole BNC ";
	
	$wordTable = "allWords";
	$wordTaggedTable = "allWordsT";
	$lemmaTable = "allLemma";
	
}


if ($params{inst} ne "show all") {
	# set start and end s number
	$start = ($params{chunk} * $params{inst}) - ($params{inst});
	$end = (($params{chunk} + 1) * $params{inst}) - ($params{inst});
	$limit = "LIMIT $start, $params{inst}";
} else {
	$limit = "";
}

if ($showLemma) {
	$range =~ s/HAVING bla /freq /;
	$theLemma='' if ($theLemma=~m/_all/);
	
	if ($params{regexValue}) {
		
		$regexKind = "";
		if ($params{regex} eq "begin") {
			$regex = " AND lemma regexp '\^$params{regexValue}'";
			$insertText = " starting with '$params{regexValue}'";
		} elsif ($params{regex} eq "end") {
			$regex = " AND lemma regexp '$params{regexValue}_'";
			$insertText = " ending in '$params{regexValue}'";
		} else {
			$regex = " AND lemma regexp '$params{regexValue}'";
			$insertText = " containing '$params{regexValue}'";
		}
		$Text=~s/Û/$insertText/;
	}
	
	$sqlQuery="SELECT lemma, freq from $lemmaTable WHERE $range AND ($theLemma) $regex ORDER BY freq $params{direction}, lemma  $limit";
	
	
} else {
	
	if ($params{regexValue}) {
		
		$regexKind = "";
		if ($params{regex} eq "begin") {
			$regex = " AND word regexp '\^$params{regexValue}'";
			$insertText = " starting with '$params{regexValue}'";
		} elsif ($params{regex} eq "end") {
			
			if (($params{showTag}) && (!$theTags)) {
				$regex = " AND word regexp '$params{regexValue}_[A-Z012]{3}(-[A-Z012]{3})?\$\'";
			} else {
				$regex = " AND word regexp '$params{regexValue}\$\'";
			}
			$insertText = " ending in '$params{regexValue}'";
		} else {
			$regex = " AND word regexp '$params{regexValue}'";
			$insertText = " containing '$params{regexValue}'";
		}
		$Text=~s/Û/$insertText/;
	}

	if ($theTags) {
		$theTags=~s/tag REGEXP/substring(word, LOCATE('_', word)) REGEXP/g;
		$regex=~s/word regexp/substring_index(word, '_', 1) REGEXP/g;
		$sqlQuery="SELECT substring_index(word, '_', 1) as word2, sum(freq) as bla, substring_index(word, '_', -1) as tag FROM $wordTaggedTable WHERE ($theTags) $regex GROUP BY word2 $range ORDER BY bla $params{direction}, word2 $limit";

	} else {
		$range =~ s/HAVING bla /freq /;
		if ($params{showTag}) {
			$sqlQuery="SELECT word, freq from $wordTaggedTable WHERE $range $regex ORDER BY freq $params{direction}, word $limit";
		} else {
			$sqlQuery="SELECT word, freq from $wordTable WHERE $range $regex ORDER BY freq $params{direction}, word  $limit";
		}
	}
}


$sqlQuery=~s/AND \(\)//;
$sqlQuery=~s/WHERE\s+AND/ WHERE /;
$sqlQuery=~s/WHERE\s+ORDER/ORDER/;

$Text=~s/Û//;
$Text=~s/\A(\w)/uc($1)/e;

print "Content-type: text/html\n\n";
print <<END;

<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 3.2 Final//EN">
<HTML>
<HEAD>

<TITLE>BNC frequency list</TITLE>

<META NAME="generator" CONTENT="BBEdit 4.5">
<meta http-equiv="content-type" content="text/html; charset=ISO-8859-1">
</HEAD>
<BODY BGCOLOR="#FFFFFF">
<TABLE BORDER="0" CELLPADDING="2" CELLSPACING="2" WIDTH="100%">
	<TR WIDTH="100%">
		<TD HEIGHT="26" BGCOLOR="#CCCCFF" COLSPAN="4">
			<P ALIGN="LEFT"><B>$Text</B>
		</TD>
	</TR>
END

$sth = $bncHandle->prepare($sqlQuery) or bark("Can't prepare $sqlQuery:" . $bncHandle::errstr);
$sth->execute or bark("Can't execute $sqlQuery:" . $sth::errstr);
$countFRes=$sth->rows;
$resArrayResult=$sth->fetchall_arrayref;

$theLines="";
for $k ( 0 .. ($#{$resArrayResult}) ) {
	$theWord=$resArrayResult->[$k][0];
	$theFrequency=$resArrayResult->[$k][1];
	$theTag=$resArrayResult->[$k][2];
		
	if ($showLemma) {
		$theWord=~m/_([A-Z]+)\Z/;
		$theWord= $`;
		$theTag=$1;
	} else {
		if (($params{showTag}) && (!$theTags)) { 
			$theWord=~m/_([A-Z012]{3}(-[A-Z012]{3})?)/;
			$theWord = $`;
			$theTag = $1;
		} else {
			$theWord=~s/(~|_)/ /g;
		}
	}
	
	$theWord=&output2($theWord);
	$theWord=lc($theWord);
	$theLink = '<A HREF="/' . $bwCGIalias . '/' . $main . '?queryType=simple&qMode=Simple+query+(ignore+case)&qtype=' . $spowri . '&thMode=INIT&theData=XYZ2&chunk=1&inst=50&max=INIT&qname=INIT&urlTest=yes">';

	if ($showLemma) {
		$theQuery = "{" . $theWord . "/" . $theTag . "}";
	} else {
		if ($params{showTag}) {
			$theQuery = $theWord . "_" . $theTag;
			
		} else {
			if ($simplified) {
				$class = pos2class($theTag);
				$theQuery = $theWord . "_{" . $class . "}";
			} else {
				if ($theTag) {
					$theQuery = $theWord . "_" . $theTag;
				} else {
					$theQuery = $theWord;
				}
			}
		}
	}

	$theQuery=~s/(\W)/sprintf("%%%x", ord($1))/eg;
	$theQuery=~s/ /+/g;
	$theLink=~s/XYZ2/$theQuery/;
	
	$lineIndicator = $start + 1 + $k;
	if (($params{showTag}) || ($showLemma)) {
		$theLines .= '<TR VALIGN="Top" BGCOLOR="#DDDDDD"><TD ALIGN="RIGHT" WIDTH="5%"><B>' . "$lineIndicator</B></TD>" . '<TD ALIGN="LEFT" NOWRAP WIDTH="40%">' . "&nbsp;$theLink<B>$theWord</B></A></TD>" . '<TD NOWRAP ALIGN=MIDDLE>' . "&nbsp;$theTag</TD>" . '<TD NOWRAP ALIGN=MIDDLE>' . "&nbsp;$theFrequency</TD>";
	} else {
		$theLines .= '<TR VALIGN="Top" BGCOLOR="#DDDDDD"><TD ALIGN="RIGHT" WIDTH="5%"><B>' . "$lineIndicator</B></TD>" . '<TD ALIGN="LEFT" NOWRAP WIDTH="40%">' . "&nbsp;$theLink<B>$theWord</B></A></TD>" . '<TD NOWRAP ALIGN=MIDDLE>' . "&nbsp;$theFrequency</TD>";
	}
}

if (!$countFRes) {
	print <<END;
		</TABLE>
		<H3>There are no words in the BNC that match your requirements</H3>
END
	# print the end of html
	&printFooter();
	
	exit(0);
}

&createNavigationLinks();

print <<END;
	<TR WIDTH="100%">$navBar
		<FORM ACTION="/$bwCGIalias/dlogs.pl" METHOD=GET>
			<TD BGCOLOR="#DDDDDD">
				<SELECT NAME="selected">
					<OPTION>New Frequency List</OPTION>
					<OPTION>Download whole Frequency List</OPTION>
					<OPTION>New Query</OPTION>
				</SELECT>
				<INPUT TYPE="hidden" NAME="tag" VALUE="$params{tag}">
				<INPUT TYPE="hidden" NAME="regex" VALUE="$params{regex}">
				<INPUT TYPE="hidden" NAME="regexValue" VALUE="$params{regexValue}">
				<INPUT TYPE="hidden" NAME="spowri" VALUE="$params{spowri}">
				<INPUT TYPE="hidden" NAME="minValue" VALUE="$params{minValue}">
				<INPUT TYPE="hidden" NAME="maxValue" VALUE="$params{maxValue}">
				<INPUT TYPE="hidden" NAME="direction" VALUE="$params{direction}">
				<INPUT TYPE="hidden" NAME="showTag" VALUE="$params{showTag}">
				<INPUT TYPE="hidden" NAME="freqType" VALUE="$params{freqType}">	
				<INPUT TYPE="hidden" NAME="input" VALUE="$theInput">			
				<INPUT TYPE="hidden" NAME="urlTest" VALUE="yes">
				<INPUT TYPE="SUBMIT" VALUE="Go!">
			</TD>
		</FORM>
		</TR>
		</TABLE>
	<TABLE BORDER="0" CELLPADDING="2" CELLSPACING="2" WIDTH="100%">
END

if ($showLemma) {
	print '<TR BGCOLOR="#FFCC66">' . "<TD VALIGN=TOP WIDTH=\"5%\"><B>&nbsp;No.</B></TD><TD VALIGN=TOP WIDTH=\"40%\"><B>&nbsp;Headword</B></TD><TD ALIGN=MIDDLE><B>Type</B></TD><TD VALIGN=TOP ALIGN=MIDDLE><B>Frequency</B></TD></TR>\n";
} else {
	if ($params{showTag}) {
		print '<TR BGCOLOR="#FFCC66">' . "<TD VALIGN=TOP WIDTH=\"5%\"><B>&nbsp;No.</B></TD><TD VALIGN=TOP WIDTH=\"40%\"><B>&nbsp;Word</B></TD><TD ALIGN=MIDDLE><B>Tag</B></TD><TD VALIGN=TOP ALIGN=MIDDLE><B>Frequency</B></TD></TR>\n";
	} else {
		print '<TR BGCOLOR="#FFCC66">' . "<TD VALIGN=TOP WIDTH=\"5%\"><B>&nbsp;No.</B></TD><TD VALIGN=TOP WIDTH=\"40%\"><B>&nbsp;Word</B></TD><TD VALIGN=TOP ALIGN=MIDDLE><B>Frequency</B></TD></TR>\n";
	}
}
print $theLines;
print "</TABLE>";

# print the end of html
&printFooter();

exit(0);

sub createNavigationLinks {
	# print links to other pages
	if ($params{inst} ne "show all") {
		
		$theLink = '<A HREF="/' . $bwCGIalias . '/' . $thisProg . '?XYZ2">';
		$link = "chunk=XXZ1&inst=$paramsEnc{inst}&spowri=$paramsEnc{spowri}&freqType=$paramsEnc{freqType}&regex=$paramsEnc{regex}&regexValue=$paramsEnc{regexValue}&direction=$paramsEnc{direction}&minValue=$paramsEnc{minValue}&maxValue=$paramsEnc{maxValue}&showTag=$params{showTag}${tagLink}${lemmaLink}&urlTest=yes";
		$theLink =~ s/XYZ2/$link/o;
		$startFont="<FONT SIZE=3 FACE=\"Arial, Helvetica\"><B>";
		$endFont="</B></FONT>";
		if (($params{chunk} -1) >= 1) {
			$theLink1 = $theLink;
			$i = $params{chunk} - 1;
			$theLink1 =~ s/XXZ1/$i/;
			$navBar.= "<TD WIDTH=\"3%\" BGCOLOR=\"#DDDDDD\" NOWRAP><P ALIGN=\"CENTER\">${theLink1}$startFont&nbsp;&lt;&lt;&nbsp;$endFont</A></TD>\n";
		} else {
			$navBar.= "<TD WIDTH=\"3%\" BGCOLOR=\"#DDDDDD\" NOWRAP><P ALIGN=\"CENTER\">$startFont&nbsp;&lt;&lt;&nbsp;$endFont</TD>\n";
		}
		if ($params{inst} == $countFRes) {
			$theLink1 = $theLink;
			$i = $params{chunk} +1;
			$theLink1 =~ s/XXZ1/$i/;
			$navBar.= "<TD WIDTH=\"3%\" BGCOLOR=\"#DDDDDD\" NOWRAP><P ALIGN=\"CENTER\">${theLink1}$startFont&nbsp;&gt;&gt;&nbsp;$endFont</A></TD>\n";
		} else {
			$navBar.= "<TD WIDTH=\"3%\" BGCOLOR=\"#DDDDDD\" NOWRAP><P ALIGN=\"CENTER\">$startFont&nbsp;&gt;&gt;&nbsp;$endFont</TD>\n";
		}

		if ($params{chunk} != 1) {
			$theLink1 = $theLink;
			$theLink1 =~ s/XXZ1/1/;
			$navBar = "<TD WIDTH=\"3%\" BGCOLOR=\"#DDDDDD\" NOWRAP><P ALIGN=\"CENTER\">${theLink1}$startFont&nbsp;I&lt;&nbsp;$endFont</A></TD>$navBar\n";
		} else {
			$navBar = "<TD WIDTH=\"3%\" BGCOLOR=\"#DDDDDD\" NOWRAP><P ALIGN=\"CENTER\">$startFont&nbsp;I&lt;&nbsp;$endFont</TD>$navBar\n";
		}

	}
}

sub pos2class ( $ ) {
  my $pos = shift;
  return "A" if $pos=~m/^(AJ.|CRD|DT0|ORD)/;
  return "ADV" if $pos=~m/^(AV.|XX0)/;
  return "ART" if $pos=~m/^(AT0)/;
  return "CONJ" if $pos=~m/^(CJ.)/;
  return "INT" if $pos=~m/^(ITJ)/;
  return "PREP" if $pos=~m/^(PR.|TO0)/;
  return "PRO" if $pos=~m/^(DPS|DT[SQ]|EX0|PN.)/;
  return "STOP" if $pos=~m/^(POS|PU.)/;
  return "N" if $pos=~m/^(N[NP].|ZZ0|NN1-NP0|NP0-NN1)/;
  return "V" if $pos=~m/^(V..|VVD-VVN|VVN-VVD)/;
  return "UNC"; # everything else is UNC
}

