#!/usr/bin/perl

use strict;

# Program budujcy automat skoczony rozpoznajcy dany zbir sw i 
# przypisujcy im opisy (sownik).  Na wejciu posortowana lista sw
# opatrzonych opisami w formacie
# <sowo> <opis>
# (sowo do pierwszej spacji, reszta jest opisem)

# Struktury danych:
# 
# przejcie: para [$znak, $stan]
#
# stan automatu: trjka [[$przejscie, ...], $opis, $numer]
#  $opis ma warto undef jeli stan nieakceptujcy
#
# protostan (kandydat-na-stan): trjka [[$przejscie, ...], $opis, $znak]
#  $opis ma warto undef jeli stan nieakceptujcy
#  $znak przechowuje znak etykietujcy przejcie do nastpnego protostanu
#  $znak ma warto undef dla ostatniego znaku na licie

# W czasie budowy skrajna prawa cieka w budowanym grafie jest
# przechowywana w postaci listy proto-stanw. [...]

########################################################################
# Zmienne globalne:

# @protostates: lista protostanw
# $stateno: numer ostatnio zaalokowanego stanu
# %states: rejestr gotowych stanw
# $inputpattern: wzorzec dla linii czytanych z wejcia (powinien zawiera dwie pary nawiasw)

use vars qw(@protostates $stateno %states $inputpattern);

@protostates = ();
$stateno = 0;
%states = ();

$inputpattern = '^([^ ]+) +(.*)$';
#$inputpattern = '^([^:]+):(.*)$'; #'

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


# makechain($opis, @ogon)  
#
# dodaje ogon sowa @ogon do listy protostanw, ostatni akceptujcy z
# opisem $opis

sub makechain {
    my ($opis, @ogon) = @_; 
    my $char;
    push @protostates, [[], undef, $char]
	while ($char = shift @ogon);
    push @protostates, [[], $opis, undef];
}

# lookupstate($przej, $opis) returns $state
#
# Prbuje odnale stan izomorficzny z zadanym przez $przej(cia) i
# $opis, w razie niepowodzenia generuje nowy i wprowadza do rejestru stanw

sub lookupstate {
    my ($przej, $opis) = @_;
    my $state;
    my $id = '';

    foreach my $p (@$przej) {
	$id .= ":$p->[0]$p->[1]->[2]";
    }
    $id .= "|$opis" if defined($opis);
    $state = $states{$id};
    if (!defined($state)) {
	$state = [$przej, $opis, ++$stateno];
	$states{$id} = $state;
    }
#    print STDERR "Lookup: $id ---> $state->[2]\n";
    return $state;
}

# compresspath($fromstate)
#
# przeksztaca proto-stany w stany dla
# @protostates[$fromstate+1..$#protostates] sprawdzajc, czy mona
# zastpi izomorficznymi

sub compresspath {
    my $from = shift;
    my $stan = undef;
    while ($#protostates > $from) {
	my ($przej, $opis, $znak) = @{pop @protostates};
#	print "$#protostates, @$przej, $opis, $znak\n";
	push @$przej, [$znak, $stan]
	    if defined($stan);
#	print "$#protostates, @$przej, $opis, $znak\n";
	$stan = lookupstate($przej, $opis);
    }
    return $stan;
}

# addword($opis, @slowo)
#
# dodaje do automatu w budowie slowo @slowo o opisie $opis

sub addword {
    my ($opis, @slowo) = @_;
    my $lastcommon = 0;
    my $stan;
    $lastcommon++ 
	while ($lastcommon < @slowo && 
	       $protostates[$lastcommon]->[2] eq $slowo[$lastcommon]);
#    die "Sort order!" if 
#    print "<$lastcommon | @slowo[$lastcommon..$#slowo]>\n";
    die "Sort order (0)" if $lastcommon == @slowo;
 
    $stan = compresspath($lastcommon);
    push @{@protostates[$lastcommon]->[0]}, 
	 [$protostates[$lastcommon]->[2], $stan] if $stan;
    
    $protostates[$lastcommon]->[2] = $slowo[$lastcommon];
    makechain($opis, @slowo[$lastcommon+1..$#slowo]);
}

# fixupdfa() returns $stan
#
# przeksztaca automat w budowie w automat zamykajc ostatni ciek

sub fixupdfa {
    my($przej, $opis, $znak) = @{$protostates[0]};
    push @$przej, [$znak, compresspath(0)];
    return [$przej, $opis, ++$stateno];
}

# builddfa() returns $stan
#
# buduje automat z listy sw podanej na stdin

sub builddfa {
    $_ = <>;
    die "Bdne wejcie: $_\n"
	unless m/$inputpattern/o;
    my ($slowo,$opis) = ($1,$2);
#    print STDERR "$slowo --> $opis\n";
    makechain($opis, split('',$slowo));

    while (<>) {
	chomp;
	die "Bdne wejcie: $_\n"
	    unless m/$inputpattern/o;
	($slowo,$opis) = ($1,$2);
#	print STDERR "$slowo --> $opis\n";
	print STDERR "+" if $. % 1000 == 0;
	addword($opis, split('',$slowo))
    }
    return fixupdfa();
}

# printdfa($stan):
# drukuje automat o stanie pocztkowym $stan

use vars qw($statenoprinted);
$statenoprinted = 0;
sub printdfa {
    my $state = shift;
    my ($przej, $opis, $nr) = @$state;
    return unless $statenoprinted < $nr;
    foreach my $child (@$przej) {
	printdfa($child->[1]);
	}
    print "$nr#", defined($opis)?"+$opis":'-', "#";
    foreach my $child (@$przej) {
	print " $child->[0]\->$child->[1]->[2]";
    }
    $statenoprinted = $nr;
    print "\n";
}



########################################################################
# Program gwny:-)

printdfa builddfa();
print STDERR "\n";

__END__
########################################################################
# test:

makechain("ala ma kota", split('',"koce"));
addword("ola", split('',"kota"));
addword("foka", split('',"kotanyi"));
#makechain("mIV", split('',"kot"));
#addword("Va", split('',"ku"));
#addword("mIV", split('',"lot"));
printdfa fixupdfa();

__END__
use vars qw($elem $c $o);
foreach $elem (@protostates) {
    $o = $elem->[1];
    $c = $elem->[2];
    
    print "[", join(',',@{$elem->[0]}), "]\t", (defined($o)?$o:'nil1'), "\t", 
    (defined($c)?$c:'nil2'), "\n";
}
print "\n";

