Модуль рассчета движения шариков

unit sharovidniy_struckt;

interface

uses Classes, windows, SysUtils, math;

const
  W_glob =450;
  H_glob =450;
  Sp_GAUSS=0; //скорости  - как генерировать
  Sp_EQUAL=1;
  tail_dimension = 15; //размерность массива для сохраниения хвоста
  savetype = 'SvballSimv1.0';   //токен для идетификации
  max_srt = 100; //максимальное число сортов

type

  tvector = record
    dx,dy:single;
  end;

  presave_struct = record
    NM:string[18];
    NumBall:cardinal; //число шаров
    NumSort:cardinal; //число сортов
    delta_t: single; //время итерации в методе конечных разностей
    close_hustle : single; //константа близкого расталкивания
    conglut : boolean; //освобождаться от слипания
    pregenglut : boolean; //сгенерировать так, чтобы шарики не были слипшимися
  end;

  Ball = record
    x,y:single;      //координаты
    color:dword;     //цвет
    vx,vy:single;    //скорость
    fx,fy:single;    //сила
    m:smallint;      //масса
    q:smallint;      //заряд
    r:dword;         //радиус
    tl:array[0..tail_dimension,0..1]of single;//131
  end;

  Lpball = ^ball;

  sort = record
    S:string[40];    //название сорта
    n:smallint;      //число таких шаров
    m:smallint;      //масса
    q:smallint;      //заряд
    r:dword;         //радиус
    color:dword;     //цвет
    speedGen: integer; //тип распеределения по скоростям при генерации сорта
  end;

  TGlob_var = record
    gravX, gravY: single; //параметры ускорения
    GravOn: boolean;
    xbord, ybord: integer;  //размеры окошка
    balance : integer;  //баланс между гравитационным меж частичным взаимодействием и кулоновским взаимодействием
    precis : integer; //точность - ход с самой малой скоростью разбит ещё на подшаги
    claster : boolean; //модель границ
    flexible: boolean; //упругие вз-вия
    interact_grav: boolean; //меж частичная гравитация
  end;

  Tvisi_var = record
//хвост
    tail_length: integer; //длина
    exe_tail : boolean;   //обрабатывать или нет
      tl_len, tl_pos : integer;//текущая длина, текущая позиция - внутренние характеристики
//эквалайзеры
    vr,hr: array[0..100] of integer; //накопители
    ekvX, ekvY: boolean;//аквалайзеры включены
    step_ek :integer; // число шагов по вертикали и горизонтали
//число пропусков визуалтзации
    visstep: integer;   //пропуск тактов визуализации
    auto_frameset:boolean; //автоматический подсчет числа скрытых кадров
    hidframes:integer;  //скрытых фреймов
  end;

  ballexec = class
    delta_t: single; //время итерации в методе конечных разностей
    conglut : boolean; //освобождаться от слипания
    pregenglut : boolean; //сгенерировать так, чтобы шарики не были слипшимися
    close_hustle : single; //константа близкого расталкивания
//параметры исполнения
    glob : Tglob_var;
    vis : Tvisi_var;
    procedure Execute;
//блоки исполнения
    procedure GlobalParamsRequestExecution;
//инициализация
    function buildballlist:boolean;  //расставляем шарики, вычисляем первую delta_t
//загрузка-выгрузка
    function save(flname:string;mode:byte):boolean; //запись с позициями вместе
    function saveposes(flname:string):boolean;
    function savesortes(flname:string):boolean;
    function loadposes(flname:string):boolean;
    destructor destroy; override;
  private
    { Private declarations }
  protected
    constructor Create;
  end;

var
//массив шариков
  Bl:array of ball; //список мячей
  srt:array of sort;//список сортов
//форма 3
  ab: tGlob_var; //глобальные переменные, которые используются в форме No 3 - Global params
  applyRequest: boolean; //требование их обновить
//собстаенно сам объект
  fastup:ballexec;

procedure default_init;

//вспомогательные процедуры

function GetInteger(s:string;i,i1,i2:integer):integer;
function GetFloat(s:string;r,r1,r2:real):real;
function reversecolor(c:integer):dword;
procedure FixSeparator(var s:string);
procedure SetClientRect(w,h:integer; th:thandle);

implementation

function ballexec.save(flname:string;mode:byte):boolean; //запись с позициями вместе
var ts: presave_struct;
    z: tfilestream;
  function sv(const Buffer; Count: Longint): boolean;
  begin
    result:= (z.Write(buffer,count) = Count);
  end;
begin    //mode 0  -  poses, mode 1  -  sortes
  result:=false;
  if (mode<>0) and (mode<>1) then exit;
  ts.NM:= savetype;  //заполниние аспомогательной структуры
  case mode of
  0:  ts.NumBall:=length(bl);
  1:  ts.NumBall:=0;
  end;
  ts.NumSort:=length(srt);
  ts.delta_t:=delta_t;    //сохраним дополнительные параметры
  ts.close_hustle:=close_hustle;
  ts.conglut:= conglut;
  ts.pregenglut:= pregenglut;
  z:=tfilestream.Create(flname,fmCreate,fmShareDenyWrite); //создание
  if sv(ts,sizeof(presave_struct)) and sv(fastup.glob,sizeof(Tglob_var)) and sv(fastup.vis,sizeof(Tvisi_var)) and
     sv(srt[0],sizeof(sort)*ts.NumSort) then result:=true;  //запись
  if mode=0 then
    result:=result and sv(bl[0],sizeof(ball)*ts.NumBall);
  z.Destroy; //высвободим память, закроем файл
end;

function ballexec.saveposes(flname:string):boolean; //запись с позициями вместе
begin
  result:=save(flname, 0);
end;

function ballexec.savesortes(flname:string):boolean;  //запись только сортов без позиций
begin
  result:=save(flname, 1);
end;

function ballexec.loadposes(flname:string):boolean; //загрузка данных с позициями
var ts: presave_struct;
    z: tfilestream;
  function LD(var Buffer; Count: Longint): boolean;
  begin
    result:= (z.Read(buffer,count) = Count);
  end;
