program gitter;
uses dos ,graph,crt;
const xmin=30;xmax=450;c2=0.00004;maabst=0.6;maxsteck=12;grad=3;c3=0.0001;
      maxcol=20;fy=350/480;
var graphdriver,graphmode:integer;
    i,i1,i2,i3,anz,xp,yp,b1,b6,b9,fi,ri,icol,bildtyp,inumber,ibp,anzd:integer;
    x1,y1,z1,x2,y2,z2,xo,yo,zo,xn,yn,zn,sx,sy,sz,xb,yb,zb,bo,rii,bdf:real;
    almax,alpz,alsz,gah,gah2,gav,gav2,c1,ax,ay,az:real;
    wa,wb,wc,dax,db,dc,dbx,dby,dcx,dcy,dcz,dr,c4:real;
    name,ubers,zeile1,zeile2,zeile3,zeile4,zeile5,zeile6:string;
    tex:text;
    farbe,xasp,yasp,c5:word;
    b2,b3,b4,b5,b7,b8,b19,key:char;
    sa2i:real;
    MausX, MausY: Integer;
    regs: Registers;
    x,y,z,r,sqrabst,sa2,xs,ys,rs:array [1..400] of real;
    f,folge,sort:array [1..400] of word;
    col:array [1..maxcol] of word;
    steck:array[1..400,1..maxsteck] of word;
var c: array[1..grad] of real;
    de: array[1..grad] of extended;
    b:array[1..grad,1..grad] of extended;
    stelle:array [1..grad] of integer;
    eax,ebx,ecx,eay,eby,ecy,norx,nory,norz:real;
    xneux,xneuy,xneuz,yneux,yneuy,yneuz,zneux,zneuy,zneuz:real;
    zsneux,zsneuy,zsneuz:real;
    apsx,apsy,apsz,assx,assy,assz,firot,anonorm:real;

procedure ig;
 begin
 graphdriver:=VGA;graphmode:=VGAMed;
 initgraph(graphdriver,graphmode,'c:\sprachen\tp\bgi');
 SetActivePage(0);
 end;

procedure colorinit;
begin
for i:=1 to maxcol do col[i]:=i;
end;

function color(ii:word):word;
begin
if ((0<ii)and(ii<=maxcol)) then color:=col[ii] else color:=ii;
end;

procedure getnumber;
var bb1:char;
    i1:word;
    zeig:boolean;
begin
inumber:=0;
repeat
bb1:=readkey;
zeig:=false;
if bb1='1' then i1:=1;
if bb1='2' then i1:=2;
if bb1='3' then i1:=3;
if bb1='4' then i1:=4;
if bb1='5' then i1:=5;
if bb1='6' then i1:=6;
if bb1='7' then i1:=7;
if bb1='8' then i1:=8;
if bb1='9' then i1:=9;
if bb1='0' then i1:=0;
delay(100);
case bb1 of '0'..'9':
  begin inumber:=10*inumber+i1;bb1:='v';zeig:=true;end;
end;
until zeig=false;
end;

procedure farben;
var i1,ix,ixmin,ixmax,iy,iymin,iymax,inr:integer;
    sinr,ssorte,sfarbe,si1:string;
    bb1:char;
begin
ig;
 settextstyle(0,horizdir,0);
settextjustify(centertext,centertext);
for ix:=1 to 4 do begin
ixmin:=(ix-1)*100+1;ixmax:=ix*100;
for iy:=1 to 4 do begin
iymin:=(iy-1)*100+81;iymax:=iy*100+80;
inr:=4*(iy-1)+ix;
setcolor(inr);
for i1:=iymin to iymax do line(ixmin,round(fy*i1),ixmax,round(fy*i1));
setcolor(15);
if ((inr=15)or(inr=7)or(inr=14)) then setcolor(0);
str(inr,sinr);
outtextxy(round((ixmin+ixmax)/2),round(fy*(iymin+iymax)/2),sinr);
end;end;

setcolor(15);
settextjustify(lefttext,centertext);
outtextxy(10,round(fy*20),'Ende');
outtextxy(70,round(fy*20),'Standardeinstellung');
outtextxy(260,round(fy*20),'Einstellung');
outtextxy(360,round(fy*20),'ansehen');
outtextxy(460,round(fy*20),'Einstellung');
outtextxy(560,round(fy*20),'ver„ndern');
setcolor(12);
outtextxy(10,round(fy*20),'E');
outtextxy(70,round(fy*20),'S');
outtextxy(360,round(fy*20),'a');
outtextxy(560,round(fy*20),'v');
repeat
bb1:=readkey;
if ((bb1='s')or(bb1='S')) then colorinit;
if ((bb1='a')or(bb1='A')) then begin
setcolor(0);
for i1:=50 to 480 do line(410,round(fy*i1),640,round(fy*i1));
setcolor(15);
settextjustify(lefttext,centertext);
outtextxy(450,round(fy*70),'Sorte');
outtextxy(550,round(fy*70),'Farbe');
for i1:=1 to maxcol do begin
str(i1,ssorte);str(col[i1],sfarbe);
outtextxy(450,round(fy*(80+18*i1)),ssorte);
outtextxy(550,round(fy*(80+18*i1)),sfarbe);
end;
end;
if ((bb1='v')or(bb1='V')) then begin
setcolor(0);
for i1:=50 to 480 do line(410,round(fy*i1),640,round(fy*i1));
setcolor(15);
settextjustify(righttext,centertext);
outtextxy(550,round(fy*100),'Sortennummer: ');
repeat
getnumber;
until ((0<inumber)and(inumber<=maxcol));
i1:=inumber;str(i1,si1);
settextjustify(lefttext,centertext);
outtextxy(550,round(fy*100),si1);
settextjustify(righttext,centertext);
outtextxy(550,round(fy*120),'Neue Farbe: ');
repeat
getnumber;
until ((0<=inumber)and(inumber<17));
str(inumber,si1);
settextjustify(lefttext,centertext);
outtextxy(550,round(fy*120),si1);
col[i1]:=inumber;
end;
until ((bb1='e')or(bb1='E'));
closegraph;
end;

