[TP] Szalone obliczenia z systemem mrówkowym i probemy TP

0

Mam taki kod:

program komiwoj;

uses Crt, Graph;

type
ptr = ^town;
town = record
  x,
  y: word;
  num:byte;
  prev,
  next:ptr;
end;

neighbour = array [0..50] of array [0..50] of boolean;
antferom  = array [0..50] of array [0..50] of double;
probabtab = array [0..50] of double;
bannedcit = array [0..50] of boolean;
pass      = array [0..50] of byte;
bestpasslen = double;

function power(const x,y : double) : double;
begin
power := exp(ln(abs(x))*y);
end;

procedure insnext(var head,tail:ptr; x,y:word );
  var
    ntown:ptr;
  begin
    new(ntown);
    ntown^.x:=x;
    ntown^.y:=y;
    ntown^.prev:=nil;
    ntown^.next:=nil;
    if tail<>nil then
      begin
        ntown^.next:=tail^.next;
        if ntown^.next<>nil then
          ntown^.next^.prev:=ntown;
        tail^.next:=ntown;
        ntown^.prev:=tail;
        ntown^.num:=tail^.num+1;
        tail:=ntown;
      end
    else
      begin
        head:=ntown;
        tail:=ntown;
        tail^.num:=0;
      end;
end;

procedure loadnb(var tab:neighbour);
  var
    f:text;
    x,y:byte;
    a:string;
  begin
    x:=0;
    y:=0;
    assign(f, 'nb.txt');
    reset(f);
   while not eof(f) do
     begin
        readln(f,a);
        for y:=0 to length(a)-1 do
          begin
           if (a[y+1]='0') then
              tab[x,y]:=false
            else
              tab[x,y]:=true;
          end;
        x:=x+1;
      end;
    close(f);
end;

procedure loadtwns(var head,tail:ptr);

  procedure Pars(const s:string; var ix, iy: integer);
  var
    x,y:string;
    ciach:integer;
  begin
    ciach:=Pos(',',s);
    x:=copy(s,1,ciach-1);
    y:=copy(s,ciach+1,(length(s)-ciach));
    val(x, ix, ciach);
    val(y, iy, ciach);
  end;

  var
    f:text;
    x,y:integer;
    a:string;

  begin
    x:=0;
    y:=0;
    assign(f, 'tw.txt');
    reset(f);
    while not eof(f) do
      begin
        readln(f,a);
        if a='' then
          continue;
        pars(a, x, y);
        insnext(head, tail, x, y);
      end;
    close(f);
  end;

procedure generatepass(var head, tail, phead, ptail:ptr; const bestpass:pass);
var
  i: byte;
  tmpptr: ptr;
begin
  for i:=0 to tail^.num do
    begin
      tmpptr:=head;
      while tmpptr^.num<>bestpass[i] do
        tmpptr:=tmpptr^.next;
      insnext(phead, ptail, tmpptr^.x, tmpptr^.y);
    end;
end;

function getlen(const x, y: byte; const head, tail: ptr) : double;
var
  xptr,
  yptr:ptr;

begin
  xptr:=head;
  while xptr^.num<>x do
    xptr:=xptr^.next;
  yptr:=head;
  while yptr^.num<>y do
    yptr:=yptr^.next;

  getlen:= sqrt( sqr(yptr^.x - xptr^.x) + sqr(yptr^.y - xptr^.y) );
end;

procedure displaypass(const head, tail: ptr);
var
  sterownik, tryb, blad: integer;
  tmpptr:ptr;
begin
  sterownik:=Detect;
  InitGraph( sterownik, tryb, './BGI');
  blad:=GraphResult;
  if blad<> grOK then
    begin
      WriteLn('Sie skopcila grafika');
      write('mowi ze ja boli ', blad);
      Halt;
    end;
  MoveTo(head^.x, head^.y);
  tmpptr:=head^.next;
  while tmpptr<>nil do
    begin
      LineTo(tmpptr^.x, tmpptr^.y);
      tmpptr:=tmpptr^.next;
    end;
  Line(head^.x, head^.y, tail^.x, tail^.y);
  readln;
  CloseGraph;
end;

procedure antmoves(const head, tail: ptr; const tab: neighbour; var bestpass: pass);
var
  iters, numcit, currcit, trycnt, tabued: byte;
  antpopul, antnum: word;
  road, bestroad: double;
  tmprt: integer;
  ferr: antferom;
  prob: probabtab;
  tabu: bannedcit;
  pas: pass;

