#!/usr/bin/perl # última mod.: Paulo Rocha 28 Nov 2008 $temp=$ENV{'QUERY_STRING'}; $temp=~y#\+# #; $temp=~s#%3D#IGUAL#g; $temp=~s/%([A-F0-9]{2})/chr(hex($1))/egi; %opc=split(/[&=]/,$temp || shift); $opc{pedido}=~s#IGUAL#=#g; $opc{inicial}=0 unless ($opc{inicial}); $ENV{'QUERY_STRING'}=~s#\&inicial=\d+##g; $ENV{'QUERY_STRING'}=~s#\&format=\w##; %desccorpora=("virgem","Floresta Virgem 3.0","amazonia","Amazônia 1.0","selva","Selva 1.0","bosque","Bosque 8.0"); binmode(STDOUT, ":latin1"); print "Content-type: text/html\n\n"; print "Milhafre: buscas na Floresta Sintá(c)tica"; print ""; $opc{pedido}=~s#MV#P\?MV#g; $opc{pedido}=~s#AUX#P\?AUX#g; @partes=($opc{pedido}=~/(\S+)=(e\d)\b/g); %partes=reverse @partes; $pedido=$opc{pedido}; $cab="Frase"; foreach (split //, $opc{elai}) { $cab.="".$partes{"e$_"}; push @th,"\%t=e$_="; push @lm,"\%y=e$_=:\%z=e$_="; } $cab="" unless ($opc{elai}=~/\d\d/); # obtem resultados do pedido via TGrep2 open F1, "./tgrep2 -c $opc{corpus}.tg -a \' $pedido \' -m \"\%tw:::".(join " ", @th).":::".join ("::",@lm).":::\%um\\n\" |"; @resultado=split /\n/, join "", ; close F1; if ($#resultado>1000) { $muitos=1; } # selecciona resultados conforme opções de variante/género if ($opc{corpus} eq "bosque" || $opc{corpus} eq "virgem") { if (!$opc{variantebr}) { @resultado=grep ! /CF\d+/, @resultado; } if (!$opc{variantept}) { @resultado=grep ! /CP\d+/, @resultado; } $notas="; variantes: ".($opc{variantebr} ? "BR " : " ").($opc{variantept} ? "PT" : "")."\n"; } if ($opc{corpus} eq "selva") { if (!$opc{generoLIT}) { @resultado=grep ! /LIT-/, @resultado; } if (!$opc{generoFAL}) { @resultado=grep ! /FAL-/, @resultado; } if (!$opc{generoCIE}) { @resultado=grep ! /CIE-/, @resultado; } $notas="; géneros: ".($opc{generoLIT} ? "LIT " : " ").($opc{generoFAL} ? "FAL " : " ").($opc{generoCIE} ? "CIE " : " ")."\n"; } #print ""; #print ""; print " resultados completos em txt (clique com o botão direito do rato para descarregar)
"; # escreve cabeçalho caso haja mais de 1000 respostas if ($muitos) { print "Página "; for ($t=0;$t<$#resultado/1000;$t++) { if ($t==$opc{inicial}) { print ($t+1); } else { print " ".($t+1)." "; } } print " (1000 resultados por página)"; } print "
clique num identificador de frase para visualizar a árvore graficamente
" if ($opc{corpus} eq "bosque"); print ""; print "
Corpus ".$desccorpora{$opc{corpus}}."$notas\n
"; print "
Resultados".($#resultado+1); # conta quantidade de resultados por chave de agrupamento foreach (@resultado) { $qfac{$_}=ªf($_); $contando{$qfac{$_}}++; } @resultado=sort { $contando{$qfac{$b}}<=>$contando{$qfac{$a}} || $qfac{$a} cmp $qfac{$b}} @resultado; # grava pesquisa no log, se for a primeira página e o IP não for do DEI unless ($opc{inicial} || $ENV{'REMOTE_ADDR'} eq "193.137.203.230") { open F2, ">>log.txt"; ($_,$n,$h,$d,$m,$a)=localtime; print F2 sprintf("%02d/%02d/%02d %02d:%02d %15s %6s %5d %3s%3s%3s%3s %s\n",$a-100,$m+1,$d,$h,$n,$ENV{'REMOTE_ADDR'},$opc{corpus},$#resultado+1,$opc{op1},$opc{op2},$opc{op3},$opc{op4},$opc{pedido}); close F2; } # seleciona os 1000 resultados pretendidos $a1=$opc{inicial}*1000; $a2=$a1+999; if ($a2>$#resultado) { $a2=$#resultado; } @resultado=@resultado[$a1..$a2]; foreach (@resultado) { $contando2{$qfac{$_}}++; # print "
  • ".&limpa($_)."\n"; $ex{$qfac{$_}}.="
  • ".&limpa($_)."\n"; } # imprime as chaves de agrupamento, se existirem if ($opc{op1} || $opc{op2} || $opc{op3} || $opc{op4} || $opc{op5}) { foreach (sort {$contando{$b}<=>$contando{$a} || $a cmp $b} keys %contando) { if ($ex{$_}) { print "
    • $_".($muitos ? "$contando2{$_} de " : "")."$contando{$_}"; } else { print "
    $_$contando{$_}"; } } } print "
    "; # apresenta respostas, por chave de agrupamento foreach (sort {$contando{$b}<=>$contando{$a} || $a cmp $b} keys %contando) { next if ($ex{$_} eq ""); # se e só se o corpus é o Bosque, liga ID ao VISL $ex{$_}=~s/([CFP]+[0-9]+\-[0-9]+)/$1<\/a>/g if ($opc{corpus} eq "bosque"); if ($opc{tiporesp} eq "t") { print "

    $_ ($contando{$_})

    " if ($_=~/\S/); print ""; print $cab; $ex{$_}=~s#(C[FP]\S+|(FAL|CIE|LIT|AM)-\S+):#$1
    #g; $ex{$_}=~s#
  • #
    • #g; $ex{$_}=~s# ##g; print $ex{$_}; print "
    "; } else { print "

    $_ ($contando{$_})

    " if ($_=~/\S/); print ""; } } print "
    "; print ""; #ordena as respostas conforme chave de agrupamento sub ordff { $_=pop; @t=(); # $_=~s#¨#:#g; @ad=split /:::/, $_; $ad[3]=~s#>#>#g; $ad[3]=~s#<#<#g; @ac=split /:/, $ad[3]; if ($opc{op1}) { push @t, $ac[0]; } if ($opc{op2}) { push @t, $ac[1]; } if ($opc{op3}) { push @t, $ac[2]; } if ($opc{op4}) { push @t, $ac[3]; } if ($opc{op5}) { push @t, $ad[1]; } return join ":", @t; } # prepara as frases para apresentação sub limpa { $k=pop; # caracteres especiais $k=~s#\[#AbPR#g; $k=~s#\]#FxPR#g; $k=~s#\.#PntF#g; $k=~s#\$#CIFRÃO#g; ($fr,$pt,$llm)=split /:::/, $k; #localiza ID da frase $fr=~s#(C[FP]\d+-\d+[abc]?|(LIT|CIE|FAL)-\S+|AM-\d+-\d+)##; $id=$1; if ($opc{tiporesp} eq "t") { $fr=$pt; } # se extracto else { # sublinha os elementos a sublinhar foreach (split /::/, $llm) { ($ddi,$ddf)=split /:/, $_; @fr=split /\s+/, $fr; $fr[$ddi-1]="".$fr[$ddi-1]; $fr[$ddf-1]=$fr[$ddf-1].""; $fr=join " ", @fr; } } $fr=" $fr "; $fr=~s#_# #g; #contracções $fr=~s#\b([Dd])e\+()? #$1$2#g; $fr=~s#\bem\+()? #n$1$2#g; $fr=~s#\bEm\+()? #N$1$2#g; $fr=~s#\b([Pp])or\+()? #$1el$2#g; $fr=~s#\b([Aa])\+()? ()?o(s?)\b#$1$2$3o$4#g; $fr=~s#\ba\+ a#à$1#g; $fr=~s#\bA\+ a#À$1#g; $fr=~s#\b(m|t|lh)e\+()? ()?([oa]s?)#$1$2$3$4#g; $fr=~s#([Cc])om\+()? ()?([nv]).s#$1on$2$3$4osco#g; $fr=~s#([Cc])om\+()? ()?mim\b#$1om$2$3igo#g; $fr=~s#([Cc])om\+()? ()?ti\b#$1on$2$3tigo#g; $fr=~s#([Cc])om\+()? ()?si\b#$1on$2$3sigo#g; $fr=~s#-\s*(|)?\s*?(me|te|nos|vos|se|os?|as?|lhes?)\b#-$1$2#g; $fr=~s#ar-\s*(|)?\s*?(l[oa]s?)#á-$1$2#g; $fr=~s#er-\s*(|)?\s*?(l[oa]s?)#ê-$1$2#g; $fr=~s#ir-\s*(|)?\s*?(l[oa]s?)#í-$1$2#g; $fr=~s#-\s*(|)?\s*?(l[oa]s?)#-$1$2#g; $fr=~s#\b(anti|arqui|auto|contra|ex|inter|intra|mal|neo|pós|pró|pré|recém|sub|vice)-()?\s+#$1-$2#ig; # repões caracteres especiais $fr=~s#\}#\)#g; $fr=~s#\{#\(#g; $fr=~s#AbPR#\[#g; $fr=~s#FxPR#\]#g; $fr=~s#PntF#\.#g; $fr=~s#CIFRÃO#\$#g; $fr=~s#DOISPONTOS#:#g; $fr=~s#\s+([\.\,\?\!\:\;\)])#$1#g; $fr=~s#([\(])\s*#$1#g; # $fr=~s#-#-#g; return "$id: $fr"; }