procedure matrixtrafo(j1:integer);
var bb:array[1..grad] of real;
    dede:real;
    j2,jmax:integer;
begin
if (j1<grad) then begin
jmax:=j1;
for j2:=j1+1 to grad do begin
if (abs(b[jmax,j1])<abs(b[j2,j1])) then jmax:=j2;end;
for j2:=1 to grad do begin
bb[j2]:=b[j1,j2];b[j1,j2]:=b[jmax,j2];b[jmax,j2]:=bb[j2];end;
dede:=de[j1];de[j1]:=de[jmax];de[jmax]:=dede;
end;
end;

procedure koeff;
var detb:real;
    faktor:extended;
    ka,ki,i1,i2:integer;
begin
for i1:=1 to grad do begin
matrixtrafo(i1);
i2:=0;
repeat
inc(i2);
stelle[i1]:=i2;
until b[i1,i2]<>0;
 if i1<grad then begin
  for ka:=i1+1 to grad do begin
  faktor:=b[ka,i2]/b[i1,i2];
   for ki:=i2 to grad do begin
   b[ka,ki]:=b[ka,ki]-faktor*b[i1,ki];
   end;
  b[ka,i2]:=0;
  de[ka]:=de[ka]-faktor*de[i1];
  end;
 end;
end;
end;

procedure koeff2;
var i1,i2:integer;
begin
for i1:=grad downto 2 do begin
  c[stelle[i1]]:=de[i1]/b[i1,stelle[i1]];
    for i2:=i1-1 downto 1 do begin
    de[i2]:=de[i2]-c[stelle[i1]]*b[i2,stelle[i1]];
    end;
end;
c[stelle[1]]:=de[1]/b[1,stelle[1]];
end;


function arccos(xa:real):extended;
var ii:integer;
    signxa:integer;
    yn:extended;
begin
if abs(xa)<0.9 then begin
  yn:=0.5*pi;
  repeat
  yn:=yn-(xa-cos(yn))*sin(yn);
  until abs(xa-cos(yn))<c2;
end else begin
    signxa:=round(xa/abs(xa));
    xa:=sqrt(1-sqr(xa));
    yn:=0;
    repeat
    yn:=yn+(xa-sin(yn))*cos(yn);
    until abs(xa-sin(yn))<c2;
    yn:=abs(pi/2-yn);
    yn:=pi/2-signxa*yn;
    end;
arccos:=yn;
end;

function arcsin(xa:real):real;
begin
  arcsin:=pi/2-arccos(xa);
end;

procedure Grafikselbsttest;
var i1,i2,pc:word;
begin
ig;
 GetAspectRatio(Xasp,Yasp);
repeat
setaspectratio(xasp,round(c4*yasp));
clrscr;
setcolor(9);
setfillstyle(1,9);
pieslice(240,round(fy*240),0,360,200);
i1:=0;
repeat
inc(i1);pc:=getpixel(240,i1);
until pc=9;
setlinestyle(0,0,1);
setcolor(10);
ellipse(240,round(fy*240),0,360,200,round(fy*200));
i2:=0;
repeat
inc(i2);pc:=getpixel(240,i2);
until pc=10;
if i1<i2 then c4:=c4*1.002;
if i2<i1 then c4:=c4/1.002;
until i1=i2;
closegraph;
end;

