program TSP;
uses graph,crt;

type tCoord=record
                x,y:word;
              end;
     tPoblacion=array[0..60000]of byte;
     tUbicacion=array[0..255] of tCoord;
     tPuntaje=array[0..0] of real;
var
  nCiudades: byte;
  nPoblacion, mejorCrom: word;
  pPobl, pPobl1, pPobl2, pCopia, pOriginal: ^tPoblacion;
  pUbicacion: ^tUbicacion;
  pPuntaje: ^tPuntaje;
  mejorDist, distanciaMedia: longint;
  visualPage: byte;
  puntajeTotal: real;

{  Rutina que muestra la mejor soluci¢n  }
procedure MostrarMejor;
  function IntAStr(n:longint):string;
  { Funci¢n auxiliar que pasa un entero a un string usando notaci¢n cient¡fica si es muy largo }
    var strAux:string[30]; i,j:byte;
    begin
      Str(n,strAux);
      if length(strAux)>5 then begin
                                 i:=30;
                                 {repeat i:=i-1 until strAux[i]='0';}
                                 j:=i;
                                 repeat i:=i-1 until not(strAux[i]='0');
                                 IntAStr:=copy(strAux,1,i)+'E'+IntAStr(j-i);
                               end
                          else IntAStr:=strAux;
    end;
var I:byte; mejorPunt:real;
begin
  ClearDevice;
  MoveTo(pUbicacion^[pPobl^[mejorCrom*nCiudades*sizeOf(byte)]].x,
        pUbicacion^[pPobl^[mejorCrom*nCiudades*sizeOf(byte)]].y);
  for I:=1 to nCiudades-1 do
    LineTo(pUbicacion^[pPobl^[(mejorCrom*nCiudades+I)*sizeOf(byte)]].x,
        pUbicacion^[pPobl^[(mejorCrom*nCiudades+I)*sizeOf(byte)]].y);
  LineTo(pUbicacion^[pPobl^[(mejorCrom*nCiudades)*sizeOf(byte)]].x,
      pUbicacion^[pPobl^[(mejorCrom*nCiudades)*sizeOf(byte)]].y);
  SetTextStyle(DefaultFont, HorizDir, 1);
  mejorPunt:=pPuntaje^[mejorCrom];
  OutTextXY(10,10, 'Distancia del mejor candidato: '+IntAStr(mejorDist));
  OutTextXY(10,20, 'Distancia media: '+IntAStr(distanciaMedia));
end;

{  Funcion evaluacion  }
function Eval(base:word):longint;
var suma:longint; I:byte; auxi: longint;
begin
  suma:=0;
  for I:=0 to nCiudades-2 do
    begin
      auxi:=(pUbicacion^[pPobl^[base+I]].x-pUbicacion^[pPobl^[base+I+1]].x)
            *(pUbicacion^[pPobl^[base+I]].x-pUbicacion^[pPobl^[base+I+1]].x)
            +(pUbicacion^[pPobl^[base+I]].y-pUbicacion^[pPobl^[base+I+1]].y)
            *(pUbicacion^[pPobl^[base+I]].y-pUbicacion^[pPobl^[base+I+1]].y);
      suma:=suma+round(sqrt(auxi));
    end;
  auxi:=(pUbicacion^[pPobl^[base+nCiudades-1]].x-pUbicacion^[pPobl^[base]].x)
        *(pUbicacion^[pPobl^[base+nCiudades-1]].x-pUbicacion^[pPobl^[base]].x);
  auxi:=auxi+(pUbicacion^[pPobl^[base+nCiudades-1]].y-pUbicacion^[pPobl^[base]].y)
        *(pUbicacion^[pPobl^[base+nCiudades-1]].y-pUbicacion^[pPobl^[base]].y);
  suma:=suma+round(sqrt(auxi));
  { La £ltima suma fue para cerrar el ciclo }
  Eval:=suma;
end;


var
  I,J,K,L,M,aux: word;
  posicion1,posicion2,auxiByte: byte;
  base,intAuxi1,intAuxi2,intAuxi3: word;
  peorDist, distancia, mejorAnterior: longint;
  grDriver,grMode,ErrCode: integer;
  probCruza,probMuta,realAuxi,conv: real;
  pArrayAuxi1,pArrayAuxi2: ^tPoblacion;
  no_esta: boolean;

begin

