Object Pascal/Przykłady kodu
Program czytający ciąg znaków i informujący, czy jego długość jest liczbą parzystą czy nieparzystą. edytuj
program parzysta_nieparzysta; {nagłówek, obowiązkowy - "program" oznacza program główny ale}
{może być też "unit" jako moduł programu (np: CRT)}
uses crt; {uzywa biblioteki crt (potrzebna do podstawowych operacji)}
var t:string; {deklaracja zmiennych}
begin {początek programu}
writeln('Podaj dowolny ciąg znaków i nacisnij ENTER.'); {wyświetlenie napisu na ekranie}
readln(t); {pobranie łańcucha}
if length(t) mod 2 = 0 then {Sprawdzenie podzielności długości łańcucha przez 2}
writeln('Długość jest liczbą parzystą.') {jeśli podzielna}
else
writeln('Długość jest liczba nieparzystą.'); {w innym przypadku}
readln; {pobranie danych, w tym przypadku zapobiega natychmiastowemu zamknięcia się okienka}
end. {koniec programu}
Program ruszający gwiazdką na ekranie za pomocą kursorów. Pomysł oparty na kodzie z KŚE 7-8/06. edytuj
program ruch;
uses Crt;
var x,y : Integer;
kierunek : Char;
begin
ClrScr;
x:=10;
y:=10;
repeat
ClrScr;
TextColor(WHITE);
GotoXY(X,Y);
Write('*');
kierunek:=ReadKey;
if kierunek=#0 then
begin
kierunek:=ReadKey;
GotoXY(x,y);
Write('*');
if (kierunek=#75) AND (x>1) then x:=x-1;
if (kierunek=#77) AND (x<79) then x:=x+1;
if (kierunek=#72) AND (y>1) then y:=y-1;
if (kierunek=#80) AND (y<25) then y:=y+1;
end;
until kierunek=#27;
end.
Program wyszukujący dla dwóch podanych liczb największy wspólny dzielnik. edytuj
uses crt;
var a,b,n:byte;
begin
clrscr;
write('Podaj pierwsza liczbe ');
readln(a);
write('Podaj druga liczbe ');
readln(b);
n:=a;
while (a mod n<>0) or (b mod n<>0) do n:=n-1;
writeln('Najwiekszy wspolny dzielnik liczb ',a,' i ',b,' to ',n:0);
readln;
end.
Program wyszukujący dla dwóch podanych liczb najmniejszą wspólną wielokrotność. edytuj
uses crt;
var a,b,n,x:word;
begin
clrscr;
write('Podaj pierwsza liczbe ');
readln(a);
write('Podaj druga liczbe ');
readln(b);
n:=a;
while (n mod a<>0) or (n mod b<>0) do n:=n+1;
writeln('Najmniejsza wspolna wielokrotnosc liczb ',a,' i ',b,' to ',n:0);
readln;
end.
Program obliczający silnię podanej liczby. edytuj
uses crt;
var a:byte;
function silnia(n:byte):longint;
begin
if n=0 then silnia:=1
else silnia:=silnia(n-1)*n;
end;
begin
clrscr;
write('Podaj liczbe: ');
readln(a);
silnia(a);
write('Silnia tej liczby to ',silnia(a));
readln;
end.
Moduł do obsługi grafiki : rysowanie, skalowanie grafiki edytuj
{$A+,B-,D+,E+,F-,I+,L+,N-,O-,R+,S+,V+}
{$M 16384,0,655360}
{$N+}
UNIT OknaM;
INTERFACE {**************************************************************}
Uses Dos,Crt,Graph,zespolonyM,MathM;
Type SkaliT=(Liniowe,LogRozsz,LogZwez);
Type OkiennyT=Record Xmin,Xmax,Dx:real;
Ymin,Ymax,Dy:real;
XEmin,XEmax,Dxe:integer;
YEmin,YEmax,Dye:integer;
LiczbaPunktow:LongInt;
case TypySkalOsi:skaliT of
Liniowe : (Ax,Bx,KrokX,Ay,By,krokY:real);
LogRozsz: (LrMin,LrMax,dLr,XlrMin,XlrMax,dXlr,Ayr,Byr,krokYr:real);
LogZwez : (LzMin,LzMax,dLz,XlzMin,XlzMax,dXlz,Ayz,Byz,krokYz:real);
end; { type okiennyT=Record }
Type PixelowyT =Record Xe,Ye:integer; end;
{Type ZespolonyT=Record Re,Im:real; end;}
Type PunktowyT=Record Ekranu:pixelowyT;
Rzeczywisty:zespolonyT;
kolor:word;
okno:okiennyT;
End; { Type PunktowyT=record }
Procedure Kojarz(var okno:okiennyT;xMin,xMax,yMin,yMax:real;TypSkalOsiXY:skaliT;
xeMin,xeMax,yeMin,yeMax:integer);
Function SkalaXe2X(Xe:integer;okno:okiennyT):real; { xe --> x }
Procedure PunktP(x,y:real;okno:okiennyT;color:word);
Procedure PunktOblicz(z:zespolonyT;okno:okiennyT;var punktEkranu:pixelowyT);
Procedure Pisz(x,y:real;tekst:string;okno:okiennyT);
Procedure DajPunkt(NrPunktu:LongInt;Okno:okiennyT;var punkt:punktowyT);
Procedure DajPunktSkosnie(NrPunktu:LongInt;Okno:okiennyT;var Punkt:punktowyT);
Procedure RysujPunkt(punkt:punktowyT;kolor:word);
Procedure Kolo(srodek:zespolonyT;r:real;kolor:word;okno:okiennyT);
IMPLEMENTATION {************************************************************}
Procedure Kojarz(var okno:okiennyT;xMin,xMax,yMin,yMax:real;TypSkalOsiXY:skaliT;
xeMin,xeMax,yeMin,yeMax:integer);
begin okno.TypySkalOsi:=TypSkalOsiXY;
okno.Xmin:=Xmin; { wspolrzedne przestrzeni }
okno.Xmax:=Xmax; { funkcji }
okno.Dx:=Xmax-Xmin;
okno.Ymin:=Ymin;
okno.Ymax:=Ymax;
okno.Dy:=Ymax-Ymin;
okno.XEmin:=XEmin; { wspolrzedne ekranu }
okno.XEmax:=XEmax;
okno.Dxe:=XEmax-XEmin+1;
okno.YEmin:=YEmin;
okno.YEmax:=YEmax;
okno.Dye:=YEmax-YEmin+1;
okno.LiczbaPunktow:=Longint(okno.Dxe)*LongInt(okno.Dye); { liczba pixeli ekranu }
case TypSkalOsiXY of
liniowe : begin
okno.Ax:=(okno.Dxe)/(okno.dx); { XE=Ax*x+Bx }
okno.Bx:=XEmin-(okno.Ax*Xmin);
okno.KrokX:=(okno.Dx)/(okno.Dxe);
okno.Ay:=(okno.Dye)/(okno.dy);
okno.By:=YEmin-(okno.Ay*Ymin);
okno.KrokY:=(okno.Dy)/(okno.dye);
end;
LogRozsz: begin { nieliniowa , tj. logarytmiczna skala osi x }
okno.LrMin:= 0; { logarytm naturalny }
okno.LrMax:=-6;
okno.dLr:=okno.LrMax-okno.LrMin;
okno.XlrMin:=exp(okno.LrMin); { Xlr = exp(Lr) }
okno.XlrMax:=exp(okno.LrMax);
okno.dXlr:=okno.XlrMax-okno.XlrMin;
okno.Ayr:=(okno.Dye)/(okno.dy); { liniowa skala osi y }
okno.Byr:=YEmin-(okno.Ayr*Ymin);
okno.KrokYr:=(okno.Dy)/(okno.dye);
end;
LogZwez : begin
okno.LzMin:= -6;
okno.LzMax:= 0;
okno.dLz:=okno.LzMax-okno.LzMin;
okno.XlzMin:=exp(okno.LzMin);
okno.XlzMax:=exp(okno.LzMax);
okno.dXlz:=okno.XlzMax-okno.XlzMin;
okno.Ayz:=(okno.Dye)/(okno.dy); { liniowa skala osi y }
okno.Byz:=YEmin-(okno.Ayz*Ymin);
okno.KrokYz:=(okno.Dy)/(okno.dye);
end;
end; { case ... }
end; { procedury kojarz }
{-------------------------------------------------------------------------}
Function SkalaX(X:real;okno:okiennyT):integer; { x --> xe }
var xl,l,xe:real;
begin
With okno do
case
TypySkalOsi of liniowe : skalaX:=Round(Ax*X+Bx);
LogRozsz: begin
xl:=xlrMin+(x-xMin)*dXlr/dx;
l:=ln(Xl);
Xe:=xeMin+(l-lrmin)*dxe/dlr;
skalaX:=round(xe);
end;
LogZwez : begin
xl:=xlzMin+(x-xMin)*dXlz/dx;
l:=ln(Xl);
Xe:=xeMin+(l-lzmin)*dxe/dlz;
skalaX:=round(xe);
end ;
end;
end;
{-------------------------------------------------------------------------}
Function SkalaXe2X(Xe:integer;okno:okiennyT):real; { xe --> x }
var l,xl:real;
begin
with okno do begin
case TypySkalOsi of
liniowe : begin
SkalaXe2X:=(Xe-Bx)*KrokX; { xe --> x }
end;
LogRozsz: begin
l:=lrMin+(xe-xemin)*dlr/dxe;
xl:=exp(l);
skalaXe2X:=xmin+(xl-xlrmin)*dx/dxlr;
end;
LogZwez : begin
l:=lzMin+(xe-xemin)*dlz/dxe;
xl:=exp(l);
skalaXe2X:=xmin+(xl-xlzmin)*dx/dxlz;
end;
end; { case }
end; { with okno }
end;
{-------------------------------------------------------------------------}
Function InwersjaYE(YE:integer;okno:okiennyT):integer;
begin
With okno do
begin
if YE>(Dye/2) then InwersjaYe:=YEmin+(YEmax-YE)
else InwersjaYE:=YEmax-(YE-YEmin);
end;
end;
{---------------------------------------------------------------------------}
Function SkalaY(Y:real;okno:okiennyT):integer; { y --> ye }
var Skala:integer;
begin { cialo funkcji skalaY }
with okno do
case TypySkalOsi of
liniowe : begin
Skala:=Round(Ay*Y+By);
SkalaY:=InwersjaYE(Skala,okno);
end;
LogRozsz: begin
Skala:=Round(Ayr*Y+Byr);
SkalaY:=InwersjaYE(Skala,okno);
end;
LogZwez : begin
Skala:=Round(Ayz*Y+Byz);
SkalaY:=InwersjaYE(Skala,okno);
end;
end; { case }
end; { cialo funkcji skalaY }
{---------------------------------------------------------------------------}
Function SkalaYe2Y(Ye:integer;okno:okiennyT):real; { Ye --> Y }
begin
with okno do begin
case TypySkalOsi of
liniowe : SkalaYe2Y:=(Ye-By)*KrokY; { ye --> y }
LogRozsz: SkalaYe2Y:=(Ye-Byr)*KrokYr; { ye --> y }
LogZwez : SkalaYe2Y:=(Ye-Byz)*KrokYz; { ye --> y }
end; { case }
end; { with okno }
end;
{---------------------------------------------------------------------------}
Procedure PunktP(x,y:real;okno:okiennyT;color:word);
var XE,YE:integer;
begin
with okno do
begin
XE:=SkalaX(X,okno); { X |--> Xekranu }
YE:=SkalaY(Y,okno); { Y |--> Yekranu }
PutPixel(XE,YE,color);
end;
end;
{---------------------------------------------------------------------------}
Procedure PunktOblicz(z:zespolonyT;okno:okiennyT;var punktEkranu:pixelowyT);
begin
with okno do
begin
punktEkranu.XE:=SkalaX(z.re,okno); { X |--> Xekranu }
punktEkranu.YE:=SkalaY(z.im,okno); { Y |--> Yekranu }
end;
end;
{---------------------------------------------------------------------------}
Procedure Pisz(x,y:real;tekst:string;okno:okiennyT);
var xe,ye:integer;
begin
xe:=SkalaX(x,okno);
ye:=SkalaY(y,okno);
OutTextXY(xe,ye,tekst);
end;
{---------------------------------------------------------------------------}
Procedure DajPunkt(NrPunktu:LongInt;Okno:okiennyT;var Punkt:punktowyT);
var l,xl:real;
begin
With okno do
begin
Punkt.Ekranu.Xe:=XeMin+integer(NrPunktu mod Dxe);
Punkt.Ekranu.Ye:=YeMin+integer(NrPunktu div Dxe);
Punkt.Okno:=Okno;
case okno.TypySkalOsi of
liniowe : begin
Punkt.Rzeczywisty.Re:=(Punkt.Ekranu.Xe-Bx)*KrokX; { xe --> x }
Punkt.Rzeczywisty.Im:=(Punkt.Ekranu.Ye-By)*KrokY; { ye --> y }
end;
LogRozsz: begin
l:=lrMin+(punkt.ekranu.xe-xemin)*dlr/dxe;
xl:=exp(l);
punkt.rzeczywisty.re:=xmin+(xl-xlrmin)*dx/dxlr;
Punkt.Rzeczywisty.Im:=(Punkt.Ekranu.Ye-Byr)*KrokYr; { ye --> y } ;
end;
LogZwez : begin
l:=lzMin+(punkt.ekranu.xe-xemin)*dlz/dxe;
xl:=exp(l);
punkt.rzeczywisty.re:=xmin+(xl-xlzmin)*dx/dxlz;
Punkt.Rzeczywisty.Im:=(Punkt.Ekranu.Ye-Byz)*KrokYz; { ye --> y } ;
end;
end; { case }
end; { with okno }
end; { Procedure DajPunkt }
{---------------------------------------------------------------------------}
Procedure DajPunktSkosnie(NrPunktu:LongInt;Okno:okiennyT;var Punkt:punktowyT);
begin
With okno do
begin
{if CzyWzglPierw(dxe,dye)
then begin }
Punkt.Ekranu.Xe:=XeMin+integer(NrPunktu mod Dxe);
Punkt.Ekranu.Ye:=YeMin+integer(NrPunktu mod 3);
Punkt.Okno:=Okno;
case okno.TypySkalOsi of
liniowe : begin
Punkt.Rzeczywisty.Re:=(Punkt.Ekranu.Xe-Bx)*KrokX;
Punkt.Rzeczywisty.Im:=(Punkt.Ekranu.Ye-By)*KrokY;
end;
LogRozsz: ;
LogZwez : ;
end; { case }
{ end { if CzyWzglPierw then}
{else DajPunkt(NrPunktu,Okno,Punkt); }
end; { with okno }
end; { Procedure DajPunktSkosnie }
{---------------------------------------------------------------------------}
Procedure RysujPunkt(Punkt:PunktowyT;kolor:word);
var Ye:integer;
begin
Ye:=InwersjaYe(Punkt.ekranu.Ye,Punkt.okno);
PutPixel(Punkt.ekranu.Xe,Ye,kolor);
end;
{---------------------------------------------------------------------------}
Procedure Kolo(srodek:zespolonyT;
r:real;
kolor:word;
okno:okiennyT);
var xe,ye:integer;
promien:word;
begin
xe:=SkalaX(srodek.re,okno);
ye:=SkalaY(srodek.im,okno);
Promien:=round(r*okno.Ay);
SetColor(kolor);
SetFillStyle(SolidFill,kolor);
FillEllipse(xe,ye,promien,promien);
end;
END. { modulu OknaM } {****************************************************}
program rysuje diagram bifurkacyjny edytuj
program rysuje diagram bifurkacyjny funkcji
PROGRAM diag321;
{ program rysuje diagram bifurkacyjny y[n+1]=y[n]*y[n]+x,
{ x: -2.0< x <-1.41 }
{ y: -2.0< y <2.0 }
{ nieliniowe , zmienne w 3 oknach skalowanie osi x }
{ rysuje tez punkty stale nieprzyciagajace !!!!! }
USES {moduly standardowe}
Crt,Graph,
{moje moduly}
GrafM,
OknaM,
fractalnyM,
BmpM;
VAR Okno1,okno2,okno3:OkiennyT;
Bok:integer;
BEGIN
Opengraf;
Bok:=Round(GetMaxx/7);
Kojarz(okno3,-0.200,0.25,-2,2,logRozsz,(6*bok)+2,(7*bok),0,GetMaxY);
Diagram(okno3,50,10); {unit FractalnyM}
Kojarz(okno2,-1.401,-0.200,-2,2,logZwez,(3*bok)+1,(6*bok)+1,0,GetMaxY);
Diagram(okno2,100,20);
Kojarz(okno1,-2.000,-1.401,-2,2,logRozsz,0,3*bok,0,getMaxY);
Diagram(okno1,100,200);
ScreenCopy('b',640,480);
Repeat until KeyPressed;
CloseGraph;
END.
Zbiory Julia edytuj
Zbiory Julia podobne do grafik Eschera
-
Basilica -
c = -1.24 -
Douady Rabbit
Program Esher_Julia;
{možesz zmieniac: c_re_int, c_im_int
skala }
{ mozna zmieniac skale dla x i y niezaleznie}
{ ekran : E= (XeMin;XeMax)x(YeMinx(YeMax)
plaszczyzna z = (xMin:xMax)x(yMin;yMax)
skalowanie liniowe paszczyzny Z na ekran
dla kazdego punktu plaszczyzny z=x+y*i
obliczmy ciag Nmax punktow Zn: Z0=x+y*i; Z(n+1) = (Zn*Zn) + c
w zaležnosci od spelnienia warunku okreslamy kolor punktu z
efektem jest zbior Julii dla funkcji z*z+c}
uses crt,graph,
{moje modul}
grafM,
KolorM,
bmpM;
var color:longInt;
Xe, {xEkranu,yEkranu = wspolrzedne pixeli}
Ye,
dXe,dYe:integer; {szerokosc i wysokosc ekranu}
KrokX,KrokY:extended;
y,x, { z=x+y*i }
tx,ty,
xTemp :extended; { Z(n+1)=Zn*Zn+c ; c(Cx,Cy) }
n,tn:LongInt; { numer kolejnej iteracji= punktu ciagu Zn }
const
{c=0+0*i; circle }
C_re=-0.0; {wspolczynnik funkcji F(z)=(z*z)+c }
C_im=0.0; { c jest liczba zespolona : c=c_re+c_im*i }
{target set C_int }
C_re_int=-1.1; {wspolczynnik funkcji F(z)=(z*z)+c_int }
C_im_int=-0.001; { c jest liczba zespolona : c_int=c_re_int+c_im_int*i }
skala=250.10; {standard 15 ; sproboj: -2.0; 1.0 ; 1000.0; }
xMin=-1.0;
xMax=1.0;
dx=xMax-xMin;
yMin=-1.0;
yMax=1.0;
dy=yMax-yMin;
YeMax=700; { liczba pixeli w pionie }
YeMin=0;
XeMax=YeMax; { liczba pixeli w poziomie }
XeMin=0;
nMax=100; { maksymaln liczba iteracji }
BailOut=4;
{--------------------------------------------------------------}
procedure wstep;
begin { wstep }
dYe:=YeMax-YeMin+1;
Kroky:=dy/dYe;
dXe:=XeMax-XeMin+1; {liczba punktow ekranu w poziomie}
Krokx:=dx/dXe;
end; {wstep}
{---------------------------------------------------}
procedure bmp(w,h:integer);
begin
{create new file on a disk in a given directory with given name }
Assign(bmpFile,DefaultDirectory+DefaultbmpFileName+DefaultExtension); { }
ReWrite(bmpFile,1); {ustal rozmiar zapisu na 1 bajt} { }
{fill the Headers}
with bmpInfoHeader,bmpFileHeader do
begin
ID:=19778;
InfoheaderSize:=40;
width:=w;
height:=h;
BitsPerPixel:=32;
BytesPerPixel:=BitsPerPixel div 8;
reserved:=0;
bmpDataOffset:=InfoHeaderSize+bmpFileHeaderSize;
planes:=1;
compression:=bi_RGB;
XPixPerMeter:=0;
YPixPerMeter:=0;
NumbColorsUsed:=0;
NumbImportantColors:=0;
RowSizeInBytes:=(Width*BytesPerPixel); {only for >=8 bits per pixel}
bmpDataSize:=height*RowSizeinBytes;
FileSize:=InfoHeaderSize+bmpFileHeaderSize+bmpDataSize;
{copy headers to disk file}
BlockWrite(bmpFile,bmpFileHeader,bmpFileHeaderSize);
BlockWrite(bmpFile,bmpInfoHeader,infoHeaderSize);
end;
end;
Begin {------------------------------------------------------------------}
OpenSvga; { 1280x1024x256 svga256.bgi}
wstep;
bmp(dXe,dYe);
for Ye:=YeMax DownTo YeMin do
for Xe:=XeMax DownTo XeMin do
begin
{okrela rzeczywiste wspolrzedne punktu z=x+y*i }
x:=xMin+(Xe-XeMin)*Krokx;
y:=yMin+(Ye-YeMin)*Kroky;
n:=0;
{petla zewnetrzna; c=0+0*i}
repeat {iteracja punktu Z(n+1)=(Zn*Zn)+C }
inc(n);
xTemp:=x*x-y*y+C_re;
y:=2*x*y+C_im;
x:=xTemp;
Begin { petla wewnetrzna}
tn:=0;
tx:=x*skala;
ty:=y*skala;
repeat
inc(tn);
xTemp:=(tx+ty)*(tx-ty)+C_re_int;
ty:=2*tx*ty+C_im_int;
tx:=xTemp;
until (tn>=nMax) or (ty*ty+tx*tx>BailOut);
if tn=nMax then break;
end;
If KeyPressed then exit;
until (n>=nMax) or (y*y+x*x>BailOut);
{ ................okrela kolor...................................}
if n=1 then color:=red {target set }
else if odd(n) then color:=black
else color:=white;
if sqrt(sqr(x)+sqr(y))>1 then color:=black; {out of the circle}
{..................rysuje punkt na ekranie...............}
PutPixel(Xe,Ye,color);
{ zapisuje bitmapŠ...................................................}
{convert color to color32}
case color of
black:begin
color32.Blue:=0;
color32.Green:=0;
color32.Red:=0;
color32.Alfa:=0;
end;
white:begin
color32.Blue:=255;
color32.Green:=255;
color32.Red:=255;
color32.Alfa:=0;
end;
red:begin
color32.Blue:=0;
color32.Green:=0;
color32.Red:=255;
color32.Alfa:=0;
end;
end; {case}
BlockWrite(bmpFile,color32,4);
end; {Xe}
Close(bmpFile);
repeat until KeyPressed;
{CloseGraph;}
End. {cialo}
{GetMax Y powoduje zaburzenie pracy programu}
{ Adam Majewski
adammaj@mp.pl
Walbrzych }
{jezyk programowania Turbo Pascal 7.0 firmy Borland
dla systemu operacyjnego MS-Dos firmy Microsoft}
Fraktale edytuj
unit FractalnyM;
{$A+,B-,D+,E+,F-,I+,L+,N-,O-,R+,S+,V+}
{$M 16384,0,655360}
INTERFACE {******************************************************************}
uses crt,graph,
OknaM, {okno_ekranu --> okno_rzeczywiste 2D}
ZespolonyM, { liczba zespolona }
dwumianM, { funkcja zespolona }
KolorM;
{........................................................................}
Procedure ZukMultiP (okno:okiennyT;figura:CzyNalezyDoT;ModulMax:real;iMax:integer;KolorZbioru,KolorTla:word);
Procedure Zuk (okno:okiennyT;promien:real;iMax:integer;KolorZbioru,KolorTla:word);
Procedure Z_test (okno:okiennyT;promien:real;iMax:integer;KolorZbioru,KolorTla:word);
Procedure ZukOdwr (okno:okiennyT;promien:real;iMax:integer;KolorZbioru,KolorTla:word);
Procedure ZukLsmMono (okno:okiennyT;promien:real;iMax,LiczbaWarstw:integer;
KolorZbioru,KolorTlaBezWarstw,KolorWarstwyNieParz,KolorWarstwyParz:word);
Procedure ZukLsmMoOdwr(okno:okiennyT;promien:real;iMax,LiczbaWarstw:integer;
KolorZbioru,KolorTlaBezWarstw,KolorWarstwyNieParz,KolorWarstwyParz:word);
Procedure ZukLSM (okno:okiennyT;odleglosc:real;iMax,LiczbaWarstw,LiczbaKolorow:integer;
KolorZbioru,Kolor1WarstwyTla,KolorTla:word);
Procedure ZukLSMautomat(okno:okiennyT;promien:real;iMax:integer;KolorZbioru:word);
Procedure ZukLsmOdwr (okno:okiennyT;odleglosc:real;iMax,LiczbaWarstw,LiczbaKolorow:integer;
KolorZbioru,Kolor1WarstwyTla,KolorTla:word);
Procedure ZukBiomorf (okno:okiennyT;promien:real;iMax:integer;KolorZbioru,KolorTla:word);
Procedure ZukBiomorfOdwrotnie(okno:okiennyT;promien:real;iMax:integer;KolorZbioru,KolorTla:word);
PROCEDURE ZukBin (okno:okiennyT;promien:real;iMax:integer;LiczbaWarstw:integer;
KolorZbioru,KolorTlaBezWarstw,KolorTlaGornejPol,KolorTlaDolnejPol:word);
PROCEDURE ZukBinOdwr (okno:okiennyT;promien:real;iMax:integer;LiczbaWarstw:integer;
KolorZbioru,KolorTlaBezWarstw,KolorTlaGornejPol,KolorTlaDolnejPol:word);
PROCEDURE ZukAtr (okno:okiennyT;promien:real;iMax:integer;OdlegloscMax:real;
KolorZbioru,KolorTla:word);
PROCEDURE ZukAtrOdwr (okno:okiennyT;promien:real;iMax:integer;OdlegloscMax:real;
KolorZbioru,KolorTla:word);
PROCEDURE ZukAtraktor (okno:okiennyT;promien:real;iMax:integer;OdlegloscMax:real;
KolorZbioru,KolorTla:word);
PROCEDURE ZukAtraktorOdwr(okno:okiennyT;promien:real;iMax:integer;OdlegloscMax:real;
KolorZbioru,KolorTla:word);
PROCEDURE ZukDEM (okno:okiennyT;PromienDoKw:real;iMax:integer;OdlegloscPix:real;
OverFlow:real);
PROCEDURE Diagram (okno:okiennyT;iMax1,iMax2:integer);
IMPLEMENTATION {**************************************************************}
Procedure ZukMultiP (okno:okiennyT;figura:CzyNalezyDoT;ModulMax:real;iMax:integer;KolorZbioru,KolorTla:word);
const z0:zespolonyT=(re:0.0; im:0.0);
Var i:integer; { nr iteracji }
NrPunktu:LongInt; { punkty okna ekranu}
punkt:punktowyT; { typ zdefiniowany w module oknaM }
z:zespolonyT;
kolor:word;
Begin
for NrPunktu:=0 to (okno.LiczbaPunktow-1) do
begin
DajPunkt(NrPunktu,Okno,Punkt);
Iteruj(figura,z0,Punkt.rzeczywisty,ModulMax,iMax,i,z);
kolor:=KolorLSMautomat(i,iMax,KolorZbioru);
RysujPunkt(punkt,kolor);
if KeyPressed then halt;
end;
End;
{ proponowane wywolanie: -0.6<x<2; -1.3<y<1.3; promien=2; iMax=20 }
{-------------------------------------------------------------------------}
Procedure Zuk(okno:okiennyT;
promien:real;
iMax:integer;
KolorZbioru,
KolorTla:word);
const z0:zespolonyT=(re:0.0; im:0.0);
Var i:integer; { nr iteracji }
NrPunktu:LongInt; { punkty okna ekranu}
punkt:punktowyT; { typ zdefiniowany w module oknaM }
z:zespolonyT;
kolor:word;
Begin
for NrPunktu:=0 to (okno.LiczbaPunktow-1) do
begin
DajPunkt(NrPunktu,Okno,Punkt);
IterujP(z0,Punkt.rzeczywisty,promien,iMax,i,z);
kolor:=KolorPunktu(i,iMax,KolorZbioru,KolorTla);
RysujPunkt(punkt,kolor);
if KeyPressed then halt;
end;
End;
{ proponowane wywolanie: -0.6<x<2; -1.3<y<1.3; promien=2; iMax=20 }
{-------------------------------------------------------------------------}
Procedure Z_test(okno:okiennyT;
promien:real;
iMax:integer;
KolorZbioru,
KolorTla:word);
const z0:zespolonyT=(re:0.0; im:0.0);
Var i:integer; { nr iteracji }
NrPunktu:LongInt;
punkt:punktowyT; { typ zdefiniowany w module oknaM }
z:zespolonyT;
kolor:word;
Begin
for NrPunktu:=0 to (okno.LiczbaPunktow-1) do
begin
DajPunktSkosnie(NrPunktu,Okno,Punkt);
kolor:=KolorZbioru;
RysujPunkt(punkt,kolor);
if KeyPressed then halt;
end;
End;
{ proponowane wywolanie -0.6<x<2 -1.3<y<1.3 odleglosc=2 iMax=20 }
{-------------------------------------------------------------------------}
Procedure ZukOdwr(okno:okiennyT;
promien:real;
iMax:integer;
KolorZbioru,
KolorTla:word);
const z0:zespolonyT=(re:0.0; im:0.0);
Var i:integer; { nr iteracji }
NrPunktu:LongInt;
punkt:punktowyT; { typ zdefiniowany w module oknaM }
z,c:zespolonyT;
kolor:word;
Begin
for NrPunktu:=0 to (okno.LiczbaPunktow-1) do
begin
DajPunkt(NrPunktu,Okno,Punkt);
OdwrotnaZ(Punkt.rzeczywisty,c); {**********}
IterujP(z0,c,promien,iMax,i,z);
kolor:=KolorPunktu(i,iMax,KolorZbioru,KolorTla);
RysujPunkt(punkt,kolor);
if KeyPressed then halt;
end;
End;
{ proponowane wywolanie x <y< odleglosc=2 iMax=20 }
{-------------------------------------------------------------------------------}
Procedure ZukLsmMono(okno:okiennyT;
promien:real;
iMax:integer;
LiczbaWarstw:integer;
KolorZbioru,
KolorTlaBezWarstw,
KolorWarstwyNieParz,
KolorWarstwyParz:word);
Const z0:zespolonyT=(re:0.0; im:0.0);
VAR i:integer; { nr iteracji }
NrPunktu:LongInt;
punkt:punktowyT; { typ zdefiniowany w module oknaM }
kolor:word;
z:zespolonyT;
BEGIN
for NrPunktu:=0 to (okno.LiczbaPunktow-1) do
begin
DajPunkt(NrPunktu,Okno,Punkt);
IterujP(z0,punkt.rzeczywisty,promien,iMax,i,z);
kolor:=KolorLSMmono(i,iMax,liczbaWarstw,KolorZbioru,KolorTlaBezWarstw,
KolorWarstwyNieParz,KolorWarstwyParz);
RysujPunkt(Punkt,kolor);
if KeyPressed then halt;
end;
END;
{-------------------------------------------------------------------------------}
Procedure ZukLsmMoOdwr(okno:okiennyT;
promien:real;
iMax:integer;
LiczbaWarstw:integer;
KolorZbioru,
KolorTlaBezWarstw,
KolorWarstwyNieParz,
KolorWarstwyParz:word);
Const z0:zespolonyT=(re:0.0; im:0.0);
VAR i:integer; { nr iteracji }
NrPunktu:LongInt;
punkt:punktowyT; { typ zdefiniowany w module oknaM }
kolor:word;
z,c:zespolonyT;
BEGIN
for NrPunktu:=0 to (okno.LiczbaPunktow-1) do
begin
DajPunkt(NrPunktu,Okno,Punkt);
OdwrotnaZ(Punkt.rzeczywisty,c);
IterujP(z0,c,promien,iMax,i,z);
kolor:=KolorLSMmono(i,iMax,liczbaWarstw,KolorZbioru,KolorTlaBezWarstw,
KolorWarstwyNieParz,KolorWarstwyParz);
RysujPunkt(Punkt,kolor);
if KeyPressed then halt;
end;
END;
{-----------------------------------------------------------------------------}
PROCEDURE ZukLSM(okno:okiennyT;
odleglosc:real;
iMax,
LiczbaWarstw,
LiczbaKolorow:integer;
KolorZbioru,
Kolor1WarstwyTla,
KolorTla:word);
const z0:zespolonyT=(re:0.0; im:0.0);
VAR i:integer; { nr iteracji }
NrPunktu:LongInt;
punkt:punktowyT; { typ zdefiniowany w module oknaM }
kolor:word;
z:zespolonyT;
BEGIN
for NrPunktu:=0 to (okno.LiczbaPunktow-1) do
begin
DajPunkt(NrPunktu,Okno,Punkt); { punkt = c : z= z*z + c }
IterujP(z0,punkt.rzeczywisty,odleglosc,iMax,i,z);
kolor:=KolorLSM(i,iMax,liczbaWarstw,liczbaKolorow,KolorZbioru,Kolor1warstwyTla,
KolorTla);
RysujPunkt(Punkt,kolor);
if KeyPressed then halt;
end;
END;
{-----------------------------------------------------------------------------}
PROCEDURE ZukLSMautomat(okno:okiennyT;
promien:real;
iMax:integer;
KolorZbioru:word);
const z0:zespolonyT=(re:0.0; im:0.0);
VAR i:integer; { nr iteracji }
NrPunktu:LongInt;
punkt:punktowyT; { typ zdefiniowany w module oknaM }
kolor:word;
z:zespolonyT;
BEGIN
for NrPunktu:=0 to (okno.LiczbaPunktow-1) do
begin
DajPunkt(NrPunktu,Okno,Punkt); { punkt = c : z= z*z + c }
IterujP(z0,punkt.rzeczywisty,promien,iMax,i,z);
kolor:=KolorLSMautomat(i,iMax,KolorZbioru);
RysujPunkt(Punkt,kolor);
if KeyPressed then halt;
end;
END;
{-----------------------------------------------------------------------------}
PROCEDURE ZukLsmOdwr
(okno:okiennyT;
odleglosc:real;
iMax,
LiczbaWarstw,
LiczbaKolorow:integer;
KolorZbioru,
Kolor1WarstwyTla,
KolorTla:word);
const z0:zespolonyT=(re:0.0; im:0.0);
VAR i:integer; { nr iteracji }
NrPunktu:LongInt;
punkt:punktowyT; { typ zdefiniowany w module oknaM }
kolor:word;
z,c:zespolonyT;
BEGIN
for NrPunktu:=0 to (okno.LiczbaPunktow-1) do
begin
DajPunkt(NrPunktu,Okno,Punkt); { punkt = c : z= z*z + c }
OdwrotnaZ(Punkt.rzeczywisty,c);
IterujP(z0,c,odleglosc,iMax,i,z);
kolor:=KolorLSM(i,iMax,liczbaWarstw,liczbaKolorow,KolorZbioru,Kolor1warstwyTla,
KolorTla);
RysujPunkt(Punkt,kolor);
if KeyPressed then halt;
end;
END;
{-------------------------------------------------------------------------}
Procedure ZukBiomorf(okno:okiennyT;
promien:real;
iMax:integer;
KolorZbioru,
KolorTla:word);
const z0:zespolonyT=(re:0.0; im:0.0);
Var i:integer; { nr iteracji }
NrPunktu:LongInt; { punkty okna ekranu}
punkt:punktowyT; { typ zdefiniowany w module oknaM }
z:zespolonyT;
kolor:word;
Begin
for NrPunktu:=0 to (okno.LiczbaPunktow-1) do
begin
DajPunkt(NrPunktu,Okno,Punkt);
IterujBiomorfP(z0,Punkt.rzeczywisty,promien,iMax,i);
kolor:=KolorLSMautomat(i,iMax,KolorZbioru);
RysujPunkt(punkt,kolor);
if KeyPressed then halt;
end;
End;
{ proponowane wywolanie: -10<x<10; -10<y<10; promien= 10; iMax=20 }
{-------------------------------------------------------------------------}
Procedure ZukBiomorfOdwrotnie(okno:okiennyT;
promien:real;
iMax:integer;
KolorZbioru,
KolorTla:word);
const z0:zespolonyT=(re:0.0; im:0.0);
Var i:integer; { nr iteracji }
NrPunktu:LongInt; { punkty okna ekranu}
punkt:punktowyT; { typ zdefiniowany w module oknaM }
z,c:zespolonyT;
kolor:word;
Begin
for NrPunktu:=0 to (okno.LiczbaPunktow-1) do
begin
DajPunkt(NrPunktu,Okno,Punkt);
OdwrotnaZ(Punkt.rzeczywisty,punkt.rzeczywisty);
IterujBiomorfP(z0,Punkt.rzeczywisty,promien,iMax,i);
kolor:=KolorLSMautomat(i,iMax,KolorZbioru);
RysujPunkt(punkt,kolor);
if KeyPressed then halt;
end;
End;
{ proponowane wywolanie: -10<x<10; -10<y<10; promien= 10; iMax=20 }
{--------------------------------------------------------------------------}
PROCEDURE ZukBin(okno:okiennyT;
promien:real;
iMax:integer;
LiczbaWarstw:integer;
KolorZbioru,
KolorTlaBezWarstw,
KolorTlaGornejPol,
KolorTlaDolnejPol:word);
Const z0:zespolonyT=(re:0.0; im:0.0);
VAR i:integer; { nr iteracji }
NrPunktu:LongInt;
punkt:punktowyT; { typ zdefiniowany w module oknaM }
kolor:word; { kolor punktu }
z:zespolonyT; { }
BEGIN
for NrPunktu:=0 to (okno.LiczbaPunktow-1) do
begin
DajPunkt(NrPunktu,Okno,Punkt); { punkt = c : z= z*z + c }
IterujP(z0,punkt.rzeczywisty,Promien,iMax,i,z);
kolor:=KolorBin(i,iMax,LiczbaWarstw,KolorZbioru,KolorTlaBezWarstw,
KolorTlaGornejPol,KolorTlaDolnejPol,z);
RysujPunkt(punkt,kolor);
if KeyPressed then halt;
end;
END;
{--------------------------------------------------------------------------}
PROCEDURE ZukBinOdwr
(okno:okiennyT;
promien:real;
iMax:integer;
LiczbaWarstw:integer;
KolorZbioru,
KolorTlaBezWarstw,
KolorTlaGornejPol,
KolorTlaDolnejPol:word);
Const z0:zespolonyT=(re:0.0; im:0.0);
VAR i:integer; { nr iteracji }
NrPunktu:LongInt;
punkt:punktowyT; { typ zdefiniowany w module oknaM }
kolor:word; { kolor punktu }
z,c:zespolonyT; { }
BEGIN
for NrPunktu:=0 to (okno.LiczbaPunktow-1) do
begin
DajPunkt(NrPunktu,Okno,Punkt); { punkt = c : z= z*z + c }
OdwrotnaZ(Punkt.rzeczywisty,c);
IterujP(z0,c,Promien,iMax,i,z);
kolor:=KolorBin(i,iMax,LiczbaWarstw,KolorZbioru,KolorTlaBezWarstw,KolorTlaGornejPol,
KolorTlaDolnejPol,z);
RysujPunkt(punkt,kolor);
if KeyPressed then halt;
end;
END;
{----------------------------------------------------------------------------}
PROCEDURE ZukAtr(okno:okiennyT;
promien:real;
iMax:integer;
OdlegloscMax:real;
KolorZbioru,
KolorTla:word);
const z0:zespolonyT=(re:0.0; im:0.0);
VAR i:integer; { nr iteracji }
NrPunktu:LongInt;
punkt:punktowyT; { typ zdefiniowany w module oknaM }
z,z1,z2,z3,z4,z5,z6,z7,z8,z9:zespolonyT;
kolor:word;
BEGIN
for NrPunktu:=0 to (okno.LiczbaPunktow-1) do
begin
DajPunkt(NrPunktu,Okno,Punkt); { punkt=c : z=z*z + c }
IterujP(z0,punkt.rzeczywisty,promien,iMax,i,z);
if ((i=iMax) and (ModulZ(z)<promien))
then
begin
Dwumian2Z(z,punkt.rzeczywisty,z1);
Dwumian2Z(z1,punkt.rzeczywisty,z2);
Dwumian2Z(z2,punkt.rzeczywisty,z3);
Dwumian2Z(z3,punkt.rzeczywisty,z4);
Dwumian2Z(z4,punkt.rzeczywisty,z5);
{ Dwumian2Z(z5,punkt.rzeczywisty,z6);
Dwumian2Z(z6,punkt.rzeczywisty,z7);
Dwumian2Z(z7,punkt.rzeczywisty,z8);
Dwumian2Z(z8,punkt.rzeczywisty,z9);}
kolor:=KolorZbioru;
{ if odlegloscZ(z9,z)<odlegloscMax then kolor:=magenta;
if odlegloscZ(z8,z)<odlegloscMax then kolor:=blue;
if odlegloscZ(z7,z)<odlegloscMax then kolor:=green;
if odlegloscZ(z6,z)<odlegloscMax then kolor:=red; }
if odlegloscZ(z5,z)<odlegloscMax then kolor:=cyan;
if odlegloscZ(z4,z)<odlegloscMax then kolor:=magenta;
if odlegloscZ(z3,z)<odlegloscMax then kolor:=blue;
if odlegloscZ(z2,z)<odlegloscMax then kolor:=green;
if odlegloscZ(z1,z)<odlegloscMax then kolor:=red;
end
else kolor:=KolorTla;
RysujPunkt(punkt,kolor);
if KeyPressed then halt;
end;
END;
{----------------------------------------------------------------------------}
PROCEDURE ZukAtrOdwr
(okno:okiennyT;
promien:real;
iMax:integer;
OdlegloscMax:real;
KolorZbioru,
KolorTla:word);
const z0:zespolonyT=(re:0.0; im:0.0);
VAR i:integer; { nr iteracji }
NrPunktu:LongInt;
punkt:punktowyT; { typ zdefiniowany w module oknaM }
c,z,z1,z2,z3,z4,z5,z6,z7,z8,z9:zespolonyT;
kolor:word;
BEGIN
for NrPunktu:=0 to (okno.LiczbaPunktow-1) do
begin
DajPunkt(NrPunktu,Okno,Punkt); { punkt=c : z=z*z + c }
OdwrotnaZ(Punkt.rzeczywisty,c);
IterujP(z0,c,promien,iMax,i,z);
if ((i=iMax) and (ModulZ(z)<promien))
then
begin
Dwumian2Z(z,c,z1);
Dwumian2Z(z1,c,z2);
Dwumian2Z(z2,c,z3);
Dwumian2Z(z3,c,z4);
Dwumian2Z(z4,c,z5);
{ Dwumian2Z(z5,punkt.rzeczywisty,z6);
Dwumian2Z(z6,punkt.rzeczywisty,z7);
Dwumian2Z(z7,punkt.rzeczywisty,z8);
Dwumian2Z(z8,punkt.rzeczywisty,z9);}
kolor:=KolorZbioru;
{ if odlegloscZ(z9,z)<odlegloscMax then kolor:=magenta;
if odlegloscZ(z8,z)<odlegloscMax then kolor:=blue;
if odlegloscZ(z7,z)<odlegloscMax then kolor:=green;
if odlegloscZ(z6,z)<odlegloscMax then kolor:=red; }
if odlegloscZ(z5,z)<odlegloscMax then kolor:=cyan;
if odlegloscZ(z4,z)<odlegloscMax then kolor:=magenta;
if odlegloscZ(z3,z)<odlegloscMax then kolor:=blue;
if odlegloscZ(z2,z)<odlegloscMax then kolor:=green;
if odlegloscZ(z1,z)<odlegloscMax then kolor:=red;
end
else kolor:=KolorTla;
RysujPunkt(punkt,kolor);
if KeyPressed then halt;
end;
END;
{----------------------------------------------------------------------------}
PROCEDURE ZukAtraktor(okno:okiennyT;
promien:real;
iMax:integer;
OdlegloscMax:real;
KolorZbioru,
KolorTla:word);
const z0:zespolonyT=(re:0.0; im:0.0);
nMax=10; { liczba atraktorow, nMax cykli, od jedno do nMax-punktowych }
VAR i,n,nKoniec:integer;{ i=nr iteracji, n=liczba punktow cyklu atraktora }
NrPunktu:LongInt;
punkt:punktowyT; { typ zdefiniowany w module oknaM }
z:zespolonyT;
Zn: array [1..nMax] of zespolonyT;
kolor:word;
KwadratPromienia:real;
BEGIN
KwadratPromienia:=Promien*Promien;
for NrPunktu:=0 to (okno.LiczbaPunktow-1) do
begin
DajPunkt(NrPunktu,Okno,Punkt); { punkt=c : z=z*z + c }
IterujP(z0,punkt.rzeczywisty,promien,iMax,i,z);
if ((i=iMax) and (KwModZ(z)<KwadratPromienia))
then
begin
n:=1;
Zn[1]:=z;
while (n<nMax) and (KwModZ(Zn[n])<KwadratPromienia) do
begin
Dwumian2Z(Zn[n],punkt.rzeczywisty,Zn[n+1]);
n:=n+1;
end;
kolor:=KolorZbioru;
for i:=nMax DownTo 2 do
if odlegloscZ(Zn[i],Zn[1])<odlegloscMax then kolor:=i;
end { if ((i=iMax) ... then }
else kolor:=KolorTla;
RysujPunkt(punkt,kolor);
if KeyPressed then halt;
end; { for nrPunktu ... }
END; { Procedure ZukAtraktor }
{----------------------------------------------------------------------------}
PROCEDURE ZukAtraktorOdwr
(okno:okiennyT;
promien:real;
iMax:integer;
OdlegloscMax:real;
KolorZbioru,
KolorTla:word);
const z0:zespolonyT=(re:0.0; im:0.0);
nMax=10; { liczba atraktorow, nMax cykli, od jedno do nMax-punktowych }
VAR i,n,nKoniec:integer;{ i=nr iteracji, n=liczba punktow cyklu atraktora }
NrPunktu:LongInt;
punkt:punktowyT; { typ zdefiniowany w module oknaM }
z,c:zespolonyT;
Zn: array [1..nMax] of zespolonyT;
kolor:word;
KwadratPromienia:real;
BEGIN
KwadratPromienia:=Promien*Promien;
for NrPunktu:=0 to (okno.LiczbaPunktow-1) do
begin
DajPunkt(NrPunktu,Okno,Punkt); { punkt=c : z=z*z + c }
OdwrotnaZ(Punkt.rzeczywisty,c);
IterujP(z0,c,promien,iMax,i,z);
if ((i=iMax) and (KwModZ(z)<KwadratPromienia))
then
begin
n:=1;
Zn[1]:=z;
while (n<nMax) and (KwModZ(Zn[n])<KwadratPromienia) do
begin
Dwumian2Z(Zn[n],c,Zn[n+1]);
n:=n+1;
end;
kolor:=KolorZbioru;
for i:=nMax DownTo 2 do
if odlegloscZ(Zn[i],Zn[1])<odlegloscMax then kolor:=i;
end { if ((i=iMax) ... then }
else kolor:=KolorTla;
RysujPunkt(punkt,kolor);
if KeyPressed then halt;
end; { for nrPunktu ... }
END; { Procedure ZukAtraktor }
{----------------------------------------------------------------------------}
PROCEDURE ZukDEM(okno:okiennyT;
PromienDoKw:real;
iMax:integer;
OdlegloscPix:real;
OverFlow:real);
{ Mandelbrot Set via Distance Estimate Method }
LABEL skok;
VAR X,Y,KrokX,KrokY,Odleglosc,dist:real;
i:integer; { nr iteracji }
Xe,Ye:integer;
kolor:word;
{..........................................................................}
FUNCTION MSetDist(X,Y:real;Imax:integer):real;
var i,iter:integer;
Zx,Zy,Zx2,Zy2:real;
ZxDer,ZyDer:real; { dervatives }
Temp:real;
ZxOrbit:array[0..50] of real;
ZyOrbit:array[0..50] of real;
flag:boolean;
function Max(a,b:real):real;
begin if a>b then max:=a
else max:=b; end;
function Log(a:real):real;
begin log:=0.43429*ln(a); end;
begin { function MSetDist }
Zx:=0;
Zy:=0;
Zx2:=0;
Zy2:=0;
iter:=0;
MSetDist:=0;
ZxOrbit[0]:=0;
ZyOrbit[0]:=0;
While (iter<Imax) and (Zx2+Zy2<PromienDoKw) do begin
temp:=(Zx*Zx)-(Zy*Zy)+x;
Zy:=(2*Zx*Zy)+y;
Zx:=temp;
Zx2:=Zx*Zx;
Zy2:=Zy*Zy;
iter:=iter+1;
ZxOrbit[iter]:=Zx;
ZyOrbit[iter]:=Zy;
end; { while (iter ... }
if Zx2+Zy2>PromienDoKw then begin
ZxDer:=0;
ZyDer:=0;
i:=0;
Flag:=false;
while (i<iter) and (not flag) do begin
temp:=2*(ZxOrbit[i]*ZxDer-ZyOrbit[i]*ZyDer)+1;
ZyDer:=2*(ZyOrbit[i]*ZxDer+ZxOrbit[i]*ZyDer);
ZxDer:=temp;
flag:=Max(Abs(ZxDer),Abs(ZyDer))>OverFlow;
i:=i+1;
end; { while (i,iter) ... }
if (not flag) then MSetDist:=log(Zx2+Zy2)*Sqrt(Zx2+Zy2)/Sqrt(ZxDer*Zxder+ZyDer*ZyDer);
end; { if Zx2 ... }
end; { function MSetDist }
{............................................................................}
BEGIN { ZukDem }
With Okno do begin
Odleglosc:=OdlegloscPix*krokX;
X:=Xmin;
for Xe:=XeMin to XeMax do begin
Y:=Ymin;
for Ye:=YeMin to YeMax do begin
dist:=MSetDist(X,Y,Imax);
if dist<Odleglosc then kolor:=green
else kolor:=white;
PutPixel(Xe,Ye,kolor);
Y:=Y+KrokY;
end; { for Ye ... }
if KeyPressed then goto skok;
X:=X+KrokX;
end; { for Xe ... }
skok:;
end; { with okno ... }
END; { ZukDem }
{----------------------------------------------------------------------------}
PROCEDURE Diagram(okno:okiennyT;iMax1,iMax2:integer);
{ procedura rysuje diagram bifurkacyjny funkcji y:=dwumian(y,x):=(y*y)+x
proponowany zakres x=<-2,0.25>, y=<-2,2> }
VAR X,Y:real;
y11,y12:real; { pierwiastki, y: (y*y)+x=y }
y21,y22:real; { pierwiastki, y: (y*y+x)(y*y+x)+x=y }
xe,i:integer; { nr iteracji }
LABEL skok;
Function Dwumian(x,c:real) :real;
{ polecane -2< a <0.25 ; -2< b <2 }
begin dwumian:=(x*x)+c; end;
BEGIN
Randomize;
With Okno do begin
Xe:=Xemax;
i:=1;
While Xe>=Xemin Do
begin
x:=skalaXe2X(xe,okno);
Y:=random;
{------- oczyszcza wykres z punktow dazacych do atraktora ---------}
for i:=1 to iMax1 do
begin y:=Dwumian(y,x); { y=(y*y)-x ;funkcja modulu FunkcjeM }
if abs(y)>yMax then GoTo skok;
if KeyPressed then exit;
end;
{--------------- rysuje pierwiastki ------------------------------ }
if x<=0.25 then { delta >=0 to znaczy sa dwa pierwiastki rzeczywiste }
begin y11:=(1+sqrt(1-4*x))/2;
y12:=(1-sqrt(1-4*x))/2;
PunktP(x,y11,okno,red);
PunktP(x,y12,okno,blue);
end;
{---------------- rysuje pierwiastki -------------------------------}
if x<=-0.75 then
begin y21:=(-1+sqrt(-3-4*x))/2;
y22:=(-1-sqrt(-3-4*x))/2;
PunktP(x,y21,okno,white);
PunktP(x,y22,okno,brown);
end;
{ --------------- rysuje atraktor --------------------------------- }
for i:=1 to iMax2 do
begin
y:=Dwumian(y,x);
punktP(x,y,okno,green);
if abs(y)>yMax then GoTo skok;
if KeyPressed then exit;
end;
skok:;
Xe:=Xe-1;
end;
end; { with okno ... }
END;
{----------------------------------------------------------------------------}
END. { modulu FraktalnyM } {*************************************************}
{2000.05.04 }
Moduł do operacji na dwumianie edytuj
UNIT DwumianM;
INTERFACE {******************************************************************}
Uses Crt,zespolonyM,oknaM;
type plikPunktowyT= file of pixelowyT;
type CzyNalezyDoT=(kolo,
Kwadrat, { and}
oraz,
lub, {or = Pickover}
BioMorf,
Bio2xy,
rzeczywisty,
urojony,
Manhattan,
manr);
Function Dwumian(x,c : real) :real;
Procedure Dwumian2Z(Z1,Z2:zespolonyT;var Z3:zespolonyT);
{.......................................................................}
Procedure PunktStalyDwu2Z(c:zespolonyT;var z1,z2:zespolonyT);
Procedure CyklStaly2pDwu2z(c:zespolonyT;var z21,z22:zespolonyT);
Procedure PochodnaDwumianu2Z(z1:zespolonyT;var z2:zespolonyT);
Function ZrodloDwumianu2Z(z1,z2:zespolonyT;var z3:zespolonyT):boolean;
Function SciekDwumianu2Z(z1,z2:zespolonyT;var z3:zespolonyT):boolean;
Function Scieki2Dwu2Z(s21,s22,c:zespolonyT):boolean;
{........................................................................}
Procedure ZnajdzZbiorJulii(okno:okiennyT;c,skala:zespolonyT;promien:real;
iMax:integer;var plikPunktow:plikPunktowyT);
Function CzyNalezyDo(okno:okiennyT;z:zespolonyT;var plikPunktow:plikPunktowyT):boolean;
{,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,}
Function CzyNalezyDoF(figura:CzyNalezyDoT;z:zespolonyT;ModulMax:real;i,iMax:integer):boolean;
Function WarunekKolo(z:zespolonyT;ModulMax:real;i,iMax:integer):boolean;
Function WarunekBiomorf(z:zespolonyT;Max:real;i,iMax:integer):boolean;
Function WarunekKwadratowy(z:zespolonyT;BokKwadratu:real;i,iMax:integer):boolean;
{......................................................................}
Procedure Iteruj(Figura:CzyNalezyDoT;z0,c:zespolonyT;ModulMax:real;iMax:integer;var i:integer;var z:zespolonyT);
Procedure IterujEscher(z0,c:zespolonyT;iMax:integer;okno:okiennyT;
var i:integer;var z:zespolonyT;var PlikPunktow:PlikPunktowyT);
Procedure IterujP(z0,c:zespolonyT;ModulMax:real;iMax:integer;var i:integer;var z:zespolonyT);
Procedure IterujBiomorfP(z0,c:zespolonyT;ModulMax:real;iMax:integer;var i:integer { oddaje nr ostatniej iteracji }
{var z:zespolonyT});
Procedure IterujKwadratowoP(z0,c:zespolonyT;BokKwadratu:real;iMax:integer;var i:integer;{ oddaje nr ostatniej iteracji }
var z:zespolonyT);
Procedure IterujP1(z0,c,atraktor:zespolonyT;OdlegloscMaxOdAtr:real;ModulMax:real;
iMax:integer;var i:integer;var z:zespolonyT);
Procedure IterujP2(z0,c,atraktor1,atraktor2:zespolonyT;OdlegloscMaxOdAtr:real;ModulMax:real;
iMax:integer;var i:integer;var z:zespolonyT);
Procedure IterujOP(z0,OdwrotneC:zespolonyT;ModulMax:real;iMax:integer;var i:integer;var z:zespolonyT);
Procedure WstecznaIterDwu2Z(Zn,c:zespolonyT;var Zm1,Zm2:zespolonyT);
IMPLEMENTATION {**************************************************************}
Function Dwumian(x,c:real) :real;
begin dwumian:=(x*x)+c; end;
{......................................................}
Procedure Dwumian2Z(Z1,Z2:zespolonyT;var Z3:zespolonyT);
var z:zespolonyT; { z3 = (z1*z1) + z2 }
begin
KwadratZ(Z1,Z); { z = z1 * z1 }
SumaZ(Z,Z2,Z3) { z3 = z + z2 }
end;
{---------------------------------------------------------------------------}
Procedure PunktStalyDwu2Z(c:zespolonyT;var z1,z2:zespolonyT);
{ punkt staly dwumianu f(z)=z*z+c <=> z:F(z)=z <=> z*z+c=z <=> z*z-z+c=0 }
{ wspolczynniki dwumianu a=1, b=-1,c=c:liczba zespolona }
const s2:zespolonyT=(Re:-1.0; Im:0.0); { s2=b=-1 }
s3:zespolonyT=(Re: 2.0; Im:0.0); { s3=2a=2 }
var temp,
s1, { Pierwiastek(Delta) }
sG1, { sG1=s1-s2=Pierw(delty)-b }
sG2, { sG2=s1+s2=Pierw(delty)+b }
p1,p2, { pierwiastki z liczby zespolonej }
delta:zespolonyT; { delta = (b*b) - 4*a*c = 1-4c }
begin { = (1-4*c.re)+(-4*c.im)*i }
delta.re:=1-(4*c.re);
delta.im:=-4*c.im;
Pierwiastek2aZ(delta,p1,p2);
s1:=p1; { wybieramy jeden pierwiastek }
RoznicaZ(s1,s2,sG1);
DzielZ(sG1,s3,z1); {z1= sG3/s3 = (s1-s2)/s3 = (pierwDelty-b)/2a) }
SumaZ(s1,s2,sG2);
DzielZ(sG2,s3,temp);
MinusZ(temp,z2); {z2=-(sg2/s3) = -((s1+s2)/s3) = - ((PierwDelty +b)/2a) }
end; { Procedure PunktStalyDwu2z }
{---------------------------------------------------------------------------}
Procedure CyklStaly2pDwu2z(c:zespolonyT;var z21,z22:zespolonyT);
{ z21,z22:z=f(f(z))=(z*z+c)(z*z+c)+c }
{ z=-0.5-+sqrt(-0.75-c) }
var s1, { s1=-3/4 }
s2, { s2=-1/2 }
delta,
Pierw1Delty,Pierw2Delty,
temp:zespolonyT;
begin
UtworzLZ(-0.75,0.0,s1);
UtworzLZ(-0.5,0.0,s2);
RoznicaZ(s1,c,delta);
Pierwiastek2aZ(delta,Pierw1Delty,Pierw2Delty);
SumaZ(s2,Pierw1Delty,z21);
SumaZ(s2,Pierw2Delty,z22);
end; { Procedure CyklStaly2pDwu2z }
{---------------------------------------------------------------------------}
Procedure PochodnaDwumianu2Z(z1:zespolonyT;var z2:zespolonyT);
begin z2.re:=2*z1.re; { f(z)=z*z+c }
z2.im:=2*z1.im; { f'(z)=2*z }
end;
{--------------------------------------------------------------------------}
Procedure Pochodna2Dwu2Z(z,c:zespolonyT;var p:zespolonyT);
{ F1(z)=z*z+c F2(z)=F1(F1(z))=z4+2cz2+(c2+c) }
{ F2'(z)=4z3+4cz=s1+s2 : s1=4z3 s2=4cz }
var s1,s2,cztery,z3,temp:zespolonyT;
begin utworzLZ(4.0,0.0,cztery);
PotegaZ(z,3,z3); { z3=z*z*z }
iloczynZ(cztery,z3,s1); { s1=4*z3=4*z*z*z }
iloczynZ(cztery,c,temp);
iloczynZ(temp,z,s2); { s2=4*c*z }
SumaZ(s1,s2,p); { p=s1+s2 }
end; { Procedure Pochodna2Dwu2z }
{--------------------------------------------------------------------------}
Function ZrodloDwumianu2Z(z1,z2:zespolonyT;var z3:zespolonyT):boolean;
{ z1,z2 to punkty stale dwumianu2Z tj takie,ze z:=z*z+c}
{ procedura wybiera z nich zrodlo, tj punkt staly odpychajacy }
{ sprawdza czy |F'(z)|>1 }
var p1,p2:zespolonyT; { pochodne dwumianu2Z w punkcie stalym z1 i z2 }
begin
PochodnaDwumianu2Z(z1,p1);
if ModulZ(p1)>1 { to znaczy punkt jest zrodlem czyli odpychajacym }
then begin
z3.re:=z1.re;
z3.im:=z1.im;
ZrodloDwumianu2Z:=true;
end
else begin
PochodnaDwumianu2Z(z2,p2);
If ModulZ(p2)>1 then begin z3.re:=z2.re;
z3.im:=z2.im;
ZrodloDwumianu2Z:=true;
end
else ZrodloDwumianu2Z:=false;
end; { if ModulZ(p1) ... }
end; { zrodloDwumianu2Z }
{-------------------------------------------------------------------------}
Function SciekDwumianu2Z(z1,z2:zespolonyT;var z3:zespolonyT):boolean;
{ z1,z2 to punkty stale dwumianu2Z tj takie,ze z:=f(f(z))}
{ procedura wybiera z nich sciek, tj punkt staly przyciagajacy = atraktor }
{ sprawdza czy |F'(z)|<1 }
var p1,p2:zespolonyT; { pochodne dwumianu2Z w punkcie stalym z1 i z2 }
begin
PochodnaDwumianu2Z(z1,p1);
if ModulZ(p1)<1 { to znaczy punkt z1 jest sciekiem czyli przyciagajacym }
then begin
z3.re:=z1.re;
z3.im:=z1.im;
SciekDwumianu2Z:=true;
end
else begin
PochodnaDwumianu2Z(z2,p2);
If ModulZ(p2)<1 { punkt z2 jest sciekiem }
then begin
z3.re:=z2.re;
z3.im:=z2.im;
SciekDwumianu2Z:=true;
end
else SciekDwumianu2Z:=false{ zaden punkt staly nie jest sciekiem }
end;{ if ModulZ(p1) ... else ... }
end; { sciekDwumianu2Z }
{-------------------------------------------------------------------------}
Function Scieki2Dwu2Z(s21,s22,c:zespolonyT):boolean;
{ s21,s22 to punkty stale 2 iteracji dwumianu2Z tj takie,ze z:=z*z+c}
{ procedura wybiera z nich sciek, tj punkt staly przyciagajacy = atraktor }
{ sprawdza czy |F'(z)|<1 }
var p1,p2:zespolonyT; { pochodne dwumianu2Z w punkcie stalym z1 i z2 }
begin
Pochodna2Dwu2Z(s21,c,p1);
Pochodna2Dwu2Z(s22,c,p2);
if ( ModulZ(p1)<1) and ( ModulZ(p2)<1 )
then Scieki2Dwu2Z:=true
else Scieki2Dwu2Z:=false;{ zaden punkt staly nie jest sciekiem }
end; { scieki2Dwumianu2Z }
{--------------------------------------------------------------------------}
Procedure ZnajdzZbiorJulii(okno:okiennyT;c,skala:zespolonyT;promien:real;
iMax:integer;var plikPunktow:plikPunktowyT);
var z0,z:zespolonyT;
NrPunktu:longInt;
i:integer;
punkt:punktowyT;
begin
Assign(PlikPunktow,'c:\bp\bin\punkty.pli');
Rewrite(PlikPunktow);
for NrPunktu:=0 to (okno.LiczbaPunktow-1) do
begin
DajPunkt(NrPunktu,Okno,Punkt);
iloczynZ(Punkt.rzeczywisty,skala,z0);
IterujP(z0,c,promien,iMax,i,z);
if i=iMax then begin
write(PlikPunktow,Punkt.ekranu);
RysujPunkt(Punkt,red);
end
else RysujPunkt(Punkt,white);
end; { for NrPunktu }
Seek(PlikPunktow,0);
end;{ Procedure ZnajdzZiorJulii }
{--------------------------------------------------------------------------}
Function CzyNalezyDo(okno:okiennyT;z:zespolonyT;var plikPunktow:PlikPunktowyT):boolean;
var punktEkranu,punktZbioru:pixelowyT;
znaleziono:boolean;
begin
CzyNalezyDo:=false;
znaleziono:=false;
PunktOblicz(z,okno,punktEkranu);
Seek(PlikPunktow,0);
while (not EOF(PlikPunktow)) do
begin
read(PlikPunktow,PunktZbioru);
if (PunktEkranu.xe=PunktZbioru.xe)
and (PunktEkranu.ye=PunktZbioru.ye)
then
begin
CzyNalezyDo:=true;
exit;
end;{ if }
end;{ while }
Seek(PlikPunktow,0);
end; { function CzyNalezyDo }
{.......................................................................}
Function CzyNalezyDoF(figura:CzyNalezyDoT;z:zespolonyT;ModulMax:real;i,iMax:integer):boolean;
var KwModuluMax:real;
begin
case figura of
kolo : CzyNalezyDoF:=(i<iMax) and (KwModZ(z)<ModulMax*ModulMax);
{ModulMax=promien kola} { zalecany modulMax= 2}
Kwadrat : CzyNalezyDoF:=(i<iMax) and ((z.re<ModulMax/2) and (z.im<ModulMax/2));
{ModulMax=BokKwadratu}
oraz : CzyNalezyDoF:=(i<iMax) and ((z.re*z.re<ModulMax) and (z.im*z.im<ModulMax));
lub : CzyNalezyDoF:=(i<iMax) and ((z.re*z.re<ModulMax) or (z.im*z.im<ModulMax));
BioMorf : CzyNalezyDoF:=(i<iMax) and ((abs(z.re)<ModulMax) or (abs(z.im)<ModulMax));
Bio2xy : CzyNalezyDoF:=(i<iMax) and ((abs(2*z.re*z.im)<ModulMax));
rzeczywisty:CzyNalezyDoF:=(i<iMax) and (z.re*z.re<ModulMax);
urojony : CzyNalezyDoF:=(i<iMax) and (z.im*z.im<ModulMax);
Manhattan: CzyNalezyDoF:=(i<iMax) and ((abs(z.re)+abs(z.im))*(abs(z.re)+abs(z.im))<ModulMax);
manr: CzyNalezyDoF:=(i<iMax) and ((z.re+z.im)*(z.re+z.im)<ModulMax);
end; {case} { }
end; { warianty warunku dla funkcji sprawdzaj\A5cej czy ci\A5g iteracji jest zbiezny}
{............................................................................}
Function WarunekKolo(z:zespolonyT;ModulMax:real;i,iMax:integer):boolean;
var KwModuluMax:real;
begin
KwModuluMax:=ModulMax*ModulMax;
WarunekKolo:=(i<iMax) and (KwModZ(z)<=KwModuluMax)
end;
{ zalecany modulMax= 2}
{.......................................................................}
Function WarunekBiomorf(z:zespolonyT;Max:real;i,iMax:integer):boolean;
begin
WarunekBiomorf:= (i<iMax) and ((abs(z.re)<=Max) or (Abs(z.im)<=Max))
end;
{ zalecany ModulMax:=10 a kolor : LSM}
{-------------------------------------------------------------------------}
Function WarunekKwadratowy(z:zespolonyT;BokKwadratu:real;i,iMax:integer):boolean;
begin
WarunekKwadratowy:= (i<iMax) and ((z.re<=BokKwadratu/2) or (z.im<=BokKwadratu/2));
end;
{-------------------------------------------------------------------------}
Procedure Iteruj(Figura:CzyNalezyDoT;z0,c:zespolonyT;ModulMax:real;iMax:integer;var i:integer;var z:zespolonyT);
begin
z:=z0;
i:=0;
while CzyNalezyDoF(figura,z,ModulMax,i,iMax) do
begin
Dwumian2Z(z,c,z);
i:=i+1;
end; {while}
end;{procedure}
{---------------------------------------------------------------------------}
Procedure IterujEscher(z0,
c:zespolonyT;
iMax:integer; { Max liczba iteracji }
okno:okiennyT;
var i:integer; { oddaje nr ostatniej iteracji }
var z:zespolonyT; { oddaje ostatni element ciagu }
var PlikPunktow:PlikPunktowyT);
begin
z:=z0;
i:=0;
while (i<iMax) and (not CzyNalezyDo(okno,z,plikPunktow))
do
begin
Dwumian2Z(z,c,z);
i:=i+1;
end;
end;
{-------------------------------------------------------------------------}
Procedure IterujP(z0,
c:zespolonyT;
ModulMax:real; { promien kola ograniczajacego }
iMax:integer; { Max liczba iteracji }
var i:integer; { oddaje nr ostatniej iteracji }
var z:zespolonyT); { oddaje ostatni element ciagu }
var KwModuluMax:real;
begin
KwModuluMax:=ModulMax*ModulMax;
z:=z0;
i:=0;
while WarunekKolo(z,ModulMax,i,iMax) do
begin
Dwumian2Z(z,c,z);
i:=i+1;
end;
end;
{ procedura sluzaca do rysowania zbioru Mandelbrota }
{ iteruje iMax razy punkt z0, chyba ze punkt z wyszedl z kola o promieniu ModulMax }
{ ciag z0, z1,z2, .. ,zn ; z(n+1)=F(zn,c) }
{-------------------------------------------------------------------------}
Procedure IterujBiomorfP(z0,
c:zespolonyT;
ModulMax:real; { promien kola ograniczajacego }
iMax:integer; { Max liczba iteracji }
var i:integer { oddaje nr ostatniej iteracji }
{ var z:zespolonyT}); { oddaje ostatni element ciagu }
var z:zespolonyT;
begin
z:=z0;
i:=0;
while WarunekBiomorf(z,ModulMax,i,iMax) do
begin
Dwumian2Z(z,c,z);
i:=i+1;
end;
end;
{ procedura sluzaca do }
{ iteruje iMax razy punkt z0, chyba ze punkt z wyszedl z kola o promieniu ModulMax }
{ ciag z0, z1,z2, .. ,zn ; z(n+1)=F(zn,c) }
{--------------------------------------------------------------------------}
Procedure IterujKwadratowoP(z0,c:zespolonyT;BokKwadratu:real;iMax:integer;var i:integer;
{ oddaje nr ostatniej iteracji }
var z:zespolonyT);
begin
z:=z0;
i:=0;
while WarunekKwadratowy(z,BokKwadratu,i,iMax) do
begin
Dwumian2Z(z,c,z);
i:=i+1;
end;
end;
{----------------------------------------------------------------------------}
Procedure IterujP1(z0, { pierwszy element ciagu z0,z1,z2,...,zN }
c, { F(z)=(z*z)+c }
atraktor:zespolonyT; { z: z=F(z) i |F'(z)|<1 }
OdlegloscMaxOdAtr:real;
ModulMax:real; { promien kola ograniczajacego }
iMax:integer; { Max liczba iteracji }
var i:integer; { oddaje nr ostatniej iteracji }
var z:zespolonyT); { oddaje ostatni element ciagu }
var KwModuluMax,
KwOdlegloscMax:real;
begin
KwModuluMax:=ModulMax*ModulMax;
KwOdlegloscMax:=OdlegloscMaxOdAtr*OdlegloscMaxOdAtr;
z:=z0;
i:=0;
while (i<iMax)
and (KwModZ(z)<=KwModuluMax)
and (KwOdlegloscZ(z,atraktor)>KwOdlegloscMax)
do begin
Dwumian2Z(z,c,z);
i:=i+1;
end;
end;
{----------------------------------------------------------------------------}
Procedure IterujP2(z0, { pierwszy element ciagu z0,z1,z2,...,zN }
c, { F(z)=(z*z)+c }
atraktor1,atraktor2:zespolonyT; { z: z=F(F(z)) i |F2'(z)|<1 }
OdlegloscMaxOdAtr:real;
ModulMax:real; { promien kola ograniczajacego }
iMax:integer; { Max liczba iteracji }
var i:integer; { oddaje nr ostatniej iteracji }
var z:zespolonyT); { oddaje ostatni element ciagu }
var KwModuluMax,
KwOdlegloscMax:real;
begin
KwModuluMax:=ModulMax*ModulMax;
KwOdlegloscMax:=OdlegloscMaxOdAtr*OdlegloscMaxOdAtr;
z:=z0;
i:=0;
while (i<iMax)
and (KwModZ(z)<=KwModuluMax)
and ((KwOdlegloscZ(z,atraktor1)>KwOdlegloscMax)
or (KwOdlegloscZ(z,atraktor1)>KwOdlegloscMax))
do begin
Dwumian2Z(z,c,z);
i:=i+1;
end;
end; { Procedure IterujP2 }
{-------------------------------------------------------------------------}
Procedure IterujOP(z0,
OdwrotneC:zespolonyT;
ModulMax:real; { promien kola ograniczajacego }
iMax:integer; { Max liczba iteracji }
var i:integer; { oddaje nr ostatniej iteracji }
var z:zespolonyT); { oddaje ostatni element ciagu }
var KwModuluMax:real;
c:zespolonyT;
begin
KwModuluMax:=ModulMax*ModulMax;
z:=z0;
OdwrotnaZ(OdwrotneC,c);
i:=0;
while (i<iMax) and (KwModZ(z)<=KwModuluMax) do
begin
Dwumian2Z(z,c,z);
i:=i+1;
end;
end;
{ procedura sluzaca do rysowania zbioru Mandelbrota , w plaszczyznie 1/C }
{ iteruje iMax razy punkt z0, chyba ze punkt z wyszedl z kola o promieniu ModulMax }
{ ciag z0, z1,z2, .. ,zn ; z(n+1)=F(zn,c) }
{---------------------------------------------------------------------------}
Procedure WstecznaIterDwu2Z(Zn,c:zespolonyT;var Zm1,Zm2:zespolonyT);
{ Zn=(Zm*Zm)+c => Zm=+-Sqrt(Zn-c) }
var Z: zespolonyT;
begin RoznicaZ(Zn,c,Z);
Pierwiastek2aZ(Z,Zm1,Zm2);
end;
END. { modulu DwumianM } {****************************************************}
Liczby zespolone edytuj
UNIT ZespolonyM;
INTERFACE {******************************************************************}
Uses Crt;
Type ZespolonyT=record Re,Im:double end;
Procedure UtworzLZ(x,y:real;var Z:zespolonyT);
Function Znak(r:real):integer;
Procedure MinusZ(z1:zespolonyT;var z2:zespolonyT); { liczba przeciwna do z1}
Procedure OdwrotnaZ(z1:zespolonyT;var z2:zespolonyT);
Procedure SumaZ(Z1,Z2:zespolonyT;var Z3:zespolonyT);
Procedure RoznicaZ(Z1,Z2:zespolonyT;var Z3:zespolonyT);
Procedure IloczynZ(Z1,Z2:zespolonyT;var Z3:zespolonyT);
Procedure KwadratZ(Z1:zespolonyT;var Z3:zespolonyT);
Procedure DzielZ(z1,z2:zespolonyT;var z3:zespolonyT); { z3=z1/z2 }
Function ArgumentZ(Z:zespolonyT):real;
Function ModulZ(Z:zespolonyT):real;
Function KwModZ(Z:zespolonyT):real;
Procedure PotegaZ(z1:zespolonyT;n:real;var z2:zespolonyT);
Procedure Pierwiastek2tZ(Z:zespolonyT;var Z1,Z2:zespolonyT);
Procedure Pierwiastek2aZ(Z:zespolonyT;var Z1,Z2:zespolonyT);
Function OdlegloscZ(Z1,Z2:zespolonyT):real;
Function KwOdlegloscZ(Z1,Z2:zespolonyT):real;
IMPLEMENTATION {**************************************************************}
Procedure UtworzLZ(x,y:real;var Z:zespolonyT);
begin Z.Re:=x;
Z.Im:=y;
end;
{-----------------------------------------------------------------------------}
Function Znak(r:real):integer;
begin if r >= 0 then znak:= 1
else znak:=-1;
end;
{-----------------------------------------------------------------------------}
Procedure MinusZ(z1:zespolonyT;var z2:zespolonyT); { liczba przeciwna do z1}
begin z2.re:=-z1.re;
z2.im:=-z1.im;
end;
{-----------------------------------------------------------------------------}
Procedure OdwrotnaZ(z1:zespolonyT;var z2:zespolonyT); { liczba odwrotna do z1}
{ z2=1/z1 }
var mianownik:real;
begin mianownik:=(z1.re*z1.re)+(z1.im*z1.im);
if mianownik=0 then begin z2.im:=10000;
z2.im:=10000; {?}
end
else begin
z2.re:=z1.re/mianownik;
z2.im:=-z1.im/mianownik;
end;
end;
{-----------------------------------------------------------------------------}
Procedure SumaZ; { z3=z1+z2 }
begin Z3.Re:=Z1.Re+Z2.Re;
Z3.Im:=Z1.Im+Z2.Im;
end;
{----------------------------------------------------------------------------}
Procedure RoznicaZ; { z3=z1-z2 }
begin Z3.Re:=Z1.Re-Z2.Re;
Z3.Im:=Z1.Im-Z2.Im;
end;
{----------------------------------------------------------------------------}
Procedure IloczynZ; { z3=z1*z2 }
begin Z3.Re:=(Z1.Re*Z2.Re)-(Z1.Im*Z2.Im);
Z3.Im:=(Z1.Re*Z2.Im)+(Z1.Im*Z2.Re);
end;
{---------------------------------------------------------------------------}
Procedure KwadratZ; { z3=z1*z1 }
begin Z3.Re:=(Z1.Re-Z1.Im)*(Z1.Re+Z1.Im); { (x*x)-(y*y)=(x-y)*(x+y) }
Z3.Im:=2*(Z1.Re*Z1.Im);
end;
{---------------------------------------------------------------------------}
Procedure DzielZ(z1,z2:zespolonyT;var z3:zespolonyT); { z3=z1/z2 }
var mianownik:real;
begin mianownik:=(z2.re*z2.re)+(z2.im*z2.im);
z3.re:=((z1.re*z2.re)+(z1.im*z2.im))/mianownik;
z3.im:=((z1.im*z2.re)-(z1.re*z2.im))/mianownik;
end;
{---------------------------------------------------------------------------}
Function ArgumentZ(Z:zespolonyT):real;
var A:real;
begin
if ( Z.re=0 ) or ( Z.im=0 )
then begin if ( Z.re=0 ) then if ( Z.im<0 ) then ArgumentZ:=-Pi/2
else ArgumentZ:=Pi/2;
if ( Z.im=0 ) then if ( Z.re<0 ) then ArgumentZ:=Pi
else ArgumentZ:=0;
end { if z.re=0 ... then ... }
else begin A:=ArcTan(Abs(Z.im/Z.re));
if ( Z.im<0 ) then if ( Z.re<0 ) then ArgumentZ:=-(Pi-A)
else ArgumentZ:=-A;
if ( Z.im>0 ) then if ( Z.re>0 ) then ArgumentZ:=A
else ArgumentZ:=Pi-A;
end; { if z.re=0 ... else ... }
end; { function ArgumentZ }
{----------------------------------------------------------------------------}
Function ModulZ(Z:zespolonyT):real;
begin
ModulZ:=Sqrt(Z.re*Z.re + Z.im*Z.im);
end;
{---------------------------------------------------------------------------}
Function KwModZ(Z:zespolonyT):real; { kwadrat modulu }
begin
KwModZ:=(Z.Re*Z.Re)+(Z.Im*Z.Im);
end;
{---------------------------------------------------------------------------}
Procedure PotegaZ(z1:zespolonyT;n:real;var z2:zespolonyT);
{ z2= z1 do n-tej potegi }
var temp:real;
begin if (z1.re=0.0) and (z1.im=0.0)
then begin { zero do potegi n daje zero }
z2.im:=0.0;
z2.re:=0.0;
end { if ... then }
else begin
temp:=Exp(n*Ln(ModulZ(z1)));
z2.re:=temp*cos(n*ArgumentZ(z1));
z2.im:=temp*sin(n*ArgumentZ(z1));
end; { if ... else }
end; { Procedure PotegaZ }
{----------------------------------------------------------------------------}
Procedure Pierwiastek2tZ(Z:zespolonyT;var Z1,Z2:zespolonyT);
var PierwPromienia,
PolowaKata:real;
begin PierwPromienia:=Sqrt(ModulZ(z));
PolowaKata:=ArgumentZ(z)/2;
Z1.re:=PierwPromienia*Cos(PolowaKata);
Z1.im:=PierwPromienia*Sin(PolowaKata);
Z2.re:=PierwPromienia*Cos(PolowaKata+Pi);
Z2.im:=PierwPromienia*Sin(PolowaKata+Pi);
end;
{---------------------------------------------------------------------------}
Procedure Pierwiastek2aZ(Z:zespolonyT;var Z1,Z2:zespolonyT);
var promien:real;
signum:integer;
begin promien:=ModulZ(z);
signum:=Znak(z.Im);
z1.re:=Sqrt((z.re+promien)/2);
z1.im:=signum*Sqrt((promien-z.re)/2);
z2.re:=-z1.re;
z2.im:=-z1.im;
end;
{----------------------------------------------------------------------------}
Function OdlegloscZ(Z1,Z2:zespolonyT):real;
begin
odlegloscZ:=Sqrt(Sqr(Z2.Re-Z1.Re)+Sqr(Z2.Im-Z1.Im));
end;
{----------------------------------------------------------------------------}
Function KwOdlegloscZ(Z1,Z2:zespolonyT):real;
begin
KwOdlegloscZ:=Sqr(Z2.Re-Z1.Re)+Sqr(Z2.Im-Z1.Im);
end;
{---------------------------------------------------------------------------}
END. { modulu ZespolonyM } {****************************************************}
otwieranie trybow graficznych edytuj
unit GrafM;
interface {*****************************************************************}
const PathToDriver:string = 'c:\bp\bgi';{ Stores the DOS path to *.BGI & *.CHR }
{ lancuch pusty wskazuje na katalog aktualny }
{otwieranie trybow graficznych}
procedure OpenGraf; {podstawowa procedura, nie wymaga dodatkowych plikow}
procedure OpenSvga; { 1280x1024x256, wymaga svga256.bgi}
procedure OpenSvga1;
procedure OpenPGraf; {1024 x 768 x 16M wymaga : P_Graph.tpu P_Bench.tpu}
Procedure OpenPGraf1600_256; {1600 x 1200 x 256 }
Procedure OpenSvga1280_64k; { wymaga svga64.bgi BGI Device Driver (SVGA64K) 1.7 - Aug 23, 1994
Copyright (c) 1990-94 by Jordan Hargraphix }
{ kolory 64k }
function RealDrawColor(Color : LongInt) : LongInt;
function RealFillColor(Color : LongInt) : LongInt;
function RealColor(Color : LongInt) : LongInt;
function WhitePixel : LongInt;
function BluePixel : LongInt;
function GreenPixel : LongInt;
{kolor 32bit = 16M}
function ColorRGB(r,g,b:byte):longInt;
implementation {************************************************************}
uses Crt,dos,Graph,
P_Graph,P_Bench; {Power Graph Library dla funkcji OpenPGraf dostepne w
postaci plikow *.tpu a nie *.pas}
PROCEDURE OpenGraf; {------------------------------------------------------}
{ procedura otwierajaca tryb graficzny. Wybiera aktualny sterownik zgodny
z aktualnie uzywanym sterownikiem w Dos'ie oraz tryb wysokiej rozdzielczosci.
Turbo Pascasl >= 5.5 }
var
GraphDriver : integer; { The Graphics device driver }
GraphMode : integer; { The Graphics mode value }
ErrorCode : integer; { Reports any graphics errors }
BEGIN
repeat
GraphDriver := Detect; { use autodetection }
InitGraph(GraphDriver, GraphMode, PathToDriver);
ErrorCode := GraphResult; { preserve error return }
if ErrorCode <> grOK then
begin
WriteLn('blad podczas inicjowania trybu graficznego');
WriteLn('kod bledu=',ErrorCode);
Writeln('Graphics error: ', GraphErrorMsg(ErrorCode));
if ErrorCode = grFileNotFound { obsluga bledu 'nie ma *.bgi lub *.chr'}
then begin
Writeln('Enter full path to BGI driver or type <Ctrl-Break> to quit:');
Readln(PathToDriver);
Writeln;
end
else Halt(1); { Some other error: terminate }
end;
until ErrorCode = grOK;
END;{----------- Procedure OpenGraf -----------------------------------------}
Procedure OpenSvga;
{otwiera TRYB GRAFiczzny ; užywa niestandardowy sterownik svga256.bgi }
var GraphDriver,
GraphMode,
ErrorCode : integer;
{$F+}
function tryb : Integer;
begin
tryb := 6; {1280 x 1024 x 256}
{ 0 320 x 200 x 256
1 640 x 400 x 256
2 640 x 480 x 256
3 800 x 600 x 256
4 1024 x 768 x 256
5 640 x 350 x 256
6 1280 x 1024 x 256}
end;
{$F-}
begin
repeat
GraphDriver := InstallUserDriver('SVGA256',@tryb);
GraphDriver := Detect; { use autodetection }
InitGraph(GraphDriver, GraphMode, PathToDriver);
ErrorCode := GraphResult; { preserve error return }
if ErrorCode <> grOK then
begin
WriteLn('blad podczas inicjowania trybu graficznego');
WriteLn('kod bledu=',ErrorCode);
Writeln('Graphics error: ', GraphErrorMsg(ErrorCode));
if ErrorCode = grFileNotFound { obsluga bledu 'nie ma *.bgi lub *.chr'}
then begin
Writeln('Enter full path to BGI driver or type <Ctrl-Break> to quit:');
Readln(pathToDriver);
Writeln;
end
else Halt(1); { Some other error: terminate }
end;
until ErrorCode = grOK;
end;{-------------- Procedur OpenSvga --------------------------------------}
Procedure Opensvga1;
var GraphDriver,
GraphMode,
ErrorCode : integer;
{..................................................................}
function CzyVesa(NrTrybu:word):boolean;
{ sprawdza czy sterownik graficzny jest zgodny ze standardem VESA }
{ i czy dostepny jest dany tryb }
TYPE ListaTrybowTyp=Array[1..$7FFF] of word;
ListaTrybowWsk=^ListaTrybowTyp;
NazwaProdTyp=Array[1..$FFFF] of char;
NazwaProdWsk=^NazwaProdTyp;
{ struktura bufora na informacje o SVGA }
BuforTyp=Record Sygnatura:Array[1..4] of char;
NrWersji:Word;
NazwaProd:NazwaProdWsk;
Inform:LongInt;
ListaTrybow:ListaTrybowWsk;
Zarezerwowane:Array[1..238] of Byte;
End;
VAR Bufor:BuforTyp;
Regs:Registers;
Idx:Word;
Jest:Boolean;
BEGIN { cialo funkcji CzyVesa }
CzyVesa:=False;
With Regs do begin { odczytanie informacji o SVGA }
AX:=$4F00; { nr funkcji VESA }
ES:=Seg(Bufor); { adres bufora na informacje }
DI:=Ofs(Bufor);
end;
Intr($10,Regs);
If Regs.Ax=$004F Then { funkcja jest dostepna }
Begin
Idx:=0;
Jest:=False;
With Bufor Do {przeszukiwanie listy trybow }
While (ListaTrybow^[Idx]<>$FFFF) and (Not Jest) Do
Begin Jest:=ListaTrybow^[Idx]=NrTrybu;
Inc(Idx);
End;
CzyVesa:=Jest;
End;
END; { funkcji CzyVesa }
{..........................................................................}
begin
if CzyVesa($105) {sprawdza czy dostepny jest tryb VESA : 1024 x 768 }
then OpenSvga { 1024 x 768 x 256 }
else OpenGraf;{ 640 x 480 x 16 }
end;{-------------- Procedur OpenSvga1 --------------------------------------}
Procedure OpenPGraf; {1024 x 768 x 16M }
Function SelectMode:word;
{wymaga niestandardowych modulow P_Graph,P_Bench
zawierajacych biblioteke Power Graf Library }
Var P:Byte;
C:Char;
M:Word;
MN:Byte;
X:Byte;
MD:Array[1..50] of Word;
b:boolean;
bpp:byte;
Begin
c:='4'; {1024 x 768 }
bpp:=32; { 32 bits per pixel = 16M}
MN:=0;
For P:=0 to PTotalMode do
Begin
b:=PGetModeInfo(PModeID[P]);
If PModeInfo.BitsPPixel=Bpp Then
Begin
Inc(MN);
TextAttr:=10;
MD[MN]:=PModeID[P];
End;
End;
x:=Byte(c)-48;
M:=MD[x];
SelectMode:=M;
End;{Function SelectMode }
begin
If Not PSetMode(SelectMode) Then Halt;
end; {Procedure OpenPGraf;} { PPutPixel(x,y,100); }
{****************************************************************************}
Procedure OpenPGraf1600_256; {1600 x 1200 x 256 }
Function SelectMode:word;
{wymaga niestandardowych modulow P_Graph,P_Bench
zawierajacych biblioteke Power Graf Library }
Var P:Byte;
C:Char;
M:Word;
MN:Byte;
X:Byte;
MD:Array[1..50] of Word;
b:boolean;
bpp:byte;
Begin
c:='9'; {1600 x 1200 }
bpp:=8; { 8 bits per pixel = 256}
{ moze byc i 16 bpp = 64 k}
MN:=0;
For P:=0 to PTotalMode do
Begin
b:=PGetModeInfo(PModeID[P]);
If PModeInfo.BitsPPixel=Bpp Then
Begin
Inc(MN);
TextAttr:=10;
MD[MN]:=PModeID[P];
End;
End;
x:=Byte(c)-48;
M:=MD[x];
SelectMode:=M;
End;{Function SelectMode }
begin
If Not PSetMode(SelectMode) Then Halt;
end; {Procedure OpenPGraf;} { PPutPixel(x,y,100); }
{****************************************************************************}
Procedure OpenSvga1280_64k;
{otwiera TRYB GRAFiczzny ; užywa niestandardowy sterownik svga64.bgi }
var GraphDriver,
GraphMode,
GrErr : integer;
{$F+}
function DetectVGA64k : Integer;
begin DetectVGA64k := 6; { 6 := 1280 x 1024 x 65 536 kolorow}
{ 0 320 x 200 x 65 536
1 640 x 350 x 65 536
2 640 x 400 x 65 536
3 640 x 480 x 65 536
4 800 x 600 x 65 536
5 1024 x 768 x 65 536
6 1280 x 1024 x 65 536}
end;
{$F-}
begin {}
GraphDriver := InstallUserDriver('Svga64k',@DetectVGA64k);
GraphDriver := Detect;
InitGraph(GraphDriver,GraphMode,PathToDriver);
GrErr := GraphResult; { preserve error return }
if GrErr AND $80 = $80 then GrErr := GrErr OR $ff00;
if GrErr <> grOK then begin
Writeln('Graphics error: ', GraphErrorMsg(GrErr));
Halt(1);
end;
end; {----------------------------------------------------------------}
{-------------- kolory 64 k --------------}
function RealDrawColor(Color : LongInt) : LongInt;
var
MaxC : Longint;
begin
MaxC := GetMaxColor;
if (MaxC = 65535) then
SetRgbPalette(1024,(Color SHR 11) AND 31,(Color SHR 5)AND 63,Color AND 31)
else if (MaxC = 32767) then
SetRgbPalette(1024,(Color SHR 10) AND 31,(Color SHR 5)AND 31,Color AND 31)
else if (MaxC = 16777) then
begin
SetRgbPalette(1024,(Color SHR 16) AND 255,(Color SHR 8)AND 255,Color AND 255);
end;
RealDrawColor := Color;
end;
{ uzycie liczby w setcolor nie dziaa
uzyj realDrawColor : setcolor(realDrawColor(65000));}
function RealFillColor(Color : LongInt) : LongInt;
var
MaxC : Longint;
begin
MaxC := GetMaxColor;
if (MaxC = 65535) then
SetRgbPalette(1025,(Color SHR 11) AND 31,(Color SHR 5)AND 63,Color AND 31)
else if (MaxC = 32767) then
SetRgbPalette(1025,(Color SHR 10) AND 31,(Color SHR 5)AND 31,Color AND 31)
else if (MaxC = 16777) then
begin
SetRgbPalette(1025,(Color SHR 16) AND 255,(Color SHR 8)AND 255,Color AND 255);
Color := 0;
end;
RealFillColor := Color;
end;
function RealColor(Color : LongInt) : LongInt;
var
MaxC : Longint;
begin
MaxC := GetMaxColor;
if (MaxC = 65535) then
SetRgbPalette(1026,(Color SHR 11) AND 31,(Color SHR 5)AND 63,Color AND 31)
else if (MaxC = 32767) then
SetRgbPalette(1026,(Color SHR 10) AND 31,(Color SHR 5)AND 31,Color AND 31)
else if (MaxC = 16777) then
begin
SetRgbPalette(1026,(Color SHR 16) AND 255,(Color SHR 8)AND 255,Color AND 255);
Color := 0;
end;
RealColor := Color;
end;
function WhitePixel : LongInt;
var
Clr : LongInt;
begin
Clr := GetMaxColor;
if (Clr = 65535) then Clr := $FFFF
else if (Clr = 32767) then Clr := $7FFF
else if (Clr = 16777) then Clr := $ffffff
else Clr := 15;
WhitePixel := Clr;
end;
function BluePixel : LongInt;
var
Clr : LongInt;
begin
Clr := GetMaxColor;
if (Clr = 65535) then Clr := $1F
else if (Clr = 32767) then Clr := $1F
else if (Clr = 16777) then Clr := $ff
else Clr := 1;
BluePixel := Clr;
end;
function GreenPixel : LongInt;
var
Clr : LongInt;
begin
Clr := GetMaxColor;
if (Clr = 65535) then Clr := 63 SHL 5
else if (Clr = 32767) then Clr := 31 SHL 5
else if (Clr = 16777) then Clr := $ff00
else Clr := 2;
GreenPixel := Clr;
end;
{}
function ColorRGB(r,g,b:byte):longInt;
begin colorRGB:=(b or (g shl 8) or (r shl 16));
end;
{color:=PFindRGB(0,0,0) z modulu Power Graphic Library}
End.{********************************************************************}
{jezyk programowania Turbo Pascal 7.0 firmy Borland
styl : proceduralny
dla systemu operacyjnego MS-Dos firmy Microsoft}
{ biblioteka Power Graf :
,**************************************,
,** Power Library 1998-1999 **,
*** Power Graph 1.95 ***
(*** Target: Real ***)
*** http://dexter.zst.bytom.pl/~vertis ***
`** vertis@dexter.zst.bytom.pl **'
`**************************************'}
{ plik svga256 i svga64:
*===============================*===========================================*
| Jordan Powell Hargrave | Internet: jh5y@andrew.cmu.edu |
| 1000 Morewood Ave, Box #3277 | Bitnet: jh5y%andrew.cmu.edu@cmccvb |
| Pittsburgh, PA 15213 | UUCP: uunet!andrew.cmu.edu!jh5y |
| (412) 268-4493 | Prodigy: HXNJ79A |
| | Compuserve: [72510,1143] |
*===============================*===========================================*
}
Sterownik drukarki w jezyku PCL level III edytuj
PCL (Printer Command Language)[1] język obsługi drukarek laserowych i drukarek atramentowych opracowanych przez firmę Hewlett-Packard.
{PRINTERM.PAS - printing graphical screen on Hewlet Packard Desk Jet 550 C printer ( using PCL level III language - only black and white )}
Unit PrinterM;
{ obsluga drukarki Hewlett Packard DeskJet 550C w jezyku PCL level III }
INTERFACE {****************************************************************}
uses dos,graph;
const LPT1=0; { nr portu drukarki }
Escape=#27;
FormFeed=#12;
Reset=Escape+#69;
LandscapePageOrientation=Escape+#38+#108+#49+#79;
PortraitPageOrientation=Escape+#38+#108+#48+#79;
StartGraphicsAtLeft=Escape+'*r0A';
StartGraphicsAtCurrent=Escape+'*r1A';
EndGraphics=Escape+'*rbC';
var rejestr:registers;
Procedure WriteLst(tekst:string);
Procedure TestDrukarki;
Procedure KopiaEkranuP(XminWydruku,YminWydruku,RozdzielczoscWydruku:integer);
Procedure KopiaEkranuP1;
IMPLEMENTATION {************************************************************}
Procedure WriteLst(tekst:string);
var i:integer;
begin with rejestr do
for i:=1 to Length(tekst) do
begin Ah:=0; { kod funkcji, 0 oznacza wyprowadzenie bajtu }
Dx:=LPT1; { nr portu drukarki }
Al:=Byte(tekst[i]); { wyprowadzony bajt }
Intr($17,rejestr);
end; { for i:=1 ... }
end; { Procedure WriteLst }
{...........................................................................}
Procedure TestDrukarki; { dziala w trybie tekstowym }
begin
rejestr.dx:=LPT1; { Nr Portu do ktorego jest przylaczona drukarka ; 0 = LPT1 }
rejestr.ah:=2; { Nr funkcji ; status portu drukarki }
Intr($17,rejestr); { przerwanie nr 17 BIOS : inicjuje wskazany port drukarki
i zwraca jego status }
if rejestr.ah=144 { 10010000B tj. (bit 7) =1 i (bit 4) =1 }
then writeLn('Printer on LPT1 is OK')
else writeLn('Printer on LPT1 is not OK');
WriteLst(Reset);
end; { Procedure TestDrukarki }
{..........................................................................}
Procedure KopiaEkranuP(XminWydruku,YminWydruku,RozdzielczoscWydruku:integer);
const waga: array[0..7] of byte=(1,2,4,8,16,32,64,128);
var Xmax,Ymax,x,y:integer;
LiczbaBajtowL,
RozdzWydrukuL,
XminWydrukuL,YminWydrukuL:string;
bajt:byte;
begin
WriteLst(PortraitPageOrientation);
{--------------------- wielkosc ekranu ---------------------------------}
Xmax:=GetMaxX;
Ymax:=GetMaxY;
{--------------------- liczba bajtow w jednym poziomym pasmie ----------}
Str((Xmax div 8)+1,LiczbaBajtowL);
{--------------------- rozdzielczosc wydruku ---------------------------}
Case RozdzielczoscWydruku of 75,100,150,300 : Str(RozdzielczoscWydruku,RozdzWydrukuL);
else if Xmax<=319 then RozdzWydrukuL:='75'
else if Xmax<=639 then RozdzWydrukuL:='100'
else RozdzWydrukuL:='150';
end; { Case RozdzielczoscWydruku }
WriteLst(Escape+'*t'+RozdzWydrukuL+'R'); { set raster graphic printing resolution }
{------------------- pozycja kursora -----------------------------------}
Str(XminWydruku,XminWydrukuL);
Str(YminWydruku,YminWydrukuL);
WriteLst(Escape+'*p'+XminWydrukuL+'X' { pozycja kursora }
+YminWydrukuL+'Y');
WriteLst(StartGraphicsAtCurrent);
{----------------------------------------------------------------------}
For y:=0 to Ymax do
begin
bajt:=0;
WriteLst(Escape+'*b'+LiczbaBajtowL+'W'); { transfer raster graphics }
For x:=0 to Xmax do
begin
If GetPixel(x,y)<>black then Bajt:=Bajt+Waga[7-(x mod 8)];
If ( x mod 8)=7 then begin
WriteLst(Chr(bajt));
Bajt:=0;
end; { If ( x mod 8 ) ... }
end; { for x:=0 ... }
end; { for y:=0 ... }
{---------------------------------------------------------------------}
WriteLst(EndGraphics);
WriteLst(FormFeed);
end; { Procedure KopiaEkranuP }
{..........................................................................}
Procedure KopiaEkranuP1;
const waga: array[0..7] of byte=(1,2,4,8,16,32,64,128);
RozdzielczoscWydruku='75'; { dpi= dots per inch, jako lancuch }
var Xmax,Ymax,x,y:integer;
LiczbaBajtowL,
RozdzWydrukuL:string;
bajt:byte;
kolor:word;
begin
WriteLst(PortraitPageOrientation);
{--------------------- wielkosc ekranu ---------------------------------}
Xmax:=GetMaxX;
Ymax:=GetMaxY;
{--------------------- liczba bajtow w jednym poziomym pasmie ----------}
Str((Xmax div 8)+1,LiczbaBajtowL);
{--------------------- rozdzielczosc wydruku ---------------------------}
WriteLst(Escape+'*t'+RozdzielczoscWydruku+'R');
{------------------- pozycja kursora -----------------------------------}
WriteLst(StartGraphicsAtLeft);
{----------------------------------------------------------------------}
For y:=0 to Ymax do
begin
bajt:=0;
WriteLst(Escape+'*b'+LiczbaBajtowL+'W'); { transfer raster graphics }
For x:=0 to Xmax do
begin
If GetPixel(x,y)<>black then Bajt:=Bajt+Waga[7-(x mod 8)];
If ( x mod 8)=7 then begin
WriteLst(Chr(bajt));
Bajt:=0;
end; { If ( x mod 8 ) ... }
end; { for x:=0 ... }
end; { for y:=0 ... }
{---------------------------------------------------------------------}
WriteLst(EndGraphics);
WriteLst(FormFeed);
end; { Procedure KopiaEkranuP1 }
END.{********************* modulu PrinterM **********************************}
{jezyk programowania Turbo Pascal 7.0 firmy Borland dla systemu operacyjnego MS-Dos firmy Microsoft}
bitmapa *.bmp edytuj
Unit bmpM;
{this unit is to deal with bitmaps
32 bit color = 16 mln
______________________
uses untyped files
------------------------------
It based upon of:
1.web article: Write your own 24 bit bitmap
by Thaha Hussain http://delphi.about.com/library/weekly/aa101803a.htm
2.Mariusz BĽk - Bitmap Generator of Julia's fractals
http://zeus.polsl.gliwice.pl/~alef0/julia
thx - it's a great program, it uses typed files
3.types are taken from unit bitmaps XPERT software production Tamer Fakhoury
---------------
hardware: PC
OS: Microsoft windows 98
language: Pascal
compiler:
IDE:Borland Pascal v. 7.0
style: procedural
-----------------
2004-04-23
}
{*.bmp=
bmpFileHeader = 14 bytes
bmpInfoHeader = 40 bytes
if bitsPerPixel < 16 there is Colour Table
else No Colour Table
PixelData =
}
{word = 2 byte}
{Long integer = 4 byte}
Interface
Type {integer numbers}
{from unit bitmaps XPERT software production Tamer Fakhoury}
_bit = $00000000..$00000001; {number 1 bit without sign= (0..1) }
_byte = $00000000..$000000FF; {number 1 byte without sign= (0..255)}
_word = $00000000..$0000FFFF; {number 2 bytes without sign=(0..65 535)}
_dWord = $00000000..$7FFFFFFF; {number 4 bytes withoust sign= (0..4 294 967 296)}
_longInt = $80000000..$7FFFFFFF;{number 4 bytes with sign
= (-2 147 483 648..2 147 483 648}
TbmpFileHeader =
Record
ID: _word; { Must be 'BM' =19778=$424D for windows}
FileSize: _dWord; { Size of this file in bytes}
Reserved: _dWord; { ??? }
bmpDataOffset: _dword; {= 54=$36 from begining of file to begining of bmp data }
end;
TbmpInfoHeader =
Record
InfoHeaderSize: _dword; { Size of Info header
= 28h= 40 (decymal)
for windows}
Width,
Height: _longInt; { Width and Height of image in pixels}
Planes, { number of planes of bitmap}
BitsPerPixel: _word; { Bits can be 1, 4, 8, 24 or 32}
Compression,
bmpDataSize:_dword; { in bytes rounded to the next 4 byte boundary }
XPixPerMeter, {horizontal resolution in pixels}
YPixPerMeter:_longInt; {vertical}
NumbColorsUsed,
NumbImportantColors:_dword; {= NumbColorUsed}
End; { TbmpHeader = Record ...}
T32Color=record { 4 byte = 32 bit }
Blue:byte;
Green:byte;
Red:Byte;
Alfa:byte
end;
Var directory,
bmpFileName:string;
bmpFile: File; { untyped file}
bmpFileHeader: TbmpFileHeader;
bmpInfoHeader:TbmpInfoHeader;
color32:T32Color;
RowSizeInBytes:integer;
BytesPerPixel:integer;
const defaultBmpFileName='test';
DefaultDirectory='c:\bp\programy\fraktale\esher\';
DefaultExtension='.bmp';
bmpFileHeaderSize=14;
{ compression specyfication}
bi_RGB = 0; {none compression}
bi_RLE8 = 1;
bi_RLE4 = 2;
bi_BITFIELDS = 3;
{}
bmp_OK = 0;
bmp_NotBMP = 1;
bmp_OpenError = 2;
bmp_ReadError = 3;
Procedure CreateBmpFile32(directory:string;FileName:
string;iWidth,iHeight:_LongInt);
{************************************************}
Implementation {-----------------------------}
{************************************************}
Procedure CreateBmpFile32(directory:string;FileName:
string;iWidth,iHeight:_LongInt);
var x,y:integer;
begin
{create new file on a disk in a given directory with given name }
Assign(bmpFile,directory+ bmpFileName+DefaultExtension); { }
ReWrite(bmpFile,1); {ustal rozmiar zapisu na 1 bajt} { }
{fill the Headers}
with bmpInfoHeader,bmpFileHeader do
begin
ID:=19778;
InfoheaderSize:=40;
width:=100;
height:=100;
BitsPerPixel:=32;
BytesPerPixel:=BitsPerPixel div 8;
reserved:=0;
bmpDataOffset:=InfoHeaderSize+bmpFileHeaderSize;
planes:=1;
compression:=bi_RGB;
XPixPerMeter:=0;
YPixPerMeter:=0;
NumbColorsUsed:=0;
NumbImportantColors:=0;
RowSizeInBytes:=(Width*BytesPerPixel); {only for >=8 bits per pixel}
bmpDataSize:=height*RowSizeinBytes;
FileSize:=InfoHeaderSize+bmpFileHeaderSize+bmpDataSize;
{copy headers to disk file}
BlockWrite(bmpFile,bmpFileHeader,bmpFileHeaderSize);
BlockWrite(bmpFile,bmpInfoHeader,infoHeaderSize);
{fill the Pixel data area}
for y:= (height-1) downto 0 do
begin
for x:= 0 to (width -1) do
begin { Pixel(x,y) }
color32.Blue:=255;
color32.Green:=0;
color32.Red:=0;
color32.Alfa:=0;
BlockWrite(bmpFile,color32,4);
end; { For x ...}
end; { for y ...}
Close(bmpFile);
end; {with bmpInfoHeader,bmpFileHeader}
end; {procedure}
{--------------------------------------------------------}
Procedure ScreenCopy(directory:string;FileName:
string;iWidth,iHeight:_LongInt);
var x,y:integer;
color:word;
begin
{create new file on a disk in a given directory with given name }
Assign(bmpFile,directory+ bmpFileName+DefaultExtension); { }
ReWrite(bmpFile,1); {ustal rozmiar zapisu na 1 bajt} { }
{fill the Headers}
with bmpInfoHeader,bmpFileHeader do
begin
ID:=19778;
InfoheaderSize:=40;
width:=100;
height:=100;
BitsPerPixel:=32;
BytesPerPixel:=BitsPerPixel div 8;
reserved:=0;
bmpDataOffset:=InfoHeaderSize+bmpFileHeaderSize;
planes:=1;
compression:=bi_RGB;
XPixPerMeter:=0;
YPixPerMeter:=0;
NumbColorsUsed:=0;
NumbImportantColors:=0;
RowSizeInBytes:=(Width*BytesPerPixel); {only for >=8 bits per pixel}
bmpDataSize:=height*RowSizeinBytes;
FileSize:=InfoHeaderSize+bmpFileHeaderSize+bmpDataSize;
{copy headers to disk file}
BlockWrite(bmpFile,bmpFileHeader,bmpFileHeaderSize);
BlockWrite(bmpFile,bmpInfoHeader,infoHeaderSize);
{fill the Pixel data area}
for y:= (height-1) downto 0 do
begin
for x:= 0 to (width -1) do
begin { Pixel(x,y) }
{color:=GetPixel(x,y);}
{convert color to color32}
color32.Blue:=255;
color32.Green:=0;
color32.Red:=0;
color32.Alfa:=0;
BlockWrite(bmpFile,color32,4);
end; { For x ...}
end; { for y ...}
Close(bmpFile);
end; {with bmpInfoHeader,bmpFileHeader}
end; {procedure}
{--------------------------------------------------------}
END.