Занимательная графика Опции

[BlackShadow]

В этой теме приведены исходники, отрисовывающие следующие фигуры:

1. "Архимедова спираль" (ниже в этом же сообщении)
   
   
2. 
   Исходник для Турбо Паскаля (процедуры)
   Исходник для Турбо Паскаля (ООП)
   Отрисовка только прямыми линиями
   
   
3. 
   Исходник для FPC
   
   
4. 
   
   
5. 
   
   
6. 
   
   
7. 
   Фрактальные деревья
   
   
8. "Фигуры Лиссажу"
9. Пример RGB графики в режиме 13h

Архимедова спираль

Параметрическое представление спирали: x = r cos t , y = r sin t, r = t/2

Если количество витков = n, то T пробегает от 0 до n*2*pi. r растёт от 0 до R_max (данный внешний радиус), и пропорционален T. Тогда r = T/(n*2*pi)*R_max.

Uses Graph, Crt;

Const
  r_max = 200;
  n = 7;
Var
  gr, gm: Integer;
  i, k: Integer;
  ZeroX, ZeroY: Integer;
  x, y, r, t: Double;

begin
  gr := Detect;

  InitGraph(gr, gm, '');
  k := n * 140;

  ZeroX := Round(GetMaxX/2);
  ZeroY := Round(GetMaxY/2);
  {MoveTo(ZeroX, ZeroY);}
  For i := 1 To k Do
    Begin
      T := (n * 2 * Pi) * i / k;
      r := T / (n * 2 * Pi) * r_max;
      x := r * Cos(T);
      y := r * Sin(T);
      PutPixel(ZeroX + Round(x), ZeroY - Round(y), White)
    End;
  ReadKey;
  CloseGraph;
end.

[volvo]

Можно задавать разное количество вершин и коэффициент...

{$N+}

Uses Graph;

Type
  TPoint =
    Record
      X, Y: Integer;
    End;

  PArrPoint = ^arrPoint;
  arrPoint =
    Array[1 .. maxInt Div SizeOf(TPoint)] Of TPoint;

  TFigure =
    Object
      nPoints: Byte;
      arr: PArrPoint;

      p: Integer;
      a: Double;

      Constructor Init(np: Integer;
        pVal: Integer; aVal: Double);
      Destructor Done;
      Procedure Run;

    Private
      Procedure InitPoints;

      Function Recalc: Boolean;
      Procedure Draw;
    End;

Constructor TFigure.Init(np: Integer;
            pVal: Integer; aVal: Double);
  Begin
    nPoints := np;
    a := aVal; p := pVal;
    GetMem(arr, nPoints * SizeOf(TPoint));

    InitPoints
  End;

Destructor TFigure.Done;
  Begin
    FreeMem(arr, nPoints * SizeOf(TPoint));
  End;

Procedure TFigure.InitPoints;

  Const
    RadToGrad = (180 / Pi);

  Procedure GetPoint(Var P: TPoint;
            Len: Integer; phi: Integer);
    Var fPhi: Double;
    Begin
      fPhi := phi / RadToGrad;
      P.X := (GetMaXX div 2) + Trunc(Len * Sin(fPhi));
      P.Y := (GetMaxY div 2) - Trunc(Len * Cos(fPhi));
    End;

  Var
    i, Len, phi: Integer;
    x: Double;
  Begin
    phi := 360 div nPoints;
    x := Cos(phi / RadToGrad);
    Len := Trunc(p / Sqrt(2* (1 - x)));

    For i := 1 To nPoints Do
      GetPoint(arr^[i], Len, Pred(i) * phi);
  End;

Function TFigure.Recalc: Boolean;
  Var
    T: PArrPoint;
    i, next: Integer;
  Begin
    GetMem(T, nPoints * SizeOf(TPoint));
    For i := 1 To nPoints Do
      Begin
        If i = nPoints Then next := 1 Else next := Succ(i);

        T^[i].x := Trunc((arr^[i].x + a*arr^[next].x) / (1 + a));
        T^[i].y := Trunc((arr^[i].y + a*arr^[next].y) / (1 + a));
      End;
    Recalc := (T^[1].x <> arr^[1].x);

    Move(T^, arr^, nPoints * SizeOf(TPoint));
    FreeMem(T, nPoints * SizeOf(TPoint))
  End;

Procedure TFigure.Draw;

  Procedure DrawLine( p1, p2: TPoint );
    Begin
      Line( p1.X, p1.Y, p2.X, p2.Y )
    End;

  Var
    i, next: Integer;
  Begin
    For i := 1 To nPoints Do
      Begin
        next := Succ(i);
        If i = nPoints Then next := 1;
        DrawLine( arr^[i], arr^[next] );
      End;
  End;


Procedure TFigure.Run;
  Begin
    Repeat
      Draw
    Until not ReCalc;
    ReadLn
  End;


Var
  f: TFigure;

  grDriver, grMode, ErrCode: Integer;
Begin
  grDriver := Detect;
  InitGraph(grDriver, grMode, '');
  ErrCode := GraphResult;
  If ErrCode <> grOk Then
    Begin
      WriteLn('Graphic Error: ', GraphErrorMsg(ErrCode));
      Halt(100)
    End;

  { 7 вершин, длина каждой стороны = 140, коэффициент = 0.05 }
  f.Init( 7, 140, 0.05 );
  f.Run;
  f.Done;

  CloseGraph;
End.

Скачать исходник:  poly.pas ( 2.75 килобайт ) Кол-во скачиваний: 1982