const
  antfer=0.1; {ilość zostawianego feromonu}
  antdefer=0.3; {szybkość odparowywania: 30%}
  alfa = 0.5;{znaczenie feromonu}
  beta = 3.5;{znaczenie widoczności}
  {antpopul = 100;} {wielkosc popuacji mrowek, najlepiej by bylo 2*iosc miast.}
  maxiters = 100; {liczba iteracji, im wiencej tym lepiej, tym dluzej}
  maxtry = 10; {maksymalna liczba powrotow, po blendnie dobranej trasie, im wieej tym lepiej, tym wolniej}

  procedure SetUpFerr;
  var
    x, y: byte;
  begin
    for x:=0 to numcit do
      for y:=0 to numcit do
        ferr[x, y]:=0.01;
  end;

  procedure SetUpTabu;
  var
    t: byte;
  begin
    for t:=0 to numcit do
        tabu[t]:=false;
  end;

  procedure SetUpPass;
  var
    t: byte;
  begin
    for t:=0 to numcit do
        pas[t]:=0;
  end;

  procedure makeprobtab(const x: byte);

    function sum: double;
    var
      y: byte;
      ret: double;
    begin
      ret:=0;
      for y:=0 to numcit do
        if (tabu[y] = false) and (tab[x, y] = true) and (x<>y) then
          ret:=ret+(power(ferr[x,y], alfa) * power( 1/getlen(x,y,head,tail), beta));
      sum:=ret;
    end;

  var
    y: byte;
  begin
    for y:=0 to numcit do
      begin
        if (tabu[y] = true) or (tab[x, y] = false) or (x=y) then
          prob[y]:=0
        else
          prob[y]:= (power(ferr[x,y], alfa) * power( 1/getlen(x,y,head,tail), beta))/sum;
      end;
  end;

  function selectroute: integer; {select route from 5 most possible}
  var
    y:byte;
    ymax: integer;
    max, lastmax:double;
    ra: array[0..4] of integer;
  begin
    for y:=0 to 4 do
      ra[y]:=-1;
    max:=0;
    ymax:=-1;
    for y:=0 to numcit do
      if prob[y]>max then
        begin
          max:=prob[y];
          ymax:=y;
        end;
    if ymax<>-1 then
      ra[2]:=ymax
    else
      begin
      {no possible routes}
        writeln('poszło sie jebać');
        selectroute:=-1;
        exit;
      end;
    lastmax:=max;
    max:=0;
    ymax:=-1;
    for y:=0 to numcit do
      if (prob[y]>max) and (prob[y]<lastmax) then
        begin
          max:=prob[y];
          ymax:=y;
        end;
    if ymax<>-1 then
      ra[3]:=ymax
    else
      begin
      {jetna droka}
        selectroute:=ra[3];
        exit;
      end;
    {mamy wincy nisz jetno droke, to zie bafimy}
    lastmax:=max;
    max:=0;
    ymax:=-1;
    for y:=0 to numcit do
      if (prob[y]>max) and (prob[y]<lastmax) then
        begin
          max:=prob[y];
          ymax:=y;
        end;

   ra[1]:=ymax;
    lastmax:=max;
    max:=0;
    ymax:=-1;
    for y:=0 to numcit do
      if (prob[y]>max) and (prob[y]<lastmax) then
        begin
          max:=prob[y];
          ymax:=y;
        end;
    ra[4]:=ymax;
    lastmax:=max;
    max:=0;
    ymax:=-1;
    for y:=0 to numcit do
      if (prob[y]>max) and (prob[y]<lastmax) then
        begin
          max:=prob[y];
          ymax:=y;
        end;
    ra[0]:=ymax;
    lastmax:=max;
    repeat
      y:=random(5);
    until ra[y]<>-1;
    selectroute:=ra[y];
  end;

  procedure VaporFerr;
  var
    x,y:byte;
  begin
    for x:=0 to numcit do
      for y:=0 to numcit do
        ferr[x,y]:=ferr[x,y] * (1-antdefer);
  end;

  function cntroad: double;
  var
    x: byte;
    ret: double;
  begin
    ret:=0;
    for x:=1 to numcit do
      begin
        ret:=ret+getlen(pas[x-1], pas[x], head, tail);
      end;
    ret:=ret+getlen(pas[numcit], pas[0], head, tail);
  end;

  procedure passage;
  var
    x: byte;
  begin
    for x:=0 to numcit do
      begin
        bestpass[x]:=pas[x];
      end;
  end;

  procedure distferr(const road:double);
  var
    x:byte;
  begin
    for x:=1 to numcit do
      begin
        ferr[x-1, x]:=ferr[x-1, x]+(antfer/road);
      end;
  end;

