#!/run/bin/perl
#       gay-dating.pl
#       = Copyright 2010 Xiong Changnian <xiong@xuefang.com> =
#       = Free Software = Artistic License 2.0 = NO WARRANTY =

use strict;
use warnings;

use feature qw( say );
use Perl6::Form;

#----------------------------------------------------------------------------#

# KEY CONCEPTS
#
# DATA is read for $guy records; each consists of a $name and a list of @days.
# A $day is an integer (1..31) on which a guy is free for playtime.
# $book accumulates the varied day preferences of all of the guys.
# $report records the matches found between guys. 


# pseudo-globals
my $data_start      ;               # tell the first line of DATA

my $book            = [             # accumulator; fat boy
                                    #   AoA: $book->[$day] eq [@names]
];

my $report          = {};           # reports by -name

# main
my $exit            = 1;            # bash failure, initially
$exit = ( main() +1 ) %2;           # 1 for 0, 0 for 1
exit($exit);


sub main {
    $data_start     = tell DATA;    # remember
    first_pass();                   # accumulate wants
    seek DATA, $data_start, 0;      # start over
    second_pass();                  # make dates
    print_reports();                # see what we got
    return 1;
};

# Load records and accumulate wants
#   Writes $book
#
sub first_pass {
    my $guy         ;               # current guy
    my $name        ;               # current guy's name
    
    GETDATA:
    while (<DATA>) {
        
        next GETDATA if ( skip_record($_) );    # comment or blank
        last GETDATA if ( last_record($_) );    # END
        $guy        = parse_record($_);
        $name       = $guy->{-name};
        
        # for this guy do
        my @days                        = @{ $guy->{-days} };
        
        # record wants - not cheating, just for our final output
        $report->{$name}{-wantdays}     = \@days;
        
        # accumulate demands
        foreach my $day (@days) {
            push @{ $book->[$day] }, $name;
        };  
    };
};

# Find out who is compatible
#
sub second_pass {
    my $guy         ;               # current guy
    my $name        ;               # current guy's name
    
    GETDATA:
    while (<DATA>) {
        
        next GETDATA if ( skip_record($_) );    # comment or blank
        last GETDATA if ( last_record($_) );    # END
        $guy        = parse_record($_);
        $name       = $guy->{-name};
        
        # for this guy do
        my @days                        = @{ $guy->{-days} };
        
        # find hits on days
        foreach my $today (@days) {
            my @name_hits_today         = @{ $book->[$today] };
            @name_hits_today            = weed($name, @name_hits_today);
            
            foreach my $name_hit (@name_hits_today) {
                my $match   = {
                                -name   => $name_hit,
                                -day    => $today,
                            };
                push @{ $report->{$name}{-matches} }, $match;
            };
        };
    };
};

# Dump out all the reports
#
sub print_reports {
    
say q{};
say  q*|    name            wantdays                                       |*;
say  q*|-------------------------------------------------------------------|*;
foreach my $name (sort keys %$report) {
    my $wantdays        = join q{, }, @{ $report->{$name}{-wantdays} };
    
        print form
     q*|    {<<<<<<<<<<}    {<<<<<<<<<<}                                   |*,
            $name,          $wantdays,          
        ;
    
    foreach my $match ( @{ $report->{$name}{-matches} } ) {
        my $boytoy      = $match->{-name};
        my $today       = $match->{-day};
        my $ith         = get_ith($today);
        my $message     = qq{$boytoy can meet you on the $today$ith.};
        
        print form
     q*|        {<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<}          |*,
                $message,          
        ;
    };

    if ( not @{ $report->{$name}{-matches} } ) {
        my $message     = qq{Sorry! No matches.};
        
        print form
     q*|        {<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<}          |*,
                $message,          
        ;
        
    };
    
say  q*|                                                                   |*;
    };
say  q*|-------------------------------------------------------------------|*;
say q{};

};

# my $guy       = parse_record( $string );
#
#   key     meaning                             example
#
#   -name   $guy's name                         'Al'
#   -days   days of month available             [1, 2]
#
sub parse_record {
    my $string          = $_[0];
    chomp $string       ;
    my @split_white     = split ' ', $string;
    my $name            = $split_white[0];
    my @days            = split /[,|\s]+/, $split_white[1];
    
    my $guy     = {
        -name       => $name,
        -days       => \@days,
        
    };
    
    return $guy;
};

# $bool     = skip_record($_)
#
sub skip_record {
    local $_    = shift;
    return 1 if /^[\s]*#/;          # comment
    return 1 if /^[\s]*$/;          # essentially blank line 
    return 0;
};

# $bool     = last_record($_)
#
sub last_record {
    local $_    = shift;
    
    return 1 if /^__END__/;         # end of data; ignore 
    return 0;
};

# Convert cardinals to ordinals
#
sub get_ith {
    local $_    = shift;
    
    return q{th} if /1\d/;      # 11th, 12th,   13th
    return q{st} if /1$/;       # 1st,  21st,   31st
    return q{nd} if /2$/;       # 2nd,  22nd
    return q{rd} if /3$/;       # 3rd,  23rd
    return q{th};               # default
};

# Narrow a list of matches according to some hypothetical, expensive criteria
# We only eliminate masturbation in this demo.
# Note that more than one filtering step can be applied here; 
#   the cheaper steps should come first, aborting further processing
# 
sub weed {
    my $name        = shift;
    my @names       = @_;
    
    my @not_mes     = grep {!/$name/} @names;
    
    return @not_mes;
};


__DATA__
# name      days

Al          1,2
Bob         2,13
Chuck       12,4
Dick        3,7,30
Edgar       5,7
Fred        2,23
Greg        4,5,12
Harry       6
Ian         1,20
Jack        4,23
__END__


##</code><code>##


|    name            wantdays                                       |
|-------------------------------------------------------------------|
|    Al              1, 2                                           |
|        Ian can meet you on the 1st.                               |
|        Bob can meet you on the 2nd.                               |
|        Fred can meet you on the 2nd.                              |
|                                                                   |
|    Bob             2, 13                                          |
|        Al can meet you on the 2nd.                                |
|        Fred can meet you on the 2nd.                              |
|                                                                   |
|    Chuck           12, 4                                          |
|        Greg can meet you on the 12th.                             |
|        Greg can meet you on the 4th.                              |
|        Jack can meet you on the 4th.                              |
|                                                                   |
|    Dick            3, 7, 30                                       |
|        Edgar can meet you on the 7th.                             |
|                                                                   |
|    Edgar           5, 7                                           |
|        Greg can meet you on the 5th.                              |
|        Dick can meet you on the 7th.                              |
|                                                                   |
|    Fred            2, 23                                          |
|        Al can meet you on the 2nd.                                |
|        Bob can meet you on the 2nd.                               |
|        Jack can meet you on the 23rd.                             |
|                                                                   |
|    Greg            4, 5, 12                                       |
|        Chuck can meet you on the 4th.                             |
|        Jack can meet you on the 4th.                              |
|        Edgar can meet you on the 5th.                             |
|        Chuck can meet you on the 12th.                            |
|                                                                   |
|    Harry           6                                              |
|        Sorry! No matches.                                         |
|                                                                   |
|    Ian             1, 20                                          |
|        Al can meet you on the 1st.                                |
|                                                                   |
|    Jack            4, 23                                          |
|        Chuck can meet you on the 4th.                             |
|        Greg can meet you on the 4th.                              |
|        Fred can meet you on the 23rd.                             |
|                                                                   |
|-------------------------------------------------------------------|