home *** CD-ROM | disk | FTP | other *** search
/ Computer Club Elmshorn Atari PD / CCE_PD.iso / pc / 0600 / CCE_0661.ZIP / CCE_0661.PD / CUBELIFE / CUBELIFE.PAS next >
Pascal/Delphi Source File  |  1989-10-08  |  9KB  |  242 lines
  1. { (c) by Chistian Wolff, Spanbeck,   6/87,   Freeware,  Monochrom }
  2. program DreiDeCubes;
  3.  
  4.   const xl=42; yl=27; zl=27;
  5.  
  6.   type tsuppe=packed array[1..xl,1..yl,1..zl] of byte;
  7.        tscreen=packed array[0..32760]of byte;
  8.        tptr=^tscreen;
  9.  
  10.   var cod:string;
  11.       sprite,save:array[0..36]of integer;
  12.       xp,yp,zp,c,i:integer;
  13.       sup1,sup2,emp,zel:tsuppe;
  14.       q,w,e,r,key:char;
  15.       norm,s:boolean;
  16.       a1,a2,a3:long_integer;
  17.       screen:tptr;
  18.       convert:record case boolean of
  19.              true:(ptr:tptr);
  20.              false:(adr:long_integer);
  21.            end;
  22.  
  23.   function coninnoecho:char; gemdos(8);
  24.   function setcolor(colnum,col:integer):integer; xbios(7);
  25.   procedure hardcopy; xbios(20);
  26.   function rand:long_integer; xbios(17);
  27.   function physbase:long_integer; xbios(2);
  28.   function logbase:long_integer; xbios(3);
  29.   procedure setscreen(log,phys:long_integer;rez:integer); xbios(5);
  30.   procedure waitvbl; xbios(37);
  31.  
  32.   procedure newscreen;
  33.     begin
  34.       new(screen);
  35.       convert.ptr:=screen;
  36.       a3:=convert.adr;
  37.       a1:=physbase;
  38.       a2:=a3+$100-(a3 & $ff);
  39.     end;
  40.  
  41.   procedure freemem;
  42.     begin
  43.       setscreen(a1,a1,-1);
  44.       waitvbl;
  45.     end;
  46.  
  47.   procedure init;
  48.     var i,j,k,col:integer;
  49.     begin
  50.       if s then newscreen;
  51.       for i:=1 to xl do for j:=1 to yl do for k:=1 to zl do emp[i,j,k]:=0;
  52.       col:=setcolor(0,$000); col:=setcolor(1,$777);
  53.       sprite[0]:=0; sprite[1]:=0; sprite[2]:=2; sprite[3]:=1; sprite[4]:=0;
  54.       sprite[5 ]:=$0000; sprite[6 ]:=$0000;
  55.       sprite[7 ]:=$0000; sprite[8 ]:=$0000;
  56.       sprite[9 ]:=$1ffc; sprite[10]:=$0000;
  57.       sprite[11]:=$355c; sprite[12]:=$0aa0;
  58.       sprite[13]:=$6abc; sprite[14]:=$1540;
  59.       sprite[15]:=$d57c; sprite[16]:=$2a80;
  60.       sprite[17]:=$fffc; sprite[18]:=$0000;
  61.       sprite[19]:=$803c; sprite[20]:=$7fc0;
  62.       sprite[21]:=$803c; sprite[22]:=$7fc0;
  63.       sprite[23]:=$803c; sprite[24]:=$7fc0;
  64.       sprite[25]:=$803c; sprite[26]:=$7fc0;
  65.       sprite[27]:=$803c; sprite[28]:=$7fc0;
  66.       sprite[29]:=$803c; sprite[30]:=$7fc0;
  67.       sprite[31]:=$8038; sprite[32]:=$7fc0;
  68.       sprite[33]:=$8030; sprite[34]:=$7fc0;
  69.       sprite[35]:=$ffe0; sprite[36]:=$0000;
  70.     end;
  71.  
  72.   procedure ende;
  73.     var ch:char;
  74.         fore,back:integer;
  75.     begin
  76.       ch:=coninnoecho;
  77.       if (ch in['Q','q']) or (ord(ch) in[27]) then begin
  78.         write(chr(27),'e');
  79.         if s then freemem;
  80.         halt;
  81.       end else
  82.       if ch in['P','p'] then begin
  83.         back:=setcolor(0,$777); fore:=setcolor(1,$000);
  84.         hardcopy;
  85.         back:=setcolor(0,back); fore:=setcolor(1,fore);
  86.       end else
  87.         write(chr(7));
  88.         repeat until keypress;
  89.         ch:=coninnoecho;
  90.         write(chr(7));
  91.     end;
  92.  
  93.   procedure fill;
  94.     var i,j,k,im1,ip1,jm1,jp1,km1,kp1,x,y,z:integer;
  95.     begin
  96.       write(chr(27),'E',chr(27),'f');
  97.       case c of
  98.         -1:begin {Glider}
  99.              sup1[10,10,10]:=1; sup1[11,11,10]:=1; sup1[11,12,10]:=1;
  100.              sup1[10,13,10]:=1; sup1[10,10,11]:=1; sup1[11,11,11]:=1;
  101.              sup1[11,12,11]:=1; sup1[10,13,11]:=1; sup1[10,11,12]:=1;
  102.            sup1[10,12,12]:=1; end;
  103.         -2:begin {Bockender Bronco/Mühle}
  104.              sup1[10,11,11]:=1; sup1[11,12,11]:=1; sup1[11,11,10]:=1;
  105.              sup1[11,10,11]:=1; sup1[11,10,12]:=1; sup1[12,12,11]:=1;
  106.              sup1[12,11,10]:=1; sup1[12,10,11]:=1; sup1[12,10,12]:=1;
  107.            sup1[13,11,11]:=1; end;
  108.         -3:begin {Stimmgabel/Badewanne}
  109.              sup1[10,12,10]:=1; sup1[10,11,10]:=1; sup1[10,10,11]:=1;
  110.              sup1[10,11,12]:=1; sup1[10,12,12]:=1; sup1[11,12,10]:=1;
  111.              sup1[11,11,10]:=1; sup1[11,10,11]:=1; sup1[11,11,12]:=1;
  112.            sup1[11,12,12]:=1; end;
  113.       end;
  114.       x:=0; for i:=1 to xl do begin x:=x+10;
  115.         if i=1 then im1:=xl else im1:=i-1;
  116.         if i=xl then ip1:=1 else ip1:=i+1;
  117.         y:=398; for j:=1 to yl do begin y:=y-10;
  118.           if j=1 then jm1:=yl else jm1:=j-1;
  119.           if j=yl then jp1:=1 else jp1:=j+1;
  120.           z:=112; for k:=1 to zl do begin z:=z-4;
  121.             if k=1 then km1:=zl else km1:=k-1;
  122.             if k=zl then kp1:=1 else kp1:=k+1;
  123.             if c>=0 then
  124.               if (rand mod 100)<c then sup1[i,j,k]:=1 else sup1[i,j,k]:=0;
  125.             if sup1[i,j,k]=1 then draw_sprite(x+z,y-z,sprite,save);
  126.           end;
  127.         end;
  128.       end;
  129.       write(chr(27),'Y  Berechnen der 1. Generation');
  130.       if s then setscreen(a2,a1,-1);
  131.     end;
  132.  
  133.   procedure life(lv,lb,tv,tb:integer);
  134.     var xp,yp,zp,i,im1,ip1,j,jm1,jp1,k,km1,kp1,x,y,z,zeler:integer;
  135.         a:boolean;
  136.     begin
  137.       a:=true;
  138.       repeat
  139.         zel:=emp;
  140.         for i:=1 to xl do begin if sup1[i]<>emp[1] then begin
  141.           if i=1 then im1:=xl else im1:=i-1;
  142.           if i=xl then ip1:=1 else ip1:=i+1;
  143.           for j:=1 to yl do if sup1[i,j]<>emp[1,1] then begin
  144.             if j=1 then jm1:=yl else jm1:=j-1;
  145.             if j=yl then jp1:=1 else jp1:=j+1;
  146.             for k:=1 to zl do if sup1[i,j,k]<>0 then begin
  147.               if k=1 then km1:=zl else km1:=k-1;
  148.               if k=zl then kp1:=1 else kp1:=k+1;
  149.               zel[im1,jm1,km1]:=zel[im1,jm1,km1]+1;
  150.               zel[im1,jm1,k]:=zel[im1,jm1,k]+1;
  151.               zel[im1,jm1,kp1]:=zel[im1,jm1,kp1]+1;
  152.               zel[im1,j,km1]:=zel[im1,j,km1]+1;
  153.               zel[im1,j,k]:=zel[im1,j,k]+1;
  154.               zel[im1,j,kp1]:=zel[im1,j,kp1]+1;
  155.               zel[im1,jp1,km1]:=zel[im1,jp1,km1]+1;
  156.               zel[im1,jp1,k]:=zel[im1,jp1,k]+1;
  157.               zel[im1,jp1,kp1]:=zel[im1,jp1,kp1]+1;
  158.               zel[i,jm1,km1]:=zel[i,jm1,km1]+1;
  159.               zel[i,jm1,k]:=zel[i,jm1,k]+1;
  160.               zel[i,jm1,kp1]:=zel[i,jm1,kp1]+1;
  161.               zel[i,j,km1]:=zel[i,j,km1]+1;
  162.               zel[i,j,kp1]:=zel[i,j,kp1]+1;
  163.               zel[i,jp1,km1]:=zel[i,jp1,km1]+1;
  164.               zel[i,jp1,k]:=zel[i,jp1,k]+1;
  165.               zel[i,jp1,kp1]:=zel[i,jp1,kp1]+1;
  166.               zel[ip1,jm1,km1]:=zel[ip1,jm1,km1]+1;
  167.               zel[ip1,jm1,k]:=zel[ip1,jm1,k]+1;
  168.               zel[ip1,jm1,kp1]:=zel[ip1,jm1,kp1]+1;
  169.               zel[ip1,j,km1]:=zel[ip1,j,km1]+1;
  170.               zel[ip1,j,k]:=zel[ip1,j,k]+1;
  171.               zel[ip1,j,kp1]:=zel[ip1,j,kp1]+1;
  172.               zel[ip1,jp1,km1]:=zel[ip1,jp1,km1]+1;
  173.               zel[ip1,jp1,k]:=zel[ip1,jp1,k]+1;
  174.               zel[ip1,jp1,kp1]:=zel[ip1,jp1,kp1]+1;
  175.             end;
  176.           end;
  177.         end; if keypress then ende; end;
  178.         write(chr(27),'E');
  179.         zeler:=0;
  180.         if norm then begin
  181.           xp:=0; for i:=1 to xl do begin xp:=xp+10;
  182.             yp:=398; for j:=1 to yl do begin yp:=yp-10;
  183.               zp:=112; for k:=1 to zl do begin zp:=zp-4;
  184.                 if zel[i,j,k] in[4..5] then begin
  185.                   if zel[i,j,k]=5 then sup1[i,j,k]:=1;
  186.                   if sup1[i,j,k]=1 then begin
  187.                     zeler:=zeler+1;
  188.                     draw_sprite(xp+zp,yp-zp,sprite,save);
  189.                   end;
  190.                 end else sup1[i,j,k]:=0;
  191.               end;
  192.             end;
  193.           end;
  194.         end else begin
  195.           xp:=0; for i:=1 to xl do begin xp:=xp+10;
  196.             yp:=398; for j:=1 to yl do begin yp:=yp-10;
  197.               zp:=112; for k:=1 to zl do begin zp:=zp-4;
  198.                 if sup1[i,j,k]=1 then
  199.                   if (zel[i,j,k]>=lv) and (zel[i,j,k]<=lb) then begin
  200.                     sup1[i,j,k]:=1;
  201.                     zeler:=zeler+1;
  202.                     draw_sprite(xp+zp,yp-zp,sprite,save);
  203.                   end else sup1[i,j,k]:=0
  204.                 else
  205.                   if (zel[i,j,k]>=tv) and (zel[i,j,k]<=tb) then begin
  206.                     sup1[i,j,k]:=1;
  207.                     zeler:=zeler+1;
  208.                     draw_sprite(xp+zp,yp-zp,sprite,save);
  209.                   end else sup1[i,j,k]:=0;
  210.               end;
  211.             end;
  212.           end;
  213.         end;
  214.         write(chr(27),'Y  ',zeler,' Teile');
  215.         if s then if a then setscreen(a1,a2,-1) else setscreen(a2,a1,-1);
  216.         a:=not a;
  217.       until false;
  218.     end;
  219.  
  220.   begin
  221.     writeln('Dreidimensionales Life von CHW');
  222.     writeln('42 * 27 * 27 Elemente');
  223.     writeln('Nach Spektrum der Wissenschaft, Mai 87, S.6 ff');
  224.     writeln('Mit Q quit, mit P Hardcopy');
  225.     writeln('Es dauert ca. 5..6 sec. von einem Bild zum nächsten');
  226.     writeln;
  227.     write('Gib die Codezahl ein (z.B. 4555): ');
  228.     read(q,w,e,r); writeln;
  229.     norm:=(q='4')and(w='5')and(e='5')and(r='5');
  230.     write('Raumausfuellung des Startfeldes in prozent (ca. 5..25) : ');
  231.     readln(c); if c>100 then c:=100;
  232.     repeat
  233.       write('Mit Bildschirmumschaltung? (Na klar!) ');
  234.       read(key);
  235.       writeln;
  236.     until key in['y','Y','j','J','n','N'];
  237.     s:=not(key in['n','N']);
  238.     init;
  239.     fill;
  240.     life(ord(q)-48,ord(w)-48,ord(e)-48,ord(r)-48);
  241.   end.
  242.