# basic shapes and their descriptions and categories

#%text = (
#         'duru' => 'inverted T-shape',
#         'fogu' => 'ring',
#         'mala' => '/-shape',
#         'olo' => 'Y-shape',
#         'uta' => 'upward-pointing triangle',
#         'zudu' => 'X-shape',
#         'fruta' => 'up arrow',
#         'pratu' => 'right arrow',
#         'gruto' => 'left arrow',
#         'babo' => 'diamond');

@cat1 = ('fruta', 'pratu', 'duru', 'zudu', 'olo', 'gruto');
@cat2 = ('fogu', 'uta', 'babo');
@cat3 = ('mala');

@basics = (@cat1, @cat2, @cat3);

foreach $shape (@basics)
{
    # compact description of a basic shape is the first letter of its name
    # in road sign language
    $desc{$shape} = substr($shape, 0, 1);
}

# invertible shapes
@invertibles = ('duru', 'mala',
                'olo', 'uta', 'fruta');
foreach $shape (@invertibles) {
    $invertible{$shape} = 1;
}


# 'frontification' of vowels
%front = ('a' => 'e',
          'o' => 'i',
          'u' => 'y',

          'e' => 'e',
          'i' => 'i',
          'y' => 'y'
          );

# The gender of a basic noun is determined by the last letter of it, which
# will be 'a', 'o', or 'u'.
foreach $noun (@basics)
{
    my $last = substr($noun, -1);
    $gender{$noun} = $last;
}

sub invert
{
    my ($noun) = @_;
    my $descr = $desc{$noun};
    $noun =~ /^([^aeiouy]*)([aeiouy])/ or die;
    my $start = $1;
    my $firstv = $2;
    my $end = $';
    my $inv = $firstv . $start . $front{$firstv} . $end;
    # prepend 'i' to get inverted description.
    $descr = "i$descr";
    $desc{$inv} = $descr;
    $gender{$inv} = $gender{$noun};
    return $inv;
}    

