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

[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.

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

[volvo]

Сделал, сделал... Только новая версия в корне отличается от первоначальной... Если у кого слабое сердце или нервы - то исходники не стОит смотреть ни в коем случае...

Несколько слов о программе: компилироваться код будет только под FPC, начиная с версии 2.2.0, поскольку я решил использовать Free Pascal по-полной, и задействовал Дженерики. Угу, вот так вот, хотелось проверить, что можно сделать с их помощью... Еще одно уточнение - приложение работоспособно только под Windows (я даже не стал вычищать код, там до сих пор есть "наследие" Турбо-Паскаля), возможно, в следующих версиях это изменится. Есть еще идеи, можно много добавить в эту программу, но времени сейчас не хватает.

Присоединяю 2 архива: один - с EXE-шником и DLL-кой, необходимой для его работы, второй - с исходниками. Не удивляйтесь размеру исходников, вы все поймете, как только скомпилируете и запустите программу Нужный режим компиляции прописан в каждом файле, поэтому в настройки компилятора лазить не надо. Играться без особой надобности с условной компиляцией - тоже не надо, файлы, которые я выложил - только для тех директив, которые установлены сейчас, для других - надо еще другие файлы, но присоединять все, что есть (чтобы работало со всеми комбинациями) - сомневаюсь, что кто-то будет это качать, полный размер всей папки у меня - больше 30 Мб. Да, еще одно. Папка, из которой программа запускается, должна иметь разрешение на запись, иначе запуска не произойдет (это к тем, кто сидит НЕ под Админом)

Вот сами архивы:

[andriano]

Сделал, сделал...

Очень симпатичные новогодние папоротники.

Есть еще идеи, можно много добавить в эту программу, но времени сейчас не хватает.

Можно один из фракталов зеркально развернуть относительно вертикальной оси. Думаю, много времени это не займет.
Можно, наоборот, сымитировать ветер. Тогда все фракталы останутся развернутыми в одну сторону, но в том же направлении надо добавить некоторую горизонтальную составляющую всем снежинкам. Думаю, тоже много времени не понадобиться.
Когда шарики-фонарики перекрывают друг друга, получается не совсем красивый эффект, т.к. последний зажегшийся "вылезает" на первый план. Лучше либо предусмотреть экранирование, либо исключить пересечение.
Физика движущихся по экрану точек очень здорово не соответствует физике снежинок, но, возможно, и ничего страшного, т.к. чтобы заметить это нужно специально приглядываться, а "издалека" снег выглядит вполне натурально.
Периодически наблюдаются "подтормаживания". Вероятно, каждый кадр считается с фиксированным приращением времени. Т.е. внутреннее время программы связано с номером кадра, а не с физическим временем.
Через некоторое время снегопад остановился. А вместе с ним остановились и невыпавшие снежинки. Могу предположить, что снежинки, достигая сугроба, не исключаются из списка снежинок, а продолжают в нем фигурировать, из-за чего естественное ограничение на их максимальное количество приводит к невозможности продолжать счет.
Нет, ошибся. Пока писал предыдущий абзац, снегопад восстановился. Но была явная пауза минимум в несколько секунд, не прерывающаяся даже по перемещению окна и изменению фокуса.
Снова остановился...
Загадка.
Хотя картинка и не движется, приложение исправно жрет свои 50% времени.
Снег снова пошел и расход CPU снизился до 2-11%.
Снова остановился.