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

> Внимание!

Давайте пожалуйста своим демо названия!
В названии темы указывайте название!

> Елка, снег, игрушки ..., (предновогодняя тема)
сообщение
Сообщение #1


Гость






Близится Новый Год...

Скоро опять будем наряжать елку. Вот я и подумал, а чего бы мне елку не сделать на мониторе? smile.gif

Естественно, подобные темы уже были на форуме. Вот тут, например: Помогите с елкой
или тут: Елки палки

Теперь Вашему вниманию предлагается программа, совмещающая приятное с полезным: во-первых, она рисует красивую картинку (и не только картинку, а еще и движущиеся объекты), а во-вторых - очень неплохая иллюстрация к использованию ООП получилась.

При написании данной программы я использовал уже готовые свои модули (они, кстати, выложены и на форуме:
ООП. Объектно-ориентированное программирование
, за объяснениями по поводу работы со списками идем сюда: Все о динамических структурах данных.
...

Примечание: в реализацию модулей item_dx + list_dx внесены некоторые изменения, сейчас эти модули в стадии отладки (эта программа изначально задумывалась, кстати, как одна из тестовых, и только потом пришла идея сделать именно елку), поэтому сырые исходники выкладываться не будут, я присоединяю архив с *.TPU / *.PPU+*.O файлами, чтобы можно было откомпилировать и посмотреть работу основной программы как с использованием TP, так и на FPC. Как только станет понятно, что новая версия TList не содержит глюков и багов, я просто обновлю исходники по первой ссылке...

excl.gif

Комментироваться ниже будет только основная часть программы (в архиве комментарии отсутствуют).

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.


Предложения по улучшению принимаются. Есть идея, например, добавить еще кое-где облака фоном (фрактальные, разумеется), возможно - звезды, Луну...
 К началу страницы 
+ Ответить 
 
 Ответить  Открыть новую тему 
Ответов
сообщение
Сообщение #2


Гость






"Почему-то не работает" - это не диагностика ошибки. Программа рабочая, проверено неоднократно. Кстати, в ближайшее время будет выложена очередная версия (ага, Новый Год все ближе и ближе yes2.gif )
 К началу страницы 
+ Ответить 

Сообщений в этой теме
volvo   Елка, снег, игрушки ...   1.12.2006 19:15
Michael_Rybak   Очень красиво, спасибо :) А давай еще чтоб снег н…   1.12.2006 20:29
Bokul   :lol: Супер!!! Очень реалистично…   1.12.2006 22:33
мисс_граффити   Классно! Когда ж на улице такая красотища буде…   1.12.2006 23:45
Bokul   volvo, не мог бы ты выложить модуль с объектом tba…   2.12.2006 3:21
volvo   :no1: Пока нет... Вместо этого выкладываю новую …   2.12.2006 19:54
Bokul   Эта красивее :) . Только замечены пара багов-небаг…   2.12.2006 23:22
volvo   :yes2: Это была неудачная попытка сделать "т…   2.12.2006 23:44
Archon   Ещё странно, что снежинки после падения разбухают…   3.12.2006 3:46
Error 205   :good: спасибо   12.12.2009 0:56
MaZaHaKa   дак ты её уже сделал???   12.12.2009 9:24
Bokul   Мне наоборот это нравится.   3.12.2006 4:32
volvo   Очередное обновление - драфтовая версия, я убрал ц…   4.12.2006 3:10
Archon   :lol: Ёлка - генератор снега. Снега с неё падает я…   4.12.2006 3:39
Altair   Вы ничего не понимаете это снежный апокалипсис :) …   4.12.2006 14:48
volvo   :lol: :lol: Это я в одном месте знак перепутал...…   4.12.2006 17:01
Altair   :lol: *мысли вслух* На самом деле она должна была …   5.12.2006 3:46
настюша   Извините что беспокою но просто очень хочется посм…   17.12.2006 1:59
Bokul   Ну как там дальнейшее развитии идет? Оно идет? Есл…   17.12.2006 3:59
volvo   Идет... Программа отлаживается, выковыриваются баг…   17.12.2006 4:35
Bokul   { Ниже описаны функции, позволяющие одним вызов…   17.12.2006 10:13
настюша   ...наверное только должен...но там его почему то …   17.12.2006 17:28
volvo   Под TP имелась в виду директория, где у тебя на ко…   17.12.2006 17:45
настюша   Ой :mega_chok: ...извини те за.... ....я все там …   17.12.2006 18:46
volvo   Забирай:   17.12.2006 18:58
настюша   Спасибо огромное :give_rose: ...вот только оно опя…   17.12.2006 19:07
volvo   :) Меню Options -> Compiler -> группа Numeri…   17.12.2006 19:09
настюша   А теперь оно пишет ошибку 203 : Heap overflow erro…   17.12.2006 19:20
volvo   Не знаю... У меня все работает на настройках по ум…   17.12.2006 19:28
настюша   ой....получилось вдруг!!! ....ВАУ КАК …   17.12.2006 19:30
Belchonok   А сама программа в теме выкладывалась? Пока читала…   2.09.2008 2:39
Lapp   Или вся (окончательная версия) программы -- в перв…   19.09.2008 17:27
volvo   Полная версия этой программы вообще никогда ЗДЕСЬ …   19.09.2008 17:34
puporev   Круто! Прочитал тему как детектив!   20.09.2008 13:20
volvo   puporev, флеймить будешь в созданных собой темах (…   20.09.2008 15:19
Lapp   А то, что на форуме творится беспредел и редактиру…   20.09.2008 18:52
Ivan   Felt so hopeless looikng for answers to my questio…   20.11.2012 5:26
Altair   +1 я ничего не удалял если что!   13.01.2009 1:51
MaZaHaKa   А у меня она почему-то не работает.   11.12.2009 13:02
volvo   "Почему-то не работает" - это не диагнос…   11.12.2009 16:38
MaZaHaKa   А когда примерно выложешь???   11.12.2009 20:53
volvo   Может завтра, может на следующей неделе.   11.12.2009 21:15
volvo   Сделал, сделал... Только новая версия в корне отли…   15.12.2009 1:22
Lapp   Спасибо, volvo! Крастотища :) Папка, из котор…   15.12.2009 1:50
andriano   Сделал, сделал...Очень симпатичные новогодние папо…   15.12.2009 15:15
Unconnected   Куууул!!! Очень красиво :good:. Музык…   15.12.2009 2:30
SKVOZNJAK   Под вайном тоже работает. А был ли смысл запихиват…   15.12.2009 2:46
Unconnected   Мм в каком плане нельзя проиграть без распаковки…   15.12.2009 2:55
volvo   Это его под BASS-ом нельзя проиграть, не распаковы…   15.12.2009 2:57
Unconnected   Запускаю программу из архива, не распаковывая, н…   15.12.2009 3:12
volvo   Unconnected, ты до сих пор думаешь, что оно запуск…   15.12.2009 3:50
Unconnected   Не, я знаю, что временная создаётся, кажется, в па…   15.12.2009 3:56
SKVOZNJAK   Под вайном ничего не чистится и окон создаётся дв…   15.12.2009 5:12
volvo   :lol: ... Вот так лучше будет: Во-первых, не с…   15.12.2009 5:45
SKVOZNJAK   Насчёт каёмочки. Включённой лампе её действительно…   15.12.2009 8:29
MaZaHaKa   Вау!!!СУПЕР!!! Слов нет...…   15.12.2009 15:54


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

 





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