procedure Eingabe1;
var jn1:char;
begin
writeln('Programm zur r„umlichen Gitterdarstellung.');
write('Grafikselbsttest durchfhren? (j/n) ');readln(jn1);
if jn1='j' then grafikselbsttest;
write('Handeingabe (1) / Datei einlesen (2)  ');readln(b1);
if b1=1 then begin
write('Anzahl der Atome : ');readln(anz);
for i:=1 to anz do begin
writeln;
write('Atomart von A',i,' : ');readln(f[i]);
write('Radius von A',i,' : ');readln(r[i]);
write('X-Koordinate von A',i,' : ');readln(x[i]);
write('Y-Koordinate von A',i,' : ');readln(y[i]);
write('Z-Koordinate von A',i,' : ');readln(z[i]);
end;
writeln;
write('Werte abspeichern ? (j/n) ');readln(b2);
if b2='j' then begin
write('Dateiname : ');readln(name);
assign(tex,name);rewrite(tex);
for i:=1 to anz do begin
writeln(tex,f[i]);writeln(tex,r[i]);
writeln(tex,x[i]);writeln(tex,y[i]);writeln(tex,z[i]);
end;
close(tex);
end;
end;
if b1<>1 then begin
write('Dateiname : ');readln(name);
assign(tex,name);reset(tex);
write('Alle Sorten darstellen ? (j/n) ');readln(b4);
if b4='j' then begin
i:=0;
repeat
inc(i);
readln(tex,f[i]);readln(tex,r[i]);
readln(tex,x[i]);readln(tex,y[i]);readln(tex,z[i]);
until eof(tex);
anz:=i;
end;
if b4<>'j' then begin
for i:=1 to 20 do sort[i]:=0;
writeln('Geben Sie die Sortennummern ein, die nicht dargestellt werden sollen!');
writeln('Als letzte Zahl "0" eingeben!');
i:=0;
repeat
inc(i);
readln(sort[i]);
until sort[i]=0;
i:=0;
repeat
inc(i);
readln(tex,fi);
i1:=0;i2:=0;
repeat
inc(i1);
if fi=sort[i1] then inc(i2);
until sort[i1]=0;
if i2=0 then begin
f[i]:=fi;
readln(tex,r[i]);
readln(tex,x[i]);readln(tex,y[i]);readln(tex,z[i]);
end else begin
dec(i);
readln(tex,rii);readln(tex,rii);readln(tex,rii);readln(tex,rii);end;
until eof(tex);
anz:=i;
end;
close(tex);
end;
end;

procedure Eingabe1k5;
begin
write('Standardisiertes Orthogonales Koordinatensystem ? (j/n) ');
readln(b5);
if b5='n' then begin
write('Winkel zwischen X"- und Y"-Achse in ø : ');readln(wc);
write('Winkel zwischen X"- und Z"-Achse in ø : ');readln(wb);
write('Winkel zwischen Y"- und Z"-Achse in ø : ');readln(wa);
write('Dehnungsfaktor in X"-Richtung : ');readln(dax);
write('Dehnungsfaktor in Y"-Richtung : ');readln(db);
write('Dehnungsfaktor in Z"-Richtung : ');readln(dc);
write('Radiendehnungsfaktor : ');readln(dr);
wc:=wc*pi/180;wb:=wb*pi/180;wa:=wa*pi/180;
dbx:=db*cos(wc);dby:=db*sin(wc);
dcx:=dc*cos(wb);dcy:=(db*dc*cos(wa)-dbx*dcx)/dby;
dcz:=sqrt(sqr(dc)-sqr(dcx)-sqr(dcy));
for i:=1 to anz do begin
x[i]:=dax*x[i]+dbx*y[i]+dcx*z[i];
y[i]:=dby*y[i]+dcy*z[i];
z[i]:=dcz*z[i];
r[i]:=r[i]*dr;end;
end;
end;

procedure Eingabe1k7;
var jn1,jn2:char;
begin
write('Beschriftung der Grafik (j/n) ');readln(jn1);
if jn1='n' then begin
ubers:='';zeile1:='';zeile2:='';zeile3:='';zeile4:='';zeile5:='';zeile6:='';
end else begin
repeat
write('Eingabe der šberschrift : ');readln(ubers);
write('Eingabe Randzeile 1 : ');readln(zeile1);
write('Eingabe Randzeile 2 : ');readln(zeile2);
write('Eingabe Randzeile 3 : ');readln(zeile3);
write('Eingabe Randzeile 4 : ');readln(zeile4);
write('Eingabe Randzeile 5 : ');readln(zeile5);
write('Eingabe Randzeile 6 : ');readln(zeile6);
write('Alle Eingaben richtig (j/n) ? ');readln(jn2);
until jn2='j';
clrscr;
end;
end;

procedure eingabe1k8;
var jn1:char;
begin
write('Steckermodus „ndern? (j/n) ');readln(jn1);
if jn1='j' then begin
writeln('Der aktuelle Modus ist');
if b8<>'j' then writeln('Stecker nicht mitzeichnen')
else begin
if b9=1 then writeln('Stecker mitzeichnen / absolut / Amax= ',c1:0:3)
else writeln('Stecker mitzeichnen / relativ / c= ',c1:0:3);
end;
write('Stecker mitzeichnen? (j/n) ');readln(b8);
if  b8='j' then begin
write('Steckermodus absolut (1) / relativ (2) ');readln(b9);
if b9=1 then begin
writeln('Es werden Stecker zwischen allen Atomen gezeichnet, die bis zu einem');
writeln('Maximalabstand Amax voneinander entfernt sind.');
write('Amax: ');readln(c1);
end else begin
writeln('Es werden Stecker zu allen Atomen gezeichnet deren Abstand nicht grӇer');
writeln('als der c-fache Abstand zum n„chsten Nachbarn ist.');
write('c: ');readln(c1);
end;
end;end;end;

