{ (c) by Chistian Wolff, Spanbeck,   6/87,   Freeware,  Monochrom }
program DreiDeCubes;

  const xl=42; yl=27; zl=27;

  type tsuppe=packed array[1..xl,1..yl,1..zl] of byte;
       tscreen=packed array[0..32760]of byte;
       tptr=^tscreen;

  var cod:string;
      sprite,save:array[0..36]of integer;
      xp,yp,zp,c,i:integer;
      sup1,sup2,emp,zel:tsuppe;
      q,w,e,r,key:char;
      norm,s:boolean;
      a1,a2,a3:long_integer;
      screen:tptr;
      convert:record case boolean of
             true:(ptr:tptr);
             false:(adr:long_integer);
           end;

  function coninnoecho:char; gemdos(8);
  function setcolor(colnum,col:integer):integer; xbios(7);
  procedure hardcopy; xbios(20);
  function rand:long_integer; xbios(17);
  function physbase:long_integer; xbios(2);
  function logbase:long_integer; xbios(3);
  procedure setscreen(log,phys:long_integer;rez:integer); xbios(5);
  procedure waitvbl; xbios(37);

  procedure newscreen;
    begin
      new(screen);
      convert.ptr:=screen;
      a3:=convert.adr;
      a1:=physbase;
      a2:=a3+$100-(a3 & $ff);
    end;

  procedure freemem;
    begin
      setscreen(a1,a1,-1);
      waitvbl;
    end;

  procedure init;
    var i,j,k,col:integer;
    begin
      if s then newscreen;
      for i:=1 to xl do for j:=1 to yl do for k:=1 to zl do emp[i,j,k]:=0;
      col:=setcolor(0,$000); col:=setcolor(1,$777);
      sprite[0]:=0; sprite[1]:=0; sprite[2]:=2; sprite[3]:=1; sprite[4]:=0;
      sprite[5 ]:=$0000; sprite[6 ]:=$0000;
      sprite[7 ]:=$0000; sprite[8 ]:=$0000;
      sprite[9 ]:=$1ffc; sprite[10]:=$0000;
      sprite[11]:=$355c; sprite[12]:=$0aa0;
      sprite[13]:=$6abc; sprite[14]:=$1540;
      sprite[15]:=$d57c; sprite[16]:=$2a80;
      sprite[17]:=$fffc; sprite[18]:=$0000;
      sprite[19]:=$803c; sprite[20]:=$7fc0;
      sprite[21]:=$803c; sprite[22]:=$7fc0;
      sprite[23]:=$803c; sprite[24]:=$7fc0;
      sprite[25]:=$803c; sprite[26]:=$7fc0;
      sprite[27]:=$803c; sprite[28]:=$7fc0;
      sprite[29]:=$803c; sprite[30]:=$7fc0;
      sprite[31]:=$8038; sprite[32]:=$7fc0;
      sprite[33]:=$8030; sprite[34]:=$7fc0;
      sprite[35]:=$ffe0; sprite[36]:=$0000;
    end;

  procedure ende;
    var ch:char;
        fore,back:integer;
    begin
      ch:=coninnoecho;
      if (ch in['Q','q']) or (ord(ch) in[27]) then begin
        write(chr(27),'e');
        if s then freemem;
        halt;
      end else
      if ch in['P','p'] then begin
        back:=setcolor(0,$777); fore:=setcolor(1,$000);
        hardcopy;
        back:=setcolor(0,back); fore:=setcolor(1,fore);
      end else
        write(chr(7));
        repeat until keypress;
        ch:=coninnoecho;
        write(chr(7));
    end;

  procedure fill;
    var i,j,k,im1,ip1,jm1,jp1,km1,kp1,x,y,z:integer;
    begin
      write(chr(27),'E',chr(27),'f');
      case c of
        -1:begin {Glider}
             sup1[10,10,10]:=1; sup1[11,11,10]:=1; sup1[11,12,10]:=1;
             sup1[10,13,10]:=1; sup1[10,10,11]:=1; sup1[11,11,11]:=1;
             sup1[11,12,11]:=1; sup1[10,13,11]:=1; sup1[10,11,12]:=1;
           sup1[10,12,12]:=1; end;
        -2:begin {Bockender Bronco/M�hle}
             sup1[10,11,11]:=1; sup1[11,12,11]:=1; sup1[11,11,10]:=1;
             sup1[11,10,11]:=1; sup1[11,10,12]:=1; sup1[12,12,11]:=1;
             sup1[12,11,10]:=1; sup1[12,10,11]:=1; sup1[12,10,12]:=1;
           sup1[13,11,11]:=1; end;
        -3:begin {Stimmgabel/Badewanne}
             sup1[10,12,10]:=1; sup1[10,11,10]:=1; sup1[10,10,11]:=1;
             sup1[10,11,12]:=1; sup1[10,12,12]:=1; sup1[11,12,10]:=1;
             sup1[11,11,10]:=1; sup1[11,10,11]:=1; sup1[11,11,12]:=1;
           sup1[11,12,12]:=1; end;
      end;
      x:=0; for i:=1 to xl do begin x:=x+10;
        if i=1 then im1:=xl else im1:=i-1;
        if i=xl then ip1:=1 else ip1:=i+1;
        y:=398; for j:=1 to yl do begin y:=y-10;
          if j=1 then jm1:=yl else jm1:=j-1;
          if j=yl then jp1:=1 else jp1:=j+1;
          z:=112; for k:=1 to zl do begin z:=z-4;
            if k=1 then km1:=zl else km1:=k-1;
            if k=zl then kp1:=1 else kp1:=k+1;
            if c>=0 then
              if (rand mod 100)<c then sup1[i,j,k]:=1 else sup1[i,j,k]:=0;
            if sup1[i,j,k]=1 then draw_sprite(x+z,y-z,sprite,save);
          end;
        end;
      end;
      write(chr(27),'Y  Berechnen der 1. Generation');
      if s then setscreen(a2,a1,-1);
    end;

  procedure life(lv,lb,tv,tb:integer);
    var xp,yp,zp,i,im1,ip1,j,jm1,jp1,k,km1,kp1,x,y,z,zeler:integer;
        a:boolean;
    begin
      a:=true;
      repeat
        zel:=emp;
        for i:=1 to xl do begin if sup1[i]<>emp[1] then begin
          if i=1 then im1:=xl else im1:=i-1;
          if i=xl then ip1:=1 else ip1:=i+1;
          for j:=1 to yl do if sup1[i,j]<>emp[1,1] then begin
            if j=1 then jm1:=yl else jm1:=j-1;
            if j=yl then jp1:=1 else jp1:=j+1;
            for k:=1 to zl do if sup1[i,j,k]<>0 then begin
              if k=1 then km1:=zl else km1:=k-1;
              if k=zl then kp1:=1 else kp1:=k+1;
              zel[im1,jm1,km1]:=zel[im1,jm1,km1]+1;
              zel[im1,jm1,k]:=zel[im1,jm1,k]+1;
              zel[im1,jm1,kp1]:=zel[im1,jm1,kp1]+1;
              zel[im1,j,km1]:=zel[im1,j,km1]+1;
              zel[im1,j,k]:=zel[im1,j,k]+1;
              zel[im1,j,kp1]:=zel[im1,j,kp1]+1;
              zel[im1,jp1,km1]:=zel[im1,jp1,km1]+1;
              zel[im1,jp1,k]:=zel[im1,jp1,k]+1;
              zel[im1,jp1,kp1]:=zel[im1,jp1,kp1]+1;
              zel[i,jm1,km1]:=zel[i,jm1,km1]+1;
              zel[i,jm1,k]:=zel[i,jm1,k]+1;
              zel[i,jm1,kp1]:=zel[i,jm1,kp1]+1;
              zel[i,j,km1]:=zel[i,j,km1]+1;
              zel[i,j,kp1]:=zel[i,j,kp1]+1;
              zel[i,jp1,km1]:=zel[i,jp1,km1]+1;
              zel[i,jp1,k]:=zel[i,jp1,k]+1;
              zel[i,jp1,kp1]:=zel[i,jp1,kp1]+1;
              zel[ip1,jm1,km1]:=zel[ip1,jm1,km1]+1;
              zel[ip1,jm1,k]:=zel[ip1,jm1,k]+1;
              zel[ip1,jm1,kp1]:=zel[ip1,jm1,kp1]+1;
              zel[ip1,j,km1]:=zel[ip1,j,km1]+1;
              zel[ip1,j,k]:=zel[ip1,j,k]+1;
              zel[ip1,j,kp1]:=zel[ip1,j,kp1]+1;
              zel[ip1,jp1,km1]:=zel[ip1,jp1,km1]+1;
              zel[ip1,jp1,k]:=zel[ip1,jp1,k]+1;
              zel[ip1,jp1,kp1]:=zel[ip1,jp1,kp1]+1;
            end;
          end;
        end; if keypress then ende; end;
        write(chr(27),'E');
        zeler:=0;
        if norm then begin
          xp:=0; for i:=1 to xl do begin xp:=xp+10;
            yp:=398; for j:=1 to yl do begin yp:=yp-10;
              zp:=112; for k:=1 to zl do begin zp:=zp-4;
                if zel[i,j,k] in[4..5] then begin
                  if zel[i,j,k]=5 then sup1[i,j,k]:=1;
                  if sup1[i,j,k]=1 then begin
                    zeler:=zeler+1;
                    draw_sprite(xp+zp,yp-zp,sprite,save);
                  end;
                end else sup1[i,j,k]:=0;
              end;
            end;
          end;
        end else begin
          xp:=0; for i:=1 to xl do begin xp:=xp+10;
            yp:=398; for j:=1 to yl do begin yp:=yp-10;
              zp:=112; for k:=1 to zl do begin zp:=zp-4;
                if sup1[i,j,k]=1 then
                  if (zel[i,j,k]>=lv) and (zel[i,j,k]<=lb) then begin
                    sup1[i,j,k]:=1;
                    zeler:=zeler+1;
                    draw_sprite(xp+zp,yp-zp,sprite,save);
                  end else sup1[i,j,k]:=0
                else
                  if (zel[i,j,k]>=tv) and (zel[i,j,k]<=tb) then begin
                    sup1[i,j,k]:=1;
                    zeler:=zeler+1;
                    draw_sprite(xp+zp,yp-zp,sprite,save);
                  end else sup1[i,j,k]:=0;
              end;
            end;
          end;
        end;
        write(chr(27),'Y  ',zeler,' Teile');
        if s then if a then setscreen(a1,a2,-1) else setscreen(a2,a1,-1);
        a:=not a;
      until false;
    end;

  begin
    writeln('Dreidimensionales Life von CHW');
    writeln('42 * 27 * 27 Elemente');
    writeln('Nach Spektrum der Wissenschaft, Mai 87, S.6 ff');
    writeln('Mit Q quit, mit P Hardcopy');
    writeln('Es dauert ca. 5..6 sec. von einem Bild zum n�chsten');
    writeln;
    write('Gib die Codezahl ein (z.B. 4555): ');
    read(q,w,e,r); writeln;
    norm:=(q='4')and(w='5')and(e='5')and(r='5');
    write('Raumausfuellung des Startfeldes in prozent (ca. 5..25) : ');
    readln(c); if c>100 then c:=100;
    repeat
      write('Mit Bildschirmumschaltung? (Na klar!) ');
      read(key);
      writeln;
    until key in['y','Y','j','J','n','N'];
    s:=not(key in['n','N']);
    init;
    fill;
    life(ord(q)-48,ord(w)-48,ord(e)-48,ord(r)-48);
  end.