label fin;
begin
  result:=false;
  z:=tfilestream.Create(flname,fmOpenRead,fmShareDenyWrite); //создание
  if not LD(ts,sizeof(presave_struct)) then goto fin;
  if (ts.NM <> savetype) or (ts.NumSort>max_srt) then goto fin;  //проверка вспомогательной структуры
  if ts.NumBall<>0 then setlength(bl,ts.NumBall);
  setlength(srt,ts.NumSort);
  if LD(fastup.glob,sizeof(Tglob_var)) and LD(fastup.vis,sizeof(Tvisi_var)) and
     LD(srt[0],sizeof(sort)*ts.NumSort) and LD(bl[0],sizeof(ball)*ts.NumBall) then result:=true;  //загрузка
fin:
  if not result then
  begin
    if ts.NumBall<>0 then
      setlength(bl,0);
    setlength(srt,0);
  end else begin
    delta_t:=ts.delta_t;    //восстановим дополнительные параметры если загрузка произошла удачно
    close_hustle:=ts.close_hustle;
    conglut:= ts.conglut;
    pregenglut:= ts.pregenglut;
  end;
  z.Destroy; //высвободим память, закроем файл
end;

function ballexec.buildballlist:boolean;  //расставляем шарики, вычисляем первую delta_t
var re,ve,dif,V:single;
    n,try_init,j,k:integer;
    R:smallint;
    f:boolean;
label retpoint;
begin
  setlength(bl,0);
  result:=false;
  n:=0;
  V:=1;
  fastup.close_hustle:=0; //расчет константы рассталкивания
  for k:=0 to length(srt)-1 do //цикл по сортам
  begin
    setlength(bl,length(bl)+srt[k].n);//прирост числа шаров
    if srt[k].speedGen=sp_gauss then dif:=0.3*V else dif:=0;
    while n<length(bl) do  //генерация шариков сорта
    begin
      f:=false; //ошибка генереции позиции шара
      try_init:=0; //счетчик попыток в ноль
      repeat      //пока нормальных координат не сгенерирует
        if try_init>500 then
        begin
          if IDcancel=messagebox(0,'I have done 500 attempts for creation ball`s position. Do you wish continue?','Creation crash :-(',MB_RETRYCANCEL) then
          begin
            setlength(bl,0); //чтобы не смогли записать глюковые координаты
            exit;
          end;
          try_init:=0;
        end;
        inc(try_init);
        R:=srt[k].r;
        Bl[n].x:=random*(glob.xbord-2*R)+R;//random coord
        Bl[n].y:=random*(glob.ybord-2*R)+R;
        if (n>0) and pregenglut then  //если шарик не первый и надо создавать не слипшуюся конфигурацию
          for j:=0 to n-1 do begin
            f:= (sqr(Bl[n].x-Bl[j].x)+sqr(Bl[n].y-Bl[j].y))<=sqr(R+bl[j].r);
            if f then break;
          end;
      until not f;
      re:=PI*random*2;    //random direction
      ve:=RandG(V,dif);   //случайная длина вектора скорости
      with bl[n] do begin
        vx:=cos(re)*Ve; //стартовая скорость
        vy:=sin(re)*Ve;
        q:=srt[k].q;   //параметры шара
        m:=srt[k].m;
        r:=srt[k].r;
        color:=srt[k].color;
        fastup.close_hustle:=max(fastup.close_hustle,m); //этот параметр достаточно сложный...
        fastup.close_hustle:=max(fastup.close_hustle,q);
      end;
      inc(n); //следующий ! кричит заведущий
    end; //генерация шариков сорта k
  end; //сорт k
  delta_t:=0.5 / glob.precis; //precis идет по умолчанию, потом Vmax=2 ну и ещё попалам, как некая минимальная величина
  result:=true;
end;

procedure ballexec.GlobalParamsRequestExecution;
begin
  if applyrequest then //обработка запроса на новые глобальные настройки
  begin
    fastup.glob:=ab; //запись новых глобальных настроек
    applyrequest:=false; //запрос выполнен
  end;
end;

procedure ballexec.Execute;
var hlpX,hlpY,L,L1,mxspeed,mnspeed:single;
    a1,a2,a3:^ball;
    i, k, j, h:integer;
    jin,allmass:integer;
    n, R:integer;
    hlp,hlp2,xx,yy,len,cx,cy:single;
    Gkoef, Ckoef: single; //коэффициенты балансировки кулона и гравитации
label miss, never_stop, nxt;
begin
  GlobalParamsRequestExecution;
//инициализация
  n:= length(Bl)-1; //номер последнего шара
  if n=-1 then exit;
//интерпретация балансировки гравитации, и зарядового притяжения
  Gkoef:=-1;  //притяжение
  Ckoef:=1;   //рассталкивание
  if glob.balance<0 then begin
    Gkoef:=1/glob.balance;
    Ckoef:=-glob.balance;
  end;
  if glob.balance>0 then begin
    Gkoef:=-glob.balance;
    Ckoef:=1/glob.balance;
  end;

//скрыть кадры !!
  for j:=1 to vis.hidframes*vis.visstep do    //число итераций без визуализа
  begin
    for k:=0 to n do // n - всего шаров
    begin            // очистка силовой составляющей
      Bl[k].fx:=0;   //сюда входит только парные взаимодействия
      Bl[k].fy:=0;
    end;
    k:=0;// циклы треугольника парных взаимодействий
    while k<n do//for k:=1 to n-1 do
    begin
      a1:=@Bl[k];// используем указатели на шарики 1-й объект
      i:=k+1;
      while i<=n do//for i:=k+1 to n do
      begin
        a2:=@Bl[i];// используем указатели на шарики 2-й объект
        xx:=a1.x-a2.x;//dx
        yy:=a1.y-a2.y;//dy
        hlp:=xx*xx+yy*yy;//D**2
        len:=sqrt(hlp);//D