procedure Eingabe2;
var xbt,ybt,zbt,norm:real;
begin
writeln;
writeln('Betrachterposition : ');
if b5='n' then begin
writeln('Eingabe im aktuellen Koordinatensystem (1) / Standardisierten Orthogonalen');
write('Koordinatensystem (2) ');readln(b6);
if b6=1 then begin
write('X"-Koordinate : ');readln(xbt);
write('Y"-Koordinate : ');readln(ybt);
write('Z"-Koordinate : ');readln(zbt);
xb:=dax*xbt+dbx*ybt+dcx*zbt;
yb:=dby*ybt+dcy*zbt;
zb:=dcz*zbt;
end;end;
if ((b5<>'n') or (b6<>1)) then begin
write('X-Koordinate : ');readln(xb);
write('Y-Koordinate : ');readln(yb);
write('Z-Koordinate : ');readln(zb);
end;
ax:=xn-xb;ay:=yn-yb;az:=zn-zb;
norm:=sqrt(sqr(ax)+sqr(ay)+sqr(az));
anonorm:=norm;
ax:=ax/norm;ay:=ay/norm;az:=az/norm;
write('Bilddehnungsfaktor : ');readln(bdf);bdf:=1/abs(bdf);
repeat
write('Bildtyp (1,2) : ');readln(bildtyp);
until((bildtyp=1) or (bildtyp=2));
end;

procedure Eingabe2k2;
var xst,yst,zst,norm:real;
    bed:boolean;
begin
writeln('Geben Sie einen Vektor ein, der die senkrechte Achse auf dem');
writeln('Bildschirm festlegt!');
repeat
if b5='n' then begin
writeln('Eingabe im aktuellen Koordinatensystem (1) / Standardisierten Orthogonalen');
write('Koordinatensystem (2) ');readln(b6);
if b6=1 then begin
write('X"-Koordinate : ');readln(xst);
write('Y"-Koordinate : ');readln(yst);
write('Z"-Koordinate : ');readln(zst);
sx:=dax*xst+dbx*yst+dcx*zst;
sy:=dby*yst+dcy*zst;
sz:=dcz*zst;
end;end;
if ((b5<>'n') or (b6<>1)) then begin
write('X-Koordinate : ');readln(sx);
write('Y-Koordinate : ');readln(sy);
write('Z-Koordinate : ');readln(sz);
end;
if (sqr(ax*sx+ay*sy+az*sz)<0.99*(sqr(ax)+sqr(ay)+sqr(az))*
(sqr(sx)+sqr(sy)+sqr(sz))) then bed:=true else begin
bed:=false;
writeln('Dieser Vektor kann nicht senkrecht senkrecht auf dem Bildschirm');
writeln('dargestellt werden. Geben Sie einen anderen Vektor ein!');end;
until bed=true;
norm:=sqrt(sqr(sx)+sqr(sy)+sqr(sz));
sx:=sx/norm;sy:=sy/norm;sz:=sz/norm;
repeat
write('Drehwinkel (0<fi<75) : ');readln(firot);
until((0<firot)and(firot<75));
firot:=sin(firot*pi/180);
end;

procedure xyzinit;
var eskax,eskay,eskaz,norm,assx2,assy2,assz2,ass:real;
begin
apsx:=ax*sx;apsy:=ay*sy;apsz:=az*sz;
assx:=ax-apsx;assy:=ay-apsy;assz:=az-apsz;
ass:=sqrt(sqr(assx)+sqr(assy)+sqr(assz));
eskax:=sy*az-sz*ay;
eskay:=sz*ax-sx*az;
eskaz:=sx*ay-sy*ax;
norm:=sqrt(sqr(eskax)+sqr(eskay)+sqr(eskaz));
eskax:=eskax/norm;
eskay:=eskay/norm;
eskaz:=eskaz/norm;
assx2:=assx+eskax*firot*ass;
assy2:=assy+eskay*firot*ass;
assz2:=assz+eskaz*firot*ass;
norm:=sqrt(sqr(assx2)+sqr(assy2)+sqr(assz2))/ass;
assx2:=assx2/norm;
assy2:=assy2/norm;
assz2:=assz2/norm;
ax:=apsx+assx2;ay:=apsy+assy2;az:=apsz+assz2;
xb:=xn-ax*anonorm;yb:=yn-ay*anonorm;zb:=zn-az*anonorm;
end;

procedure Blickposition;
begin
xn:=0;yn:=0;zn:=0;
for i:=1 to anz do begin
xn:=xn+x[i];yn:=yn+y[i];zn:=zn+z[i];
end;
xn:=xn/anz;yn:=yn/anz;zn:=zn/anz;
end;

procedure Eingabe2k5;
begin
write('Farben neu setzen? (j/n) ');readln(b7);
if b7='j' then begin
farben;
end;
end;

