Близится Новый Год...
Скоро опять будем наряжать елку. Вот я и подумал, а чего бы мне елку не сделать на мониторе?
Естественно, подобные темы уже были на форуме. Вот тут, например:
Теперь Вашему вниманию предлагается программа, совмещающая приятное с полезным: во-первых, она рисует красивую картинку (и не только картинку, а еще и движущиеся объекты), а во-вторых - очень неплохая иллюстрация к использованию ООП получилась.
При написании данной программы я использовал уже готовые свои модули (они, кстати, выложены и на форуме:
...
внесены некоторые изменения, сейчас эти модули в стадии отладки (эта программа изначально задумывалась, кстати, как одна из тестовых, и только потом пришла идея сделать именно елку), поэтому сырые исходники выкладываться не будут, я присоединяю архив с *.TPU / *.PPU+*.O файлами, чтобы можно было откомпилировать и посмотреть работу основной программы как с использованием TP, так и на FPC. Как только станет понятно, что новая версия TList не содержит глюков и багов, я просто обновлю исходники по первой ссылке...
Комментироваться ниже будет только основная часть программы (в архиве комментарии отсутствуют).
uses
crt, graph
item_dx, list_dx;
const
{
Эта константа - для будущего использования...
Мне, если честно, не совсем нравится, как ложится снег на "землю", я попробовал сделать
что-то вроде сглаживания, но это не совсем то, что я хотел (а хотелось сделать сугробы или
нечто на них похожее), так что программа тоже еще будет дорабатываться, до НГ есть время
}
linear_size = 25;
{ Цвет отображения снега }
snow_color = white;
type
{
Указатель на массив, хранящий "уровень снега" для каждой вертикальной колонки
пикселей на картинке + еще несколько значений влево/вправо, чтобы не вылетать
за пределы массива при произведении сглаживания...
}
pzero_array = ^zero_array;
zero_array =
array[1 - linear_size .. (maxint div 2) div sizeof(integer)] of integer;
{
Собственно, сама функция сглаживания, пока не совсем правильно работающая
}
function linearize(const current: integer;
const arr: array of integer): integer;
function index(x: integer): integer;
begin
index := x - 1;
end;
var
i, left, right: integer;
s: longint;
begin
s := 0;
for i := current-linear_size to current+linear_size do
s := s + arr[index(i)];
s := trunc(s / (2 * linear_size + 1));
if arr[index(current)] - 1 < s then linearize := 0 else linearize := 1;
end;
var
gZero: pzero_array;
snow_level: integer;
const
snow_count: longint = 0;
type
{
Объект - снежинка, наследник типа tbase, что позволяет создать список снежинок
}
ptsnow = ^tsnow;
tsnow = object(tbase)
{ текущие координаты снежинки }
x, y: integer;
{ скорость (гориз. и верт. соответственно) }
Vx, Vy: double;
{ является ли снежинка активной (при получении значения false объект изымается из списка) }
active: boolean;
constructor init;
destructor done; virtual;
procedure show;
procedure hide;
{ пересчет координат снежинки }
procedure recalc;
private
{ масса снежинки в граммах }
mass: integer;
{ буфер, хранящий изображение под снежинкой }
under: integer;
end;
{
Функция сравнения снежинок (на самом деле, в этой функции проверяется, является ли значение
поля active одной снежинки аналогичным значению поля active другой)
}
function snow_item_compare(const a, b: ttype): boolean;
{$ifndef FPC} far; {$endif}
begin
{
поскольку фактические параметры имеют тип указателя на объект - предок,
для получения доступа к полю требуется привести указатель к нужному типу...
}
snow_item_compare := (ptsnow(a)^.active = ptsnow(b)^.active)
end;
const
{
коэффициент вертикальной составляющей скорости:
чем он больше, тем быстрее будут падать снежинки
}
VScale = 1.25;
{
"вероятность внезапного порыва ветра", что заставит снежинку полететь в другом
направлении (на данный момент меняется знак горизонтальной составляющей скорости)
}
wind_probability = 0.01;
constructor tsnow.init;
const
{
при выпадении каждой 2000-ной (почему не 2007 =) ) снежинки
высота снежного покрова _может_ увеличиться еще на 1 пиксел
}
every = 2000;
begin
inherited init;
{ счетчик снежинок }
inc(snow_count);
{ регулируем высоту снежного покрова }
snow_level := 10 + (snow_count div every);
{ вновь созданная снежинка еще не лежит на земле }
active := true;
mass := random(5) + 1;
{ координаты X и Y }
x := random(getmaxx);
y := random(getmaxy div 4);
{ Вычисляем скорости }
Vx := random(5) - 2;
Vy := mass * VScale;
show;
end;
destructor tsnow.done;
begin end;
procedure tsnow.show;
begin
{ изображение под снежинкой: если уже цвет снега - не сохранять }
under := getpixel(x, y);
if under = snow_color then under := -1
else putpixel(x, y, white);
end;
procedure tsnow.hide;
begin
{ если что-то было сохранено, то надо его восстановить }
if under <> -1 then
putpixel(x, y, under);
end;
procedure tsnow.recalc;
var lin: integer;
begin
{ если случился "порыв ветра" - поменять направление движения снежинки }
if random < wind_probability then Vx := - Vx;
{ пересчитываем координаты в зависимости от скоростей }
x := trunc(x + vx);
y := trunc(y + vy);
{
если снежинка достигла "уровня снега", то делаем следующее: если этот самый
"уровень" не выше разрешенного (см. описание snow_level), то проверяем, что
скажет функция сглаживания, и в зависимости от этого либо поднимаем, либо нет
уровень снега в этой колонке, и, в любом случае, "выводим снежинку из игры"
}
if y >= gZero^[x] then begin
if gzero^[x] > getmaxx - snow_level then
dec(gZero^[x], linearize(x, gZero^));
y := gZero^[x];
active := false;
end;
end;
{
Переходим к реализации "гирлянды"
}
type
{
этот массив может хранить 2 цвета лампочки, соответственно -
во включенном, и в выключенном состоянии
}
tcolorstate = array[boolean] of integer;
{
сам объект - "лампочка" - тоже наследник tbase, что позволяет хранить
всю гирлянду в таком же списке типа tlist
}
ptlight = ^tlight;
tlight = object(tbase)
{ координаты центра лампочки }
x, y: integer;
{ ее цвет (выкл./вкл.) }
color: tcolorstate;
{ включена ли она в данный момент }
is_active: boolean;
constructor init(px, py: integer; pcolor: tcolorstate);
destructor done; virtual;
procedure show;
end;
constructor tlight.init(px, py: integer;
pcolor: tcolorstate);
begin
inherited init;
x := px; y := py; color := pcolor;
{ в момент инициализации выключаем лампу }
is_active := false;
end;
destructor tlight.done;
begin end;
procedure tlight.show;
begin
setfillstyle(solidfill, color[is_active]);
setcolor(color[is_active]);
fillellipse(x, y, 5, 5);
setcolor(white);
circle(x, y, 5);
end;
Const
min = 1;
ColorizeLevel = 8;
LightsOnLevel = 14;
{
Количество и цвета существующих лампочек...
Вся гирлянда будет состоять из ламп этих цветов
}
maxLightColors = 4;
light_colors:
array[0 .. pred(maxLightColors)] of tcolorstate = (
(blue, lightblue),
(red, lightred),
(brown, yellow),
(magenta, lightmagenta)
);
{
Следующие 2 процедуры рисуют фрактальное дерево
(точнее - "папоротник")
}
Procedure lineto1(level: integer; var lst: tlist;
x, y : Integer; l, u : real);
var the_color: integer;
Begin
Line(x, y, Round(x + l * cos(u)), Round(y - l * sin(u)));
if level = ColorizeLevel then begin
{
с вероятностью 15% будет выбран светло-зеленый цвет
"листа", иначе - темно зеленый.
}
if random(100) < 15 then the_color := lightgreen
else the_color := green;
setfillstyle(solidfill, the_color);
fillellipse(Round(x + l * cos(u)), Round(y - l * sin(u)), 3, 3);
end
else if level = (LightsOnLevel) then begin
{
"Лампочки" будут располагаться на определенном уровне "елки". В моем случае -
на 14-ом... Да и то не на каждой такой ветке, а только на 75% из них:
}
if random(100) > 25 then
lst.append(
new(ptlight,
init(Round(x + l * cos(u)), Round(y - l * sin(u)),
light_colors[random(maxLightColors)])
)
);
end;
End;
{
Собственно, рекурсивная отрисовка "папоротника"
}
Procedure Draw_fern(level: integer; var lst: tlist;
x, y : Integer; l, u : real);
Begin
If l > min then Begin
{
этого в исходном алгоритме нет, я добавил этот вызов для того, чтобы
"елка" была заполнена внутри, а не просто очерчивался ее контур
}
if (level > 1) and (level < 5) then
draw_fern(5, lst, x, y, 21, u);
lineto1(level, lst, x, y, l, u);
x := Round(x + l * cos(u));
y := Round(y - l * sin(u));
Draw_fern(succ(level), lst, x, y, l*0.45, u - 14*pi/30);
Draw_fern(succ(level), lst, x, y, l*0.45, u + 14*pi/30);
Draw_fern(succ(level), lst, x, y, l*0.73, u + pi/30);
End;
End;
{
А теперь - переходим собственно к реализации "сцены":
}
{
Первое что нам понадобится - задержка перед очередной перерисовкой
изображения. Поскольку программа тестировалась как на Turbo, так и на
Free Паскале, я воспользовался директивами компилятора
}
const
to_delay =
{$ifdef FPC}
55
{$else}
1255
{$endif}
;
var
grDriver, grMode:
{$ifdef FPC}
smallint
{$else}
integer
{$endif}
;
ErrCode: integer;
{
Еще одна часть программы, которая будет важна при компиляции на TP, а для FPC
ее быть не должно - включение BGI драйвера непосредственно в EXE файл
}
{$ifndef FPC}
{$L EGAVGA.OBJ}
Procedure EGAVGADriverProc; External;
{$endif}
procedure OpenGraphix;
begin
{ инициализируем нужный графический режим }
{$ifdef FPC}
grDriver := d8bit; grMode := m800x600;
{$else}
If RegisterBGIDriver(@EGAVGADriverProc) < 0 Then Begin
WriteLn('Error registering driver: ',
GraphErrorMsg(GraphResult));
Halt( 100 )
End;
grDriver := Detect;
{$endif}
InitGraph(grDriver, grMode, '');
ErrCode := GraphResult;
if ErrCode <> grOk then begin
Writeln('Graphics error:', GraphErrorMsg(ErrCode));
writeln('Press Enter to halt()'); readln; halt(100);
end;
end;
procedure CloseGraphix;
begin
{ закрываем графику }
closegraph;
end;
{
Константа показывает количество снежинок, которое будет присутствовать на экране
(можно ее изменять, но учтите что программа выполняет отнюдь не маленький объем
вычислений для каждой такой снежинки, и при больших значениях snow_amount может
начать подтормаживать)
}
const
snow_amount = 400;
{ Вот это и есть наша "сцена"... }
type
tscene = object
{ список снежинок }
snowlist: tlist;
{ гирлянда - список лампочек }
lightlist: tlist;
constructor init;
destructor done;
{ и основное действие =) }
procedure run;
end;
{
Ниже описаны функции, позволяющие одним вызовом произвести над всеми
элементами списка какую-то операцию в зависимости от определенного условия
}
{ 1) показать лампочку (смысл: отрисовка гирлянды) }
procedure show_lights(p: ptitem);
{$ifndef FPC} far; {$endif}
begin
with ptlight(p^.info)^ do show;
end;
{ 2) зажечь/погасить лампу }
procedure light_the_lamp(p: ptitem);
{$ifndef FPC} far; {$endif}
begin
with ptlight(p^.info)^ do begin
is_active := not is_active; show;
end;
end;
{
А это - функции-условия (уточняющие, КОГДА производить те или иные действия)
}
{ 1) редко (с вероятностью около 5%) }
function seldom(p: ptitem): boolean;
{$ifndef FPC} far; {$endif}
begin
seldom := (random(100) < 5);
end;
{ 2) всегда (функция всегда возвращает "истину") }
function always(p: ptitem): boolean;
{$ifndef FPC} far; {$endif}
begin
always := true;
end;
{ инициализация сцены: }
constructor tscene.init;
var
i: integer;
begin
{ Запускаем графический режим }
OpenGraphix;
{ инициализируем список для хранения "гирлянды" }
lightlist.init;
{
и отрисовываем "елку"; напомню, в процессе ее рисования
лампочки только добавляются в список, но не показываются
}
Draw_fern(1, lightlist, getmaxx div 2, getmaxy, 130, pi/2);
{
а вот теперь используем возможность запустить зажигание для
всех лампочек, которые есть в списке
}
lightlist.ForEachTrue(always, show_lights);
{
до этого момента случайность нам была не нужна, елка будет отрисовываться
одинаково при нескольких последовательных запусках, а вот снежинки должны
как раз появляться случайно...
}
randomize;
{ инициализируем список снежинок }
snowlist.init;
{
запрашиваем место в дин. памяти для хранения "уровня снега", и заносим туда
случайные значения, мало отличающиеся (разница в 5 пикселей максимум) от
нижней границы экрана.
Я не стал делать этот массив статическим только потому, что на этапе компиляции
(ДО вызова initgraph) размер графического экрана неизвестен, а делать что-то
"про запас" - "это не наш метод" ( С )
}
getmem(gZero, (getmaxx + 2 * linear_size) * sizeof(integer));
for i := (1 - linear_size) to (getmaxx + linear_size) do
gZero^[i] := getmaxy - random(5);
{ Добавляем в список нужное количество снежинок }
for i := 1 to snow_amount do {begin}
snowlist.append(new(ptsnow, init));
end;
{
При "разрушении" сцены я удаляю все объекты в порядке, _строго обратном_
порядку их создания (иногда помогает при поиске багов)
}
destructor tscene.done;
begin
freemem(gZero, (getmaxx + 2 * linear_size) * sizeof(integer));
snowlist.done;
lightlist.done;
CloseGraphix;
end;
{
очередная процедура, показывающая, ЧТО делать с элементами списка.
Здесь - приводим указатель на базовый класс к типу "указатель на снежинку", и
скрываем/пересчитываем координаты/показываем ее
}
procedure refresh(p: ptitem);
{$ifndef FPC} far; {$endif}
begin
with ptsnow(p^.info)^ do
if active then begin
hide; recalc; show;
end;
end;
procedure tscene.run;
var
i, count: integer;
just_non_active: ptsnow;
begin
{
Для того, чтобы сравнить две "снежинки" есть 2 пути:
1) перегрузка оператора "=" (в FPC совершенно нет с этим никакой проблемы,
но проблема есть в TP)
2) инициализация "пустого" объекта с нужным нам значением поля, и вызов функции,
сравнивающей именно значения этих полей в переданных ей объектах (это способ
будет работать как в FPC, так и в TP, и именно его я и реализовал)
}
{ Инициализируем доп. объект, и его поле active устанавливаем в False }
just_non_active := new(ptsnow, init);
just_non_active^.active := false;
{ основной цикл программы }
while true do begin
{
Обновляем положение всех снежинок на экране
(еще раз: для каждого итема списка снежинок
"всегда (always)" вызываем функцию refresh)
}
snowlist.ForEachTrue(always, refresh);
{
если на данной итерации появились "упавшие на землю" снежинки (очевидно,
это те, у которых Active = False), то удалить их из списка (и количество удаленных
элементов) запомнить в переменной count
}
count := snowlist.remove(just_non_active, snow_item_compare);
{
поскольку count снежинок были "выведены из игры", и также удалены из списка,
добавляем в список еще столько же снежинок... Таким образом, у нас всегда будет
snow_amount _падающих_ снежинок...
}
for i := 1 to count do
snowlist.append(new(ptsnow, init));
{
Здесь даем инструкцию "гирлянде" зажечь лампы, только не "всегда", а
"редко (seldom)"... Как я показывал выше, функция seldom вернет true только
при 5% вызовов
}
lightlist.ForEachTrue(seldom, light_the_lamp);
{ приостанавливаем действие }
delay(to_delay);
{
Проверяем, не была ли нажата клавиша. Если была - выходим из цикла
}
if keypressed then break;
end;
{
Все, цикл окончен, больше не потребуется сравнивать "снежинки" с образцом,
можно его удалить, чтобы не было утечки памяти ( хоть и кратковременной =) )
}
dispose(just_non_active, done);
{ enter выходит из метода Run }
readln;
end;
{
Как и рекомендуется в ООП - основная программа состоит только из
инициализации объекта, запуска его основной функции, и удаления
}
var
scene: tscene;
begin
scene.init;
scene.run;
scene.done;
end.
Предложения по улучшению принимаются. Есть идея, например, добавить еще кое-где облака фоном (фрактальные, разумеется), возможно - звезды, Луну...
Елка, снег, игрушки ..., (предновогодняя тема)
1.12.2006 15:15
24 
volvo Елка, снег, игрушки ... 1.12.2006 15:15
