Teams

Asignación de equipos de trabajo a calendarios semanales.
La historia de este código es extraña. Hay una versión en C correspondiente a un paper colectivo que se mandó a un congreso en Bosnia Herzegovina para Sept. 2002 (ref. TMT02-089). El código fuente no se pudo aceptar por exceder el número máximo de páginas, por lo que sólo se describe el procedimiento. Pues he aquí la versión perl para asignar turnos de trabajo a equipos de tamaño arbitrariamente variable, según una tabla de requisitos de presencia.

#!/usr/bin/perl

package t;
use strict;

my $TIME = time();
my @q = (0, 10, 20, 10,
	  15, 20, 25,
	  30, 20, 10,
	  25, 10, 12,
	  13, 14, 15,
	  20, 15, 10,
	  20, 16);

my $maxwork = 5;
my $maxacum = $maxwork;
my ($numsol, $tryed, $ZZ, $min, $max, $numteam, $numperson);
my (@s, @t, @y);

my ($i,$j,$m,$n,$ok);
for (@q){ $q[0] += $_; }
$min = 999999999;
$max =0;
for (1..$#q){
    if ($q[$_]<$min && $q[$_]>0){ $min=$q[$_]; }
    if ($q[$_]>$max) { $max=$q[$_]; }
}
my $MINRESOLVE = 1e+16;
my $scut0 = int($#q/$maxwork);
# my $scut1 = $#q-$scut0+.5;
my $scut1 = int(.5+$#q/2);
my $scut2 = $max-2.5;
 
while (1){
INI:  $ZZ=0;
    $numteam = $scut0+int(rand($scut1));
    @t=();
    @y=();
    $y[0]=$y[1]=0;
    $t[1]=$min;
    $numperson=$t[1];
    for (2..$numteam){
	$t[$_] = 3+int(rand($scut2));     # mininum team, 3 workers
	$numperson += $t[$_];
	$y[$_]=0;
    }
    redo if ($numperson*$maxwork<$q[0]); 
    $tryed++;
    for $i (0..$#q){                                # primitiveness
	for (0..$maxacum){ $s[$i][$_]=0; }
    }
    for $i (1..$#q){                                 # LLENADO
	next if ($s[$i][0]>=$q[$i]);
	for $j (1..$numteam){
	    next if (check($i,$j)!=0);
	    for (1..$maxacum){
		next if ($s[$i][$_]>0);
		$s[$i][$_]=$j;
		$y[0]++;
		$y[$j]++;
		$s[$i][0] += $t[$j];
		$s[0][0] += $t[$j];
		last;
	    }
	    last if ($s[$i][0]>=$q[$i]);
	}
    }
    for ($i=$#q;$i>=1;$i--){                                 # LLENADO B
	next if ($s[$i][0]>=$q[$i]);
	for $j (1..$numteam){
	    next if (check($i,$j)!=0);
	    for (1..$maxacum){
		next if ($s[$i][$_]>0);
		$s[$i][$_]=$j;
		$y[0]++;
		$y[$j]++;
		$s[$i][0] += $t[$j];
		$s[0][0] += $t[$j];
		last;
	    }
	    last if ($s[$i][0]>=$q[$i]);
	}
    }
    for $i (1..$#q){                                   # filtrar innecesarios
	next if ($q[$i]>=$s[$i][0]);
	for $j (1..$numteam){
	    next if ($y[$j] <= 0);
	    next if ($t[$j]>$s[$i][0]-$q[$i]);
	    for (1..$maxacum){
		if ($s[$i][$_]==$j){
		    $s[$i][$_]=0;
		    $y[0]--;
		    $y[$j]--;
		    $s[$i][0] -= $t[$j];
		    $s[0][0] -= $t[$j];
		    last;
		}
	    }
	}
    }
    for ($i=$#q;$i>=1;$i--){                           # rellenar posibles faltas
#	next if ($q[$i]<=$s[$i][0]);
	for $j (1..$numteam){
	    next if (check($i,$j)!=0);
	    for (1..$maxacum){
		$ok = $s[$i][$_];
		if ($ok<1 && $q[$i]>$s[$i][0]){
		    $s[$i][$_]=$j;
		    $y[0]++;
		    $y[$j]++;
		    $s[$i][0] += $t[$j];
		    $s[0][0] += $t[$j];
		    last;
		}elsif (($t[$j]>$t[$ok] && $q[$i]>$s[$i][0]) ||
			 ($t[$j]<$t[$ok] && $t[$ok]-$t[$j]<=$s[$i][0]-$q[$i])){
		    $y[0]--;                            # swap equipos
		    $y[$ok]--;
		    $s[$i][0] -= $t[$ok];
		    $s[0][0] -= $t[$ok];
		    $s[$i][$_]=$j;
		    $y[0]++;
		    $y[$j]++;
		    $s[$i][0] += $t[$j];
		    $s[0][0] += $t[$j];
		    last;
		}
	    }
	}
  	if ($s[$i][0]<$q[$i]) { goto INI; }
    }
    $numperson=0;
    for ($j=$numteam;$j>=1;$j--){                             # ahorrar personas
	$ok=0;
	$n=999;
	for $i (1..$#q){
	    next if ($q[$i]==$s[$i][0]);
	    for (1..$maxacum){
		if ($s[$i][$_]==$j) { 
		    $ok++;
		    $m=$s[$i][0]-$q[$i];
		    if ($m>$t[$j]){ $m=$t[$j]; }
		    if ($m<$n){ $n=$m; }
		}
	    }
	}
	if ($ok==$y[$j] && $n<999){          #  && $t[$j]>2){ 
	    $t[$j]-=$n;
	    for $i (1..$#q){
		next if ($q[$i]==$s[$i][0]);
		for (1..$maxacum){
		    if ($s[$i][$_]==$j){
			$s[$i][0]-=$n;
			$s[0][0]-=$n;
			last;
		    }
		}
	    }
	}
	if ($t[$j]<=0 || $y[$j]<=0) {
	    $ZZ -= 15000;
	}else{
	    $numperson += $t[$j]
	}
    }
    $ZZ += $numperson*35000+$numteam*15000;  # wages of personal and a plus per team leader
    if ($ZZ <= $MINRESOLVE){
	$MINRESOLVE=$ZZ;
	$numsol++; 
	print "\nSolution $numsol:  attempts $tryed  objective $ZZ";
	print "  personal $numperson  equipos $numteam\n";
	for $i (1..$#q){
	    print "Shift $i demand $q[$i] supply $s[$i][0]: ";
	    for $j (1..$numteam){
		for (1..$maxacum){
		    if ($s[$i][$_]==$j){
			print "team$j $t[$j], ";   # workers 
		    }
		}
	    }
	    print "\n";
	}
	print "Total demand $q[0], total supply $s[0][0]\nTeams $y[0]: ";
	for (1..$numteam){
	    print "team$_ $y[$_], ";
	}
	print "\n";
 	print "Desde inicio, ",((time-$TIME)/60)," minutos de tiempo real;\n";
	my ($user,$system,$cuser,$csystem) = times;
	print "Se han consumido $user y $system segundos/cpu de usuario y sistema.\n";   
    }
}


sub check {
    my ($i,$j) = @_;
    my ($n,$a,$b,$short);
    if ($y[$j]>=$maxwork) { return -1; }
    for ($i-2..$i+2){
	if ($_==$#q+2) { $n=2; }
	elsif ($_==$#q+1) { $n=1; }
	elsif ($_==0) { $n= $#q; }
	elsif ($_==-1) { $n= $#q-1; }
	else { $n = $_; }
	for (1..$maxacum){
	    if ($s[$n][$_]==$j){ return 1; }
	}
    }
    return 0;
}

__END__