procedure XYZneu;
var aps,norm,fzx,fzy:real;
begin
aps:=ax*sx+ay*sy+az*sz;
zsneux:=ay*sz-az*sy;zsneuy:=az*sx-ax*sz;zsneuz:=ax*sy-ay*sx;
norm:=sqrt(sqr(zsneux)+sqr(zsneuy)+sqr(zsneuz));
zsneux:=zsneux/norm;zsneuy:=zsneuy/norm;zsneuz:=zsneuz/norm;
zneux:=sx-aps*ax;zneuy:=sy-aps*ay;zneuz:=sz-aps*az;
norm:=sqrt(sqr(zneux)+sqr(zneuy)+sqr(zneuz));
zneux:=zneux/norm;zneuy:=zneuy/norm;zneuz:=zneuz/norm;
if (sqr(zneux)+sqr(zneuy))>c3 then begin
  fzx:=zneux/(sqr(zneux)+sqr(zneuy));
  fzy:=zneuy/(sqr(zneux)+sqr(zneuy));
  xneux:=fzx*zneux*zneuz+fzy*zneuy;
  xneuy:=fzx*zneuy*zneuz-fzy*zneux;
  xneuz:=-fzx*(sqr(zneux)+sqr(zneuy));
  yneux:=fzy*zneux*zneuz-fzx*zneuy;
  yneuy:=fzy*zneuy*zneuz+fzx*zneux;
  yneuz:=-fzy*(sqr(zneux)+sqr(zneuy));
end else begin
  if zneuz>0 then begin
  xneux:=1;xneuy:=0;xneuz:=0;
  yneux:=0;yneuy:=1;yneuz:=0;
  end else begin
  xneux:=0;xneuy:=-1;xneuz:=0;
  yneux:=-1;yneuy:=0;yneuz:=0;
  end;
end;
end;

procedure kotrafo;
begin
b[1,1]:=xneux;
b[1,2]:=yneux;
b[1,3]:=zneux;
b[2,1]:=xneuy;
b[2,2]:=yneuy;
b[2,3]:=zneuy;
b[3,1]:=xneuz;
b[3,2]:=yneuz;
b[3,3]:=zneuz;
de[1]:=x1;
de[2]:=y1;
de[3]:=z1;
koeff;koeff2;
x1:=c[1];y1:=c[2];z1:=c[3];
end;

procedure Ordnen;
var j,folgei:integer;
    sa2i:real;
begin
for i:=1 to anz do begin
sqrabst[i]:=sqr(xb-x[i])+sqr(yb-y[i])+sqr(zb-z[i]);
sa2[i]:=sqrabst[i];folge[i]:=i;end;
repeat
j:=0;
for i:=1 to anz-1 do begin
if sa2[i]<sa2[i+1] then begin
inc(j);
sa2i:=sa2[i];sa2[i]:=sa2[i+1];sa2[i+1]:=sa2i;
folgei:=folge[i];folge[i]:=folge[i+1];folge[i+1]:=folgei;
end;end;
until j=0;
end;

procedure Maxwinkel;
var smabst,sabst:real;
begin
smabst:=0;
for i:=1 to anz do begin
sabst:=sqr(xn-x[i])+sqr(yn-y[i])+sqr(zn-z[i]);
if smabst<sabst then smabst:=sabst;end;
bo:=sqrt(sqr(xb-xn)+sqr(yb-yn)+sqr(zb-zn));
almax:=2.5*bdf*arcsin(sqrt(smabst)/bo);
end;

procedure Winkel;
var sqr12,sqrx,sqry:real;
    signx,signy,signz:integer;
begin
sqr12:=sqr(x1-x2)+sqr(y1-y2)+sqr(z1-z2);
bo:=sqrt(sqr12);
sqrx:=sqr(x1-x2)/sqr12;sqry:=sqr(y1-y2)/sqr12;
if z1=z2 then signz:=1 else
signz:=round((z1-z2)/abs(z1-z2));
if y1=y2 then signy:=1 else
signy:=round((y1-y2)/abs(y1-y2));
if x1=x2 then signx:=1 else
signx:=round((x1-x2)/abs(x1-x2));
alpz:=signz*arccos(sqrt(sqrx+sqry));
alsz:=-signy*arccos(signx*sqrt(sqrx/(sqrx+sqry)));
end;

procedure MausEingabe;
begin
    regs.ax:=$01;intr($33,Regs);
    repeat
    regs.ax:=$03;intr($33,Regs);
    until regs.bx > 0;
    MausX := regs.cx;
    MausY := regs.dx;
    delay(500);
end;

procedure Info;
var sx,sy,sz,sfi:string;
    yi:integer;
begin
 settextstyle(1,horizdir,2);
settextjustify(centertext,centertext);
outtextxy(220,round(fy*15),ubers);
 settextstyle(0,horizdir,0);
