source: nawszelkiwypadek/tools/gue_dic/stat.pl @ 4518a0b

#! /usr/bin/perl

use locale;

######################################################
# na wej¶ciu znajduje siê plik zawieraj±cy linie     #
# postaci:                                           #
# slowo;opis                                         #
#                                                    #
# na wyj¶ciu ma siê znaleŒæ plik zawieraj±cy linie:  #
# koñcówka(rev);prawdopodobieñstwo;opis              #
# gdzie:                                             #
# - koñcówka(rev) jest koñcówk± wyrazu zapisan±      #
#   w odwrotnej kolejno¶ci, dla ka¿dego wyrazu       #
#   w s³owniku wypisujemy koñcówki o d³ugo¶ciach     #
#   od 1 do d³ugo¶ci wyrazu,                         #
# - prawdopodobieñstwo jest prawdopodobieñstwem      #
#   wyst±pienia danego opisu dla danej koñcówki      #
#   (obliczonym na podstwie statystycznej analizy    #
#   s³ownika), np: 250 oznacza, ze opis popjawia sie #
#   1 raz na 4 wyst±pienia koñcówki.                 #
#   Zapisana zostaje odwrotno¶æ prawdopodobieñstwa   #
#   aby scie¿ka najbardziej prawdopodobna mia³a      #
#   najmniejszy koszt.                               #
######################################################

######
#STALE
#
# Jak bardzo prawdopodobna musi byæ dana ¶cie¿ka, aby
# braæ j± pod uwagê? (w promilach)
$MIN_PROB = 0;
#
# Maksymalna ilo¶æ powtórzeñ danej koñcówki (brane od
# najbardziej prawdopodbnej w dó³
$MAX_PATH = 10;
#
# Znak odzielajacy koncowke od prefiksu
$PREF_SIGN = '_';
######
# Zmienne globalne
# 
# Tablica okreslajaca, ktore prefiksy nalezy uwzlednic
# w wyjsciowym pliku.
# Klucz - ciag znakow prefiks$PREF_SIGNopis.
#  Wartosc: 1 - jezeli nalezy uwzglednic, 0 w przeciwnym przypadku
my %prefs;
#
# maksymalna dlugosc analizowanego prefiksu
my $MAX_PREF = 0;
######

###########################################################
# FUNKCJE

# wczytuje prefiksy do tablicy hashowej
# parametry:
# - nazwa pliku, z ktorego nalezy pobrac prefiksy
#   Plik w formacie:
#   prefiks\topis...\n
sub load_prefs {

    my $file = shift;
    open(IN, $file);

    while (<IN>) {
        $_ =~ /^(\w+)\t([^\t]+)\t/;
        my $key = "$1$PREF_SIGN$2";
        my $len = length($1);
        if ($len > $MAX_PREF) {
            $MAX_PREF = $len;
        }
        $prefs{$key} = 1;
    }
}

###########################################################

# Jezeli podano parametr to jest to nazwa pliku z prefiksami

if (@ARGV > 0) {
#    print "Laduje prefiksy ($ARGV[0])\n";
    load_prefs(shift);
#     print "Zaladowane:\n";
#     for $key (keys(%prefs)) {
#       print "$key\t$prefs{$key}\n";
#     }
#     print "++++++++++++++++++++++++++++++++++++++++++++++++++\n";
}

@input = <>;

#$max = 0;

#for $m (@input) {
#    $m =~ /(\w+);.*$/;
#    if (length($1) > $max) {
#       $max = length($1);
#    }
#}

$n = 2; #$max; 

$go = 1;

while ($go) {

    my %koncowki;
    my $sumy;
 
    $go = 0;
    for $m (@input) {
        if ($m =~ /(\w{$n});(.*)$/) {
            $go = 1;
            my $ending = $1;
            my $desc = $2;
            for (my $i=$MAX_PREF; $i>0; $i--) {
                $m =~ /^(\w{$i}).*/;
                my $key = "$1$PREF_SIGN$desc";
                if ($prefs{$key} == 1) {
                    $ending .= "$PREF_SIGN$1";
                    last;
                }
            }
            $koncowki{$ending.";".$desc}++;
            $sumy{$ending}++;
        }
    }

    print "\n";
 
    for $koncowka (keys %koncowki) {
        $koncowka =~ /^(.*);(.*)$/;
        my $ending = $1;
        my $opis = $2;
        $p = $koncowki{$koncowka} / $sumy{$ending};
        $p *= 1000;                     #wartosc w promilach

        if ($p <= $MIN_PROB) {
            next;
        }

        #if ($p == 1000) {
        #    $p--;
        #}

        #$p = 1000 - $p;                 #odwrotnosc
        my $old = $2;
        $ending =~ /^(\w+)$PREF_SIGN(\w+)/;

        my $rev = reverse($1);

        if ($2 !~ /^$old$/) {
            $rev .= "$PREF_SIGN$2";
        }

        # opakowujemy znak '-' znakami [] ;) dla lextools
        $opis =~ s/-/\[-\]/;

        printf "%s~%.0f;%s\n", $rev, $p, $opis;
    }

  $n++;

}