Finishing off the schedule conflict detection script

In Yet more Perl for coaching, I went through the evolution of a Perl script to detect conflicts between siblings on multiple teams. One thing I tried to do was throw out the coach data (no parents). This shaving was wrong, we also need to consider conflicts caused by a coach who doesn't have any kids playing. They do not want to be coaching multiple teams at once.

I'm going to skip ahead and present close to the finished product. There were interesting things which happened, but I want to concentrate on deciding on how to make functions. Here is the base script:

#! /usr/bin/perl

sub stripArray {
        my(@ar) = @_;

        for ($i = 0; $i < @ar; $i++) {
                if ($ar[$i] =~ /\^"(.\*)"$/) {
                        ($ar[$i]) = $ar[$i] =~ /"(.\*)"/;
                }
        }

        @ar;
}

do 'getthead.pl';

open(LNG_FILE, $ARGV[0]) || die "Can't open LNG_FILE: $!\\n";

# Determine the Column Names
do main'read_txtfile_format(\*LNG_FILE, \*languages); #' Hack to get color correct in vim...

my(@arSibs, @arCoaches);

lang: while (<LNG_FILE>) {
        next lang if (/\^#/ || /\^!/);
        eval "($languages) = stripArray(split(/[,\\n]/))";

        if (($father eq "" && $flname eq "") || ($mother eq "" && $glname eq "")) {
                my(%curr) = (
                        'first' => $fname,
                        'last' => $lname,
                        'team' => $team,
                        'tcode' => $tcode);

                #
                # Note that a coach can do multiple teams.
                #
                push(@arCoaches, \\%curr);
        } elsif (($father ne "" && $flname ne "") || ($mother ne "" && $glname ne "")) {
                my(%curr) = (
                        'first' => $fname,
                        'last' => $lname,
                        'team' => $team,
                        'tcode' => $tcode,
                        'ffirst' => $father,
                        'flast' => $flname,
                        'fmatch' => 0,
                        'mfirst' => $mother,
                        'mlast' => $glname,
                        'mmatch' => 0);

                push(@arSibs, \\%curr);
        }
}

close LANG_FILE;

sub sortByLast {
        $$a{last} cmp $$b{last};
}

my(@ar) = sort(sortByLast @arSibs);

my(%conflict);

#
# First get players taken care of...
#
for ($i = 0; $i < @ar; $i++) {
        $match = 0;

        #
        # First consider other players
        #
        for ($j = 0; $j < @ar; $j++) {
                if ($i == $j) {
                        next;
                }

                $fmatch = ($ar[$i]{ffirst} eq $ar[$j]{ffirst}) &&
                                ($ar[$i]{flast} eq $ar[$j]{flast}) &&
                                ($ar[$i]{ffirst} ne "") &&
                                ($ar[$i]{flast} ne "");

                $mmatch = ($ar[$i]{mfirst} eq $ar[$j]{mfirst}) &&
                                ($ar[$i]{mlast} eq $ar[$j]{mlast}) &&
                                ($ar[$i]{mfirst} ne "") &&
                                ($ar[$i]{mlast} ne "");;

                $tmatch = ($ar[$i]{tcode} eq $ar[$j]{tcode});

                if (($fmatch || $mmatch) && !$tmatch && ($ar[$i]{tcode} ne "") &&
                                ($ar[$j]{tcode} ne "")) {
                        if ($conflict{$ar[$i]{tcode}}) {
                                if (!($conflict{$ar[$i]{tcode}} =~ /$ar[$j]{tcode}/)) {
                                        $conflict{$ar[$i]{tcode}} = $conflict{$ar[$i]{tcode}} .
                                                 ", " . $ar[$j]{tcode};
                                }
                        } else {
                                $conflict{$ar[$i]{tcode}} = $ar[$j]{tcode};
                        }

                        if ($conflict{$ar[$j]{tcode}}) {
                                if (!($conflict{$ar[$j]{tcode}} =~ /$ar[$i]{tcode}/)) {
                                        $conflict{$ar[$j]{tcode}} = $conflict{$ar[$j]{tcode}} .
                                                ", " . $ar[$i]{tcode};
                                }
                        } else {
                                $conflict{$ar[$j]{tcode}} = $ar[$i]{tcode};
                        }
                }
        }

        #
        # Now consider coaches
        #
        for ($j = 0; $j < @arCoaches; $j++) {
                $fmatch = ($ar[$i]{ffirst} eq $arCoaches[$j]{first}) &&
                                ($ar[$i]{flast} eq $arCoaches[$j]{last}) &&
                                ($ar[$i]{ffirst} ne "") &&
                                ($ar[$i]{flast} ne "");

                $mmatch = ($ar[$i]{mfirst} eq $arCoaches[$j]{first}) &&
                                ($ar[$i]{mlast} eq $arCoaches[$j]{last}) &&
                                ($ar[$i]{mfirst} ne "") &&
                                ($ar[$i]{mlast} ne "");;

                $tmatch = ($ar[$i]{tcode} eq $arCoaches[$j]{tcode});

                if (($fmatch || $mmatch) && !$tmatch && ($ar[$i]{tcode} ne "") &&
                                ($arCoaches[$j]{tcode} ne "")) {
                        if ($conflict{$ar[$i]{tcode}}) {
                                if (!($conflict{$ar[$i]{tcode}} =~ /$arCoaches[$j]{tcode}/)) {
                                        $conflict{$ar[$i]{tcode}} = $conflict{$ar[$i]{tcode}} .
                                                ", " . $arCoaches[$j]{tcode};
                                }
                        } else {
                                $conflict{$ar[$i]{tcode}} = $arCoaches[$j]{tcode};
                        }

                        if ($conflict{$arCoaches[$j]{tcode}}) {
                                if (!($conflict{$arCoaches[$j]{tcode}} =~ /$ar[$i]{tcode}/)) {
                                        $conflict{$arCoaches[$j]{tcode}} =
                                                $conflict{$arCoaches[$j]{tcode}} .
                                                ", " . $ar[$i]{tcode};
                                }
                        } else {
                                $conflict{$arCoaches[$j]{tcode}} = $ar[$i]{tcode};
                        }
                }
        }
}

#
# First get players taken care of...
#
my(@ar) = sort(sortByLast @arCoaches);
for ($i = 0; $i < @ar; $i++) {
        for ($j = $i + 1; $j < @ar; $j++) {
                $match = ($ar[$i]{first} eq $ar[$j]{first}) &&
                                ($ar[$i]{last} eq $ar[$j]{last}) &&
                                ($ar[$i]{first} ne "") &&
                                ($ar[$i]{last} ne "");

                $tmatch = ($ar[$i]{tcode} eq $ar[$j]{tcode});

                if ($match && !$tmatch && ($ar[$i]{tcode} ne "") && ($ar[$j]{tcode} ne "")) {
                        if ($conflict{$ar[$i]{tcode}}) {
                                if (!($conflict{$ar[$i]{tcode}} =~ /$ar[$j]{tcode}/)) {
                                        $conflict{$ar[$i]{tcode}} = $conflict{$ar[$i]{tcode}} .
                                                ", " . $ar[$j]{tcode};
                                }
                        } else {
                                $conflict{$ar[$i]{tcode}} = $ar[$j]{tcode};
                        }

                        if ($conflict{$ar[$j]{tcode}}) {
                                if (!($conflict{$ar[$j]{tcode}} =~ /$ar[$i]{tcode}/)) {
                                        $conflict{$ar[$j]{tcode}} = $conflict{$ar[$j]{tcode}} .
                                                ", " . $ar[$i]{tcode};
                                }
                        } else {
                                $conflict{$ar[$j]{tcode}} = $ar[$i]{tcode};
                        }
                }
        }
}

foreach $key (sort(keys(%conflict))) {
        print "Team $key has conflicts with " . $conflict{$key} . "\\n";
}

exit(0);

Some sample output:

[usc@adept ~]$ ./scheds_all.pl people.txt | head
Team 05C01 has conflicts with 10G04, 08B04, 16B01
Team 05C02 has conflicts with 08B03, 10B01
Team 05C03 has conflicts with 12B03
Team 05C04 has conflicts with 16B02, 16G03
Team 06C01 has conflicts with 09B01
Team 06C02 has conflicts with 08B09
Team 06C03 has conflicts with 08B08
Team 06C05 has conflicts with 09B01
Team 06C08 has conflicts with 14G02
Team 06C15 has conflicts with 14B01C

We've basically got the same code in 3 places - where we build up the conflict string. At first glance, it looks hard to functionalize - the coaches' array has a different containing structure. (I'm more used to C, which would really make this difficult.) But as we look at it, both structures share a tcode. If we examine it more carefully, we don't care at all about the arrays - we just care about their contents. The following changes give us new functionality:

sub addConflicts {
        my($tcode1, $tcode2) = @_;

        if ($conflict{$tcode1}) {
                if (!($conflict{$tcode1} =~ /$tcode2/)) {
                        $conflict{$tcode1} = $conflict{$tcode1} . ", " . $tcode2;
                }
        } else {
                $conflict{$tcode1} = $tcode2;
        }

        if ($conflict{$tcode2}) {
                if (!($conflict{$tcode2} =~ /$tcode1/)) {
                        $conflict{$tcode2} = $conflict{$tcode2} . ", " . $tcode1;
                }
        } else {
                $conflict{$tcode2} = $tcode1;
        }
}

do 'getthead.pl';

...

#
# First get players taken care of...
#
for ($i = 0; $i < @ar; $i++) {
        $match = 0;

        #
        # First consider other players
        #
        for ($j = 0; $j < @ar; $j++) {
                if ($i == $j) {
                        next;
                }

                $fmatch = ($ar[$i]{ffirst} eq $ar[$j]{ffirst}) &&
                                ($ar[$i]{flast} eq $ar[$j]{flast}) &&
                                ($ar[$i]{ffirst} ne "") &&
                                ($ar[$i]{flast} ne "");

                $mmatch = ($ar[$i]{mfirst} eq $ar[$j]{mfirst}) &&
                                ($ar[$i]{mlast} eq $ar[$j]{mlast}) &&
                                ($ar[$i]{mfirst} ne "") &&
                                ($ar[$i]{mlast} ne "");;

                $tmatch = ($ar[$i]{tcode} eq $ar[$j]{tcode});

                if (($fmatch || $mmatch) && !$tmatch && ($ar[$i]{tcode} ne "") &&
                                ($ar[$j]{tcode} ne "")) {
                        addConflicts($ar[$i]{tcode}, $ar[$j]{tcode});
                }
        }

        #
        # Now consider coaches
        #
        for ($j = 0; $j < @arCoaches; $j++) {
                $fmatch = ($ar[$i]{ffirst} eq $arCoaches[$j]{first}) &&
                                ($ar[$i]{flast} eq $arCoaches[$j]{last}) &&
                                ($ar[$i]{ffirst} ne "") &&
                                ($ar[$i]{flast} ne "");

                $mmatch = ($ar[$i]{mfirst} eq $arCoaches[$j]{first}) &&
                                ($ar[$i]{mlast} eq $arCoaches[$j]{last}) &&
                                ($ar[$i]{mfirst} ne "") &&
                                ($ar[$i]{mlast} ne "");;

                $tmatch = ($ar[$i]{tcode} eq $arCoaches[$j]{tcode});

                if (($fmatch || $mmatch) && !$tmatch && ($ar[$i]{tcode} ne "") &&
                                ($arCoaches[$j]{tcode} ne "")) {
                        addConflicts($ar[$i]{tcode}, $arCoaches[$j]{tcode});
                }
        }
}

#
# First get players taken care of...
#
my(@ar) = sort(sortByLast @arCoaches);
for ($i = 0; $i < @ar; $i++) {
        for ($j = $i + 1; $j < @ar; $j++) {
                $match = ($ar[$i]{first} eq $ar[$j]{first}) &&
                                ($ar[$i]{last} eq $ar[$j]{last}) &&
                                ($ar[$i]{first} ne "") &&
                                ($ar[$i]{last} ne "");

                $tmatch = ($ar[$i]{tcode} eq $ar[$j]{tcode});

                if ($match && !$tmatch && ($ar[$i]{tcode} ne "") && ($ar[$j]{tcode} ne "")) {
                        addConflicts($ar[$i]{tcode}, $ar[$j]{tcode});
                }
        }
}

foreach $key (sort(keys(%conflict))) {
        print "Team $key has conflicts with " . $conflict{$key} . "\\n";
}

The code is much easier to read, further abstraction can take place, but does it work?

[usc@adept ~]$ ./sall.pl people.txt | head
[usc@adept ~]$

What is wrong? My first thought was that %conflict was the problem. It is declared after the function. What happens if we take:

my(@ar) = sort(sortByLast @arSibs);

my(%conflict);

#
# First get players taken care of...
#

And move the declaration to:

my(%conflict);

sub addConflicts {

Well, I was right:

[usc@adept ~]$ ./sall.pl people.txt | head
Team 05C01 has conflicts with 10G04, 08B04, 16B01
Team 05C02 has conflicts with 08B03, 10B01
Team 05C03 has conflicts with 12B03
Team 05C04 has conflicts with 16B02, 16G03
Team 06C01 has conflicts with 09B01
Team 06C02 has conflicts with 08B09
Team 06C03 has conflicts with 08B08
Team 06C05 has conflicts with 09B01
Team 06C08 has conflicts with 14G02
Team 06C15 has conflicts with 14B01C

And a full diff of the output of both versions matches up. We really need to make addConflicts more robust. Again we have the same basic code in two places. What if we wanted to change the way we stored the list?

my(%conflict);

sub checkConflict {
        my($tcode1, $tcode2) = @_;

        if ($conflict{$tcode1}) {
                if (!($conflict{$tcode1} =~ /$tcode2/)) {
                        $conflict{$tcode1} = $conflict{$tcode1} . ", " . $tcode2;
                }
        } else {
                $conflict{$tcode1} = $tcode2;
        }

}

sub addConflicts {
        my($tcode1, $tcode2) = @_;

        checkConflict($tcode1, $tcode2);
        checkConflict($tcode2, $tcode1);
}

And a check of the data:

[usc@adept ~]$ ./sall2.pl people.txt | head
Team 05C01 has conflicts with 10G04, 08B04, 16B01
Team 05C02 has conflicts with 08B03, 10B01
Team 05C03 has conflicts with 12B03
Team 05C04 has conflicts with 16B02, 16G03
Team 06C01 has conflicts with 09B01
Team 06C02 has conflicts with 08B09
Team 06C03 has conflicts with 08B08
Team 06C05 has conflicts with 09B01
Team 06C08 has conflicts with 14G02
Team 06C15 has conflicts with 14B01C

I'm really satisfied with the script for now. I could add an option to only check for conflicts for coaches and not all parents. I.e., we only care to help those people who volunteer their time. Basically, we just need to make entering the First consider other players optional.

And here is the final script:

#! /usr/bin/perl

sub stripArray {
        my(@ar) = @_;

        for ($i = 0; $i < @ar; $i++) {
                if ($ar[$i] =~ /\^"(.\*)"$/) {
                        ($ar[$i]) = $ar[$i] =~ /"(.\*)"/;
                }
        }

        @ar;
}

my(%conflict);

sub checkConflict {
        my($tcode1, $tcode2) = @_;

        if ($conflict{$tcode1}) {
                if (!($conflict{$tcode1} =~ /$tcode2/)) {
                        $conflict{$tcode1} = $conflict{$tcode1} . ", " . $tcode2;
                }
        } else {
                $conflict{$tcode1} = $tcode2;
        }

}

sub addConflicts {
        my($tcode1, $tcode2) = @_;

        checkConflict($tcode1, $tcode2);
        checkConflict($tcode2, $tcode1);
}

do 'getthead.pl';

open(LNG_FILE, $ARGV[0]) || die "Can't open LNG_FILE: $!\\n";

# Determine the Column Names
do main'read_txtfile_format(\*LNG_FILE, \*languages); #' Hack to get color correct in vim...

my(@arSibs, @arCoaches);

lang: while (<LNG_FILE>) {
        next lang if (/\^#/ || /\^!/);
        eval "($languages) = stripArray(split(/[,\\n]/))";

        if (($father eq "" && $flname eq "") || ($mother eq "" && $glname eq "")) {
                my(%curr) = (
                        'first' => $fname,
                        'last' => $lname,
                        'team' => $team,
                        'tcode' => $tcode);

                #
                # Note that a coach can do multiple teams.
                #
                push(@arCoaches, \\%curr);
        } elsif (($father ne "" && $flname ne "") || ($mother ne "" && $glname ne "")) {
                my(%curr) = (
                        'first' => $fname,
                        'last' => $lname,
                        'team' => $team,
                        'tcode' => $tcode,
                        'ffirst' => $father,
                        'flast' => $flname,
                        'fmatch' => 0,
                        'mfirst' => $mother,
                        'mlast' => $glname,
                        'mmatch' => 0);

                push(@arSibs, \\%curr);
        }
}

close LANG_FILE;

sub sortByLast {
        $$a{last} cmp $$b{last};
}

my(@ar) = sort(sortByLast @arSibs);

#
# First get players taken care of...
#
for ($i = 0; $i < @ar; $i++) {
        $match = 0;

        #
        # First consider other players
        #
        for ($j = 0; $j < @ar; $j++) {
                if ($i == $j) {
                        next;
                }

                $fmatch = ($ar[$i]{ffirst} eq $ar[$j]{ffirst}) &&
                                ($ar[$i]{flast} eq $ar[$j]{flast}) &&
                                ($ar[$i]{ffirst} ne "") &&
                                ($ar[$i]{flast} ne "");

                $mmatch = ($ar[$i]{mfirst} eq $ar[$j]{mfirst}) &&
                                ($ar[$i]{mlast} eq $ar[$j]{mlast}) &&
                                ($ar[$i]{mfirst} ne "") &&
                                ($ar[$i]{mlast} ne "");;


                $tmatch = ($ar[$i]{tcode} eq $ar[$j]{tcode});

                if (($fmatch || $mmatch) && !$tmatch && ($ar[$i]{tcode} ne "") &&
                               ($ar[$j]{tcode} ne "")) {
                        addConflicts($ar[$i]{tcode}, $ar[$j]{tcode});
                }
        }

        #
        # Now consider coaches
        #
        for ($j = 0; $j < @arCoaches; $j++) {
                $fmatch = ($ar[$i]{ffirst} eq $arCoaches[$j]{first}) &&
                                ($ar[$i]{flast} eq $arCoaches[$j]{last}) &&
                                ($ar[$i]{ffirst} ne "") &&
                                ($ar[$i]{flast} ne "");

                $mmatch = ($ar[$i]{mfirst} eq $arCoaches[$j]{first}) &&
                                ($ar[$i]{mlast} eq $arCoaches[$j]{last}) &&
                                ($ar[$i]{mfirst} ne "") &&
                                ($ar[$i]{mlast} ne "");;

                $tmatch = ($ar[$i]{tcode} eq $arCoaches[$j]{tcode});

                if (($fmatch || $mmatch) && !$tmatch && ($ar[$i]{tcode} ne "") &&
                               ($arCoaches[$j]{tcode} ne "")) {
                        addConflicts($ar[$i]{tcode}, $arCoaches[$j]{tcode});
                }
        }
}

#
# Now find conflicts by the coach...
#
my(@ar) = sort(sortByLast @arCoaches);
for ($i = 0; $i < @ar; $i++) {
        for ($j = $i + 1; $j < @ar; $j++) {
                $match = ($ar[$i]{first} eq $ar[$j]{first}) &&
                                ($ar[$i]{last} eq $ar[$j]{last}) &&
                                ($ar[$i]{first} ne "") &&
                                ($ar[$i]{last} ne "");

                $tmatch = ($ar[$i]{tcode} eq $ar[$j]{tcode});

                if ($match && !$tmatch && ($ar[$i]{tcode} ne "") && ($ar[$j]{tcode} ne "")) {
                        addConflicts($ar[$i]{tcode}, $ar[$j]{tcode});
                }
        }
}

foreach $key (sort(keys(%conflict))) {
        print "Team $key has conflicts with " . $conflict{$key} . "\\n";
}

exit(0);

Technorati Tags:
Orginally posted on Kool Aid Served Daily
Copyright (C) 2006, Kool Aid Served Daily
Comments:

Post a Comment:
  • HTML Syntax: NOT allowed
About

tdh

Search

Archives
« April 2014
SunMonTueWedThuFriSat
  
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
   
       
Today