begin
  iters:=0;
  numcit:=tail^.num;
  antpopul:=numcit*2;
  SetUpFerr;
  bestroad:=-1;
  Writeln('Generating...');
    repeat
    write('Iter ', iters,'; ant:');
    for antnum:=1 to antpopul do
      begin
        write(antnum, ', ');
        SetUpTabu;
        SetUpPass;
        pas[0]:=0;
        tabu[0]:=true;
        currcit:=0;
        trycnt:=0;
        repeat
          makeprobtab(pas[currcit]);
          tmprt:=selectroute;
          if tmprt=-1 then
            begin
              if currcit=0 then
                begin
                  writeln('ozeszek ty mac');
                  exit;
                end;
              currcit:=currcit-1;
              trycnt:=trycnt+1;
              if trycnt=maxtry then
                begin
                  writeln('ni ma szczynscia');
                  exit;
                end;
              continue;{to wykopie do poczatku penti jak jest ok}
            end;
          {jakezesmy dotarli tutej to jest dopze}
          currcit:=currcit+1;
          pas[currcit]:=tmprt;
          tabu[pas[currcit]]:=true;
        until pas[numcit]<>0;{koncowa droga, szit, straszny ten warunek}
{tu jestesmy, znaczy ze droga przeszla, uff, a moglo sie zle skonczyc, bo jak moze nie byc sasiadow to jest straszna lipa}
        road:=cntroad;
        if bestroad=-1 then
          bestroad:=road;
        if road<bestroad then
          begin
            bestroad:=road;
            passage;
          end;
        if not (road>bestroad) then
          begin
            distferr(road);{im krutsza droga tym wiencej feromonu}
          end;
      end;
    VaporFerr;
      iters:=iters+1;
    writeln;
    until iters=maxiters;           
end;

var
  head, tail, phead, ptail: ptr;
  nb: neighbour;
  bestpass: pass;

begin
  loadnb(nb);
  loadtwns(head, tail);
  antmoves(head, tail, nb, bestpass);
  generatepass(head, tail, phead, ptail, bestpass);
  readln;
  displaypass(phead, ptail);
end.

przy zawartości pliku nb.txt:

0111111111
1011111111
1101111111
1110111111
1111011111
1111101111
1111110111
1111111011
1111111101
1111111110

i tw.txt:

10,10
45,20
100,230
55,300
550,400
510,1
1,420
320,240
123,456
250,150

program wykrzaza się przy obliczaniu długości pierwszej drogi z błędem Floating Point Overflow, podczas gdy ta droga nie powinna być dłuższa przy pierwszym obliczeniu (1 i 2) niż 36,4.

//ps. nie wiem czemu ale znaczniki delphi i code wstawiają w cholere enterów.

0

Wybacz, że tak z grubej rury przywalę, bo nie czytałem kodu bo jest dośc długi natomiast na podstawie tego co piszesz sugeruje sprawdzić czy gdzieś nie ma odwołania do niezainicjowanej zmiennej zmiennoprzecinkowej , wtedy często występuje floatig point overflow. np:


procedure procka;
var x,y:double;
begin
x:=y;// już tu może wystąpić floating point overflow bo zmienna y może nie byc zainicjowana(w zasadzie z tego co pamiętam to nie jest zainicjowana na większości chyba kompilatorów borlanda i z resztą słusznie) i następuje odwołanie do 8 bajtów , które zinterpretowane jako liczba double nie mieszczą się w zakresie przewidzianym dla tego formatu
end;
0

Oj, dokadnie sprawdzałem, ale najwidoczniej doszukać się nie mogę. Wszystko na czym cokolwiek polega jest wcześniej inicjalizowane.

Dodatkowo ponowne skompilowanie kodu bez przeglądania, tylko usunięty graph a metoda go wykorzystująca zmieniona na wyświetlającą kolejne współrzędne, problem z floating point overflow znika, natomiast funkcja wybierająca dobrą drogę nie może sobie poradzić ze zwróceniem dobrego wyniku, mimo iż tablica prawdopodobieństw jest wypełniona... ta, tyle że te wartości są dość dziwne, jak ktoś ma czas to niech skompiluje sobie i przepatrzy, ja nie mam już cierpliwości do pascala. FreePascal odstawia głupoty na tym wykraczając się na operacjach z wskaźnikami.

1 użytkowników online, w tym zalogowanych: 0, gości: 1, botów: 0