Program czytający ciąg znaków i informujący, czy jego długość jest liczbą parzystą czy nieparzystą.[edytuj]
programparzysta_nieparzysta;{nagłówek, obowiązkowy - "program" oznacza program główny ale}{może być też "unit" jako moduł programu (np: CRT)}usescrt;{uzywa biblioteki crt (potrzebna do podstawowych operacji)}vart: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}iflength(t)mod2=0then{Sprawdzenie podzielności długości łańcucha przez 2}writeln('Długość jest liczbą parzystą.'){jeśli podzielna}elsewriteln('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 wyszukujący dla dwóch podanych liczb największy wspólny dzielnik.[edytuj]
usescrt;vara,b,n:byte;beginclrscr;write('Podaj pierwsza liczbe ');readln(a);write('Podaj druga liczbe ');readln(b);n:=a;while(amodn<>0)or(bmodn<>0)don:=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]
usescrt;vara,b,n,x:word;beginclrscr;write('Podaj pierwsza liczbe ');readln(a);write('Podaj druga liczbe ');readln(b);n:=a;while(nmoda<>0)or(nmodb<>0)don:=n+1;writeln('Najmniejsza wspolna wielokrotnosc liczb ',a,' i ',b,' to ',n:0);readln;end.
Program obliczający silnię podanej liczby.[edytuj]
usescrt;vara:byte;functionsilnia(n:byte):longint;beginifn=0thensilnia:=1elsesilnia:=silnia(n-1)*n;end;beginclrscr;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+}UNITOknaM;INTERFACE{**************************************************************}UsesDos,Crt,Graph,zespolonyM,MathM;TypeSkaliT=(Liniowe,LogRozsz,LogZwez);TypeOkiennyT=RecordXmin,Xmax,Dx:real;Ymin,Ymax,Dy:real;XEmin,XEmax,Dxe:integer;YEmin,YEmax,Dye:integer;LiczbaPunktow:LongInt;caseTypySkalOsi:skaliTofLiniowe:(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 }TypePixelowyT=RecordXe,Ye:integer;end;{Type ZespolonyT=Record Re,Im:real; end;}TypePunktowyT=RecordEkranu:pixelowyT;Rzeczywisty:zespolonyT;kolor:word;okno:okiennyT;End;{ Type PunktowyT=record }ProcedureKojarz(varokno:okiennyT;xMin,xMax,yMin,yMax:real;TypSkalOsiXY:skaliT;xeMin,xeMax,yeMin,yeMax:integer);FunctionSkalaXe2X(Xe:integer;okno:okiennyT):real;{ xe --> x }ProcedurePunktP(x,y:real;okno:okiennyT;color:word);ProcedurePunktOblicz(z:zespolonyT;okno:okiennyT;varpunktEkranu:pixelowyT);ProcedurePisz(x,y:real;tekst:string;okno:okiennyT);ProcedureDajPunkt(NrPunktu:LongInt;Okno:okiennyT;varpunkt:punktowyT);ProcedureDajPunktSkosnie(NrPunktu:LongInt;Okno:okiennyT;varPunkt:punktowyT);ProcedureRysujPunkt(punkt:punktowyT;kolor:word);ProcedureKolo(srodek:zespolonyT;r:real;kolor:word;okno:okiennyT);IMPLEMENTATION{************************************************************}ProcedureKojarz(varokno:okiennyT;xMin,xMax,yMin,yMax:real;TypSkalOsiXY:skaliT;xeMin,xeMax,yeMin,yeMax:integer);beginokno.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 }caseTypSkalOsiXYofliniowe:beginokno.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:beginokno.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 }{-------------------------------------------------------------------------}FunctionSkalaX(X:real;okno:okiennyT):integer;{ x --> xe }varxl,l,xe:real;beginWithoknodocaseTypySkalOsiofliniowe:skalaX:=Round(Ax*X+Bx);LogRozsz:beginxl:=xlrMin+(x-xMin)*dXlr/dx;l:=ln(Xl);Xe:=xeMin+(l-lrmin)*dxe/dlr;skalaX:=round(xe);end;LogZwez:beginxl:=xlzMin+(x-xMin)*dXlz/dx;l:=ln(Xl);Xe:=xeMin+(l-lzmin)*dxe/dlz;skalaX:=round(xe);end;end;end;{-------------------------------------------------------------------------}FunctionSkalaXe2X(Xe:integer;okno:okiennyT):real;{ xe --> x }varl,xl:real;beginwithoknodobegincaseTypySkalOsiofliniowe:beginSkalaXe2X:=(Xe-Bx)*KrokX;{ xe --> x }end;LogRozsz:beginl:=lrMin+(xe-xemin)*dlr/dxe;xl:=exp(l);skalaXe2X:=xmin+(xl-xlrmin)*dx/dxlr;end;LogZwez:beginl:=lzMin+(xe-xemin)*dlz/dxe;xl:=exp(l);skalaXe2X:=xmin+(xl-xlzmin)*dx/dxlz;end;end;{ case }end;{ with okno }end;{-------------------------------------------------------------------------}FunctionInwersjaYE(YE:integer;okno:okiennyT):integer;beginWithoknodobeginifYE>(Dye/2)thenInwersjaYe:=YEmin+(YEmax-YE)elseInwersjaYE:=YEmax-(YE-YEmin);end;end;{---------------------------------------------------------------------------}FunctionSkalaY(Y:real;okno:okiennyT):integer;{ y --> ye }varSkala:integer;begin{ cialo funkcji skalaY }withoknodocaseTypySkalOsiofliniowe:beginSkala:=Round(Ay*Y+By);SkalaY:=InwersjaYE(Skala,okno);end;LogRozsz:beginSkala:=Round(Ayr*Y+Byr);SkalaY:=InwersjaYE(Skala,okno);end;LogZwez:beginSkala:=Round(Ayz*Y+Byz);SkalaY:=InwersjaYE(Skala,okno);end;end;{ case }end;{ cialo funkcji skalaY }{---------------------------------------------------------------------------}FunctionSkalaYe2Y(Ye:integer;okno:okiennyT):real;{ Ye --> Y }beginwithoknodobegincaseTypySkalOsiofliniowe: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;{---------------------------------------------------------------------------}ProcedurePunktP(x,y:real;okno:okiennyT;color:word);varXE,YE:integer;beginwithoknodobeginXE:=SkalaX(X,okno);{ X |--> Xekranu }YE:=SkalaY(Y,okno);{ Y |--> Yekranu }PutPixel(XE,YE,color);end;end;{---------------------------------------------------------------------------}ProcedurePunktOblicz(z:zespolonyT;okno:okiennyT;varpunktEkranu:pixelowyT);beginwithoknodobeginpunktEkranu.XE:=SkalaX(z.re,okno);{ X |--> Xekranu }punktEkranu.YE:=SkalaY(z.im,okno);{ Y |--> Yekranu }end;end;{---------------------------------------------------------------------------}ProcedurePisz(x,y:real;tekst:string;okno:okiennyT);varxe,ye:integer;beginxe:=SkalaX(x,okno);ye:=SkalaY(y,okno);OutTextXY(xe,ye,tekst);end;{---------------------------------------------------------------------------}ProcedureDajPunkt(NrPunktu:LongInt;Okno:okiennyT;varPunkt:punktowyT);varl,xl:real;beginWithoknodobeginPunkt.Ekranu.Xe:=XeMin+integer(NrPunktumodDxe);Punkt.Ekranu.Ye:=YeMin+integer(NrPunktudivDxe);Punkt.Okno:=Okno;caseokno.TypySkalOsiofliniowe:beginPunkt.Rzeczywisty.Re:=(Punkt.Ekranu.Xe-Bx)*KrokX;{ xe --> x }Punkt.Rzeczywisty.Im:=(Punkt.Ekranu.Ye-By)*KrokY;{ ye --> y }end;LogRozsz:beginl:=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:beginl:=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 }{---------------------------------------------------------------------------}ProcedureDajPunktSkosnie(NrPunktu:LongInt;Okno:okiennyT;varPunkt:punktowyT);beginWithoknodobegin{if CzyWzglPierw(dxe,dye) then begin }Punkt.Ekranu.Xe:=XeMin+integer(NrPunktumodDxe);Punkt.Ekranu.Ye:=YeMin+integer(NrPunktumod3);Punkt.Okno:=Okno;caseokno.TypySkalOsiofliniowe:beginPunkt.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 }{---------------------------------------------------------------------------}ProcedureRysujPunkt(Punkt:PunktowyT;kolor:word);varYe:integer;beginYe:=InwersjaYe(Punkt.ekranu.Ye,Punkt.okno);PutPixel(Punkt.ekranu.Xe,Ye,kolor);end;{---------------------------------------------------------------------------}ProcedureKolo(srodek:zespolonyT;r:real;kolor:word;okno:okiennyT);varxe,ye:integer;promien:word;beginxe:=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 }{****************************************************}
PROGRAMdiag321;{ 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;VAROkno1,okno2,okno3:OkiennyT;Bok:integer;BEGINOpengraf;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);RepeatuntilKeyPressed;CloseGraph;END.
ProgramEsher_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}usescrt,graph,{moje modul}grafM,KolorM,bmpM;varcolor: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;{--------------------------------------------------------------}procedurewstep;begin{ wstep }dYe:=YeMax-YeMin+1;Kroky:=dy/dYe;dXe:=XeMax-XeMin+1;{liczba punktow ekranu w poziomie}Krokx:=dx/dXe;end;{wstep}{---------------------------------------------------}procedurebmp(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}withbmpInfoHeader,bmpFileHeaderdobeginID:=19778;InfoheaderSize:=40;width:=w;height:=h;BitsPerPixel:=32;BytesPerPixel:=BitsPerPixeldiv8;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);forYe:=YeMaxDownToYeMindoforXe:=XeMaxDownToXeMindobegin{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;repeatinc(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);iftn=nMaxthenbreak;end;IfKeyPressedthenexit;until(n>=nMax)or(y*y+x*x>BailOut);{ ................okrela kolor...................................}ifn=1thencolor:=red{target set }elseifodd(n)thencolor:=blackelsecolor:=white;ifsqrt(sqr(x)+sqr(y))>1thencolor:=black;{out of the circle}{..................rysuje punkt na ekranie...............}PutPixel(Xe,Ye,color);{ zapisuje bitmapŠ...................................................}{convert color to color32}casecolorofblack:begincolor32.Blue:=0;color32.Green:=0;color32.Red:=0;color32.Alfa:=0;end;white:begincolor32.Blue:=255;color32.Green:=255;color32.Red:=255;color32.Alfa:=0;end;red:begincolor32.Blue:=0;color32.Green:=0;color32.Red:=255;color32.Alfa:=0;end;end;{case}BlockWrite(bmpFile,color32,4);end;{Xe}Close(bmpFile);repeatuntilKeyPressed;{CloseGraph;}End.{cialo}{GetMax Y powoduje zaburzenie pracy programu}{ Adam Majewskiadammaj@mp.plWalbrzych }{jezyk programowania Turbo Pascal 7.0 firmy Borlanddla systemu operacyjnego MS-Dos firmy Microsoft}
unitFractalnyM;{$A+,B-,D+,E+,F-,I+,L+,N-,O-,R+,S+,V+}{$M 16384,0,655360}INTERFACE{******************************************************************}usescrt,graph,OknaM,{okno_ekranu --> okno_rzeczywiste 2D}ZespolonyM,{ liczba zespolona }dwumianM,{ funkcja zespolona }KolorM;{........................................................................}ProcedureZukMultiP(okno:okiennyT;figura:CzyNalezyDoT;ModulMax:real;iMax:integer;KolorZbioru,KolorTla:word);ProcedureZuk(okno:okiennyT;promien:real;iMax:integer;KolorZbioru,KolorTla:word);ProcedureZ_test(okno:okiennyT;promien:real;iMax:integer;KolorZbioru,KolorTla:word);ProcedureZukOdwr(okno:okiennyT;promien:real;iMax:integer;KolorZbioru,KolorTla:word);ProcedureZukLsmMono(okno:okiennyT;promien:real;iMax,LiczbaWarstw:integer;KolorZbioru,KolorTlaBezWarstw,KolorWarstwyNieParz,KolorWarstwyParz:word);ProcedureZukLsmMoOdwr(okno:okiennyT;promien:real;iMax,LiczbaWarstw:integer;KolorZbioru,KolorTlaBezWarstw,KolorWarstwyNieParz,KolorWarstwyParz:word);ProcedureZukLSM(okno:okiennyT;odleglosc:real;iMax,LiczbaWarstw,LiczbaKolorow:integer;KolorZbioru,Kolor1WarstwyTla,KolorTla:word);ProcedureZukLSMautomat(okno:okiennyT;promien:real;iMax:integer;KolorZbioru:word);ProcedureZukLsmOdwr(okno:okiennyT;odleglosc:real;iMax,LiczbaWarstw,LiczbaKolorow:integer;KolorZbioru,Kolor1WarstwyTla,KolorTla:word);ProcedureZukBiomorf(okno:okiennyT;promien:real;iMax:integer;KolorZbioru,KolorTla:word);ProcedureZukBiomorfOdwrotnie(okno:okiennyT;promien:real;iMax:integer;KolorZbioru,KolorTla:word);PROCEDUREZukBin(okno:okiennyT;promien:real;iMax:integer;LiczbaWarstw:integer;KolorZbioru,KolorTlaBezWarstw,KolorTlaGornejPol,KolorTlaDolnejPol:word);PROCEDUREZukBinOdwr(okno:okiennyT;promien:real;iMax:integer;LiczbaWarstw:integer;KolorZbioru,KolorTlaBezWarstw,KolorTlaGornejPol,KolorTlaDolnejPol:word);PROCEDUREZukAtr(okno:okiennyT;promien:real;iMax:integer;OdlegloscMax:real;KolorZbioru,KolorTla:word);PROCEDUREZukAtrOdwr(okno:okiennyT;promien:real;iMax:integer;OdlegloscMax:real;KolorZbioru,KolorTla:word);PROCEDUREZukAtraktor(okno:okiennyT;promien:real;iMax:integer;OdlegloscMax:real;KolorZbioru,KolorTla:word);PROCEDUREZukAtraktorOdwr(okno:okiennyT;promien:real;iMax:integer;OdlegloscMax:real;KolorZbioru,KolorTla:word);PROCEDUREZukDEM(okno:okiennyT;PromienDoKw:real;iMax:integer;OdlegloscPix:real;OverFlow:real);PROCEDUREDiagram(okno:okiennyT;iMax1,iMax2:integer);IMPLEMENTATION{**************************************************************}ProcedureZukMultiP(okno:okiennyT;figura:CzyNalezyDoT;ModulMax:real;iMax:integer;KolorZbioru,KolorTla:word);constz0:zespolonyT=(re:0.0;im:0.0);Vari:integer;{ nr iteracji }NrPunktu:LongInt;{ punkty okna ekranu}punkt:punktowyT;{ typ zdefiniowany w module oknaM }z:zespolonyT;kolor:word;BeginforNrPunktu:=0to(okno.LiczbaPunktow-1)dobeginDajPunkt(NrPunktu,Okno,Punkt);Iteruj(figura,z0,Punkt.rzeczywisty,ModulMax,iMax,i,z);kolor:=KolorLSMautomat(i,iMax,KolorZbioru);RysujPunkt(punkt,kolor);ifKeyPressedthenhalt;end;End;{ proponowane wywolanie: -0.6<x<2; -1.3<y<1.3; promien=2; iMax=20 }{-------------------------------------------------------------------------}ProcedureZuk(okno:okiennyT;promien:real;iMax:integer;KolorZbioru,KolorTla:word);constz0:zespolonyT=(re:0.0;im:0.0);Vari:integer;{ nr iteracji }NrPunktu:LongInt;{ punkty okna ekranu}punkt:punktowyT;{ typ zdefiniowany w module oknaM }z:zespolonyT;kolor:word;BeginforNrPunktu:=0to(okno.LiczbaPunktow-1)dobeginDajPunkt(NrPunktu,Okno,Punkt);IterujP(z0,Punkt.rzeczywisty,promien,iMax,i,z);kolor:=KolorPunktu(i,iMax,KolorZbioru,KolorTla);RysujPunkt(punkt,kolor);ifKeyPressedthenhalt;end;End;{ proponowane wywolanie: -0.6<x<2; -1.3<y<1.3; promien=2; iMax=20 }{-------------------------------------------------------------------------}ProcedureZ_test(okno:okiennyT;promien:real;iMax:integer;KolorZbioru,KolorTla:word);constz0:zespolonyT=(re:0.0;im:0.0);Vari:integer;{ nr iteracji }NrPunktu:LongInt;punkt:punktowyT;{ typ zdefiniowany w module oknaM }z:zespolonyT;kolor:word;BeginforNrPunktu:=0to(okno.LiczbaPunktow-1)dobeginDajPunktSkosnie(NrPunktu,Okno,Punkt);kolor:=KolorZbioru;RysujPunkt(punkt,kolor);ifKeyPressedthenhalt;end;End;{ proponowane wywolanie -0.6<x<2 -1.3<y<1.3 odleglosc=2 iMax=20 }{-------------------------------------------------------------------------}ProcedureZukOdwr(okno:okiennyT;promien:real;iMax:integer;KolorZbioru,KolorTla:word);constz0:zespolonyT=(re:0.0;im:0.0);Vari:integer;{ nr iteracji }NrPunktu:LongInt;punkt:punktowyT;{ typ zdefiniowany w module oknaM }z,c:zespolonyT;kolor:word;BeginforNrPunktu:=0to(okno.LiczbaPunktow-1)dobeginDajPunkt(NrPunktu,Okno,Punkt);OdwrotnaZ(Punkt.rzeczywisty,c);{**********}IterujP(z0,c,promien,iMax,i,z);kolor:=KolorPunktu(i,iMax,KolorZbioru,KolorTla);RysujPunkt(punkt,kolor);ifKeyPressedthenhalt;end;End;{ proponowane wywolanie x <y< odleglosc=2 iMax=20 }{-------------------------------------------------------------------------------}ProcedureZukLsmMono(okno:okiennyT;promien:real;iMax:integer;LiczbaWarstw:integer;KolorZbioru,KolorTlaBezWarstw,KolorWarstwyNieParz,KolorWarstwyParz:word);Constz0:zespolonyT=(re:0.0;im:0.0);VARi:integer;{ nr iteracji }NrPunktu:LongInt;punkt:punktowyT;{ typ zdefiniowany w module oknaM }kolor:word;z:zespolonyT;BEGINforNrPunktu:=0to(okno.LiczbaPunktow-1)dobeginDajPunkt(NrPunktu,Okno,Punkt);IterujP(z0,punkt.rzeczywisty,promien,iMax,i,z);kolor:=KolorLSMmono(i,iMax,liczbaWarstw,KolorZbioru,KolorTlaBezWarstw,KolorWarstwyNieParz,KolorWarstwyParz);RysujPunkt(Punkt,kolor);ifKeyPressedthenhalt;end;END;{-------------------------------------------------------------------------------}ProcedureZukLsmMoOdwr(okno:okiennyT;promien:real;iMax:integer;LiczbaWarstw:integer;KolorZbioru,KolorTlaBezWarstw,KolorWarstwyNieParz,KolorWarstwyParz:word);Constz0:zespolonyT=(re:0.0;im:0.0);VARi:integer;{ nr iteracji }NrPunktu:LongInt;punkt:punktowyT;{ typ zdefiniowany w module oknaM }kolor:word;z,c:zespolonyT;BEGINforNrPunktu:=0to(okno.LiczbaPunktow-1)dobeginDajPunkt(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);ifKeyPressedthenhalt;end;END;{-----------------------------------------------------------------------------}PROCEDUREZukLSM(okno:okiennyT;odleglosc:real;iMax,LiczbaWarstw,LiczbaKolorow:integer;KolorZbioru,Kolor1WarstwyTla,KolorTla:word);constz0:zespolonyT=(re:0.0;im:0.0);VARi:integer;{ nr iteracji }NrPunktu:LongInt;punkt:punktowyT;{ typ zdefiniowany w module oknaM }kolor:word;z:zespolonyT;BEGINforNrPunktu:=0to(okno.LiczbaPunktow-1)dobeginDajPunkt(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);ifKeyPressedthenhalt;end;END;{-----------------------------------------------------------------------------}PROCEDUREZukLSMautomat(okno:okiennyT;promien:real;iMax:integer;KolorZbioru:word);constz0:zespolonyT=(re:0.0;im:0.0);VARi:integer;{ nr iteracji }NrPunktu:LongInt;punkt:punktowyT;{ typ zdefiniowany w module oknaM }kolor:word;z:zespolonyT;BEGINforNrPunktu:=0to(okno.LiczbaPunktow-1)dobeginDajPunkt(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);ifKeyPressedthenhalt;end;END;{-----------------------------------------------------------------------------}PROCEDUREZukLsmOdwr(okno:okiennyT;odleglosc:real;iMax,LiczbaWarstw,LiczbaKolorow:integer;KolorZbioru,Kolor1WarstwyTla,KolorTla:word);constz0:zespolonyT=(re:0.0;im:0.0);VARi:integer;{ nr iteracji }NrPunktu:LongInt;punkt:punktowyT;{ typ zdefiniowany w module oknaM }kolor:word;z,c:zespolonyT;BEGINforNrPunktu:=0to(okno.LiczbaPunktow-1)dobeginDajPunkt(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);ifKeyPressedthenhalt;end;END;{-------------------------------------------------------------------------}ProcedureZukBiomorf(okno:okiennyT;promien:real;iMax:integer;KolorZbioru,KolorTla:word);constz0:zespolonyT=(re:0.0;im:0.0);Vari:integer;{ nr iteracji }NrPunktu:LongInt;{ punkty okna ekranu}punkt:punktowyT;{ typ zdefiniowany w module oknaM }z:zespolonyT;kolor:word;BeginforNrPunktu:=0to(okno.LiczbaPunktow-1)dobeginDajPunkt(NrPunktu,Okno,Punkt);IterujBiomorfP(z0,Punkt.rzeczywisty,promien,iMax,i);kolor:=KolorLSMautomat(i,iMax,KolorZbioru);RysujPunkt(punkt,kolor);ifKeyPressedthenhalt;end;End;{ proponowane wywolanie: -10<x<10; -10<y<10; promien= 10; iMax=20 }{-------------------------------------------------------------------------}ProcedureZukBiomorfOdwrotnie(okno:okiennyT;promien:real;iMax:integer;KolorZbioru,KolorTla:word);constz0:zespolonyT=(re:0.0;im:0.0);Vari:integer;{ nr iteracji }NrPunktu:LongInt;{ punkty okna ekranu}punkt:punktowyT;{ typ zdefiniowany w module oknaM }z,c:zespolonyT;kolor:word;BeginforNrPunktu:=0to(okno.LiczbaPunktow-1)dobeginDajPunkt(NrPunktu,Okno,Punkt);OdwrotnaZ(Punkt.rzeczywisty,punkt.rzeczywisty);IterujBiomorfP(z0,Punkt.rzeczywisty,promien,iMax,i);kolor:=KolorLSMautomat(i,iMax,KolorZbioru);RysujPunkt(punkt,kolor);ifKeyPressedthenhalt;end;End;{ proponowane wywolanie: -10<x<10; -10<y<10; promien= 10; iMax=20 }{--------------------------------------------------------------------------}PROCEDUREZukBin(okno:okiennyT;promien:real;iMax:integer;LiczbaWarstw:integer;KolorZbioru,KolorTlaBezWarstw,KolorTlaGornejPol,KolorTlaDolnejPol:word);Constz0:zespolonyT=(re:0.0;im:0.0);VARi:integer;{ nr iteracji }NrPunktu:LongInt;punkt:punktowyT;{ typ zdefiniowany w module oknaM }kolor:word;{ kolor punktu }z:zespolonyT;{ }BEGINforNrPunktu:=0to(okno.LiczbaPunktow-1)dobeginDajPunkt(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);ifKeyPressedthenhalt;end;END;{--------------------------------------------------------------------------}PROCEDUREZukBinOdwr(okno:okiennyT;promien:real;iMax:integer;LiczbaWarstw:integer;KolorZbioru,KolorTlaBezWarstw,KolorTlaGornejPol,KolorTlaDolnejPol:word);Constz0:zespolonyT=(re:0.0;im:0.0);VARi:integer;{ nr iteracji }NrPunktu:LongInt;punkt:punktowyT;{ typ zdefiniowany w module oknaM }kolor:word;{ kolor punktu }z,c:zespolonyT;{ }BEGINforNrPunktu:=0to(okno.LiczbaPunktow-1)dobeginDajPunkt(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);ifKeyPressedthenhalt;end;END;{----------------------------------------------------------------------------}PROCEDUREZukAtr(okno:okiennyT;promien:real;iMax:integer;OdlegloscMax:real;KolorZbioru,KolorTla:word);constz0:zespolonyT=(re:0.0;im:0.0);VARi: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;BEGINforNrPunktu:=0to(okno.LiczbaPunktow-1)dobeginDajPunkt(NrPunktu,Okno,Punkt);{ punkt=c : z=z*z + c }IterujP(z0,punkt.rzeczywisty,promien,iMax,i,z);if((i=iMax)and(ModulZ(z)<promien))thenbeginDwumian2Z(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; }ifodlegloscZ(z5,z)<odlegloscMaxthenkolor:=cyan;ifodlegloscZ(z4,z)<odlegloscMaxthenkolor:=magenta;ifodlegloscZ(z3,z)<odlegloscMaxthenkolor:=blue;ifodlegloscZ(z2,z)<odlegloscMaxthenkolor:=green;ifodlegloscZ(z1,z)<odlegloscMaxthenkolor:=red;endelsekolor:=KolorTla;RysujPunkt(punkt,kolor);ifKeyPressedthenhalt;end;END;{----------------------------------------------------------------------------}PROCEDUREZukAtrOdwr(okno:okiennyT;promien:real;iMax:integer;OdlegloscMax:real;KolorZbioru,KolorTla:word);constz0:zespolonyT=(re:0.0;im:0.0);VARi: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;BEGINforNrPunktu:=0to(okno.LiczbaPunktow-1)dobeginDajPunkt(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))thenbeginDwumian2Z(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; }ifodlegloscZ(z5,z)<odlegloscMaxthenkolor:=cyan;ifodlegloscZ(z4,z)<odlegloscMaxthenkolor:=magenta;ifodlegloscZ(z3,z)<odlegloscMaxthenkolor:=blue;ifodlegloscZ(z2,z)<odlegloscMaxthenkolor:=green;ifodlegloscZ(z1,z)<odlegloscMaxthenkolor:=red;endelsekolor:=KolorTla;RysujPunkt(punkt,kolor);ifKeyPressedthenhalt;end;END;{----------------------------------------------------------------------------}PROCEDUREZukAtraktor(okno:okiennyT;promien:real;iMax:integer;OdlegloscMax:real;KolorZbioru,KolorTla:word);constz0:zespolonyT=(re:0.0;im:0.0);nMax=10;{ liczba atraktorow, nMax cykli, od jedno do nMax-punktowych }VARi,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]ofzespolonyT;kolor:word;KwadratPromienia:real;BEGINKwadratPromienia:=Promien*Promien;forNrPunktu:=0to(okno.LiczbaPunktow-1)dobeginDajPunkt(NrPunktu,Okno,Punkt);{ punkt=c : z=z*z + c }IterujP(z0,punkt.rzeczywisty,promien,iMax,i,z);if((i=iMax)and(KwModZ(z)<KwadratPromienia))thenbeginn:=1;Zn[1]:=z;while(n<nMax)and(KwModZ(Zn[n])<KwadratPromienia)dobeginDwumian2Z(Zn[n],punkt.rzeczywisty,Zn[n+1]);n:=n+1;end;kolor:=KolorZbioru;fori:=nMaxDownTo2doifodlegloscZ(Zn[i],Zn[1])<odlegloscMaxthenkolor:=i;end{ if ((i=iMax) ... then }elsekolor:=KolorTla;RysujPunkt(punkt,kolor);ifKeyPressedthenhalt;end;{ for nrPunktu ... }END;{ Procedure ZukAtraktor }{----------------------------------------------------------------------------}PROCEDUREZukAtraktorOdwr(okno:okiennyT;promien:real;iMax:integer;OdlegloscMax:real;KolorZbioru,KolorTla:word);constz0:zespolonyT=(re:0.0;im:0.0);nMax=10;{ liczba atraktorow, nMax cykli, od jedno do nMax-punktowych }VARi,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]ofzespolonyT;kolor:word;KwadratPromienia:real;BEGINKwadratPromienia:=Promien*Promien;forNrPunktu:=0to(okno.LiczbaPunktow-1)dobeginDajPunkt(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))thenbeginn:=1;Zn[1]:=z;while(n<nMax)and(KwModZ(Zn[n])<KwadratPromienia)dobeginDwumian2Z(Zn[n],c,Zn[n+1]);n:=n+1;end;kolor:=KolorZbioru;fori:=nMaxDownTo2doifodlegloscZ(Zn[i],Zn[1])<odlegloscMaxthenkolor:=i;end{ if ((i=iMax) ... then }elsekolor:=KolorTla;RysujPunkt(punkt,kolor);ifKeyPressedthenhalt;end;{ for nrPunktu ... }END;{ Procedure ZukAtraktor }{----------------------------------------------------------------------------}PROCEDUREZukDEM(okno:okiennyT;PromienDoKw:real;iMax:integer;OdlegloscPix:real;OverFlow:real);{ Mandelbrot Set via Distance Estimate Method }LABELskok;VARX,Y,KrokX,KrokY,Odleglosc,dist:real;i:integer;{ nr iteracji }Xe,Ye:integer;kolor:word;{..........................................................................}FUNCTIONMSetDist(X,Y:real;Imax:integer):real;vari,iter:integer;Zx,Zy,Zx2,Zy2:real;ZxDer,ZyDer:real;{ dervatives }Temp:real;ZxOrbit:array[0..50]ofreal;ZyOrbit:array[0..50]ofreal;flag:boolean;functionMax(a,b:real):real;beginifa>bthenmax:=aelsemax:=b;end;functionLog(a:real):real;beginlog:=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)dobegintemp:=(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 ... }ifZx2+Zy2>PromienDoKwthenbeginZxDer:=0;ZyDer:=0;i:=0;Flag:=false;while(i<iter)and(notflag)dobegintemp:=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(notflag)thenMSetDist:=log(Zx2+Zy2)*Sqrt(Zx2+Zy2)/Sqrt(ZxDer*Zxder+ZyDer*ZyDer);end;{ if Zx2 ... }end;{ function MSetDist }{............................................................................}BEGIN{ ZukDem }WithOknodobeginOdleglosc:=OdlegloscPix*krokX;X:=Xmin;forXe:=XeMintoXeMaxdobeginY:=Ymin;forYe:=YeMintoYeMaxdobegindist:=MSetDist(X,Y,Imax);ifdist<Odlegloscthenkolor:=greenelsekolor:=white;PutPixel(Xe,Ye,kolor);Y:=Y+KrokY;end;{ for Ye ... }ifKeyPressedthengotoskok;X:=X+KrokX;end;{ for Xe ... }skok:;end;{ with okno ... }END;{ ZukDem }{----------------------------------------------------------------------------}PROCEDUREDiagram(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> }VARX,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 }LABELskok;FunctionDwumian(x,c:real):real;{ polecane -2< a <0.25 ; -2< b <2 }begindwumian:=(x*x)+c;end;BEGINRandomize;WithOknodobeginXe:=Xemax;i:=1;WhileXe>=XeminDobeginx:=skalaXe2X(xe,okno);Y:=random;{------- oczyszcza wykres z punktow dazacych do atraktora ---------}fori:=1toiMax1dobeginy:=Dwumian(y,x);{ y=(y*y)-x ;funkcja modulu FunkcjeM }ifabs(y)>yMaxthenGoToskok;ifKeyPressedthenexit;end;{--------------- rysuje pierwiastki ------------------------------ }ifx<=0.25then{ delta >=0 to znaczy sa dwa pierwiastki rzeczywiste }beginy11:=(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 -------------------------------}ifx<=-0.75thenbeginy21:=(-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 --------------------------------- }fori:=1toiMax2dobeginy:=Dwumian(y,x);punktP(x,y,okno,green);ifabs(y)>yMaxthenGoToskok;ifKeyPressedthenexit;end;skok:;Xe:=Xe-1;end;end;{ with okno ... }END;{----------------------------------------------------------------------------}END.{ modulu FraktalnyM }{*************************************************}{2000.05.04 }
UNITDwumianM;INTERFACE{******************************************************************}UsesCrt,zespolonyM,oknaM;typeplikPunktowyT=fileofpixelowyT;typeCzyNalezyDoT=(kolo,Kwadrat,{ and}oraz,lub,{or = Pickover}BioMorf,Bio2xy,rzeczywisty,urojony,Manhattan,manr);FunctionDwumian(x,c:real):real;ProcedureDwumian2Z(Z1,Z2:zespolonyT;varZ3:zespolonyT);{.......................................................................}ProcedurePunktStalyDwu2Z(c:zespolonyT;varz1,z2:zespolonyT);ProcedureCyklStaly2pDwu2z(c:zespolonyT;varz21,z22:zespolonyT);ProcedurePochodnaDwumianu2Z(z1:zespolonyT;varz2:zespolonyT);FunctionZrodloDwumianu2Z(z1,z2:zespolonyT;varz3:zespolonyT):boolean;FunctionSciekDwumianu2Z(z1,z2:zespolonyT;varz3:zespolonyT):boolean;FunctionScieki2Dwu2Z(s21,s22,c:zespolonyT):boolean;{........................................................................}ProcedureZnajdzZbiorJulii(okno:okiennyT;c,skala:zespolonyT;promien:real;iMax:integer;varplikPunktow:plikPunktowyT);FunctionCzyNalezyDo(okno:okiennyT;z:zespolonyT;varplikPunktow:plikPunktowyT):boolean;{,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,}FunctionCzyNalezyDoF(figura:CzyNalezyDoT;z:zespolonyT;ModulMax:real;i,iMax:integer):boolean;FunctionWarunekKolo(z:zespolonyT;ModulMax:real;i,iMax:integer):boolean;FunctionWarunekBiomorf(z:zespolonyT;Max:real;i,iMax:integer):boolean;FunctionWarunekKwadratowy(z:zespolonyT;BokKwadratu:real;i,iMax:integer):boolean;{......................................................................}ProcedureIteruj(Figura:CzyNalezyDoT;z0,c:zespolonyT;ModulMax:real;iMax:integer;vari:integer;varz:zespolonyT);ProcedureIterujEscher(z0,c:zespolonyT;iMax:integer;okno:okiennyT;vari:integer;varz:zespolonyT;varPlikPunktow:PlikPunktowyT);ProcedureIterujP(z0,c:zespolonyT;ModulMax:real;iMax:integer;vari:integer;varz:zespolonyT);ProcedureIterujBiomorfP(z0,c:zespolonyT;ModulMax:real;iMax:integer;vari:integer{ oddaje nr ostatniej iteracji }{var z:zespolonyT});ProcedureIterujKwadratowoP(z0,c:zespolonyT;BokKwadratu:real;iMax:integer;vari:integer;{ oddaje nr ostatniej iteracji }varz:zespolonyT);ProcedureIterujP1(z0,c,atraktor:zespolonyT;OdlegloscMaxOdAtr:real;ModulMax:real;iMax:integer;vari:integer;varz:zespolonyT);ProcedureIterujP2(z0,c,atraktor1,atraktor2:zespolonyT;OdlegloscMaxOdAtr:real;ModulMax:real;iMax:integer;vari:integer;varz:zespolonyT);ProcedureIterujOP(z0,OdwrotneC:zespolonyT;ModulMax:real;iMax:integer;vari:integer;varz:zespolonyT);ProcedureWstecznaIterDwu2Z(Zn,c:zespolonyT;varZm1,Zm2:zespolonyT);IMPLEMENTATION{**************************************************************}FunctionDwumian(x,c:real):real;begindwumian:=(x*x)+c;end;{......................................................}ProcedureDwumian2Z(Z1,Z2:zespolonyT;varZ3:zespolonyT);varz:zespolonyT;{ z3 = (z1*z1) + z2 }beginKwadratZ(Z1,Z);{ z = z1 * z1 }SumaZ(Z,Z2,Z3){ z3 = z + z2 }end;{---------------------------------------------------------------------------}ProcedurePunktStalyDwu2Z(c:zespolonyT;varz1,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 }consts2:zespolonyT=(Re:-1.0;Im:0.0);{ s2=b=-1 }s3:zespolonyT=(Re:2.0;Im:0.0);{ s3=2a=2 }vartemp,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 }{---------------------------------------------------------------------------}ProcedureCyklStaly2pDwu2z(c:zespolonyT;varz21,z22:zespolonyT);{ z21,z22:z=f(f(z))=(z*z+c)(z*z+c)+c }{ z=-0.5-+sqrt(-0.75-c) }vars1,{ s1=-3/4 }s2,{ s2=-1/2 }delta,Pierw1Delty,Pierw2Delty,temp:zespolonyT;beginUtworzLZ(-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 }{---------------------------------------------------------------------------}ProcedurePochodnaDwumianu2Z(z1:zespolonyT;varz2:zespolonyT);beginz2.re:=2*z1.re;{ f(z)=z*z+c }z2.im:=2*z1.im;{ f'(z)=2*z }end;{--------------------------------------------------------------------------}ProcedurePochodna2Dwu2Z(z,c:zespolonyT;varp: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 }vars1,s2,cztery,z3,temp:zespolonyT;beginutworzLZ(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 }{--------------------------------------------------------------------------}FunctionZrodloDwumianu2Z(z1,z2:zespolonyT;varz3: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 }varp1,p2:zespolonyT;{ pochodne dwumianu2Z w punkcie stalym z1 i z2 }beginPochodnaDwumianu2Z(z1,p1);ifModulZ(p1)>1{ to znaczy punkt jest zrodlem czyli odpychajacym }thenbeginz3.re:=z1.re;z3.im:=z1.im;ZrodloDwumianu2Z:=true;endelsebeginPochodnaDwumianu2Z(z2,p2);IfModulZ(p2)>1thenbeginz3.re:=z2.re;z3.im:=z2.im;ZrodloDwumianu2Z:=true;endelseZrodloDwumianu2Z:=false;end;{ if ModulZ(p1) ... }end;{ zrodloDwumianu2Z }{-------------------------------------------------------------------------}FunctionSciekDwumianu2Z(z1,z2:zespolonyT;varz3: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 }varp1,p2:zespolonyT;{ pochodne dwumianu2Z w punkcie stalym z1 i z2 }beginPochodnaDwumianu2Z(z1,p1);ifModulZ(p1)<1{ to znaczy punkt z1 jest sciekiem czyli przyciagajacym }thenbeginz3.re:=z1.re;z3.im:=z1.im;SciekDwumianu2Z:=true;endelsebeginPochodnaDwumianu2Z(z2,p2);IfModulZ(p2)<1{ punkt z2 jest sciekiem }thenbeginz3.re:=z2.re;z3.im:=z2.im;SciekDwumianu2Z:=true;endelseSciekDwumianu2Z:=false{ zaden punkt staly nie jest sciekiem }end;{ if ModulZ(p1) ... else ... }end;{ sciekDwumianu2Z }{-------------------------------------------------------------------------}FunctionScieki2Dwu2Z(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 }varp1,p2:zespolonyT;{ pochodne dwumianu2Z w punkcie stalym z1 i z2 }beginPochodna2Dwu2Z(s21,c,p1);Pochodna2Dwu2Z(s22,c,p2);if(ModulZ(p1)<1)and(ModulZ(p2)<1)thenScieki2Dwu2Z:=trueelseScieki2Dwu2Z:=false;{ zaden punkt staly nie jest sciekiem }end;{ scieki2Dwumianu2Z }{--------------------------------------------------------------------------}ProcedureZnajdzZbiorJulii(okno:okiennyT;c,skala:zespolonyT;promien:real;iMax:integer;varplikPunktow:plikPunktowyT);varz0,z:zespolonyT;NrPunktu:longInt;i:integer;punkt:punktowyT;beginAssign(PlikPunktow,'c:\bp\bin\punkty.pli');Rewrite(PlikPunktow);forNrPunktu:=0to(okno.LiczbaPunktow-1)dobeginDajPunkt(NrPunktu,Okno,Punkt);iloczynZ(Punkt.rzeczywisty,skala,z0);IterujP(z0,c,promien,iMax,i,z);ifi=iMaxthenbeginwrite(PlikPunktow,Punkt.ekranu);RysujPunkt(Punkt,red);endelseRysujPunkt(Punkt,white);end;{ for NrPunktu }Seek(PlikPunktow,0);end;{ Procedure ZnajdzZiorJulii }{--------------------------------------------------------------------------}FunctionCzyNalezyDo(okno:okiennyT;z:zespolonyT;varplikPunktow:PlikPunktowyT):boolean;varpunktEkranu,punktZbioru:pixelowyT;znaleziono:boolean;beginCzyNalezyDo:=false;znaleziono:=false;PunktOblicz(z,okno,punktEkranu);Seek(PlikPunktow,0);while(notEOF(PlikPunktow))dobeginread(PlikPunktow,PunktZbioru);if(PunktEkranu.xe=PunktZbioru.xe)and(PunktEkranu.ye=PunktZbioru.ye)thenbeginCzyNalezyDo:=true;exit;end;{ if }end;{ while }Seek(PlikPunktow,0);end;{ function CzyNalezyDo }{.......................................................................}FunctionCzyNalezyDoF(figura:CzyNalezyDoT;z:zespolonyT;ModulMax:real;i,iMax:integer):boolean;varKwModuluMax:real;begincasefiguraofkolo: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}{............................................................................}FunctionWarunekKolo(z:zespolonyT;ModulMax:real;i,iMax:integer):boolean;varKwModuluMax:real;beginKwModuluMax:=ModulMax*ModulMax;WarunekKolo:=(i<iMax)and(KwModZ(z)<=KwModuluMax)end;{ zalecany modulMax= 2}{.......................................................................}FunctionWarunekBiomorf(z:zespolonyT;Max:real;i,iMax:integer):boolean;beginWarunekBiomorf:=(i<iMax)and((abs(z.re)<=Max)or(Abs(z.im)<=Max))end;{ zalecany ModulMax:=10 a kolor : LSM}{-------------------------------------------------------------------------}FunctionWarunekKwadratowy(z:zespolonyT;BokKwadratu:real;i,iMax:integer):boolean;beginWarunekKwadratowy:=(i<iMax)and((z.re<=BokKwadratu/2)or(z.im<=BokKwadratu/2));end;{-------------------------------------------------------------------------}ProcedureIteruj(Figura:CzyNalezyDoT;z0,c:zespolonyT;ModulMax:real;iMax:integer;vari:integer;varz:zespolonyT);beginz:=z0;i:=0;whileCzyNalezyDoF(figura,z,ModulMax,i,iMax)dobeginDwumian2Z(z,c,z);i:=i+1;end;{while}end;{procedure}{---------------------------------------------------------------------------}ProcedureIterujEscher(z0,c:zespolonyT;iMax:integer;{ Max liczba iteracji }okno:okiennyT;vari:integer;{ oddaje nr ostatniej iteracji }varz:zespolonyT;{ oddaje ostatni element ciagu }varPlikPunktow:PlikPunktowyT);beginz:=z0;i:=0;while(i<iMax)and(notCzyNalezyDo(okno,z,plikPunktow))dobeginDwumian2Z(z,c,z);i:=i+1;end;end;{-------------------------------------------------------------------------}ProcedureIterujP(z0,c:zespolonyT;ModulMax:real;{ promien kola ograniczajacego }iMax:integer;{ Max liczba iteracji }vari:integer;{ oddaje nr ostatniej iteracji }varz:zespolonyT);{ oddaje ostatni element ciagu }varKwModuluMax:real;beginKwModuluMax:=ModulMax*ModulMax;z:=z0;i:=0;whileWarunekKolo(z,ModulMax,i,iMax)dobeginDwumian2Z(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) }{-------------------------------------------------------------------------}ProcedureIterujBiomorfP(z0,c:zespolonyT;ModulMax:real;{ promien kola ograniczajacego }iMax:integer;{ Max liczba iteracji }vari:integer{ oddaje nr ostatniej iteracji }{ var z:zespolonyT});{ oddaje ostatni element ciagu }varz:zespolonyT;beginz:=z0;i:=0;whileWarunekBiomorf(z,ModulMax,i,iMax)dobeginDwumian2Z(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) }{--------------------------------------------------------------------------}ProcedureIterujKwadratowoP(z0,c:zespolonyT;BokKwadratu:real;iMax:integer;vari:integer;{ oddaje nr ostatniej iteracji }varz:zespolonyT);beginz:=z0;i:=0;whileWarunekKwadratowy(z,BokKwadratu,i,iMax)dobeginDwumian2Z(z,c,z);i:=i+1;end;end;{----------------------------------------------------------------------------}ProcedureIterujP1(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 }vari:integer;{ oddaje nr ostatniej iteracji }varz:zespolonyT);{ oddaje ostatni element ciagu }varKwModuluMax,KwOdlegloscMax:real;beginKwModuluMax:=ModulMax*ModulMax;KwOdlegloscMax:=OdlegloscMaxOdAtr*OdlegloscMaxOdAtr;z:=z0;i:=0;while(i<iMax)and(KwModZ(z)<=KwModuluMax)and(KwOdlegloscZ(z,atraktor)>KwOdlegloscMax)dobeginDwumian2Z(z,c,z);i:=i+1;end;end;{----------------------------------------------------------------------------}ProcedureIterujP2(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 }vari:integer;{ oddaje nr ostatniej iteracji }varz:zespolonyT);{ oddaje ostatni element ciagu }varKwModuluMax,KwOdlegloscMax:real;beginKwModuluMax:=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))dobeginDwumian2Z(z,c,z);i:=i+1;end;end;{ Procedure IterujP2 }{-------------------------------------------------------------------------}ProcedureIterujOP(z0,OdwrotneC:zespolonyT;ModulMax:real;{ promien kola ograniczajacego }iMax:integer;{ Max liczba iteracji }vari:integer;{ oddaje nr ostatniej iteracji }varz:zespolonyT);{ oddaje ostatni element ciagu }varKwModuluMax:real;c:zespolonyT;beginKwModuluMax:=ModulMax*ModulMax;z:=z0;OdwrotnaZ(OdwrotneC,c);i:=0;while(i<iMax)and(KwModZ(z)<=KwModuluMax)dobeginDwumian2Z(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) }{---------------------------------------------------------------------------}ProcedureWstecznaIterDwu2Z(Zn,c:zespolonyT;varZm1,Zm2:zespolonyT);{ Zn=(Zm*Zm)+c => Zm=+-Sqrt(Zn-c) }varZ:zespolonyT;beginRoznicaZ(Zn,c,Z);Pierwiastek2aZ(Z,Zm1,Zm2);end;END.{ modulu DwumianM }{****************************************************}
UNITZespolonyM;INTERFACE{******************************************************************}UsesCrt;TypeZespolonyT=recordRe,Im:doubleend;ProcedureUtworzLZ(x,y:real;varZ:zespolonyT);FunctionZnak(r:real):integer;ProcedureMinusZ(z1:zespolonyT;varz2:zespolonyT);{ liczba przeciwna do z1}ProcedureOdwrotnaZ(z1:zespolonyT;varz2:zespolonyT);ProcedureSumaZ(Z1,Z2:zespolonyT;varZ3:zespolonyT);ProcedureRoznicaZ(Z1,Z2:zespolonyT;varZ3:zespolonyT);ProcedureIloczynZ(Z1,Z2:zespolonyT;varZ3:zespolonyT);ProcedureKwadratZ(Z1:zespolonyT;varZ3:zespolonyT);ProcedureDzielZ(z1,z2:zespolonyT;varz3:zespolonyT);{ z3=z1/z2 }FunctionArgumentZ(Z:zespolonyT):real;FunctionModulZ(Z:zespolonyT):real;FunctionKwModZ(Z:zespolonyT):real;ProcedurePotegaZ(z1:zespolonyT;n:real;varz2:zespolonyT);ProcedurePierwiastek2tZ(Z:zespolonyT;varZ1,Z2:zespolonyT);ProcedurePierwiastek2aZ(Z:zespolonyT;varZ1,Z2:zespolonyT);FunctionOdlegloscZ(Z1,Z2:zespolonyT):real;FunctionKwOdlegloscZ(Z1,Z2:zespolonyT):real;IMPLEMENTATION{**************************************************************}ProcedureUtworzLZ(x,y:real;varZ:zespolonyT);beginZ.Re:=x;Z.Im:=y;end;{-----------------------------------------------------------------------------}FunctionZnak(r:real):integer;beginifr>=0thenznak:=1elseznak:=-1;end;{-----------------------------------------------------------------------------}ProcedureMinusZ(z1:zespolonyT;varz2:zespolonyT);{ liczba przeciwna do z1}beginz2.re:=-z1.re;z2.im:=-z1.im;end;{-----------------------------------------------------------------------------}ProcedureOdwrotnaZ(z1:zespolonyT;varz2:zespolonyT);{ liczba odwrotna do z1}{ z2=1/z1 }varmianownik:real;beginmianownik:=(z1.re*z1.re)+(z1.im*z1.im);ifmianownik=0thenbeginz2.im:=10000;z2.im:=10000;{?}endelsebeginz2.re:=z1.re/mianownik;z2.im:=-z1.im/mianownik;end;end;{-----------------------------------------------------------------------------}ProcedureSumaZ;{ z3=z1+z2 }beginZ3.Re:=Z1.Re+Z2.Re;Z3.Im:=Z1.Im+Z2.Im;end;{----------------------------------------------------------------------------}ProcedureRoznicaZ;{ z3=z1-z2 }beginZ3.Re:=Z1.Re-Z2.Re;Z3.Im:=Z1.Im-Z2.Im;end;{----------------------------------------------------------------------------}ProcedureIloczynZ;{ z3=z1*z2 }beginZ3.Re:=(Z1.Re*Z2.Re)-(Z1.Im*Z2.Im);Z3.Im:=(Z1.Re*Z2.Im)+(Z1.Im*Z2.Re);end;{---------------------------------------------------------------------------}ProcedureKwadratZ;{ z3=z1*z1 }beginZ3.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;{---------------------------------------------------------------------------}ProcedureDzielZ(z1,z2:zespolonyT;varz3:zespolonyT);{ z3=z1/z2 }varmianownik:real;beginmianownik:=(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;{---------------------------------------------------------------------------}FunctionArgumentZ(Z:zespolonyT):real;varA:real;beginif(Z.re=0)or(Z.im=0)thenbeginif(Z.re=0)thenif(Z.im<0)thenArgumentZ:=-Pi/2elseArgumentZ:=Pi/2;if(Z.im=0)thenif(Z.re<0)thenArgumentZ:=PielseArgumentZ:=0;end{ if z.re=0 ... then ... }elsebeginA:=ArcTan(Abs(Z.im/Z.re));if(Z.im<0)thenif(Z.re<0)thenArgumentZ:=-(Pi-A)elseArgumentZ:=-A;if(Z.im>0)thenif(Z.re>0)thenArgumentZ:=AelseArgumentZ:=Pi-A;end;{ if z.re=0 ... else ... }end;{ function ArgumentZ }{----------------------------------------------------------------------------}FunctionModulZ(Z:zespolonyT):real;beginModulZ:=Sqrt(Z.re*Z.re+Z.im*Z.im);end;{---------------------------------------------------------------------------}FunctionKwModZ(Z:zespolonyT):real;{ kwadrat modulu }beginKwModZ:=(Z.Re*Z.Re)+(Z.Im*Z.Im);end;{---------------------------------------------------------------------------}ProcedurePotegaZ(z1:zespolonyT;n:real;varz2:zespolonyT);{ z2= z1 do n-tej potegi }vartemp:real;beginif(z1.re=0.0)and(z1.im=0.0)thenbegin{ zero do potegi n daje zero }z2.im:=0.0;z2.re:=0.0;end{ if ... then }elsebegintemp:=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 }{----------------------------------------------------------------------------}ProcedurePierwiastek2tZ(Z:zespolonyT;varZ1,Z2:zespolonyT);varPierwPromienia,PolowaKata:real;beginPierwPromienia:=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;{---------------------------------------------------------------------------}ProcedurePierwiastek2aZ(Z:zespolonyT;varZ1,Z2:zespolonyT);varpromien:real;signum:integer;beginpromien:=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;{----------------------------------------------------------------------------}FunctionOdlegloscZ(Z1,Z2:zespolonyT):real;beginodlegloscZ:=Sqrt(Sqr(Z2.Re-Z1.Re)+Sqr(Z2.Im-Z1.Im));end;{----------------------------------------------------------------------------}FunctionKwOdlegloscZ(Z1,Z2:zespolonyT):real;beginKwOdlegloscZ:=Sqr(Z2.Re-Z1.Re)+Sqr(Z2.Im-Z1.Im);end;{---------------------------------------------------------------------------}END.{ modulu ZespolonyM }{****************************************************}
unitGrafM;interface{*****************************************************************}constPathToDriver:string='c:\bp\bgi';{ Stores the DOS path to *.BGI & *.CHR }{ lancuch pusty wskazuje na katalog aktualny }{otwieranie trybow graficznych}procedureOpenGraf;{podstawowa procedura, nie wymaga dodatkowych plikow}procedureOpenSvga;{ 1280x1024x256, wymaga svga256.bgi}procedureOpenSvga1;procedureOpenPGraf;{1024 x 768 x 16M wymaga : P_Graph.tpu P_Bench.tpu}ProcedureOpenPGraf1600_256;{1600 x 1200 x 256 }ProcedureOpenSvga1280_64k;{ wymaga svga64.bgi BGI Device Driver (SVGA64K) 1.7 - Aug 23, 1994 Copyright (c) 1990-94 by Jordan Hargraphix }{ kolory 64k }functionRealDrawColor(Color:LongInt):LongInt;functionRealFillColor(Color:LongInt):LongInt;functionRealColor(Color:LongInt):LongInt;functionWhitePixel:LongInt;functionBluePixel:LongInt;functionGreenPixel:LongInt;{kolor 32bit = 16M}functionColorRGB(r,g,b:byte):longInt;implementation{************************************************************}usesCrt,dos,Graph,P_Graph,P_Bench;{Power Graph Library dla funkcji OpenPGraf dostepne w postaci plikow *.tpu a nie *.pas}PROCEDUREOpenGraf;{------------------------------------------------------}{ procedura otwierajaca tryb graficzny. Wybiera aktualny sterownik zgodny z aktualnie uzywanym sterownikiem w Dos'ie oraz tryb wysokiej rozdzielczosci. Turbo Pascasl >= 5.5 }varGraphDriver:integer;{ The Graphics device driver }GraphMode:integer;{ The Graphics mode value }ErrorCode:integer;{ Reports any graphics errors }BEGINrepeatGraphDriver:=Detect;{ use autodetection }InitGraph(GraphDriver,GraphMode,PathToDriver);ErrorCode:=GraphResult;{ preserve error return }ifErrorCode<>grOKthenbeginWriteLn('blad podczas inicjowania trybu graficznego');WriteLn('kod bledu=',ErrorCode);Writeln('Graphics error: ',GraphErrorMsg(ErrorCode));ifErrorCode=grFileNotFound{ obsluga bledu 'nie ma *.bgi lub *.chr'}thenbeginWriteln('Enter full path to BGI driver or type <Ctrl-Break> to quit:');Readln(PathToDriver);Writeln;endelseHalt(1);{ Some other error: terminate }end;untilErrorCode=grOK;END;{----------- Procedure OpenGraf -----------------------------------------}ProcedureOpenSvga;{otwiera TRYB GRAFiczzny ; užywa niestandardowy sterownik svga256.bgi }varGraphDriver,GraphMode,ErrorCode:integer;{$F+}functiontryb:Integer;begintryb:=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-}beginrepeatGraphDriver:=InstallUserDriver('SVGA256',@tryb);GraphDriver:=Detect;{ use autodetection }InitGraph(GraphDriver,GraphMode,PathToDriver);ErrorCode:=GraphResult;{ preserve error return }ifErrorCode<>grOKthenbeginWriteLn('blad podczas inicjowania trybu graficznego');WriteLn('kod bledu=',ErrorCode);Writeln('Graphics error: ',GraphErrorMsg(ErrorCode));ifErrorCode=grFileNotFound{ obsluga bledu 'nie ma *.bgi lub *.chr'}thenbeginWriteln('Enter full path to BGI driver or type <Ctrl-Break> to quit:');Readln(pathToDriver);Writeln;endelseHalt(1);{ Some other error: terminate }end;untilErrorCode=grOK;end;{-------------- Procedur OpenSvga --------------------------------------}ProcedureOpensvga1;varGraphDriver,GraphMode,ErrorCode:integer;{..................................................................}functionCzyVesa(NrTrybu:word):boolean;{ sprawdza czy sterownik graficzny jest zgodny ze standardem VESA }{ i czy dostepny jest dany tryb }TYPEListaTrybowTyp=Array[1..$7FFF]ofword;ListaTrybowWsk=^ListaTrybowTyp;NazwaProdTyp=Array[1..$FFFF]ofchar;NazwaProdWsk=^NazwaProdTyp;{ struktura bufora na informacje o SVGA }BuforTyp=RecordSygnatura:Array[1..4]ofchar;NrWersji:Word;NazwaProd:NazwaProdWsk;Inform:LongInt;ListaTrybow:ListaTrybowWsk;Zarezerwowane:Array[1..238]ofByte;End;VARBufor:BuforTyp;Regs:Registers;Idx:Word;Jest:Boolean;BEGIN{ cialo funkcji CzyVesa }CzyVesa:=False;WithRegsdobegin{ odczytanie informacji o SVGA }AX:=$4F00;{ nr funkcji VESA }ES:=Seg(Bufor);{ adres bufora na informacje }DI:=Ofs(Bufor);end;Intr($10,Regs);IfRegs.Ax=$004FThen{ funkcja jest dostepna }BeginIdx:=0;Jest:=False;WithBuforDo{przeszukiwanie listy trybow }While(ListaTrybow^[Idx]<>$FFFF)and(NotJest)DoBeginJest:=ListaTrybow^[Idx]=NrTrybu;Inc(Idx);End;CzyVesa:=Jest;End;END;{ funkcji CzyVesa }{..........................................................................}beginifCzyVesa($105){sprawdza czy dostepny jest tryb VESA : 1024 x 768 }thenOpenSvga{ 1024 x 768 x 256 }elseOpenGraf;{ 640 x 480 x 16 }end;{-------------- Procedur OpenSvga1 --------------------------------------}ProcedureOpenPGraf;{1024 x 768 x 16M }FunctionSelectMode:word;{wymaga niestandardowych modulow P_Graph,P_Bench zawierajacych biblioteke Power Graf Library }VarP:Byte;C:Char;M:Word;MN:Byte;X:Byte;MD:Array[1..50]ofWord;b:boolean;bpp:byte;Beginc:='4';{1024 x 768 }bpp:=32;{ 32 bits per pixel = 16M}MN:=0;ForP:=0toPTotalModedoBeginb:=PGetModeInfo(PModeID[P]);IfPModeInfo.BitsPPixel=BppThenBeginInc(MN);TextAttr:=10;MD[MN]:=PModeID[P];End;End;x:=Byte(c)-48;M:=MD[x];SelectMode:=M;End;{Function SelectMode }beginIfNotPSetMode(SelectMode)ThenHalt;end;{Procedure OpenPGraf;}{ PPutPixel(x,y,100); }{****************************************************************************}ProcedureOpenPGraf1600_256;{1600 x 1200 x 256 }FunctionSelectMode:word;{wymaga niestandardowych modulow P_Graph,P_Bench zawierajacych biblioteke Power Graf Library }VarP:Byte;C:Char;M:Word;MN:Byte;X:Byte;MD:Array[1..50]ofWord;b:boolean;bpp:byte;Beginc:='9';{1600 x 1200 }bpp:=8;{ 8 bits per pixel = 256}{ moze byc i 16 bpp = 64 k}MN:=0;ForP:=0toPTotalModedoBeginb:=PGetModeInfo(PModeID[P]);IfPModeInfo.BitsPPixel=BppThenBeginInc(MN);TextAttr:=10;MD[MN]:=PModeID[P];End;End;x:=Byte(c)-48;M:=MD[x];SelectMode:=M;End;{Function SelectMode }beginIfNotPSetMode(SelectMode)ThenHalt;end;{Procedure OpenPGraf;}{ PPutPixel(x,y,100); }{****************************************************************************}ProcedureOpenSvga1280_64k;{otwiera TRYB GRAFiczzny ; užywa niestandardowy sterownik svga64.bgi }varGraphDriver,GraphMode,GrErr:integer;{$F+}functionDetectVGA64k:Integer;beginDetectVGA64k:=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 }ifGrErrAND$80=$80thenGrErr:=GrErrOR$ff00;ifGrErr<>grOKthenbeginWriteln('Graphics error: ',GraphErrorMsg(GrErr));Halt(1);end;end;{----------------------------------------------------------------}{-------------- kolory 64 k --------------}functionRealDrawColor(Color:LongInt):LongInt;varMaxC:Longint;beginMaxC:=GetMaxColor;if(MaxC=65535)thenSetRgbPalette(1024,(ColorSHR11)AND31,(ColorSHR5)AND63,ColorAND31)elseif(MaxC=32767)thenSetRgbPalette(1024,(ColorSHR10)AND31,(ColorSHR5)AND31,ColorAND31)elseif(MaxC=16777)thenbeginSetRgbPalette(1024,(ColorSHR16)AND255,(ColorSHR8)AND255,ColorAND255);end;RealDrawColor:=Color;end;{ uzycie liczby w setcolor nie dziaa uzyj realDrawColor : setcolor(realDrawColor(65000));}functionRealFillColor(Color:LongInt):LongInt;varMaxC:Longint;beginMaxC:=GetMaxColor;if(MaxC=65535)thenSetRgbPalette(1025,(ColorSHR11)AND31,(ColorSHR5)AND63,ColorAND31)elseif(MaxC=32767)thenSetRgbPalette(1025,(ColorSHR10)AND31,(ColorSHR5)AND31,ColorAND31)elseif(MaxC=16777)thenbeginSetRgbPalette(1025,(ColorSHR16)AND255,(ColorSHR8)AND255,ColorAND255);Color:=0;end;RealFillColor:=Color;end;functionRealColor(Color:LongInt):LongInt;varMaxC:Longint;beginMaxC:=GetMaxColor;if(MaxC=65535)thenSetRgbPalette(1026,(ColorSHR11)AND31,(ColorSHR5)AND63,ColorAND31)elseif(MaxC=32767)thenSetRgbPalette(1026,(ColorSHR10)AND31,(ColorSHR5)AND31,ColorAND31)elseif(MaxC=16777)thenbeginSetRgbPalette(1026,(ColorSHR16)AND255,(ColorSHR8)AND255,ColorAND255);Color:=0;end;RealColor:=Color;end;functionWhitePixel:LongInt;varClr:LongInt;beginClr:=GetMaxColor;if(Clr=65535)thenClr:=$FFFFelseif(Clr=32767)thenClr:=$7FFFelseif(Clr=16777)thenClr:=$ffffffelseClr:=15;WhitePixel:=Clr;end;functionBluePixel:LongInt;varClr:LongInt;beginClr:=GetMaxColor;if(Clr=65535)thenClr:=$1Felseif(Clr=32767)thenClr:=$1Felseif(Clr=16777)thenClr:=$ffelseClr:=1;BluePixel:=Clr;end;functionGreenPixel:LongInt;varClr:LongInt;beginClr:=GetMaxColor;if(Clr=65535)thenClr:=63SHL5elseif(Clr=32767)thenClr:=31SHL5elseif(Clr=16777)thenClr:=$ff00elseClr:=2;GreenPixel:=Clr;end;{}functionColorRGB(r,g,b:byte):longInt;begincolorRGB:=(bor(gshl8)or(rshl16));end;{color:=PFindRGB(0,0,0) z modulu Power Graphic Library}End.{********************************************************************}{jezyk programowania Turbo Pascal 7.0 firmy Borlandstyl : proceduralnydla 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] |*===============================*===========================================* }
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 )}UnitPrinterM;{ obsluga drukarki Hewlett Packard DeskJet 550C w jezyku PCL level III }INTERFACE{****************************************************************}usesdos,graph;constLPT1=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';varrejestr:registers;ProcedureWriteLst(tekst:string);ProcedureTestDrukarki;ProcedureKopiaEkranuP(XminWydruku,YminWydruku,RozdzielczoscWydruku:integer);ProcedureKopiaEkranuP1;IMPLEMENTATION{************************************************************}ProcedureWriteLst(tekst:string);vari:integer;beginwithrejestrdofori:=1toLength(tekst)dobeginAh:=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 }{...........................................................................}ProcedureTestDrukarki;{ dziala w trybie tekstowym }beginrejestr.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 }ifrejestr.ah=144{ 10010000B tj. (bit 7) =1 i (bit 4) =1 }thenwriteLn('Printer on LPT1 is OK')elsewriteLn('Printer on LPT1 is not OK');WriteLst(Reset);end;{ Procedure TestDrukarki }{..........................................................................}ProcedureKopiaEkranuP(XminWydruku,YminWydruku,RozdzielczoscWydruku:integer);constwaga:array[0..7]ofbyte=(1,2,4,8,16,32,64,128);varXmax,Ymax,x,y:integer;LiczbaBajtowL,RozdzWydrukuL,XminWydrukuL,YminWydrukuL:string;bajt:byte;beginWriteLst(PortraitPageOrientation);{--------------------- wielkosc ekranu ---------------------------------}Xmax:=GetMaxX;Ymax:=GetMaxY;{--------------------- liczba bajtow w jednym poziomym pasmie ----------}Str((Xmaxdiv8)+1,LiczbaBajtowL);{--------------------- rozdzielczosc wydruku ---------------------------}CaseRozdzielczoscWydrukuof75,100,150,300:Str(RozdzielczoscWydruku,RozdzWydrukuL);elseifXmax<=319thenRozdzWydrukuL:='75'elseifXmax<=639thenRozdzWydrukuL:='100'elseRozdzWydrukuL:='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);{----------------------------------------------------------------------}Fory:=0toYmaxdobeginbajt:=0;WriteLst(Escape+'*b'+LiczbaBajtowL+'W');{ transfer raster graphics }Forx:=0toXmaxdobeginIfGetPixel(x,y)<>blackthenBajt:=Bajt+Waga[7-(xmod8)];If(xmod8)=7thenbeginWriteLst(Chr(bajt));Bajt:=0;end;{ If ( x mod 8 ) ... }end;{ for x:=0 ... }end;{ for y:=0 ... }{---------------------------------------------------------------------}WriteLst(EndGraphics);WriteLst(FormFeed);end;{ Procedure KopiaEkranuP }{..........................................................................}ProcedureKopiaEkranuP1;constwaga:array[0..7]ofbyte=(1,2,4,8,16,32,64,128);RozdzielczoscWydruku='75';{ dpi= dots per inch, jako lancuch }varXmax,Ymax,x,y:integer;LiczbaBajtowL,RozdzWydrukuL:string;bajt:byte;kolor:word;beginWriteLst(PortraitPageOrientation);{--------------------- wielkosc ekranu ---------------------------------}Xmax:=GetMaxX;Ymax:=GetMaxY;{--------------------- liczba bajtow w jednym poziomym pasmie ----------}Str((Xmaxdiv8)+1,LiczbaBajtowL);{--------------------- rozdzielczosc wydruku ---------------------------}WriteLst(Escape+'*t'+RozdzielczoscWydruku+'R');{------------------- pozycja kursora -----------------------------------}WriteLst(StartGraphicsAtLeft);{----------------------------------------------------------------------}Fory:=0toYmaxdobeginbajt:=0;WriteLst(Escape+'*b'+LiczbaBajtowL+'W');{ transfer raster graphics }Forx:=0toXmaxdobeginIfGetPixel(x,y)<>blackthenBajt:=Bajt+Waga[7-(xmod8)];If(xmod8)=7thenbeginWriteLst(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}
UnitbmpM;{this unit is to deal with bitmaps32 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: PCOS: Microsoft windows 98language: Pascalcompiler:IDE:Borland Pascal v. 7.0style: 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}InterfaceType{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=RecordID:_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=RecordInfoHeaderSize:_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:byteend;Vardirectory,bmpFileName:string;bmpFile:File;{ untyped file}bmpFileHeader:TbmpFileHeader;bmpInfoHeader:TbmpInfoHeader;color32:T32Color;RowSizeInBytes:integer;BytesPerPixel:integer;constdefaultBmpFileName='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;ProcedureCreateBmpFile32(directory:string;FileName:string;iWidth,iHeight:_LongInt);{************************************************}Implementation{-----------------------------}{************************************************}ProcedureCreateBmpFile32(directory:string;FileName:string;iWidth,iHeight:_LongInt);varx,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}withbmpInfoHeader,bmpFileHeaderdobeginID:=19778;InfoheaderSize:=40;width:=100;height:=100;BitsPerPixel:=32;BytesPerPixel:=BitsPerPixeldiv8;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}fory:=(height-1)downto0dobeginforx:=0to(width-1)dobegin{ 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}{--------------------------------------------------------}ProcedureScreenCopy(directory:string;FileName:string;iWidth,iHeight:_LongInt);varx,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}withbmpInfoHeader,bmpFileHeaderdobeginID:=19778;InfoheaderSize:=40;width:=100;height:=100;BitsPerPixel:=32;BytesPerPixel:=BitsPerPixeldiv8;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}fory:=(height-1)downto0dobeginforx:=0to(width-1)dobegin{ 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.