Оригинальный DVD-ROM: eXeL@B DVD !
eXeL@B ВИДЕОКУРС !

Курс видеоуроков КРЭКЕРСТВО + ПРОГРАММИРОВАНИЕ 2017
(актуальность: апрель 2017)
Свежие инструменты, новые видеоуроки!

  • 400+ видеоуроков
  • 800 инструментов
  • 100+ свежих книг и статей

УЗНАТЬ БОЛЬШЕ >>
Домой | Статьи | RAR-cтатьи | FAQ | Форум | Скачать | Видеокурс
Новичку | Ссылки | Программирование | Интервью | Архив | Связь

БОЛЬШОЙ FAQ ПО DELPHI



Рисование фрактальных графов

Автор: Михаил Марковский

...Очередная нетленка, которую я предлагаю Вам, написана мной самостоятельно (идею и примеры, реализованные в программе, я нашел в апрельском номере журнала "Химия и жизнь" за 1995 год). Теоретически она производит трансляцию L-систем с выводом образовавшихся фрактальных графов, а практически рисует кусты и деревья. Вроде бесполезно, но очень красиво. Эта программа написана для TP7, хотя легко переносится на Delphi (как то я уже переводил ее, но модуль бесследно исчез). Буду надеяться, что она придется Вам по душе.


 uses graph, crt;
 
 const
   GrafType = 1; {1..3}
 
 type
   PointPtr = ^Point;
   Point = record
     X, Y: Word;
     Angle: Real;
     Next: PointPtr
   end;
   GrfLine = array[0..5000] of
     Byte;
   ChangeType = array[1..30] of
     record
     Mean: Char;
     NewString: string
   end;
 
 var
   K, T, Dx, Dy, StepLength, GrafLength: Word;
   grDriver, Xt: Integer;
   grMode: Integer;
   ErrCode: Integer;
   CurPosition: Point;
   Descript: GrfLine;
   StartLine: string absolute Descript;
   ChangeNumber, Generation: Byte;
   Changes: ChangeType;
   AngleStep: Real;
   Mem: Pointer;
 
 procedure Replace(var Stroka: GrfLine;
   OldChar: Char;
   Repl: string);
 var
   I, J: Word;
 begin
   if (GrafLength = 0) or (Length(Repl) = 0) then
     Exit;
   I := 1;
   while I <= GrafLength do
   begin
     if Chr(Stroka[I]) = OldChar then
     begin
       for J := GrafLength downto I + 1 do
         Stroka[J + Length(Repl) - 1] := Stroka[J];
       for J := 1 to Length(Repl) do
         Stroka[I + J - 1] := Ord(Repl[J]);
       I := I + J;
       GrafLength := GrafLength + Length(Repl) - 1;
       continue
     end;
     I := I + 1
   end
 end;
 
 procedure PushCoord(var Ptr: PointPtr;
 
   C: Point);
 var
 
   P: PointPtr;
 begin
 
   New(P);
   P^.X := C.X;
   P^.Y := C.Y;
   P^.Angle := C.Angle;
   P^.Next := Ptr;
   Ptr := P
 end;
 
 procedure PopCoord(var Ptr: PointPtr;
 
   var Res: Point);
 begin
 
   if Ptr <> nil then
   begin
     Res.X := Ptr^.X;
     Res.Y := Ptr^.Y;
     Res.Angle := Ptr^.Angle;
     Ptr := Ptr^.Next
   end
 end;
 
 procedure FindGrafCoord(var Dx, Dy: Word;
 
   Angle: Real;
   StepLength: Word);
 begin
 
   Dx := Round(Sin(Angle) * StepLength * GetMaxX / GetMaxY);
   Dy := Round(-Cos(Angle) * StepLength);
 end;
 
 procedure NewAngle(Way: ShortInt;
 
   var Angle: Real;
   AngleStep: Real);
 begin
 
   if Way >= 0 then
     Angle := Angle + AngleStep
   else
     Angle := Angle - AngleStep;
   if Angle >= 4 * Pi then
     Angle := Angle - 4 * Pi;
   if Angle < 0 then
     Angle := 4 * Pi + Angle
 end;
 
 procedure Rost(var Descr: GrfLine;
 
   Cn: Byte;
   Ch: ChangeType);
 var
   I: Byte;
 begin
 
   for I := 1 to Cn do
     Replace(Descr, Ch[I].Mean, Ch[I].NewString);
 end;
 
 procedure Init1;
 begin
 
   AngleStep := Pi / 8;
   StepLength := 7;
   Generation := 4;
   ChangeNumber := 1;
   CurPosition.Next := nil;
   StartLine := 'F';
   GrafLength := Length(StartLine);
   with Changes[1] do
   begin
     Mean := 'F';
     NewString := 'FF+[+F-F-F]-[-F+F+F]'
   end;
 end;
 
 procedure Init2;
 begin
 
   AngleStep := Pi / 4;
   StepLength := 3;
   Generation := 5;
   ChangeNumber := 2;
   CurPosition.Next := nil;
   StartLine := 'G';
   GrafLength := Length(StartLine);
   with Changes[1] do
   begin
     Mean := 'G';
     NewString := 'GFX[+G][-G]'
   end;
   with Changes[2] do
   begin
     Mean := 'X';
     NewString := 'X[-FFF][+FFF]FX'
   end;
 end;
 
 procedure Init3;
 begin
 
   AngleStep := Pi / 10;
   StepLength := 9;
   Generation := 5;
   ChangeNumber := 5;
   CurPosition.Next := nil;
   StartLine := 'SLFF';
   GrafLength := Length(StartLine);
   with Changes[1] do
   begin
     Mean := 'S';
     NewString := '[+++G][---G]TS'
   end;
   with Changes[2] do
   begin
     Mean := 'G';
     NewString := '+H[-G]L'
   end;
   with Changes[3] do
   begin
     Mean := 'H';
     NewString := '-G[+H]L'
   end;
   with Changes[4] do
   begin
     Mean := 'T';
     NewString := 'TL'
   end;
   with Changes[5] do
   begin
     Mean := 'L';
     NewString := '[-FFF][+FFF]F'
   end;
 end;
 
 begin
 
   case GrafType of
     1: Init1;
     2: Init2;
     3: Init3;
   else
   end;
   grDriver := detect;
   InitGraph(grDriver, grMode, '');
   ErrCode := GraphResult;
   if ErrCode <> grOk then
   begin
     WriteLn('Graphics error:', GraphErrorMsg(ErrCode));
     Halt(1)
   end;
   with CurPosition do
   begin
     X := GetMaxX div 2;
     Y := GetMaxY;
     Angle := 0;
     MoveTo(X, Y)
   end;
   SetColor(white);
   for K := 1 to Generation do
   begin
     Rost(Descript, ChangeNumber, Changes);
     Mark(Mem);
     for T := 1 to GrafLength do
     begin
       case Chr(Descript[T]) of
         'F':
           begin
             FindGrafCoord(Dx, Dy, CurPosition.Angle, StepLength);
             with CurPosition do
             begin
               Xt := X + Dx;
               if Xt < 0 then
                 X := 0
               else
                 X := Xt;
               if X > GetMaxX then
                 X := GetMaxX;
               Xt := Y + Dy;
               if Xt < 0 then
                 Y := 0
               else
                 Y := Xt;
               if Y > GetMaxY then
                 Y := GetMaxY;
               LineTo(X, Y)
             end
           end;
         'f':
           begin
             FindGrafCoord(Dx, Dy, CurPosition.Angle, StepLength);
             with CurPosition do
             begin
               Xt := X + Dx;
               if Xt < 0 then
                 X := 0
               else
                 X := Xt;
               if X > GetMaxX then
                 X := GetMaxX;
               Xt := Y + Dy;
               if Xt < 0 then
                 Y := 0
               else
                 Y := Xt;
               if Y > GetMaxY then
                 Y := GetMaxY;
               MoveTo(X, Y)
             end
           end;
         '+': NewAngle(1, CurPosition.Angle, AngleStep);
         '-': NewAngle(-1, CurPosition.Angle, AngleStep);
         'I': NewAngle(1, CurPosition.Angle, 2 * Pi);
         '[': PushCoord(CurPosition.Next, CurPosition);
         ']':
           begin
             PopCoord(CurPosition.Next, CurPosition);
             with CurPosition do
               MoveTo(X, Y)
           end
       end
     end;
     Dispose(Mem);
     Delay(1000)
   end;
   repeat
   until KeyPressed;
   CloseGraph
 end.
 




<< ВЕРНУТЬСЯ В ОГЛАВЛЕНИЕ



Материалы находятся на сайте https://exelab.ru/pro/



Оригинальный DVD-ROM: eXeL@B DVD !


Вы находитесь на EXELAB.rU
Проект ReactOS