Version 1 of the oscillation simulation program.
{$N+}
program Oscill;
uses
Crt, Graph;
const
Memory=100;
Windows=4;
type
ResolutionPreference=(Lower,Higher);
ColorList=array [1..Windows] of integer;
var
Xmax,Ymax,ViewXmax,ViewYmax: integer;
Color: ColorList;
Ch: char;
BackColor: integer;
GraphDriver, GraphMode: integer;
MaxColors: word;
AccX, VelX, CurX: array[1..4] of Double;
AccY, VelY, CurY: array[1..4] of Double;
Strength: array[1..8] of Double;
InLen: array[1..8] of Double;
LenX, LenY: Double;
i: Integer;
CurPage: Integer;
BoxXmax, BoxYmax, BoxXmin, BoxYmin: Double;
{if (Gd = HercMono) or (Gd = EGA) or (Gd = EGA64) or (Gd = VGA) then}
procedure ChangePage;
begin
if CurPage = 0 then
begin
CurPage := 1;
SetActivePage(1); {Устанавливает активную графическую страницу}
SetVisualPage(0); {Устанавливает номер видимой граф. страницы}
end
else
begin
CurPage := 0;
SetActivePage(0); {----//-----}
SetVisualPage(1); {----//-----}
end;
end;
procedure DrawPoints(color:word);
var
i: Integer;
begin
ChangePage;
Graph.ClearViewPort;
SetBKColor(3);
SetFillStyle(1,4);
SetLineStyle(0,1,3);
SetColor(8);
Graph.Line(Round(BoxXmin), Round(BoxYmin), Round(CurX[1]), Round(CurY[1]));
Graph.Line(Round(BoxXmax), Round(BoxYmin), Round(CurX[2]), Round(CurY[2]));
Graph.Line(Round(BoxXmax), Round(BoxYmax), Round(CurX[3]), Round(CurY[3]));
Graph.Line(Round(BoxXmin), Round(BoxYmax), Round(CurX[4]), Round(CurY[4]));
Graph.Line(Round(CurX[1]), Round(CurY[1]), Round(CurX[2]), Round(CurY[2]));
Graph.Line(Round(CurX[2]), Round(CurY[2]), Round(CurX[3]), Round(CurY[3]));
Graph.Line(Round(CurX[3]), Round(CurY[3]), Round(CurX[4]), Round(CurY[4]));
Graph.Line(Round(CurX[4]), Round(CurY[4]), Round(CurX[1]), Round(CurY[1]));
SetColor(4); { №5-фиолетовый цвет}
for i:=1 to 4 do
begin
Graph.FillEllipse(Round(CurX[i]),Round(CurY[i]),6,6);
end;
SetColor(1); { №6-коричневыйт цвет}
Graph.Rectangle(Round(BoxXmin), Round(BoxYmin), Round(BoxXmax), Round(BoxYmax));
SetLineStyle(UserBitLn, $FFFF, $FF);
end;
function DistFromTo(xf, yf, xt, yt: Double): Double;
var res: Double;
begin
res := Sqrt((xf-xt)*(xf-xt)+(yf-yt)*(yf-yt));
if res = 0 then DistFromTo := 1
else DistFromTo := res;
end;
procedure SetIniLength;
begin {вычисление длины пружины}
InLen[1] := DistFromTo(BoxXmin, BoxYmin, CurX[1], CurY[1]);
InLen[2] := DistFromTo(CurX[1], CurY[1], CurX[2], CurY[2]);
InLen[3] := DistFromTo(BoxXmax, BoxYmin, CurX[2], CurY[2]);
InLen[4] := DistFromTo(CurX[2], CurY[2], CurX[3], CurY[3]);
InLen[5] := DistFromTo(BoxXmax, BoxYmax, CurX[3], CurY[3]);
InLen[6] := DistFromTo(CurX[3], CurY[3], CurX[4], CurY[4]);
InLen[7] := DistFromTo(BoxXmin, BoxYmax, CurX[4], CurY[4]);
InLen[8] := DistFromTo(CurX[4], CurY[4], CurX[1], CurY[1]);
end;
{вычисление действующей силы,на шарики:общей силы и сил по данным ортам}
function GetForce(xf,yf,xt,yt:Double;n:Integer):Double;
begin
GetForce:=(InLen[n]-DistFromTo(xf,yf,xt,yt))*Strength[n];
end;
function GetForceX(xf,yf,xt,yt:Double;n:Integer):Double;
begin
GetForceX:=GetForce(xf,yf,xt,yt,n)*(xf-xt)/DistFromTo(xf,yf,xt,yt);
end;
function GetForceY(xf,yf,xt,yt:Double;n:Integer):Double;
begin
GetForceY:=GetForce(xf,yf,xt,yt,n)*(yf-yt)/DistFromTo(xf,yf,xt,yt);
end;
{главный цикл}
procedure MainCycle(dt: Double);
begin
for i:=1 to 4 do
begin
AccX[i] := 0; {начальные ускорения равны нулю}
AccY[i] := 0;
end;
AccX[1] := AccX[1] + GetForceX(CurX[1], CurY[1], BoxXmin, BoxYmin, 1);
AccX[1] := AccX[1] + GetForceX(CurX[1], CurY[1], CurX[2], CurY[2], 2);
AccX[1] := AccX[1] + GetForceX(CurX[1], CurY[1], CurX[4], CurY[4], 8);
AccY[1] := AccY[1] + GetForceY(CurX[1], CurY[1], BoxXmin, BoxYmin, 1);
AccY[1] := AccY[1] + GetForceY(CurX[1], CurY[1], CurX[2], CurY[2], 2);
AccY[1] := AccY[1] + GetForceY(CurX[1], CurY[1], CurX[4], CurY[4], 8);
AccX[2] := AccX[2] + GetForceX(CurX[2], CurY[2], BoxXmax, BoxYmin, 3);
AccX[2] := AccX[2] + GetForceX(CurX[2], CurY[2], CurX[1], CurY[1], 2);
AccX[2] := AccX[2] + GetForceX(CurX[2], CurY[2], CurX[3], CurY[3], 4);
AccY[2] := AccY[2] + GetForceY(CurX[2], CurY[2], BoxXmax, BoxYmin, 3);
AccY[2] := AccY[2] + GetForceY(CurX[2], CurY[2], CurX[1], CurY[1], 2);
AccY[2] := AccY[2] + GetForceY(CurX[2], CurY[2], CurX[3], CurY[3], 4);
AccX[3] := AccX[3] + GetForceX(CurX[3], CurY[3], BoxXmax, BoxYmax, 5);
AccX[3] := AccX[3] + GetForceX(CurX[3], CurY[3], CurX[2], CurY[2], 4);
AccX[3] := AccX[3] + GetForceX(CurX[3], CurY[3], CurX[4], CurY[4], 6);
AccY[3] := AccY[3] + GetForceY(CurX[3], CurY[3], BoxXmax, BoxYmax, 5);
AccY[3] := AccY[3] + GetForceY(CurX[3], CurY[3], CurX[2], CurY[2], 4);
AccY[3] := AccY[3] + GetForceY(CurX[3], CurY[3], CurX[4], CurY[4], 6);
AccX[4] := AccX[4] + GetForceX(CurX[4], CurY[4], BoxXmin, BoxYmax, 7);
AccX[4] := AccX[4] + GetForceX(CurX[4], CurY[4], CurX[3], CurY[3], 6);
AccX[4] := AccX[4] + GetForceX(CurX[4], CurY[4], CurX[1], CurY[1], 8);
AccY[4] := AccY[4] + GetForceY(CurX[4], CurY[4], BoxXmin, BoxYmax, 7);
AccY[4] := AccY[4] + GetForceY(CurX[4], CurY[4], CurX[3], CurY[3], 6);
AccY[4] := AccY[4] + GetForceY(CurX[4], CurY[4], CurX[1], CurY[1], 8);
for i:=1 to 4 do {вычисление скорстей и прирощений}
begin {используется метод Эйлера}
VelX[i] := VelX[i] + AccX[i] * dt;
VelY[i] := VelY[i] + AccY[i] * dt;
CurX[i] := CurX[i] + VelX[i] * dt;
CurY[i] := CurY[i] + VelY[i] * dt;
end;
DrawPoints(13); {--------???--------}
end;
procedure Frame;
begin {устанавливает визуальный порт (окно) для ввода вывода}
SetViewPort(0, 0, Xmax, Ymax-(TextHeight('M')+4)-1,ClipOn);
SetColor(MaxColors);
Rectangle(0, 0, Xmax-1, (Ymax-(TextHeight('M')+4)-1)-1);
SetViewPort(1, 1, Xmax-2, (Ymax-(TextHeight('M')+4)-1)-2,ClipOn);
end { Frame };
procedure FullPort;
{ Set the view port to the entire screen }
begin
SetViewPort(0, 0, Xmax, Ymax, ClipOn);
end; { FullPort }
procedure MessageFrame(Msg:string);
begin
ChangePage;
FullPort;
SetColor(MaxColors);
SetTextStyle(DefaultFont, HorizDir, 1); {устанавливает стиль текста}
SetTextJustify(CenterText, TopText); {тип привязки текста к точке}
SetLineStyle(SolidLn, 0, NormWidth); {уст-т стиль линии}
SetFillStyle(EmptyFill, 0); {уст один из стан-х шаблонов и цвет закраски}
Bar(0, Ymax-(TextHeight('M')+4), Xmax, Ymax); {Bar-полоса}
Rectangle(0, Ymax-(TextHeight('M')+4), Xmax, Ymax);
OutTextXY(Xmax div 2, Ymax-(TextHeight('M')+2), Msg);
{ Go back to the main window }
Frame;
ChangePage;
FullPort;
SetColor(MaxColors);
SetTextStyle(DefaultFont, HorizDir, 1);
SetTextJustify(CenterText, TopText);
SetLineStyle(SolidLn, 0, NormWidth);
SetFillStyle(EmptyFill, 0);
Bar(0, Ymax-(TextHeight('M')+4), Xmax, Ymax);
Rectangle(0, Ymax-(TextHeight('M')+4), Xmax, Ymax);
OutTextXY(Xmax div 2, Ymax-(TextHeight('M')+2), Msg);
{ Go back to the main window }
Frame;
end { MessageFrame };
procedure WaitToGo; {процедура производящая остановку программы}
var
Ch : char;
begin
MessageFrame('Press any key to continue... Esc aborts');
repeat until KeyPressed;
Ch:=ReadKey;
if Ch=#27 then begin {#27-Esc}
CloseGraph;
Writeln('All done.');
Halt(1);
end
else
ClearViewPort;
MessageFrame('Press a key to stop motion, Esc quits.');
end; { WaitToGo }
{проверка на ощибки}
procedure TestGraphError(GraphErr: integer);
begin
if GraphErr <> grOk then begin
Writeln('Graphics error: ', GraphErrorMsg(GraphErr));
repeat until keypressed;
ch:=readkey;
Halt(1);
end;
end;
procedure Init;
var
Err, I: integer;
StartX, StartY: integer;
Resolution: ResolutionPreference;
s: string;
begin
Resolution:=Lower;
if paramcount>0 then begin
s:=paramstr(1);
if s[1]='/' then
if upcase(s[2])='H' then
Resolution:=Higher;
end;
{ Ch := ' ';
GraphDriver := Detect;
DetectGraph(GraphDriver, GraphMode);
TestGraphError(GraphResult);
case GraphDriver of
CGA : begin
GraphDriver := CGA;
GraphMode := CGAC1;
end;
MCGA : begin
case GraphMode of
MCGAMed, MCGAHi: GraphMode := MCGAC1;
end;
end;
EGA : begin
If Resolution = Lower then
GraphMode := EGALo
else
GraphMode := EGAHi;
end;
EGA64 : begin
If Resolution = Lower then
GraphMode := EGA64Lo
else
GraphMode := EGA64Hi;
end;
PC3270 : begin
GraphDriver := CGA;
GraphMode := CGAC1;
end;
ATT400 : case GraphMode of
ATT400C1,
ATT400C2,
ATT400Med,
ATT400Hi :
begin
GraphMode := ATT400C1;
end;
end;
end; }
InitGraph(GraphDriver, GraphMode, '');
TestGraphError(GraphResult);
SetGraphMode(1);
SetTextStyle(DefaultFont, HorizDir, 1);
SetTextJustify(CenterText, TopText);
MaxColors:=GetMaxColor;
BackColor:=0;
Xmax:=GetMaxX;
Ymax:=GetMaxY;
ViewXmax:=Xmax-2;
ViewYmax:=(Ymax-(TextHeight('M')+4)-1)-2;
end; {init}
procedure CheckForUserInput;
begin
if KeyPressed then begin
Ch := ReadKey;
if Ch <> #27 then WaitToGo;
end;
end;
function IntToStr(I: Real): String;
var
S: string[16];
begin
Str(I, S);
IntToStr:=S;
end;
procedure DoMagic;
var i : Integer;
begin
BoxXmin:=ViewXmax/4*1;
BoxXmax:=ViewXmax/4*3;
BoxYmin:=ViewYmax/4*1;
BoxYmax:=ViewYmax/4*3;
CurX[1]:=ViewXmax/3*1;
CurY[1]:=ViewYmax/3*1;
CurX[2]:=ViewXmax/3*2;
CurY[2]:=ViewYmax/3*1;
CurX[3]:=ViewXmax/3*2;
CurY[3]:=ViewYmax/3*2;
CurX[4]:=ViewXmax/3*1;
CurY[4]:=ViewYmax/3*2;
SetIniLength;
for i:=1 to 8 do Strength[i]:=1+i;
CurX[1]:=CurX[1]+10;
CurY[1]:=CurY[1]-10;
repeat
MainCycle(0.1);
{ MessageFrame(IntToStr(AccX[1]));}
CheckForUserInput;
until Ch=#27;
end;
begin
Init;
Frame;
MessageFrame('Press a key to stop action, Esc quits.');
DoMagic;
CloseGraph;
RestoreCrtMode;
Writeln('The End.');
end.