outtextxy(550,round(fy*15),'Beobachterposition :');
outtextxy(550,round(fy*90),'Blickposition :');
outtextxy(550,round(fy*165),'Blickwinkel :');
str(xb:8:2,sx);
str(yb:8:2,sy);
str(zb:8:2,sz);
outtextxy(500,round(fy*30),'X :');
outtextxy(500,round(fy*45),'Y :');
outtextxy(500,round(fy*60),'Z :');
outtextxy(580,round(fy*30),sx);
outtextxy(580,round(fy*45),sy);
outtextxy(580,round(fy*60),sz);
str(xn:8:2,sx);
str(yn:8:2,sy);
str(zn:8:2,sz);
outtextxy(500,round(fy*105),'X :');
outtextxy(500,round(fy*120),'Y :');
outtextxy(500,round(fy*135),'Z :');
outtextxy(580,round(fy*105),sx);
outtextxy(580,round(fy*120),sy);
outtextxy(580,round(fy*135),sz);
str(almax*180/pi:8:2,sfi);
outtextxy(500,round(fy*180),'Fi/ø :');
outtextxy(580,round(fy*180),sfi);
settextjustify(lefttext,centertext);
outtextxy(461,round(fy*240),zeile1);
outtextxy(461,round(fy*255),zeile2);
outtextxy(461,round(fy*270),zeile3);
outtextxy(461,round(fy*285),zeile4);
outtextxy(461,round(fy*300),zeile5);
outtextxy(461,round(fy*315),zeile6);
readln;
setcolor(0);
for yi:=0 to 30 do line(0,round(fy*yi),640,round(fy*yi));
for yi:=31 to 480 do
line(460,round(fy*yi),640,round(fy*yi));
setcolor(15);
end;

procedure Beschriftung0;
begin
 settextstyle(0,horizdir,1);
settextjustify(centertext,centertext);
outtextxy(60,round(fy*15),'ENDE');
outtextxy(260,round(fy*15),'Andere Beobachterposition');
outtextxy(450,round(fy*15),'Maus');
setcolor(10);
outtextxy(60,round(fy*15),'E   ');
outtextxy(260,round(fy*15),'A                        ');
outtextxy(450,round(fy*15),'M   ');
setcolor(15);
repeat
key:=readkey;
until((key='e')or(key='a')or(key='m'));
end;

procedure Beschriftung;
begin
setcolor(0);
outtextxy(450,round(fy*15),'Maus');
setcolor(15);
 settextstyle(0,horizdir,1);
settextjustify(centertext,centertext);
outtextxy(60,round(fy*15),'ENDE');
outtextxy(260,round(fy*15),'Andere Beobachterposition');
outtextxy(550,round(fy*15),'Position');
outtextxy(550,round(fy*55),'Radius');
outtextxy(550,round(fy*95),'Abstand');
outtextxy(550,round(fy*135),'Winkel');
outtextxy(550,round(fy*175),'Sorte');
end;
                     
function Find2:integer;
var ii,ifind:integer;
afs,mfs:longint;
begin
mfs:=300000;
for ii:=1 to anz do begin
afs:=sqr(mausx-round(xs[ii]))+sqr(mausy-round(ys[ii]*fy));
if afs<mfs then begin
           mfs:=afs;ifind:=ii;end;
end;
find2:=ifind;
end;


function Find:integer;
var ii,ifind:integer;
    afs:longint;
    invsabst,invsabstmax:real;
begin
ifind:=0;invsabstmax:=0;
for ii:=1 to anz do begin
if sqr(mausx-round(xs[ii]))+sqr(mausy-round(ys[ii]*fy))<sqr(rs[ii]) then begin
   invsabst:=1/(sqr(xb-x[ii])+sqr(yb-y[ii])+sqr(zb-z[ii]));
   if invsabst>invsabstmax then begin
   invsabstmax:=invsabst;ifind:=ii;end;
end;
end;
if ifind=0 then ifind:=find2;
find:=ifind;
end;

procedure Position;
var ifind,xi,yi,farbe1:integer;
sx,sy,sz,si:string;
begin
setcolor(0);
for yi:=200 to 480 do
line(460,round(fy*yi),640,round(fy*yi));
setcolor(15);
 settextstyle(0,horizdir,1);
settextjustify(centertext,centertext);
outtextxy(550,round(fy*220),'POSITION');
mauseingabe;
ifind:=find;
str(x[ifind]:8:2,sx);
str(y[ifind]:8:2,sy);
str(z[ifind]:8:2,sz);
str(ifind:2,si);
 settextstyle(0,horizdir,1);
settextjustify(centertext,centertext);
outtextxy(500,round(fy*320),'X');outtextxy(520,round(fy*320),si);
outtextxy(500,round(fy*360),'Y');outtextxy(520,round(fy*360),si);
outtextxy(500,round(fy*400),'Z');outtextxy(520,round(fy*400),si);
outtextxy(580,round(fy*320),sx);
outtextxy(580,round(fy*360),sy);
outtextxy(580,round(fy*400),sz);
end;

procedure Radius;
var ifind,xi,yi,farbe1:integer;
    sr,si:string;
begin
setcolor(0);
for yi:=200 to 480 do
line(460,round(fy*yi),640,round(fy*yi));
setcolor(15);
 settextstyle(0,horizdir,1);
