A simulation program for oscillatory motion or wave behavior.
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;
Colors: 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;
SetFillStyle(SolidFill, 9);
SetColor(7);
Graph.Rectangle(Round(BoxXmin), Round(BoxYmin), Round(BoxXmax), Round(BoxYmax));
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(9);
for i:=1 to 4 do
begin
Graph.FillEllipse(Round(CurX[i]), Round(CurY[i]), 3, 3)
end;
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);
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
CloseGraph;
Writeln('All done.');
Halt(1);
end
else
ClearViewPort;
MessageFrame('Press a key to stop action, 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.