{  Ingreso de par metros  }
  RestoreCrtMode;
  ClrScr;
  WriteLn('DEMO DE UN ALGORITMO GENETICO QUE SOLUCIONA EL PROBLEMA DEL VIAJANTE');
  WriteLn('Andr‚s Djordjalian');
  WriteLn('Julio de 1998');
  WriteLn;
  WriteLn('Par metros:');
  Write('   Poblaci¢n [100]: ');
  ReadLn(nPoblacion);
  if nPoblacion=0 then nPoblacion:=100;
  Write('   Cantidad de ciudades [50]: ');
  ReadLn(nCiudades);
  if nCiudades=0 then nCiudades:=50;
  Write('   Probabilidad de cruza (%) [50]');
  ReadLn(probCruza);
  if probCruza=0 then probCruza:=50;
  probCruza:=probCruza*10;
  Write('   Probabilidad de mutacion (%) [0.1]');
  ReadLn(probMuta);
  if probMuta=0 then probMuta:=0.1;
  probMuta:=probMuta*10;

{  Inicializaci¢n de variables y gr ficos  }
  grDriver := Detect;
  grMode:=VGAHi;
  InitGraph(grDriver, grMode,'d:\leng\bp\bgi\');
  ErrCode := GraphResult;
  if ErrCode <> grOk then
    begin
      Writeln('Graphics error:', GraphErrorMsg(ErrCode));
      halt(1);
    end;
  Randomize;
  GetMem(pPuntaje,nPoblacion*sizeOf(real));
  GetMem(pArrayAuxi1,nCiudades*sizeOf(byte));
  GetMem(pArrayAuxi2,nCiudades*sizeOf(byte));
  mejorDist:=MaxLongInt;

{  Determinaci¢n al azar de las posiciones de las ciudades  }
  if MaxAvail<nCiudades*sizeOf(tCoord) then halt(1);
  GetMem(pUbicacion,nCiudades*sizeOf(tCoord));
  for I:=0 to nCiudades-1 do
    begin
      pUbicacion^[I].x:=Random(640);
      pUbicacion^[I].y:=Random(480);
    end;

{  Inicializaci¢n del GA  }
  if MaxAvail<nCiudades*nPoblacion*sizeOf(byte) then halt(1);
  GetMem(pPobl1, nCiudades*nPoblacion*sizeOf(byte));
  if MaxAvail<nCiudades*nPoblacion*sizeOf(byte) then halt(1);
  GetMem(pPobl2, nCiudades*nPoblacion*sizeOf(byte));
  pPobl:=pPobl1;
  for I:=0 to nPoblacion-1 do
    begin
      base:=I*nCiudades;
      for J:=0 to nCiudades-1 do pPobl^[base+J]:=J;
      for J:=nCiudades-1 downto 1 do
        begin
          K:=Random(J);
          aux:=pPobl^[base+K];
          pPobl^[base+K]:=pPobl^[base+J];
          pPobl^[base+J]:=aux;
        end;
    end;

{  Ciclo principal del GA  }
  repeat until not(KeyPressed);
  repeat

  {  Selecci¢n  }
    puntajeTotal:=0;
    mejorAnterior:=mejorDist;
    mejorDist:=MaxLongInt;
    peorDist:=0;
    for I:=0 to nPoblacion-1 do
      begin
        distancia:=Eval(I*nCiudades);
        pPuntaje^[I]:=1/sqr(distancia);
        distanciaMedia:=(distanciaMedia*I+distancia) div (I+1);
        if distancia<mejorDist then
          begin
            mejorDist:=distancia;
            mejorCrom:=I;
          end;
        if distancia>peorDist then peorDist:=distancia;
      end;
    conv:=mejorDist/distanciaMedia;
    for I:=0 to nPoblacion-1 do
      begin
{        pPuntaje^[I]:=distanciaMedia*(1.001+3*(1-conv))*pPuntaje^[I]-1;
        if pPuntaje^[I]<0 then pPuntaje^[I]:=0; }
        puntajeTotal:=puntajeTotal+pPuntaje^[I];
      end;
    pOriginal:=pPobl;
    if pPobl=pPobl1
      then pCopia:=pPobl2
      else pCopia:=pPobl1;
    for I:=0 to nPoblacion-1 do
      begin
        repeat
          intAuxi1:=Random(32767);
          intAuxi2:=Random(32767);
        until intAuxi1<>intAuxi2;
        if intAuxi1>intAuxi2 then
           begin
             intAuxi3:=intAuxi2;
             intAuxi2:=intAuxi1;
             intAuxi1:=intAuxi3;
           end;
        realAuxi:=intAuxi1/intAuxi2;
        J:=0;
        repeat
          realAuxi:=realAuxi-pPuntaje^[J]/puntajeTotal;
          J:=J+1;
        until realAuxi<=0;
        for K:=0 to nCiudades-1 do
          pCopia^[I*nCiudades+K]:=pOriginal^[(J-1)*nCiudades+K];
      end;

  { Muestra el mejor candidato  }
    MostrarMejor;

  {  Togglea a la nueva generaci¢n }
    pPobl:=pCopia;

  {  Cruza  }
    I:=0;
    repeat
      if Random(1000)<=probCruza then
        begin
          J:=I;
          repeat J:=J+1 until ((J>=nPoblacion) or (Random(1000)<=probCruza));
          if J<nPoblacion then
            begin
              posicion1:=Random(nCiudades);
              posicion2:=Random(nCiudades);
              M:=0;
              for K:=0 to nCiudades-1 do
                begin
                  no_esta:=true;
                  L:=posicion1;
                  repeat
                    if pPobl^[I*nCiudades+K]=pPobl^[J*nCiudades+L]
                       then no_esta:=false;
                    L:=L+1;
                    if L=nCiudades then L:=0
                  until not(no_esta) or (L=posicion2+1) or ((L=0) and (posicion2=nCiudades-1));
                  if no_esta
                    then
                      begin
                        pArrayAuxi1^[M]:=pPobl^[I*nCiudades+K];
                        M:=M+1;
                      end
                    else if L=((posicion1+1) mod nCiudades) then {. . .es el primero de la cadena}
                           begin
                             L:=posicion1;
                             repeat
                               pArrayAuxi1^[M]:=pPobl^[J*nCiudades+L];
                               M:=M+1;
                               if M=nCiudades then M:=0;
                               L:=L+1;
                               if L=nCiudades then L:=0;
                             until L=(posicion2+1) mod nCiudades;
                           end;
                end;
              M:=0;
              for K:=0 to nCiudades-1 do
                begin
                  no_esta:=true;
                  L:=posicion1;
                  repeat
                    if pPobl^[J*nCiudades+K]=pPobl^[I*nCiudades+L]
                       then no_esta:=false;
                    L:=L+1;
                    if L=nCiudades then L:=0
                  until not(no_esta) or (L=posicion2+1) or ((L=0) and (posicion2=nCiudades-1));
                  if no_esta
                    then
                      begin
                        pArrayAuxi2^[M]:=pPobl^[J*nCiudades+K];
                        M:=M+1;
                      end
                    else if L=((posicion1+1) mod nCiudades) then {. . .es el primero de la cadena}
                           begin
                             L:=posicion1;
                             repeat
                               pArrayAuxi2^[M]:=pPobl^[I*nCiudades+L];
                               M:=M+1;
                               if M=nCiudades then M:=0;
                               L:=L+1;
                               if L=nCiudades then L:=0;
                             until L=(posicion2+1) mod nCiudades;
                           end;
                end;
            for K:=0 to nCiudades-1 do pPobl^[I*nCiudades+K]:=pArrayAuxi1^[K];
            for K:=0 to nCiudades-1 do pPobl^[J*nCiudades+K]:=pArrayAuxi2^[K];
            end;
          I:=J;
        end;
      I:=I+1;
    until I>=nPoblacion;


  {  Mutaci¢n  }
    I:=0;
    repeat
      if Random(1000)<=probMuta then
        begin
          posicion1:=Random(nCiudades);
          posicion2:=(posicion1+1+Random(nCiudades-1)) mod nCiudades; {para que sea <> de posicion1 }
          if posicion1<posicion2
            then begin
                   auxiByte:=pPobl^[(I*nCiudades+posicion1)*sizeOf(byte)];
                   for J:=posicion1 to posicion2-1 do
                     pPobl^[(I*nCiudades+J)*sizeOf(byte)]:=pPobl^[(I*nCiudades+J+1)*sizeOf(byte)];
                   pPobl^[(I*nCiudades+posicion2)*sizeOf(byte)]:=auxiByte;
                 end
            else begin
                   auxiByte:=pPobl^[(I*nCiudades+posicion1)*sizeOf(byte)];
                   for J:=posicion1 downto posicion2+1 do
                     pPobl^[(I*nCiudades+J)*sizeOf(byte)]:=pPobl^[(I*nCiudades+J-1)*sizeOf(byte)];
                   pPobl^[(I*nCiudades+posicion2)*sizeOf(byte)]:=auxiByte;
                 end
        end
        else I:=I+1;
    until I=nPoblacion;

{  Criterio de convergencia  }
  until KeyPressed;

{  Reporte final  }

  CloseGraph;
end.

{  Estructura de la poblaci¢n:                                  }
{    POBLACION = ARRAY [0..POBL] OF CROMOSOMA                   }
{    CROMOSOMA = ARRAY [0..#CIUDADES] OF INDICE_CIUDAD          }
{    INDICE_CIUDAD = BYTE [ MAX(#CIUDADES)=256 ]                }