settextjustify(centertext,centertext);
outtextxy(550,round(fy*220),'RADIUS');
mauseingabe;
ifind:=find;
str(r[ifind]:8:2,sr);
str(ifind:2,si);
 settextstyle(0,horizdir,1);
settextjustify(centertext,centertext);
outtextxy(500,round(fy*320),'R');outtextxy(520,round(fy*320),si);
outtextxy(580,round(fy*320),sr);
end;

procedure Abstand;
var ifind1,ifind2,xi,yi:integer;
    sr,si1,si2:string;
    rabst:real;
begin
setcolor(0);
for yi:=200 to 480 do
line(460,round(fy*yi),640,round(fy*yi));
setcolor(15);
 settextstyle(0,horizdir,1);
settextjustify(centertext,centertext);
outtextxy(550,round(fy*220),'ABSTAND');
mauseingabe;
ifind1:=find;
mauseingabe;
ifind2:=find;
rabst:=sqr(x[ifind1]-x[ifind2])+sqr(y[ifind1]-y[ifind2])+sqr(z[ifind1]-z[ifind2]);
rabst:=sqrt(rabst);
str(rabst:8:2,sr);
str(ifind1:2,si1);str(ifind2:2,si2);
 settextstyle(0,horizdir,1);
settextjustify(centertext,centertext);
outtextxy(520,round(fy*320),'A');
outtextxy(550,round(fy*320),si1);
outtextxy(580,round(fy*320),si2);
outtextxy(540,round(fy*360),sr);
end;

procedure Kleinwinkel;
var ifind1,ifind2,ifind3,xi,yi:integer;
    sr,si1,si2,si3:string;
    rabst:real;
begin
setcolor(0);
for yi:=200 to 480 do
line(460,round(fy*yi),640,round(fy*yi));
setcolor(15);
 settextstyle(0,horizdir,1);
settextjustify(centertext,centertext);
outtextxy(550,round(fy*220),'WINKEL');
mauseingabe;
ifind1:=find;
mauseingabe;
ifind2:=find;
mauseingabe;
ifind3:=find;
rabst:=(x[ifind1]-x[ifind2])*(x[ifind3]-x[ifind2]);
rabst:=rabst+(y[ifind1]-y[ifind2])*(y[ifind3]-y[ifind2]);
rabst:=rabst+(z[ifind1]-z[ifind2])*(z[ifind3]-z[ifind2]);
rabst:=rabst/sqrt(sqr(x[ifind1]-x[ifind2])+sqr(y[ifind1]-y[ifind2])+sqr(z[ifind1]-z[ifind2]));
rabst:=rabst/sqrt(sqr(x[ifind3]-x[ifind2])+sqr(y[ifind3]-y[ifind2])+sqr(z[ifind3]-z[ifind2]));
rabst:=arccos(rabst);
rabst:=rabst*180/pi;
str(rabst:8:2,sr);
str(ifind1:2,si1);str(ifind2:2,si2);str(ifind3:2,si3);
 settextstyle(0,horizdir,1);
settextjustify(centertext,centertext);
outtextxy(480,round(fy*320),'Fi');outtextxy(520,round(fy*320),si1);
outtextxy(550,round(fy*320),si2);outtextxy(580,round(fy*320),si3);
outtextxy(540,round(fy*360),sr);
end;

procedure Sorte;
var ifind,xi,yi,farbe1:integer;
ss,si:string;
begin
setcolor(0);
for yi:=200 to 480 do
line(460,round(fy*yi),640,round(fy*yi));
setcolor(15);
 settextstyle(0,horizdir,1);
settextjustify(centertext,centertext);
outtextxy(550,round(fy*220),'SORTE');
mauseingabe;
ifind:=find;
str(f[ifind]:2,ss);
str(ifind:2,si);
 settextstyle(0,horizdir,1);
settextjustify(centertext,centertext);
outtextxy(500,round(fy*320),'S');outtextxy(520,round(fy*320),si);
outtextxy(580,round(fy*320),ss);
end;

procedure Koordinatensystem1;
var spx,spy,spz,px,py,pz,ehax,ehbx,ehcx,ehay,ehby,ehcy:real;
var jj:integer;
begin
px:=xb-xn;py:=yb-yn;pz:=zb-zn;
spx:=sqr(px);spy:=sqr(py);spz:=sqr(pz);
norx:=1/sqrt(spx+spy);
nory:=1/sqrt(spx*spz+spy*spz+sqr(spx+spy));
norz:=1/sqrt(spx+spy+spz);

for jj:=1 to 3 do begin
b[1,1]:=zsneux;
b[1,2]:=zneux;
b[1,3]:=ax;
b[2,1]:=zsneuy;
b[2,2]:=zneuy;
b[2,3]:=ay;
b[3,1]:=zsneuz;
b[3,2]:=zneuz;
b[3,3]:=az;
de[1]:=0;de[2]:=0;de[3]:=0;
de[jj]:=1;
koeff;
koeff2;
if jj=1 then begin ehax:=c[1];ehay:=c[2];end;
if jj=2 then begin ehbx:=c[1];ehby:=c[2];end;
if jj=3 then begin ehcx:=c[1];ehcy:=c[2];end;
end;
eax:=ehax;eay:=ehay;ebx:=ehbx;eby:=ehby;ecx:=ehcx;ecy:=ehcy;
end;