//кулон или/и гравитация?
        if glob.interact_grav then begin //гравитация м/у объектами включена
          hlp2:=a1.m*a2.m/hlp/len*Gkoef;{grav force calc}
          hlpX:=hlp2*xx;//fx - проекции силы
          hlpY:=yy*hlp2;//fy -
          a2.fx:=a2.fx+{cs}hlpX;
          a2.fy:=a2.fy+{sn}hlpY;
          a1.fx:=a1.fx-{cs}hlpX;
          a1.fy:=a1.fy-{sn}hlpY;
        end;
        if a1.q*a2.q<>0 then begin //зарядовое взаимодействие
          hlp2:=a1.q*a2.q/hlp/len*Ckoef;{colomb force calc}
          hlpX:=hlp2*xx;//fx - зарядовое сила взаимодействия зарядов  (проекции силы)
          hlpY:=yy*hlp2;//fy - зарядовое
          a2.fx:=a2.fx+{cs}hlpX;
          a2.fy:=a2.fy+{sn}hlpY;
          a1.fx:=a1.fx-{cs}hlpX;
          a1.fy:=a1.fy-{sn}hlpY;
        end;
        if len<=a1.r+a2.r then begin//  если шарики соприкоснулись - отработка отражений
          if not glob.flexible then begin //распирающий потенциал для того чтобы не слипались наши друзья
            hlp2:=close_hustle*close_hustle*10/hlp/len;{colomb force calc}
            hlpX:=hlp2*xx;//fx - зарядовое сила взаимодействия зарядов  (проекции силы)
            hlpY:=yy*hlp2;//fy - зарядовое
            a2.fx:=a2.fx+{cs}hlpX;
            a2.fy:=a2.fy+{sn}hlpY;
            a1.fx:=a1.fx-{cs}hlpX;
            a1.fy:=a1.fy-{sn}hlpY;
          end;
 //найдём проэкцию вектора скорости на осевой вектор м/у центрами шариков
          xx:=xx/len;//нормировка к единице - далее идет оценка столкновения и отражение
          yy:=yy/len;
          L:=a2.vx*xx+a2.vy*yy;//проэкция скорости на вектор удара единичной длины
          L1:=-a1.vx*xx-a1.vy*yy;//проэкция скорости на вектор удара единичной длины
          if conglut then // разрешено избавляться от слипания при работе
            if (L<0)and(L1<0)then goto miss;//сближение не зафиксировано
          if glob.flexible then
            hlp2:=(L1+L)*2/(a2.m+a1.m) //идеально упругий обмен импульсами
          else hlp2:=(L1+L)*2/(a2.m+a1.m)*0.95; //имровизированная неупругость
          a2.vx:=a2.vx-xx*hlp2*a1.m;
          a2.vy:=a2.vy-yy*hlp2*a1.m;
          a1.vx:=a1.vx+xx*hlp2*a2.m;
          a1.vy:=a1.vy+yy*hlp2*a2.m;
  miss:
        end;{if len<R1+R2}
        inc(i);
      end;{for i}
      inc(k);
    end;{for k}
  //парные вз-вия отработаны
//************************************************************************************************************
  //new coords and borders  **********************************************************************************
    cx:=0;      //для кластерного режима надо усреднить массы и координаты
    cy:=0;
    allmass:=0;
    mxspeed:=0;//предустановка искомых границ скорости
    mnspeed:=1e10;
    if j = 1 then begin
      if vis.ekvX or vis.ekvY then
      begin               //очистка эквалайхеров
        zeromemory(@vis.vr[0],sizeof(vis.vr));
        zeromemory(@vis.hr[0],sizeof(vis.hr));
      end;
      L :=glob.xbord/vis.step_ek;//величина ячейки вертикального эквалайзера
      L1:=glob.ybord/vis.step_ek;//величина ячейки горизонтального эквалайзера
      vis.tl_len := min(vis.tl_len, vis.tail_length); //усечение хвоста при сокращении
    end;
    for k:=0 to n do
    begin
  //coords
      a1:=@Bl[k];//указатель на шарик
      xx:=a1.vx;
      yy:=a1.vy;
      hlpX:=a1.x+xx*delta_t;//x=x+V*t
      hlpY:=a1.y+yy*delta_t;
  //gravity
      if glob.GravOn then //гравитация включена
      begin
        xx:=xx+glob.gravX*delta_t;
        yy:=yy+glob.gravY*delta_t;//Vy=Vy+g*t
      end;
  //border
      R:=a1.r;
      if glob.claster then //cluster model
      begin
        if (hlpX<R)or(hlpX>glob.xbord-R) then hlpX:=glob.xbord-hlpX;
        if (hlpY<R)or(hlpY>glob.ybord-R) then hlpY:=glob.ybord-hlpy;
      end else begin //not a cluster model
        if hlpX<R then xx:=abs(xx) else  //отражение от стенок
          if hlpX>glob.xbord-R then xx:=-abs(xx);
        if hlpY<R then yy:=abs(yy) else
          if hlpY>glob.ybord-R then yy:=-abs(yy);
       end;
  //charge
      if (a1.q<>0) or glob.interact_grav then//если заряжена или включен обсчет гравитации
      begin
        xx:=xx-a1.fx*delta_t/a1.m;
        yy:=yy-a1.fy*delta_t/a1.m;
      end;

//вставка для обработки графической статистики
      if j=1 then begin //во время первой итерации
        if vis.EkvY then begin //аквалайзер накапливаем
          i:=trunc(hlpY/L1);
          if (i>=0) and (i<length(vis.vr)) then vis.vr[i]:=vis.vr[i]+a1.m;
        end;
        if vis.EkvX then begin
          i:=trunc(hlpX/L);
          if i>=0 then vis.hr[i]:=vis.hr[i]+a1.m;
        end;
        if vis.exe_tail then begin//хвост
          a1.tl[vis.tl_pos,0]:=a1.x;   //записываем старые данные хвоста
          a1.tl[vis.tl_pos,1]:=a1.y;
        end;
      end;
//конец обработки графической статистики

      a1.vx:=xx; //новая скорость
      a1.vy:=yy;
      hlp:=abs(xx)+abs(yy);//  ну типа скорость максимальную так считаю //      hlp:=sqrt(xx*xx+yy*yy);//V
      if mxspeed<hlp then mxspeed:=hlp;//поиск максимума и минимума квадрата скоростей
      if mnspeed>hlp then mnspeed:=hlp;
