home *** CD-ROM | disk | FTP | other *** search
/ DP Tool Club 17 / CD_ASCQ_17_101194.iso / dos / prg / vidal / pascal / teguor.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1994-07-21  |  4.2 KB  |  170 lines
  1.  program jdlavie;
  2.  uses crt;
  3.  const
  4.  nbl=24;
  5.  nbc=80;
  6.  cstrep=1;
  7.  popproie=500;
  8.  poppredateur=50;
  9.  cstrepredateur=3;
  10.  cstvie=8;
  11.  croissanceproie=2;
  12.  croissancepredateur=3;
  13.  poptueur=0;
  14.  cstueur=3;
  15.  cstvietueur=15;
  16.  
  17.  
  18.  type
  19.  
  20.  tableau=ARRAY[1..nbc+2,1..nbl+2] of integer;
  21.  
  22.  var t1,t3,t5,t6,t7,t8:tableau;
  23.      i,j,k,k2,gene: integer;
  24.  
  25.  
  26.  PROCEDURE init;
  27.  BEGIN
  28.    for i:=1 to nbl+2 do
  29.    for j:=1 to nbc+2 do BEGIN
  30.           t1[j,i]:=0;
  31.           t3[j,i]:=0;
  32.           t5[j,i]:=0;
  33.           t6[j,i]:=0;
  34.           t7[j,i]:=0;
  35.           t8[j,i]:=0;
  36.           END;
  37.    RANDOMIZE;
  38.    for i:=1 to popproie do
  39.       t1[random(nbc-10)+5,random(nbl-5)+2]:=1;
  40.     for i:=1 to poppredateur do
  41.       t3[random(nbc-10)+5,random(nbl-5)+2]:=1;
  42.     for i:=1 to poptueur do
  43.       t7[random(nbc-10)+5,random(nbl-5)+2]:=1;
  44.  
  45.  END;
  46.    function F(j:byte):byte;
  47.    BEGIN
  48.    if (j=1) or (j=nbc-1) then if j=1 then F:=nbc-2 else F:=2
  49.              else F:=j;
  50.    END;
  51.    function G(j:byte):byte;
  52.    BEGIN
  53.    if (j=1) or (j=nbl-1) then if j=2 then G:=nbl-2 else G:=2
  54.              else G:=j;
  55.    END;
  56.  
  57.  
  58.    PROCEDURE OPTI(c,b,a:integer;var t1,t2,tr: TABLEAU);
  59.    BEGIN
  60.    if (t2[j-1*b,i-1*a]<>0) and (tr[j-1*b,i-1*a]=c) then
  61.                          BEGIN
  62.                            t2[F(j+1),G(i+1)]:=t2[j,i];
  63.                            t2[F(j+1*b),G(i+1*a)]:=t2[j,i];
  64.                            tr[F(j+1*b),G(i+1*a)]:=0
  65.                          end
  66.                    else
  67.                          BEGIN
  68.                            t2[F(j-1*b),G(i-1*a)]:=t1[j,i];t2[j,i]:=0;
  69.                          END;
  70.    END;
  71.  
  72.    PROCEDURE transfert(var t1,tr: TABLEAU;c:integer);
  73.    var R: byte;
  74.        t2: TABLEAU;
  75.    BEGIN
  76.      t2:=t1;
  77.      for i:=1 to nbl-1 do
  78.      for j:=1 to nbc-1 do
  79.                 if t1[j,i]<>0 then
  80.                 BEGIN
  81.                    R:=random(4);
  82.                    case R of
  83.                          0:opti(c,1,0,t1,t2,tr);
  84.                          1:opti(c,-1,0,t1,t2,tr);
  85.                          2:opti(c,0,-1,t1,t2,tr);
  86.                          3:opti(c,0,1,t1,t2,tr);
  87.              END;
  88.            END;
  89.        t1:=t2;
  90.      END;
  91.  
  92.      PROCEDURE affichage;
  93.      var compt,nbrequin,nbtueur: integer;
  94.      BEGIN
  95.        GOTOXY(1,1);
  96.        compt:=0;nbrequin:=0;nbtueur:=0;
  97.        for i:=2 to nbl-2 do
  98.          for j:=2 to nbc+1 do
  99.           if t7[j,i]>0 then BEGIN nbtueur:=nbtueur+1;
  100.                                    textcolor(4);
  101.                                    write('@'); end  else
  102.           if t3[j,i]>0 then BEGIN nbrequin:=nbrequin+1;
  103.                                    textcolor(3);
  104.                                    write('R'); end  else
  105.           case t1[j,i] of
  106.            1:  BEGIN
  107.            textcolor(1);write('o');
  108.            compt:=compt+1;
  109.            END;
  110.            0: BEGIN
  111.            textcolor(1);write(' ');
  112.            END;
  113.           end;
  114.        write('GENERATION :',gene,' ');
  115.        write('POISSON ',compt,' ');write('REQUIN ',nbrequin,' ');
  116.        write('TUEUR ',nbtueur,' ');
  117.        end;
  118.  
  119.   PROCEDURE FAIM(var t3,t1,t:TABLEAU;b: byte);
  120.   BEGIN
  121.     for i:=2 to nbl+1 do
  122.          for j:=2 to nbc+1 do
  123.           BEGIN
  124.            if (t3[j,i]>0) and ((t1[j,i]>0) or (t[j,i]>0)) then
  125.                 Begin
  126.                   t3[j,i]:=1;
  127.                   t1[j,i]:=0;
  128.                    t[j,i]:=0;
  129.                 END;
  130.             if t3[j,i]>0 then t3[j,i]:=t3[j,i]+1;
  131.             if t3[j,i]>=b then t3[j,i]:=0;
  132.             END;
  133.           END;
  134.  
  135.   PROCEDURE REPRODUCTION(var t:tableau;b:byte);
  136.   BEGIN
  137.     for i:=1 to nbl+1 do
  138.          for j:=1 to nbc+1 do
  139.            if (t[j,i]<b) then t[j,i]:=t[j,i]+1;
  140.   END;
  141.  
  142.  
  143.     BEGIN
  144.     clrscr;
  145.     init;
  146.     gene:=0;
  147.     affichage;
  148.     REPEAT
  149.       reproduction(t8,cstueur);
  150.       transfert(t7,t8,cstueur);
  151.       faim(t7,t3,t3,cstvietueur);
  152.       for k2:=1 to croissancepredateur do
  153.       BEGIN
  154.         transfert(t3,t5,cstrepredateur);
  155.         reproduction(t5,cstrepredateur);
  156.         faim(t3,t1,t1,cstvie);
  157.  
  158.       END;
  159.       for k:=1 to croissanceproie do
  160.      BEGIN
  161.       transfert(t1,t6,cstrep);
  162.       reproduction(t6,cstrep);
  163.      END;
  164.      gene:=gene+1;
  165.      affichage;
  166.     UNTIL KEYPRESSED;
  167.     readln;
  168.     END.
  169.  
  170.