Елка, снег, игрушки ..., (предновогодняя тема) Опции

[volvo]

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

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

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

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

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

Примечание: в реализацию модулей item_dx + list_dx внесены некоторые изменения, сейчас эти модули в стадии отладки (эта программа изначально задумывалась, кстати, как одна из тестовых, и только потом пришла идея сделать именно елку), поэтому сырые исходники выкладываться не будут, я присоединяю архив с *.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.

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

[Michael_Rybak]

Очень красиво, спасибо

А давай еще чтоб снег накапливался, и чтоб елка таким образом в сугроб постепенно превращалась

[Bokul]

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

Супер!!! Очень реалистично и красиво вышло

[мисс_граффити]

Классно!
Когда ж на улице такая красотища будет?...

[Bokul]

volvo, не мог бы ты выложить модуль с объектом tbase даже не в отлаженном виде?

[volvo]

не мог бы ты выложить модуль с объектом tbase даже не в отлаженном виде?

Пока нет...

Вместо этого выкладываю новую версию программы, вот тут уже сглаживание присутствует в том виде, в котором я себе его представлял изначально... Правда, его реализация тоже пока скрыта, ибо есть подозрение, что возможны глюки...

Теперь вопрос: какая из реализаций более эффектно смотрится, прежняя или новая? (я про уровень снега)

[Bokul]

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

Предложение сделать елку не фоновой, чтобы снег оседал на ее ветках.

[volvo]

но примерно когда снега выпадает 1-1.5 сантиметра, появляется сплошная пустота толщиной в несколько пикселей в виде почти-что горизонтальной линии.

Это была неудачная попытка сделать "таяние снега"... Теперь будем работать в правильном направлении

Над НЕфоновой елкой работа уже ведется (это кстати задумывалось с самого начала)... + К этому, масса снежинок введена далеко не случайно, как только сумма весов снежинок, осевших на ветке, превысит некую критическую величину, снег будет обрушиваться вниз

[Archon]

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

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

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

Круто..

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

[Bokul]

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

Мне наоборот это нравится.

[volvo]

Очередное обновление - драфтовая версия, я убрал цвета, чтобы был понятен замысел, кто хочет протестировать - запускайте и смотрите подольше... Как и обещал - теперь елка на совсем фоновая, на ветках накаплявается снег, и как только его накапливается много - он падает вниз...

Сразу хочу предупредить - этот архив исходников НЕ содержит вообще - только EXE, полученный после компиляции в FPC... Код УЖАСЕН, его надо сильно причесать, перед тем, как выкладывать ...

[Archon]

Ёлка - генератор снега. Снега с неё падает явно больше, чем на неё. Об этом можно судить по тому, что через 5 минут ёлка превратилась в сугроб.
Кстати, снег с веток никуда не исчезает...

PS Может имеет смысл перенести тему в раздел Демо/Интро?

[Altair]

Вы ничего не понимаете это снежный апокалипсис

Клево, у меня на 20 примерно секунде елку просто завалило снегом

[volvo]

Это я в одном месте знак перепутал... Вместо "-" сделал "+"

Это исправлено, сейчас "причесывается" исходник, тему действительно переношу в "Демо + Интро"

[Altair]

*мысли вслух* На самом деле она должна была быть пылесосом

[настюша]

Извините что беспокою но просто очень хочется посмотреть на то как там все красиво...я оно выдает ошибку 15...о том что не найден файл GRAPH.TPU ... его надо где-то предварительно создать?....если да то скажите пожалуйста где и как ...

Заранее спасибо за ответ

[Bokul]

Ну как там дальнейшее развитии идет? Оно идет? Если нет, то повторю просьбу выложить модуль tbase...

[volvo]

Идет... Программа отлаживается, выковыриваются баги, кое-что добавляется... До НГ еще есть время...

оно выдает ошибку 15...о том что не найден файл GRAPH.TPU

Модуль GRAPH.TPU лежит (по крайней мере - должен лежать) в папке TP\UNITS... Скопируй его оттуда в папку с проектом, и компилируй.

[Bokul]

{
  Ниже описаны функции, позволяющие одним вызовом произвести над всеми
  элементами списка какую-то операцию в зависимости от определенного условия
}

{ 1) показать лампочку (смысл: отрисовка гирлянды) }
procedure show_lights(p: ptitem);
{$ifndef FPC} far; {$endif}
begin
  with ptlight(p^.info)^ do show;
end;

В связи недоступности модуля tbase , прошу объяснить как эта функция обходит все элементы. И что за операция ptlight?

[настюша]

Модуль GRAPH.TPU лежит (по крайней мере - должен лежать) в папке TP\UNITS... Скопируй его оттуда в папку с проектом, и компилируй.

...наверное только должен...но там его почему то нету ...там есть ITEM_DX.TPU, EQUA.TPU, LIST_DX.TPU и все ... а что же тогда делать ...если нету, а?