//код направлен на то чтобы избегать слипания
{      if not glob.flexible and (k>0) then //проверка на перекрытие чтобы не налазить на другие шары в режиме неупругого взаимодействия
      begin
        a2:=@Bl[0];
        for i:=0 to k-1 do
        begin

          if (sqr(hlpx-a2.x)+sqr(hlpy-a2.y))<sqr(a1.r+a2.r) then
          begin
            xx:=hlpx-a2.x;//dx - координаты расстояния м/у шарами после пересчета координат
            yy:=hlpy-a2.y;//dy
            hlp:=xx*xx+yy*yy;//D**2
            len:=sqrt(hlp)/(a1.r+a2.r+0.001);//D/R     - расстоние между шарами после пересчета координат/поделить на максимальное расстояние
            xx:=xx/len;//dx - отодвинем
            yy:=yy/len;//dy
            a3:=@Bl[0];       //проверим, вдруг при отступе мы налезем ещё на кокой то шар
            for h:=0 to n do
            begin
              if a1<>a3 then //с самим собой сранивать не надо :)
                if (sqr(xx+a2.x-a3.x)+sqr(yy+a2.y-a3.y))<sqr(a1.r+a3.r) then //вот собственно проверка
                  goto nxt;
              inc(a3);
            end;
            hlpX:=xx+a2.x; //вот такие координаты приемлимы
            hlpY:=yy+a2.y;
          end; //если новый a1 и a2 на расстоянии менее сумма радиусов
nxt:    inc(a2);
        end;//for i
      end;}

      a1.x:=hlpX;//новые координаты
      a1.y:=hlpY;
      if glob.claster then//кластер?
      begin
        jin:=a1.m;
        allmass:=allmass+jin;
        cx:=cx+hlpX*jin;
        cy:=cy+hlpY*jin;
     end;
    end;{of k}

//    delta_t:= 1 / (glob.precis*sqrt(mxspeed));
    delta_t:= 1 / (glob.precis*mxspeed+0.00001);
    if glob.claster then //реализуем кластерный режим - центровка
    begin
      cx:=glob.xbord/2-cx/allmass;
      cy:=glob.xbord/2-cy/allmass;
      for k:=0 to n do
      begin
        a1:=@Bl[k];
        a1.x:=a1.x+cx;
        a1.y:=a1.y+cy;
      end;
    end {of check8}
  end; {of j}// число итераций, которые скрыты
//эти 3 строки можно вставить и в тело j, но в рамках условия j=1 и вне цикла k=0..n
  inc(vis.tl_pos);//следующая позиция - рост хвоста или отслеживание
  if vis.tl_pos > tail_dimension then vis.tl_pos:=0;
  if vis.tail_length>vis.tl_len then inc(vis.tl_len); //длина хвоста растет

end;

destructor ballexec.destroy;
begin
  inherited destroy;
end;

constructor ballexec.Create;
begin
  inherited Create;
  with glob do //глобальные настройки по умолчанию
  begin
    xbord:= W_glob;  ybord:=h_glob;  //размеры
    gravX:=0.0;   GravY:=2.0;  //гравитация
    gravOn:=false;
    precis:=3;
    claster:=false;// коробочный режим
    flexible:=true;
    interact_grav:=false;
  end;
  with vis do  //установки визуальные по умолчанию
  begin
    tail_length:=0;
    tl_len:=0;
    tl_pos:=0;
    exe_tail:= false;
    ekvX:=false;
    ekvY:=false;
    step_ek:=25;
    auto_frameset:=true;
  end;
  ab:=glob;
end;

procedure default_init; //инициализация всех настроек
begin
  if fastup<>nil then fastup.Destroy; //создание нити
  fastup:=ballexec.Create;
  setlength(srt,1); //один сорт сделаем
  with srt[0] do
  begin
    s:='';
    n:=100;
    m:=4;
    r:=5;
    color:=$0000ff;
  end;
end;

procedure FixSeparator(var s:string);
var j:integer;
begin
  j:=pos('.',s);//замена точки или запятой на нужный разделитель
  if j<>0 then s[j]:=DecimalSeparator;
  j:=pos(',',s);
  if j<>0 then s[j]:=DecimalSeparator;
end;

//s - конвертируемое значение
//r - значение по умолчанию
//r1,r2 - диапазон допустимых значений
//на выходе хранит флоат
function GetFloat(s:string;r,r1,r2:real):real;
begin
  FixSeparator(s);//точку правим
  try
    result:=strtofloat(s);//попытка взять число
  except
    on EConvertError do
      result:=r;  //выбрали по умолчанию при ошибке
  end;
  if result<r1 then result:=r1 //подгонка к рамкам диапазона [r1..r2]
    else if result>r2 then result:=r2;
end;

//s - конвертируемое значение
//i - значение по умолчанию
//на выходе - целое число
function GetInteger(s:string;i,i1,i2:integer):integer;
begin
  result:=trunc(GetFloat(s,i,i1,i2));
end;

function reversecolor(c:integer):dword;
begin
  result:= (c and $ff0000) div $10000 + (c and $ff00) + (c and $ff) * $10000;
end;

procedure SetClientRect(w,h:integer; th:thandle); //установка размера клиентской части
var rc: Trect;
begin
  rc:=rect(0,0,w,h);
  if AdjustWindowRectEx(rc,  GetWindowLong(th,GWL_STYLE), false, GetWindowLong(th,GWL_EXSTYLE)) then
    SetWindowPos(th, 0, 0, 0, rc.Right-rc.Left, rc.Bottom-rc.Top,
      SWP_NOMOVE or SWP_NOZORDER);
end;

initialization
begin
  randomize;
end;

end.

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

124

125

126

127

128

129

130

131

132

133

134

135

136

137

138

139

140

141

142

143

144

145

146

147

148

149

150

151

152

153

154

155

156

157

158

159

160

161

162

163

164

165

166

167

168

169

170

171

172

173

174

175

176

177

178

179

180

181

182

183

184

185

186

187

188

189

190

191

192

193

194

195

196

197

198

199

200

201

202

203

204

205

206

207

208

209

210

211

212

213

214

215

216

217

218

219

220

221

222

223

224

225

226

227

228

229

230

231

232

233

234

235

236

237

238

239

240

241

242

243

244

245

246

247

248

249

250

251

252

253

254

255

256

257

