program mageye;    { Lutz Tautenhahn (c) 1995, 1999 }
uses dos,crt,graph;
const i0=320;j0=240;imax=640;jmax=480;imin=0;jmin=0;
      xp=120;zp=1000;z0=-451;dz=50;dzmax=5;
var graphdriver,graphmode:integer;
var datei: file of byte;
var dateiname: string;
    typ: integer;
    key: char;

procedure ig;
begin
  graphdriver:=detect;
  initgraph(graphdriver,graphmode,'d:\tp\bgi');
end;

procedure eingabe;
begin
  clrscr;
  writeln('DAS MAGISCHE AUGE');
  repeat
    write('Bild laden (1) / Bild erzeugen (2) ');readln(typ);
  until (typ in [1,2]);
  if typ=1 then begin
    write('Dateiname: ');readln(dateiname);
  end else begin
    write('Dateiname zur Speicherung: ');readln(dateiname);
    writeln('Die Berechnung wird mit beliebiger Taste beendet. Eine Speicherung');
    writeln('erfolgt nur, wenn am Ende "s" gedrckt wird!');
    readln;
  end;
end;

procedure ton;
begin;
  sound(400);
  delay(10);
  nosound;
end;

function infeld1(xx,yy:real):boolean; {Gitter}
begin
  if(((round(abs(xx)) mod 100) <= 40) or
     ((round(abs(yy)) mod 100) <= 40)) then infeld1:=true
  else infeld1:=false;
end;

function infeld2(xx,yy:real):boolean; {Kreis}
var rr:real;
begin
  rr:=200;
  if((sqr(xx)+sqr(yy))<sqr(rr)) then infeld2:=true
  else infeld2:=false;
end;

function infeld3(xx,yy:real):boolean; {Herz}
const rr=100;f1=0.6;f2=0.66;
begin
  yy:=round((yy+f1*abs(xx))/f2);
  if((sqr(xx)+sqr(yy))<sqr(rr)) then infeld3:=true
  else infeld3:=false;
end;

function z(xx,yy:real):real;
begin
  z:=-650;{Hintergrund}
  if infeld1(xx,yy) then z:=-600;{Gitter}
  if infeld2(xx,yy) then z:=-550;{Kreis}
  if infeld3(xx,yy) then z:=-500;{Herz}
end;

procedure fillrandom;
var ii:integer;
begin
  for ii:=0 to 1000 do begin
    setcolor(random(15));
    line(0,random(480),640,random(480));
    line(random(640),0,random(640),480);
  end;
end;

procedure make3d;
var ii,jj:integer;
    xx1,yy1,zz31,xx31,yy31,xx2,yy2,zz32,xx32,yy32:real;
begin
  while keypressed=true do key:=readkey;
  for jj:=jmin to jmax do begin
    if keypressed then exit;
    for ii:=imin to imax do begin
      xx1:=ii-i0;
      yy1:=jj-j0;
      zz31:=z0;
      repeat
        zz31:=zz31-dz;
        xx31:=(xx1+xp)*(zp-zz31)/zp-xp;
        yy31:=yy1*(zp-zz31)/zp;
      until (z(xx31,yy31)>=zz31);
      xx2:=zp/(zp-zz31)*(xx31-xp)+xp;
      yy2:=zp/(zp-zz31)*yy31;
      zz32:=z0;
      repeat
        zz32:=zz32-dz;
        xx32:=(xx2-xp)*(zp-zz32)/zp+xp;
        yy32:=yy2*(zp-zz32)/zp;
      until (z(xx32,yy32)>=zz32);
      if (abs(zz31-zz32)<dzmax) then
        putpixel(round(xx2)+i0,round(yy2)+j0,getpixel(ii,jj));
    end;
    ton;
  end;
end;

procedure loadscreen (datname :string);
var ii,jj:integer;
    ccolor1,ccolor2:byte;
    ch:char;
begin
  assign(datei,datname);
  {$i-} reset(datei) {$i+} ;
  ii:=ioresult;
  if ii<>0 then begin
    closegraph;
    writeln ('Datei ',datname,' nicht gefunden ...');
    writeln ('Program abgebrochen ! ');
    writeln ('Return drcken ... ');
    read (ch);
    halt;
  end;
  for jj:=0 to 479 do begin
    for ii:=0 to 639 do begin
      if odd(ii) then begin
        read(datei,ccolor2);
        ccolor1:=(ccolor2 shr 4);
        putpixel(ii,jj,ccolor1);
        ccolor2:=ccolor2-(ccolor1 shl 4);
        putpixel(ii-1,jj,ccolor2);
      end;
    end;
  end;
  close (datei);
  sound(400);delay(400);nosound;
end;

procedure savescreen (datname :string);
var ii,jj:integer;
    ccolor:byte;
begin
  assign(datei,datname);
  rewrite(datei);
  for jj:=0 to 479 do begin
    for ii:=0 to 639 do begin
      if odd(ii) then begin
        ccolor:=(ccolor shl 4);
        ccolor:=ccolor+getpixel(ii,jj);
        write(datei,ccolor);
      end else ccolor:=getpixel(ii,jj);
    end;
  end;
  close(datei);
  sound(400);delay(400);nosound;
end;

begin{Hauptprogramm}
  eingabe;
  randomize;
  ig;
  if typ=1 then loadscreen(dateiname);
  if typ=2 then begin
    fillrandom;
    make3d;
    repeat until keypressed;
    key:=readkey;
    if key='s' then savescreen(dateiname);
  end;
  readln;
  closegraph;
end.