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


Профи
****

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

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


Цитата
Только замечены пара багов-небагов:
1 В снегу остаются пустоты, что есть очень красиво, но примерно когда снега выпадает 1-1.5 сантиметра, появляется сплошная пустота толщиной в несколько пикселей в виде почти-что горизонтальной линии. Такой эффект - периодический, и повторяется каждые 1-2 сантиметров, что есть не сильно реалистически.
2 Лампочки, они не засыпаются снегом, т.е. они засыпаются, но при перерисовки, при смене цвета, они опять появляются с под снега. В конце получим полностью белый экран с мерцающими лампочками.

Ещё странно, что снежинки после падения разбухают, как возушая кукуруза при приготовлении.

Цитата
К этому, масса снежинок введена далеко не случайно, как только сумма весов снежинок, осевших на ветке, превысит некую критическую величину, снег будет обрушиваться вниз
shok.gifКруто.. good.gif

PS Сделай пару ёлочек поменьше на фоне и потемнее цветом. Сцена будет смотреться объёмно


--------------------
Close the World...txeN eht nepO
 Оффлайн  Профиль  PM 
 К началу страницы 
+ Ответить 
сообщение
Сообщение #3





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

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


good.gif спасибо
 Оффлайн  Профиль  PM 
 К началу страницы 
+ Ответить 
сообщение
Сообщение #4


Цвету и радуюсь:)


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

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


дак ты её уже сделал???


--------------------
"Если вам нечего делать, то не надо делать это здесь!!!"
 Оффлайн  Профиль  PM 
 К началу страницы 
+ Ответить 

Сообщений в этой теме
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 22:00
500Gb HDD, 6Gb RAM, 2 Cores, 7 EUR в месяц — такие хостинги правда бывают
Связь с администрацией: bu_gen в домене octagram.name