258

259

260

261

262

263

264

265

266

267

268

269

270

271

272

273

274

275

276

277

278

279

280

281

282

283

284

285

286

287

288

289

290

291

292

293

294

295

296

297

298

299

300

301

302

303

304

305

306

307

308

309

310

311

312

313

314

315

316

317

318

319

320

321

322

323

324

325

326

327

328

329

330

331

332

333

334

335

336

337

338

339

340

341

342

343

344

345

346

347

348

349

350

351

352

353

354

355

356

357

358

359

360

361

362

363

364

365

366

367

368

369

370

371

372

373

374

375

376

377

378

379

380

381

382

383

384

385

386

387

388

389

390

391

392

393

394

395

396

397

398

399

400

401

402

403

404

405

406

407

408

409

410

411

412

413

414

415

416

417

418

419

420

421

422

423

424

425

426

427

428

429

430

431

432

433

434

435

436

437

438

439

440

441

442

443

444

445

446

447

448

449

450

451

452

453

454

455

456

457

458

459

460

461

462

463

464

465

466

467

468

469

470

471

472

473

474

475

476

477

478

479

480

481

482

483

484

485

486

487

488

489

490

491

492

493

494

495

496

497

498

499

500

501

502

503

504

505

506

507

508

509

510

511

512

513

514

515

516

517

518

519

520

521

522

523

524

525

526

527

528

529

530

531

532

533

534

535

536

537

538

539

540

541

542

543

544

545

546

547

548

549

550

551

552

553

554

555

556

557

558

559

560

561

562

563

564

565

566

567

568

569

570

571

572

573

574

575

576

577

578

579

580

581

582

583

584

585

586

587

588

589

590

591

592

593

594

595

596

unit sharovidniy_struckt;

interface

uses Classes, windows, SysUtils, math;

const

W_glob =450;

H_glob =450;

Sp_GAUSS=0; //скорости - как генерировать

Sp_EQUAL=1;

tail_dimension = 15; //размерность массива для сохраниения хвоста

savetype = 'SvballSimv1.0'; //токен для идетификации

max_srt = 100; //максимальное число сортов

type

tvector = record

dx,dy:single;

end;

presave_struct = record

NM:string[18];

NumBall:cardinal; //число шаров

NumSort:cardinal; //число сортов

delta_t: single; //время итерации в методе конечных разностей

close_hustle : single; //константа близкого расталкивания

conglut : boolean; //освобождаться от слипания

pregenglut : boolean; //сгенерировать так, чтобы шарики не были слипшимися

end;

Ball = record

x,y:single; //координаты

color:dword; //цвет

vx,vy:single; //скорость

fx,fy:single; //сила

m:smallint; //масса

q:smallint; //заряд

r:dword; //радиус

tl:array[0..tail_dimension,0..1]of single;//131

end;

Lpball = ^ball;

sort = record

S:string[40]; //название сорта

n:smallint; //число таких шаров

m:smallint; //масса

q:smallint; //заряд

r:dword; //радиус

color:dword; //цвет

speedGen: integer; //тип распеределения по скоростям при генерации сорта

end;

TGlob_var = record

gravX, gravY: single; //параметры ускорения

GravOn: boolean;

xbord, ybord: integer; //размеры окошка

balance : integer; //баланс между гравитационным меж частичным взаимодействием и кулоновским взаимодействием

precis : integer; //точность - ход с самой малой скоростью разбит ещё на подшаги

claster : boolean; //модель границ

flexible: boolean; //упругие вз-вия

interact_grav: boolean; //меж частичная гравитация

end;

Tvisi_var = record

//хвост

tail_length: integer; //длина

exe_tail : boolean; //обрабатывать или нет

tl_len, tl_pos : integer;//текущая длина, текущая позиция - внутренние характеристики

//эквалайзеры

vr,hr: array[0..100] of integer; //накопители

ekvX, ekvY: boolean;//аквалайзеры включены

step_ek :integer; // число шагов по вертикали и горизонтали

//число пропусков визуалтзации

visstep: integer; //пропуск тактов визуализации

auto_frameset:boolean; //автоматический подсчет числа скрытых кадров

hidframes:integer; //скрытых фреймов

end;

ballexec = class

delta_t: single; //время итерации в методе конечных разностей

conglut : boolean; //освобождаться от слипания

pregenglut : boolean; //сгенерировать так, чтобы шарики не были слипшимися

close_hustle : single; //константа близкого расталкивания

//параметры исполнения

glob : Tglob_var;

vis : Tvisi_var;

procedure Execute;

//блоки исполнения

procedure GlobalParamsRequestExecution;

//инициализация

function buildballlist:boolean; //расставляем шарики, вычисляем первую delta_t

//загрузка-выгрузка

function save(flname:string;mode:byte):boolean; //запись с позициями вместе

function saveposes(flname:string):boolean;

function savesortes(flname:string):boolean;

function loadposes(flname:string):boolean;

destructor destroy; override;

private

{ Private declarations }

protected

constructor Create;

end;

var

//массив шариков

Bl:array of ball; //список мячей

srt:array of sort;//список сортов

//форма 3

ab: tGlob_var; //глобальные переменные, которые используются в форме No 3 - Global params

applyRequest: boolean; //требование их обновить

//собстаенно сам объект

fastup:ballexec;

procedure default_init;

//вспомогательные процедуры

function GetInteger(s:string;i,i1,i2:integer):integer;

function GetFloat(s:string;r,r1,r2:real):real;

function reversecolor(c:integer):dword;

procedure FixSeparator(var s:string);

procedure SetClientRect(w,h:integer; th:thandle);

implementation

function ballexec.save(flname:string;mode:byte):boolean; //запись с позициями вместе

var ts: presave_struct;

z: tfilestream;

function sv(const Buffer; Count: Longint): boolean;

begin

result:= (z.Write(buffer,count) = Count);

end;

begin //mode 0 - poses, mode 1 - sortes

result:=false;

if (mode<>0) and (mode<>1) then exit;

ts.NM:= savetype; //заполниние аспомогательной структуры

case mode of

0: ts.NumBall:=length(bl);

1: ts.NumBall:=0;

end;

ts.NumSort:=length(srt);

