Object Pascal/Przykłady kodu

Program czytający ciąg znaków i informujący, czy jego długość jest liczbą parzystą czy nieparzystą.

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.

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.

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ść.

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.

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

{$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

Diagram bifurkacyjny

program rysuje diagram bifurkacyjny funkcji $y_{n+1}=y_{n}^{2}+x$

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

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 pˆaszczyzny 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
              {okre˜la 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);


  { ................okre˜la 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

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

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

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

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 dziaˆa
  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

PCL (Printer Command Language) 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

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.