procedure Koordinatensystem2;
var xursp,yursp:integer;
    acol:word;
    sibp:string;
begin
xursp:=550;yursp:=400;
if xb-xn>0 then acol:=15 else acol:=7;
setcolor(acol);
moveto(xursp,round(fy*yursp));
lineto(xursp+round(40*eax),round(fy*(yursp-40*eay)));
if yb-yn>0 then acol:=15 else acol:=7;
setcolor(acol);
moveto(xursp,round(fy*yursp));
lineto(xursp+round(40*ebx),round(fy*(yursp-40*eby)));
if zb-zn>0 then acol:=15 else acol:=7;
setcolor(acol);
moveto(xursp,round(fy*yursp));
lineto(xursp+round(40*ecx),round(fy*(yursp-40*ecy)));
setcolor(15);
putpixel(xursp,round(fy*yursp),15);
 settextstyle(0,horizdir,0);
settextjustify(centertext,centertext);
outtextxy(xursp+round(60*eax),round(fy*(yursp-60*eay)),'x');
outtextxy(xursp+round(60*ebx),round(fy*(yursp-60*eby)),'y');
outtextxy(xursp+round(60*ecx),round(fy*(yursp-60*ecy)),'z');
{inc(ibp);str(ibp,sibp);outtextxy(15,round(fy*15),sibp);}
end;

procedure changepage;
begin
setvisualpage(c5);
if c5=0 then c5:=1 else
if c5=1 then c5:=0;
setactivepage(c5);
setcolor(0);
setfillstyle(0,0);
bar(0,0,640,round(480*fy));
end;

begin  {Hauptprogramm}
clrscr;
c4:=1.06;c5:=0;
colorinit;
eingabe1;
eingabe1k5;
eingabe1k7;
blickposition;
b8:='n';b9:=2;c1:=1.23;
repeat
b19:='w';ibp:=0;
eingabe2;
eingabe2k2;
eingabe2k5;
ig;
GetAspectRatio(Xasp,Yasp);
setaspectratio(xasp,round(c4*yasp));
anzd:=0;
repeat
inc(anzd);
changepage;
xyzinit;
xyzneu;
if anzd=1 then maxwinkel;
ordnen;
setlinestyle(0,0,1);
x1:=xb;y1:=yb;z1:=zb;kotrafo;x2:=x1;y2:=y1;z2:=z1;
x1:=xn;y1:=yn;z1:=zn;kotrafo;
winkel;
gav2:=alpz;gah2:=alsz;
for i1:=1 to anz do begin
i2:=folge[i1];
x1:=x[i2];y1:=y[i2];z1:=z[i2];kotrafo;
winkel;
gav:=alpz-gav2;
gah:=alsz-gah2;
if gah>pi then gah:=gah-2*pi else
if gah<(-pi) then gah:=gah+2*pi;
rs[i2]:=(xmax-xmin)/almax*arcsin(r[i2]/bo);
xs[i2]:=(xmin+xmax)/2+(xmax-xmin)*gah/almax;
ys[i2]:=(xmin+xmax)/2-(xmax-xmin)*gav/almax;
setlinestyle(0,0,3);
if (bildtyp=2)  then begin
setcolor(0);setfillstyle(1,0);end else begin
setcolor(color(f[i2]));
setfillstyle(1,color(f[i2]));end;
ri:=round(rs[i2]);xp:=round(xs[i2]);yp:=round(ys[i2]);
pieslice(xp,round(fy*yp),0,360,ri);
setlinestyle(0,0,1);
if (bildtyp=2) then begin
setcolor(color(f[i2]));
ellipse(xp,round(fy*yp),0,360,ri,round(fy*ri));
{circle(xp,round(fy*yp),ri);}end;
if bildtyp=1 then begin
setcolor(0);
ellipse(xp,round(fy*yp),0,360,ri+1,round(fy*(ri+1)));
{circle(xp,round(fy*yp),ri+1);}end;
{if b8='j' then steckerpaint;}
end;
koordinatensystem1;
koordinatensystem2;
if keypressed then begin if b19<>'e' then b19:=readkey;end;
if b19='s' then begin readln;b19:='w';end;
until ((b19='e')and(c5=0));
setvisualpage(c5);
info;
b3:='j';
key:='w';
beschriftung0;
if key='m' then begin
beschriftung;
regs.ax := $00; intr($33,Regs);
repeat
MausEingabe;
if mausx>460 then begin
if mausy<round(fy*35) then position else
if mausy<round(fy*75) then radius else
if mausy<round(fy*115) then abstand else
if mausy<round(fy*155) then kleinwinkel else
if mausy<round(fy*195) then sorte;
end;
until ((mausy<round(fy*30)) and (mausx<400));
if mausx<120 then b3:='n';
end;
if key='e' then b3:='n';
closegraph;
until b3<>'j';
writeln;writeln('Programmende.');readln;
end.