ts.delta_t:=delta_t; //сохраним дополнительные параметры

ts.close_hustle:=close_hustle;

ts.conglut:= conglut;

ts.pregenglut:= pregenglut;

z:=tfilestream.Create(flname,fmCreate,fmShareDenyWrite); //создание

if sv(ts,sizeof(presave_struct)) and sv(fastup.glob,sizeof(Tglob_var)) and sv(fastup.vis,sizeof(Tvisi_var)) and

sv(srt[0],sizeof(sort)*ts.NumSort) then result:=true; //запись

if mode=0 then

result:=result and sv(bl[0],sizeof(ball)*ts.NumBall);

z.Destroy; //высвободим память, закроем файл

end;

function ballexec.saveposes(flname:string):boolean; //запись с позициями вместе

begin

result:=save(flname, 0);

end;

function ballexec.savesortes(flname:string):boolean; //запись только сортов без позиций

begin

result:=save(flname, 1);

end;

function ballexec.loadposes(flname:string):boolean; //загрузка данных с позициями

var ts: presave_struct;

z: tfilestream;

function LD(var Buffer; Count: Longint): boolean;

begin

result:= (z.Read(buffer,count) = Count);

end;

label fin;

begin

result:=false;

z:=tfilestream.Create(flname,fmOpenRead,fmShareDenyWrite); //создание

if not LD(ts,sizeof(presave_struct)) then goto fin;

if (ts.NM <> savetype) or (ts.NumSort>max_srt) then goto fin; //проверка вспомогательной структуры

if ts.NumBall<>0 then setlength(bl,ts.NumBall);

setlength(srt,ts.NumSort);

if LD(fastup.glob,sizeof(Tglob_var)) and LD(fastup.vis,sizeof(Tvisi_var)) and

LD(srt[0],sizeof(sort)*ts.NumSort) and LD(bl[0],sizeof(ball)*ts.NumBall) then result:=true; //загрузка

fin:

if not result then

begin

if ts.NumBall<>0 then

setlength(bl,0);

setlength(srt,0);

end else begin

delta_t:=ts.delta_t; //восстановим дополнительные параметры если загрузка произошла удачно

close_hustle:=ts.close_hustle;

conglut:= ts.conglut;

pregenglut:= ts.pregenglut;

end;

z.Destroy; //высвободим память, закроем файл

end;

function ballexec.buildballlist:boolean; //расставляем шарики, вычисляем первую delta_t

var re,ve,dif,V:single;

n,try_init,j,k:integer;

R:smallint;

f:boolean;

label retpoint;

begin

setlength(bl,0);

result:=false;

n:=0;

V:=1;

fastup.close_hustle:=0; //расчет константы рассталкивания

for k:=0 to length(srt)-1 do //цикл по сортам

begin

setlength(bl,length(bl)+srt[k].n);//прирост числа шаров

if srt[k].speedGen=sp_gauss then dif:=0.3*V else dif:=0;

while n<length(bl) do //генерация шариков сорта

begin

f:=false; //ошибка генереции позиции шара

try_init:=0; //счетчик попыток в ноль

repeat //пока нормальных координат не сгенерирует

if try_init>500 then

begin

if IDcancel=messagebox(0,'I have done 500 attempts for creation ball`s position. Do you wish continue?','Creation crash :-(',MB_RETRYCANCEL) then

begin

setlength(bl,0); //чтобы не смогли записать глюковые координаты

exit;

end;

try_init:=0;

end;

inc(try_init);

R:=srt[k].r;

Bl[n].x:=random*(glob.xbord-2*R)+R;//random coord

Bl[n].y:=random*(glob.ybord-2*R)+R;

if (n>0) and pregenglut then //если шарик не первый и надо создавать не слипшуюся конфигурацию

for j:=0 to n-1 do begin

f:= (sqr(Bl[n].x-Bl[j].x)+sqr(Bl[n].y-Bl[j].y))<=sqr(R+bl[j].r);

if f then break;

end;

until not f;

re:=PI*random*2; //random direction

ve:=RandG(V,dif); //случайная длина вектора скорости

with bl[n] do begin

vx:=cos(re)*Ve; //стартовая скорость

vy:=sin(re)*Ve;

q:=srt[k].q; //параметры шара

m:=srt[k].m;

r:=srt[k].r;

color:=srt[k].color;

fastup.close_hustle:=max(fastup.close_hustle,m); //этот параметр достаточно сложный...

fastup.close_hustle:=max(fastup.close_hustle,q);

end;

inc(n); //следующий ! кричит заведущий

end; //генерация шариков сорта k

end; //сорт k

delta_t:=0.5 / glob.precis; //precis идет по умолчанию, потом Vmax=2 ну и ещё попалам, как некая минимальная величина

result:=true;

end;

procedure ballexec.GlobalParamsRequestExecution;

begin

if applyrequest then //обработка запроса на новые глобальные настройки

begin

fastup.glob:=ab; //запись новых глобальных настроек

applyrequest:=false; //запрос выполнен

end;

procedure ballexec.Execute;

var hlpX,hlpY,L,L1,mxspeed,mnspeed:single;

a1,a2,a3:^ball;

i, k, j, h:integer;

jin,allmass:integer;

n, R:integer;

hlp,hlp2,xx,yy,len,cx,cy:single;

Gkoef, Ckoef: single; //коэффициенты балансировки кулона и гравитации

label miss, never_stop, nxt;

begin

GlobalParamsRequestExecution;

//инициализация

n:= length(Bl)-1; //номер последнего шара

if n=-1 then exit;

//интерпретация балансировки гравитации, и зарядового притяжения

Gkoef:=-1; //притяжение

Ckoef:=1; //рассталкивание

if glob.balance<0 then begin

Gkoef:=1/glob.balance;

Ckoef:=-glob.balance;

end;

if glob.balance>0 then begin

Gkoef:=-glob.balance;

Ckoef:=1/glob.balance;

end;

//скрыть кадры !!

for j:=1 to vis.hidframes*vis.visstep do //число итераций без визуализа

begin

for k:=0 to n do // n - всего шаров

begin // очистка силовой составляющей

Bl[k].fx:=0; //сюда входит только парные взаимодействия

