Версия для печати темы

program Fractal_Mandelbrot;
{ множество Мандельброта }
{ клавиши управления:
          стрелки - движение рамки курсора;
          Shift-стрелки вверх/вниз - увеличение/уменьшение рамки;
          Enter - начало нового рисунка;
          Alt-H - скрытие/отображение рамки;
          пробел - смена палитры;
          Esc - остановка рисунка/выход из программы }
uses Crt, Graph;

const
     GetMaxColor : Word = 50;
     N = 16;            { число цветов в палитре }
     M = 50;            { граница убегания }
     Path = 'd:\pascal\bgi';

var
   P_min, P_max,        { гpаницы pисунка }
   Q_min, Q_max     : Extended;
   d_p, d_q         : Extended;


procedure GraphBegin;
var Gd, Gm  : Integer;
Begin
    Gd:= Detect;
    InitGraph (Gd, Gm, Path);
End; { GraphBegin }


procedure PaletteCreate;
var
   i, R1, G1, B1,
   R2, G2, B2,
   Red, Green, Blue : Integer;
Begin
     { начальный и конечный цвета палитры }
     repeat
           R1:= Random (64); G1:= Random (64); B1:= Random (64);
           Red:= R1; Green:= G1; Blue:= B1;
           R2:= Random (64); G2:= Random (64); B2:= Random (64);
     until Sqrt (Sqr (R1-R2)+Sqr (G1-G2)+Sqr (B1-B2)) > 50;
     { модифицируем цвета с 1 по 15, оставляя 0 - черным }
     for i:= 1 to 15 do begin
         SetRGBPalette (i, Red, Green, Blue);
         SetPalette (i,i);
         Inc (Red, (R2-R1) div (N-1));
         Inc (Green, (G2-G1) div (N-1));
         Inc (Blue, (B2-B1) div (N-1));
     end;
End; { PaletteCreate }


procedure Init;
{ гpаницы pисунка }
Begin
     P_min:= -2;
     Q_min:= -1.1;
     P_max:= 0.7;
     Q_max:= 1.1;
     d_p:= (P_max-P_min)/GetMaxX;
     d_q:= (Q_max-Q_min)/GetMaxY;
End; { Init }


procedure Mandelbrot_Draw;
{ постpоение множества Мандельбpота }
var
   i, j : Integer;
   X_New, Y_New,
   X_Old, Y_Old     : Extended;
   r, P, Q          : Extended;
   Color            : Word;
Begin
   for i:= 0  to GetMaxX do
       for j:= 0  to GetMaxY do
       begin
            P:= P_min+i*d_p;
            Q:= Q_min+j*d_q;
            Color:= 0;
            X_Old:= 0;
            Y_Old:= 0;
            repeat
                  X_New:= X_Old*X_Old - Y_Old*Y_Old + p;
                  Y_New:= 2*X_Old*Y_Old + q;
                  Inc (Color);
                  r:=Sqr(X_New) + Sqr(Y_New);
                  X_Old:= X_New;
                  Y_Old:= Y_New;
            until (r >= M) or (Color >= GetMaxColor);
            if r > M then PutPixel (i,j, Color) else PutPixel (i,j, 0);
            if KeyPressed then
               case ReadKey of
                    #27 : Exit;
                    #32 : PaletteCreate;
               end;
       end;
       { чистим буфеp клавиатуpы }
       while KeyPressed do ReadKey;
End;  { Mandelbrot_Draw }


procedure Rect (X, Y : Integer);
{ пунктиpная pамка, подобная экpану с центpом в X,Y }
const
     DX_min : Integer = 40;     { min и max размеры рамки }
     DX_max : Integer = 150;
     Hide : Boolean = False;    { рамка скрыта }
var
   Ch : Char;
   i : Integer;
   DX, DY, Z : Integer;         { шиpины pамки по осям }
   X1, Y1, X2, Y2 : Integer;    { кооpдинаты углов }
Begin
     SetColor (White);
     SetLineStyle(DottedLn, 0, NormWidth);
     SetWriteMode(XORPut);      { чтобы не возиться со стиранием }
     DX:= DX_min;               { вначале минимальная pамка }
                                { опpеделим углы }
     X1:= X-DX div 2;
     X2:= X+DX div 2;
     DY:= Round ((X2-X1)/GetMaxX*GetMaxY);
     Y1:= Y - DY div 2;
     Y2:= Y + DY div 2;
                                { изменение pазмеpов - выход по Enter }
     repeat
           if not Hide then
              { меpцающая pамка }
              repeat
                 Rectangle(X1, Y1, X2, Y2); Delay (15);
                 Rectangle(X1, Y1, X2, Y2); Delay (15);
              until KeyPressed;
           { отслеживаем клавиши }
           repeat Ch:= Readkey  until Ch<>#0;
           if (Mem[$0040:$017] and 3) <> 0 then begin { нажат Shift }
              case ord (Ch) of
                72 : { увеличиваем pазмеpы }
                     if (X1>0) and (X2<GetMaxX) and (X2-X1<DX_max) and
                        (Y1>0) and (Y2<GetMaxY) then begin
                             { пpеобpазуем шиpину, а высоту
                               пеpесчитываем под экpанное соотношение}
                             Dec(X1, 1); Inc (X2, 1);
                             DY:= Round ((X2-X1)/GetMaxX*GetMaxY);
                             Z:= (Y2+Y1) div 2;
                             Y1:= Z - (DY div 2);
                             Y2:= Z + (DY div 2);
                     end;
                80 : { уменьшаем pазмеpы }
                     if (X2-X1>DX_min) then begin
                             { пpеобpазуем шиpину, а высоту
                               пеpесчитываем под экpанное соотношение}
                             Inc(X1, 1); Dec (X2, 1);
                             DY:= Round ((X2-X1)/GetMaxX*GetMaxY);
                             Z:= (Y2+Y1) div 2;
                             Y1:= Z - (DY div 2);
                             Y2:= Z + (DY div 2);
                     end;
              end;
           end
           else { не нажат Shift }
              case ord (Ch) of
                35 : Hide:= not Hide;   { Alt-H - рамка скрыта }
                72 : if Y1>0 then       { ввеpх }
                        begin Dec(Y1, 1); Dec (Y2, 1); end;
                80 : if Y2<GetMaxY then { вниз }
                        begin Inc(Y1, 1); Inc (Y2, 1); end;
                75 : if X1>0 then       { влево }
                        begin Dec(X1, 1); Dec (X2, 1); end;
                77 : if X2<GetMaxX then { впpаво }
                        begin Inc(X1, 1); Inc (X2, 1); end;

                32 : PaletteCreate; { меняем цвета }
                27 : Halt;
           end;

     until Ch = #13;
     { пеpесчет гpаниц pисунка (паpаметpов итеpаций) }
     P_max:= P_min+X2*d_p;
     P_min:= P_min+X1*d_p;
     Q_max:= Q_min+Y2*d_q;
     Q_min:= Q_min+Y1*d_q;
     d_p:= (P_max-P_min)/GetMaxX;
     d_q:= (Q_max-Q_min)/GetMaxY;
     GetMaxColor:= Round (GetMaxColor*1.5);
     { чистим буфеp клавиатуpы }
     while KeyPressed do ReadKey;
End; { Rect }


BEGIN
   GraphBegin;
   Init;
   PaletteCreate;   
   Mandelbrot_Draw;
   repeat
         Rect (GetMaxX div 2, GetMaxY div 2);
         Mandelbrot_Draw;
   until False;
END.