IPB
ЛогинПароль:

> Внимание! Действует предмодерация

Подраздел FAQ (ЧАВО, ЧАстые ВОпросы) предназначен для размещения готовых рабочих программ, реализаций алгоритмов. Это нечто вроде справочника, он наполнялся в течение 2000х годов. Ваши вопросы, особенно просьбы решить задачу, не пройдут предмодерацию. Те, кто наполнял раздел, уже не заходят на форум, а с теми, кто на форуме сейчас, лучше начинать общение в других разделах. В частности, решение задач — здесь.

> Занимательная графика
сообщение
Сообщение #1


Гость






В этой теме приведены исходники, отрисовывающие следующие фигуры:
  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.
 К началу страницы 
+ Ответить 
 
 Ответить  Открыть новую тему 
Ответов
сообщение
Сообщение #2


Знаток
****

Группа: Пользователи
Сообщений: 303
Пол: Мужской
Реальное имя: Роман

Репутация: -  2  +


Это код для FPC:
program Uzor;
Uses Windows, WinCRT,
Graph;

Const
m = 0.1;
Max = 20;

type
TPolygon = record
Pol: Array [0..10] of PointType;
Size: word;
end;

Var
Length,
Color,
x0,y0 : word;

procedure InitGr;
var gd,gm: smallint;
begin
gd := Detect;
InitGraph (gd, gm, '..\bgi');
if Graphresult <> 0 then
Halt;
end;

procedure Rotate2D( var P: TPolygon; Angle: single);
var
_cos,_sin: single;
k: word;
xx,yy: integer;
begin
_cos := cos (Angle);
_sin := sin (Angle);
for k := 0 to P.Size - 1 do
with P.Pol[k] do
begin
xx := round (x * _cos + y * _sin);
yy := round (y * _cos - x * _sin);
x := x0 + xx;
y := y0 - yy;
end;
end;

procedure PlotFigure (P: TPolygon);
var
k: word;
begin
inc (Color);
SetColor (Color);

with P.Pol[0] do MoveTo (X, Y);

for k := 1 to P.Size - 1 do
with P.Pol[k] do LineTo (X, Y);

with P.Pol[0] do LineTo (X, Y);

FillPoly (P.Size, P.Pol);
end;

procedure PlotSquare (Length: word; phi: single);
var
Polygon : TPolygon;

begin
with Polygon do
begin
Size := 4;

Pol[0].X := -Length div 2;
Pol[0].Y := -Pol[0].X;

Pol[1].X := Pol[0].X + length;
Pol[1].Y := Pol[0].Y;

Pol[2].X := Pol[1].X;
Pol[2].Y := Pol[0].Y - length;

Pol[3].X := Pol[0].X;
Pol[3].Y := Pol[2].Y;
end;

Rotate2D (Polygon, phi);
PlotFigure (Polygon);
end;

var
i: word;
Coeff : single;
Alpha,
Beta : single;

begin
Alpha := Arctan (m / (1.0 - m));
Beta := 0.0;

ShowWindow (GetActiveWindow, 0);
InitGr;

Color := GetMaxColor div 4;

x0 := GetMaxX div 2;
y0 := GetMaxY div 2;

Length := y0;
Coeff := M / sin (Alpha);

for i := 1 to Max do
begin
PlotSquare (Length, Beta);
Beta += Alpha;
Length := round (Length * Coeff);
end;

repeat until keypressed;
CloseGraph;
end.


Скачать исходник: Прикрепленный файл  source.pas ( 2.13 килобайт ) Кол-во скачиваний: 1769


Эскизы прикрепленных изображений
Прикрепленное изображение
 Оффлайн  Профиль  PM 
 К началу страницы 
+ Ответить 

Сообщений в этой теме


 Ответить  Открыть новую тему 
1 чел. читают эту тему (гостей: 1, скрытых пользователей: 0)
Пользователей: 0

 





- Текстовая версия 4.10.2022 3:20
500Gb HDD, 6Gb RAM, 2 Cores, 7 EUR в месяц — такие хостинги правда бывают
Связь с администрацией: bu_gen в домене octagram.name