Bl[k].fy:=0;

end;

k:=0;// циклы треугольника парных взаимодействий

while k<n do//for k:=1 to n-1 do

begin

a1:=@Bl[k];// используем указатели на шарики 1-й объект

i:=k+1;

while i<=n do//for i:=k+1 to n do

begin

a2:=@Bl[i];// используем указатели на шарики 2-й объект

xx:=a1.x-a2.x;//dx

yy:=a1.y-a2.y;//dy

hlp:=xx*xx+yy*yy;//D**2

len:=sqrt(hlp);//D

//кулон или/и гравитация?

if glob.interact_grav then begin //гравитация м/у объектами включена

hlp2:=a1.m*a2.m/hlp/len*Gkoef;{grav force calc}

hlpX:=hlp2*xx;//fx - проекции силы

hlpY:=yy*hlp2;//fy -

a2.fx:=a2.fx+{cs}hlpX;

a2.fy:=a2.fy+{sn}hlpY;

a1.fx:=a1.fx-{cs}hlpX;

a1.fy:=a1.fy-{sn}hlpY;

end;

if a1.q*a2.q<>0 then begin //зарядовое взаимодействие

hlp2:=a1.q*a2.q/hlp/len*Ckoef;{colomb force calc}

hlpX:=hlp2*xx;//fx - зарядовое сила взаимодействия зарядов (проекции силы)

hlpY:=yy*hlp2;//fy - зарядовое

a2.fx:=a2.fx+{cs}hlpX;

a2.fy:=a2.fy+{sn}hlpY;

a1.fx:=a1.fx-{cs}hlpX;

a1.fy:=a1.fy-{sn}hlpY;

end;

if len<=a1.r+a2.r then begin// если шарики соприкоснулись - отработка отражений

if not glob.flexible then begin //распирающий потенциал для того чтобы не слипались наши друзья

hlp2:=close_hustle*close_hustle*10/hlp/len;{colomb force calc}

hlpX:=hlp2*xx;//fx - зарядовое сила взаимодействия зарядов (проекции силы)

hlpY:=yy*hlp2;//fy - зарядовое

a2.fx:=a2.fx+{cs}hlpX;

a2.fy:=a2.fy+{sn}hlpY;

a1.fx:=a1.fx-{cs}hlpX;

a1.fy:=a1.fy-{sn}hlpY;

end;

//найдём проэкцию вектора скорости на осевой вектор м/у центрами шариков

xx:=xx/len;//нормировка к единице - далее идет оценка столкновения и отражение

yy:=yy/len;

L:=a2.vx*xx+a2.vy*yy;//проэкция скорости на вектор удара единичной длины

L1:=-a1.vx*xx-a1.vy*yy;//проэкция скорости на вектор удара единичной длины

if conglut then // разрешено избавляться от слипания при работе

if (L<0)and(L1<0)then goto miss;//сближение не зафиксировано

if glob.flexible then

hlp2:=(L1+L)*2/(a2.m+a1.m) //идеально упругий обмен импульсами

else hlp2:=(L1+L)*2/(a2.m+a1.m)*0.95; //имровизированная неупругость

a2.vx:=a2.vx-xx*hlp2*a1.m;

a2.vy:=a2.vy-yy*hlp2*a1.m;

a1.vx:=a1.vx+xx*hlp2*a2.m;

a1.vy:=a1.vy+yy*hlp2*a2.m;

miss:

end;{if len<R1+R2}

inc(i);

end;{for i}

inc(k);

end;{for k}

//парные вз-вия отработаны

//************************************************************************************************************

//new coords and borders **********************************************************************************

cx:=0; //для кластерного режима надо усреднить массы и координаты

cy:=0;

allmass:=0;

mxspeed:=0;//предустановка искомых границ скорости

mnspeed:=1e10;

if j = 1 then begin

if vis.ekvX or vis.ekvY then

begin //очистка эквалайхеров

zeromemory(@vis.vr[0],sizeof(vis.vr));

zeromemory(@vis.hr[0],sizeof(vis.hr));

end;

L :=glob.xbord/vis.step_ek;//величина ячейки вертикального эквалайзера

L1:=glob.ybord/vis.step_ek;//величина ячейки горизонтального эквалайзера

vis.tl_len := min(vis.tl_len, vis.tail_length); //усечение хвоста при сокращении

end;

for k:=0 to n do

begin

//coords

a1:=@Bl[k];//указатель на шарик

xx:=a1.vx;

yy:=a1.vy;

hlpX:=a1.x+xx*delta_t;//x=x+V*t

hlpY:=a1.y+yy*delta_t;

//gravity

if glob.GravOn then //гравитация включена

begin

xx:=xx+glob.gravX*delta_t;

yy:=yy+glob.gravY*delta_t;//Vy=Vy+g*t

end;

//border

R:=a1.r;

if glob.claster then //cluster model

begin

if (hlpX<R)or(hlpX>glob.xbord-R) then hlpX:=glob.xbord-hlpX;

if (hlpY<R)or(hlpY>glob.ybord-R) then hlpY:=glob.ybord-hlpy;

end else begin //not a cluster model

if hlpX<R then xx:=abs(xx) else //отражение от стенок

if hlpX>glob.xbord-R then xx:=-abs(xx);

if hlpY<R then yy:=abs(yy) else

if hlpY>glob.ybord-R then yy:=-abs(yy);

end;

//charge

if (a1.q<>0) or glob.interact_grav then//если заряжена или включен обсчет гравитации

begin

xx:=xx-a1.fx*delta_t/a1.m;

yy:=yy-a1.fy*delta_t/a1.m;

end;

//вставка для обработки графической статистики

if j=1 then begin //во время первой итерации

if vis.EkvY then begin //аквалайзер накапливаем

i:=trunc(hlpY/L1);

if (i>=0) and (i<length(vis.vr)) then vis.vr[i]:=vis.vr[i]+a1.m;

end;

if vis.EkvX then begin

i:=trunc(hlpX/L);

if i>=0 then vis.hr[i]:=vis.hr[i]+a1.m;

end;

if vis.exe_tail then begin//хвост

a1.tl[vis.tl_pos,0]:=a1.x; //записываем старые данные хвоста

