# Modul pro asistenci s českým řazením textů, pokud nedůvěřujeme locale.
package csort;
use utf8; # říct Perlu, že konstantní řetězce ve zdrojáku jsou v UTF



INIT
{
    # Definice abecedních pořádků. Jednotlivá písmena jsou oddělena znakem =
    # nebo <, podle toho, zda se písmeno v prvním čtení považuje za rovnocenné
    # předcházejícímu, nebo za větší než předcházející. Pokud jsou si dvě celá
    # slova rovna, nastoupí druhé čtení a slova se porovnají přímo podle pořadí
    # písmen v této definici, bez ohledu na znaménka, která je oddělují.
    # Písmeno se může skládat i z více znaků (např. české "ch"). Znaky, které
    # nejsou v definici obsaženy, se při třídění v prvním čtení ignorují, jako
    # kdyby je slovo vůbec neobsahovalo.
    my %order;
    $order{cs} = "0<1<2<3<4<5<6<7<8<9<a=A=á=Á<b=B<c=C<č=Č<d=D=ď=Ď<e=E=é=É=ě=Ě<f=F<g=G<h=H<ch=Ch=CH<i=I=í=Í<j=J<k=K<l=L<m=M<n=N=ň=Ň<o=O=ó=Ó<p=P<q=Q<r=R<ř=Ř<s=S<š=Š<t=T=ť=Ť<u=U=ú=Ú=ů=Ů<v=V<w=W<x=X<y=Y=ý=Ý<z=Z<ž=Ž";
    $order{en} = "0<1<2<3<4<5<6<7<8<9<a=A=á=Á<b=B<c=C=č=Č<d=D=ď=Ď<e=E=é=É=ě=Ě<f=F<g=G<h=H<i=I=í=Í<j=J<k=K<l=L<m=M<n=N=ň=Ň<o=O=ó=Ó<p=P<q=Q<r=R=ř=Ř<s=S=š=Š<t=T=ť=Ť<u=U=ú=Ú=ů=Ů<v=V<w=W<x=X<y=Y=ý=Ý<z=Z=ž=Ž";
    $order{csuni} = "0<1<2<3<4<5<6<7<8<9<a=A=á=Á=ä=Ä=â=Â=ă=Ă=ą=Ą=\x{410}=\x{430}<b=B=\x{411}=\x{431}<c=C=ç=Ç=\x{426}=\x{446}<č=Č=ć=Ć=\x{427}=\x{447}<d=D=ď=Ď=\x{414}=\x{434}<e=E=é=É=ě=Ě=ë=Ë=ę=Ę=\x{415}=\x{435}=\x{42D}=\x{44D}<f=F=\x{424}=\x{444}<g=G=\x{413}=\x{433}<h=H<ch=Ch=CH=\x{425}=\x{445}<i=I=í=Í=î=Î=\x{418}=\x{438}<j=J=\x{419}=\x{439}<\x{42F}=\x{44F}<\x{42E}=\x{44E}<k=K=\x{41A}=\x{43A}<l=L=ľ=Ľ=ĺ=Ĺ=ł=Ł=\x{41B}=\x{43B}<m=M=\x{41C}=\x{43C}<n=N=ň=Ň=ń=Ń=\x{D1}=\x{F1}=\x{41D}=\x{43D}<o=O=ó=Ó=ö=Ö=ő=Ő=ô=Ô=\x{D8}=\x{F8}=\x{41E}=\x{43E}<p=P=\x{41F}=\x{43F}<q=Q<r=R=ŕ=Ŕ=\x{420}=\x{440}<ř=Ř<s=S=\x{421}=\x{441}<š=Š=ś=Ś=ş=Ş=\x{428}=\x{448}<\x{429}=\x{449}<t=T=ť=Ť=ţ=Ţ=\x{422}=\x{442}<u=U=ú=Ú=ů=Ů=ü=Ü=ű=Ű=\x{DB}=\x{FB}=\x{423}=\x{443}<v=V=\x{412}=\x{432}<w=W<x=X<y=Y=ý=Ý=\x{42B}=\x{44B}<z=Z=\x{417}=\x{437}<ž=Ž=ź=Ź=ż=Ż=\x{416}=\x{436}";
    # Předzpracované popisy řazení uložit do globálního hashe.
    while(my ($klic, $hodnota) = each(%order))
    {
        $popis{$klic} = vytvorit_tabulku_tridicich_hodnot($hodnota);
    }
    # Výchozí jazyk je čeština.
    $popis{""} = $popis{cs};
}



#------------------------------------------------------------------------------
# Převede lidsky čitelný popis abecedního řazení v určitém jazyce na číselné
# třídící hodnoty. Vytvoří i další jazykově závislé pomůcky, např. regulární
# výraz pro nalezení písmene ve slově.
#------------------------------------------------------------------------------
sub vytvorit_tabulku_tridicich_hodnot
{
    my $order = shift; # textový popis řazení v daném jazyce
    my %popis; # výstupní hash
    my @order = split(//, $order);
    my @pismena = split(/[=<]/, $order);
    my $i_pismena = 0;
    my $aktualni_ordval = 1;
    for(my $i = 0; $i<=$#order; $i++)
    {
        if($order[$i] eq "<")
        {
            $aktualni_ordval++;
        }
        elsif($order[$i] ne "=")
        {
            $popis{ordval1}{$pismena[$i_pismena]} = $aktualni_ordval;
            $popis{ordval2}{$pismena[$i_pismena]} = $i_pismena;
            $i_pismena++;
            while($i<$#order && $order[$i+1] !~ m/[<=]/)
            {
                $i++;
            }
        }
    }
    # Vytvořit seznam písmen seřazený sestupně podle počtu znaků.
    # (Ve slově se přednostně hledají písmena skládající se z více znaků.)
    @pismena = sort {length($b) <=> length($a)} @pismena;
    # regulární výraz pro identifikaci známého písmene
    $popis{rv_pismena} = join("|", @pismena);
    return \%popis;
}



#------------------------------------------------------------------------------
# Rozloží vstup na písmena (případně víceznaková).
# Zahodí znaky, které nejsou písmeny.
#------------------------------------------------------------------------------
sub rozlozit_na_pismena
{
    my $vstup = shift;
    my $rv_pismena = shift;
    my @vysledek;
    while($vstup ne "")
    {
        my $pismeno;
        my $zbytek;
        if($vstup =~ m/^($rv_pismena)(.*)/)
        {
            $pismeno = $1;
            $zbytek = $2;
            $vysledek[++$#vysledek] = $pismeno;
        }
        else
        {
            $vstup =~ m/^.(.*)/;
            $zbytek = $1;
        }
        $vstup = $zbytek;
    }
    #    print join("-", @vysledek) . "\n";
    return @vysledek;
}



#------------------------------------------------------------------------------
# Vytvoří podle řetězce tzv. řetězec třídících hodnot. Ten sestává pouze
# z číslic. Je zaručené, že porovnání dvou takovýchto řetězců odpovídá
# porovnání původních řetězců podle české abecedy.
#------------------------------------------------------------------------------
sub zjistit_tridici_hodnoty
{
    my $ret = shift;
    my $jazyk = shift; # kód jazyka, jehož řazení se má použít
    my $ordval1 = $popis{$jazyk}{ordval1};
    my $ordval2 = $popis{$jazyk}{ordval2};
    my $rv_pismena = $popis{$jazyk}{rv_pismena};
    my @retpis = rozlozit_na_pismena($ret, $rv_pismena);
    my $vysledek;
    my $i;
    for($i = 0; $i<=$#retpis; $i++)
    {
        $vysledek = $vysledek . sprintf("%02d", $ordval1->{$retpis[$i]});
    }
    $vysledek = $vysledek . " ";
    for($i = 0; $i<=$#retpis; $i++)
    {
        $vysledek = $vysledek . sprintf("%02d", $ordval2->{$retpis[$i]});
    }
    $vysledek = $vysledek . " $ret";
    return $vysledek;
}



1;