sub pluralize
{
    my ($noun) = @_;
    my $descr = $desc{$noun};
    $noun =~ /^([^aeiouy]*)([aeiouy])/ or die;
    my $start = $1;
    my $firstv = $2;
    my $end = $';

    $end =~ /([aeiouy])([^aeiouy]*)$/ or die;
    my $mid = $`;
    my $lastv = $1;
    $end = $2;

    my $plural = $start . $firstv . 'n' . $mid . $front{$lastv} . $end;
    $desc{$plural} = $descr; # no need for special description.
    $gender{$plural} = $gender{$noun};
    return $plural;
}

%color_pattern = (
    'black' => 'dr_l',
    'yellow' => 'mag_',
    'white' => 'nast_',
    'red' => 'suld_'
    );

@colors = keys(%color_pattern);

# compact descriptions of colors are the capitalized first letters.
$desc{'black'} = 'B';
$desc{'yellow'} = 'Y';
$desc{'white'} = 'W';
$desc{'red'} = 'R';

sub colorize
{
    my ($noun, $color) = @_;

    my $vowel = $front{$gender{$noun}};
    my $desc = $desc{$noun};
    my $gender = $gender{$noun};

    my $adj = $color_pattern{$color};
    $adj =~ s/_/$vowel/;
    my $ret = $adj . ' ' . $noun;
    $desc{$ret} = $desc{$color} . $desc;
    $gender{$ret} = $gender;
    $color{$ret} = $color;
    
    return $ret;
}

%number_pattern = (
    '1' => '_t',
    '2' => '_m'
);


sub numberize
{
    my ($noun, $number) = @_;

    my $desc = $desc{$noun};
    my $gender = $gender{$noun};

    my $adj = $number_pattern{$number};
    $adj =~ s/_/$gender/;
    my $ret = $noun . ' ' . $adj;
    $desc{$ret} = $number . $desc;
    $gender{$ret} = $gender;

    return $ret;
}

# expand categories by inversions.
@shapes1 = @cat1;
foreach $shape (@cat1) {
    if ($invertible{$shape}) {
        $inv = invert($shape);
        push(@shapes1, $inv);
    }
}
@shapes2 = @cat2;
foreach $shape (@cat2) {
    if ($invertible{$shape}) {
        $inv = invert($shape);
        push(@shapes2, $inv);
    }
}
@shapes3 = @cat3;
foreach $shape (@cat3) {
    if ($invertible{$shape}) {
        $inv = invert($shape);
        push(@shapes3, $inv);
    }
}


# @sings = all singular shapes w/color
@sings1 = ();
foreach $noun (@shapes1)
{
    foreach $color (@colors) {
        $sing = colorize($noun, $color);
        push(@sings1, $sing);
    }
}
@sings2 = ();
foreach $noun (@shapes2)
{
    foreach $color (@colors) {
        $sing = colorize($noun, $color);
        push(@sings2, $sing);
    }
}
@sings3 = ();
foreach $noun (@shapes3)
{
    foreach $color (@colors) {
        $sing = colorize($noun, $color);
        push(@sings3, $sing);
    }
}


@backgrounds = ();

foreach $color (@colors)
{
    $bkg = $color_pattern{$color} . 're';
    $bkg =~ s/_/a/;
    push(@backgrounds, $bkg);
    $color{$bkg} = $color;
}

@all1 = (); # only cat 1
@all2 = (); # only cat 2
foreach $bkg (@backgrounds)
{
    $bkg_color = $color{$bkg};
    $bkg_desc = "$desc{$bkg_color} ";

    # possibilities for category 1 only:
    # (A, -), (A A, -), (A B, -)
    # possibilities for category 2 only:
    # (-, X)

    
    foreach $sing1 (@sings1) {
        next if $color{$sing1} eq $bkg_color;
        
        $numbered = numberize($sing1, '1');
        $name = $bkg . ' ' . $numbered;
        $desc = $bkg_desc . $desc{$numbered};
        $desc{$name} = $desc;
        $bkg_color{$name} = $bkg_color;
        push(@all1, $name);

        # add 2nd category 1
        foreach $sing1a (@sings1) {
            next if $sing1a eq $sing1;
            next if $color{$sing1a} eq $bkg_color;
            $numbered = numberize($sing1a, '1');
            $namea = $name . ' py ' . $numbered;
            $desca = $desc . $desc{$numbered};
            $desc{$namea} = $desca;
            $bkg_color{$namea} = $bkg_color;
            push(@all1, $namea);
        }

        ($shape_color, $shape) = split(/ /, $sing1);
        $shape_color = $shape_color; # avoid perl warning
        $pluralized = pluralize($shape);

        if (0) {
        $numbered = numberize($pluralized, '2');
        $colorized = colorize($numbered, $color{$sing1});
        $name = $bkg . ' ' . $colorized;
        $desc = $bkg_desc . $desc{$colorized};
        }
        
        $colorized = colorize($pluralized, $color{$sing1});
        $numbered = numberize($colorized, '2');
        $name = $bkg . ' ' . $numbered;
        $desc = $bkg_desc . $desc{$numbered};


        $desc{$name} = $desc;
        $bkg_color{$name} = $bkg_color;
        push(@all1, $name);
    }

    # no category 1 -> @all2
    foreach $sing2 (@sings2) {
        $color = $color{$sing2};
        next if $color eq $bkg_color;
        $name = $bkg . ' ' . $sing2;
        $desc{$name} = $bkg_desc . ' ' . $desc{$sing2};
        $bkg_color{$name} = $bkg_color;
        push(@all2, $name);
    }
}


$numall1 = @all1;
$numall2 = @all2;
print STDERR "Done with 1 and 2 ($numall1, $numall2).\n";

# add a category 2 to all those with a category 1:
@all12 = ();
#$count = 0;
foreach $x (@all1)
{
#    if ((++$count % 100) == 0) {
#        print STDERR "\r$count";
#    }
    $desc = $desc{$x};
    $bkg_color = $bkg_color{$x};
    foreach $sing2 (@sings2) {
        $color = $color{$sing2};
        next if $color eq $bkg_color;
        $name = $x . ' pe ' . $sing2;
        $desc{$name} = $desc . ' ' . $desc{$sing2};
        $bkg_color{$name} = $bkg_color;
        push(@all12, $name);
    }
}

$numall12 = @all12;
print STDERR "Done with 12 ($numall12).\n";


# Add a category 3 to everything with a category 1 or a category 2.
@all3 = ();
foreach $x (@all1, @all2, @all12)
{
    $desc = $desc{$x};
    $bkg_color = $bkg_color{$x};
    foreach $sing3 (@sings3) {
        $color = $color{$sing3};
        next if $color eq $bkg_color;
        $name = $x . ' pe ' . $sing3;
        $desc{$name} = $desc . ' ' . $desc{$sing3};
        $bkg_color{$name} = $bkg_color;
        push(@all3, $name);
    }
}

$numall3 = @all3;
print STDERR "Done with 3 ($numall3).\n";

#foreach $sign (@all1, @all2, @all12, @all3)
#{
#    print "$sign\n";
#    print "$desc{$sign}\n";
#    print "\n";
#}

print STDERR "Consolidating.\n";
@all = (@all1, @all2, @all12, @all3);
$numall = @all;
print STDERR "$numall road signs.\n";

print STDERR "Computing hashes.\n";

use Digest::MD5 qw(md5_base64);

$count = 0;
foreach $sign (@all)
{
    ++$count;
    if ($count % 1000 == 0) {
        print STDERR "$count\r";
    }
    $hash = md5_base64($sign);
    push(@hashes, $hash . ' ' . $sign . ' ' . $desc{$sign});
}

print STDERR "Sorting hashes.\n";

@sorted = sort (@hashes);

print STDERR "Printing hashes.\n";

$printcount = 0;
foreach $hash (@sorted)
{
    if ($hash =~ /^gqw3TySaYqOTZW9XCB6thg /) {
        $printcount = 25;
    }
    next if $printcount == 0;

    print "$hash\n";
    --$printcount;
}