a1.tl[vis.tl_pos,1]:=a1.y;

end;

//конец обработки графической статистики

a1.vx:=xx; //новая скорость

a1.vy:=yy;

hlp:=abs(xx)+abs(yy);// ну типа скорость максимальную так считаю // hlp:=sqrt(xx*xx+yy*yy);//V

if mxspeed<hlp then mxspeed:=hlp;//поиск максимума и минимума квадрата скоростей

if mnspeed>hlp then mnspeed:=hlp;

//код направлен на то чтобы избегать слипания

{ if not glob.flexible and (k>0) then //проверка на перекрытие чтобы не налазить на другие шары в режиме неупругого взаимодействия

begin

a2:=@Bl[0];

for i:=0 to k-1 do

begin

if (sqr(hlpx-a2.x)+sqr(hlpy-a2.y))<sqr(a1.r+a2.r) then

begin

xx:=hlpx-a2.x;//dx - координаты расстояния м/у шарами после пересчета координат

yy:=hlpy-a2.y;//dy

hlp:=xx*xx+yy*yy;//D**2

len:=sqrt(hlp)/(a1.r+a2.r+0.001);//D/R - расстоние между шарами после пересчета координат/поделить на максимальное расстояние

xx:=xx/len;//dx - отодвинем

yy:=yy/len;//dy

a3:=@Bl[0]; //проверим, вдруг при отступе мы налезем ещё на кокой то шар

for h:=0 to n do

begin

if a1<>a3 then //с самим собой сранивать не надо :)

if (sqr(xx+a2.x-a3.x)+sqr(yy+a2.y-a3.y))<sqr(a1.r+a3.r) then //вот собственно проверка

goto nxt;

inc(a3);

end;

hlpX:=xx+a2.x; //вот такие координаты приемлимы

hlpY:=yy+a2.y;

end; //если новый a1 и a2 на расстоянии менее сумма радиусов

nxt: inc(a2);

end;//for i

end;}

a1.x:=hlpX;//новые координаты

a1.y:=hlpY;

if glob.claster then//кластер?

begin

jin:=a1.m;

allmass:=allmass+jin;

cx:=cx+hlpX*jin;

cy:=cy+hlpY*jin;

end;

end;{of k}

// delta_t:= 1 / (glob.precis*sqrt(mxspeed));

delta_t:= 1 / (glob.precis*mxspeed+0.00001);

if glob.claster then //реализуем кластерный режим - центровка

begin

cx:=glob.xbord/2-cx/allmass;

cy:=glob.xbord/2-cy/allmass;

for k:=0 to n do

begin

a1:=@Bl[k];

a1.x:=a1.x+cx;

a1.y:=a1.y+cy;

end;

end {of check8}

end; {of j}// число итераций, которые скрыты

//эти 3 строки можно вставить и в тело j, но в рамках условия j=1 и вне цикла k=0..n

inc(vis.tl_pos);//следующая позиция - рост хвоста или отслеживание

if vis.tl_pos > tail_dimension then vis.tl_pos:=0;

if vis.tail_length>vis.tl_len then inc(vis.tl_len); //длина хвоста растет

end;

destructor ballexec.destroy;

begin

inherited destroy;

end;

constructor ballexec.Create;

begin

inherited Create;

with glob do //глобальные настройки по умолчанию

begin

xbord:= W_glob; ybord:=h_glob; //размеры

gravX:=0.0; GravY:=2.0; //гравитация

gravOn:=false;

precis:=3;

claster:=false;// коробочный режим

flexible:=true;

interact_grav:=false;

end;

with vis do //установки визуальные по умолчанию

begin

tail_length:=0;

tl_len:=0;

tl_pos:=0;

exe_tail:= false;

ekvX:=false;

ekvY:=false;

step_ek:=25;

auto_frameset:=true;

end;

ab:=glob;

end;

procedure default_init; //инициализация всех настроек

begin

if fastup<>nil then fastup.Destroy; //создание нити

fastup:=ballexec.Create;

setlength(srt,1); //один сорт сделаем

with srt[0] do

begin

s:='';

n:=100;

m:=4;

r:=5;

color:=$0000ff;

end;

procedure FixSeparator(var s:string);

var j:integer;

begin

j:=pos('.',s);//замена точки или запятой на нужный разделитель

if j<>0 then s[j]:=DecimalSeparator;

j:=pos(',',s);

if j<>0 then s[j]:=DecimalSeparator;

end;

//s - конвертируемое значение

//r - значение по умолчанию

//r1,r2 - диапазон допустимых значений

//на выходе хранит флоат

function GetFloat(s:string;r,r1,r2:real):real;

begin

FixSeparator(s);//точку правим

try

result:=strtofloat(s);//попытка взять число

except

on EConvertError do

result:=r; //выбрали по умолчанию при ошибке

end;

if result<r1 then result:=r1 //подгонка к рамкам диапазона [r1..r2]

else if result>r2 then result:=r2;

end;

//s - конвертируемое значение

//i - значение по умолчанию

//на выходе - целое число

function GetInteger(s:string;i,i1,i2:integer):integer;

begin

result:=trunc(GetFloat(s,i,i1,i2));

end;

function reversecolor(c:integer):dword;

begin

result:= (c and $ff0000) div $10000 + (c and $ff00) + (c and $ff) * $10000;

end;

procedure SetClientRect(w,h:integer; th:thandle); //установка размера клиентской части

var rc: Trect;

begin

rc:=rect(0,0,w,h);

if AdjustWindowRectEx(rc, GetWindowLong(th,GWL_STYLE), false, GetWindowLong(th,GWL_EXSTYLE)) then

SetWindowPos(th, 0, 0, 0, rc.Right-rc.Left, rc.Bottom-rc.Top,

SWP_NOMOVE or SWP_NOZORDER);

end;

initialization

begin

randomize;

end;

end.

Комментарии к «Модуль рассчета движения шариков»

Понравилась статья? Есть вопросы? - пишите в комментариях.

Мануальный терапевт одинцово

мануальный терапевт одинцово

eastclinic.ru

Имя (обязательно)	Е-майл (не будет опубликован на сайте, обязательно для заполнения)
Комментарий: