Код:
uses Crt, Graph;
const d = 12; {13}
r = 2;
del = #219#219#219;
var Gd, Gm, i, j, x, y, k, n: integer;
Q: array[1..5] of integer;
b: pointer;
z: string;
procedure init;
begin
clrscr; writeln('vsego zeren:16*k');
write('vvedite koeffisient(ot 1 do 60)k=?', #8); readln(k);
Gd := vga; Gm := vgaHi; InitGraph(Gd, Gm, ''); {ClipOn}
SetViewPort(GetMaxX div 2, 10, GetMaxX, GetMaxy, ClipOff);
SetColor(2); Setlinestyle(Solidln, 0, ThickWidth);
Line(-6, 0, -25 * d, 0); Line(6, 0, 25 * d, 0);
OutTextXY(3 * d, -10, '(ostalos)');
SetColor(10); OutTextXY(-10 * d - 180, 38 * d, 'chisla Paskalya->');
SetTextJustify(CenterText, TopText);
Str(6 * k, z); OutTextXY(0, 38 * d, z);
Str(4 * k, z); OutTextXY(4 * d, 38 * d, z); OutTextXY(-4 * d, 38 * d, z);
Str(k, z); OutTextXY(8 * d, 38 * d, z); OutTextXY(-8 * d, 38 * d, z);
SetFillStyle(9, 2);
Randomize;
for i := 1 to 5 do Q[i] := 0;
n := 0
end; {Init}
procedure Board;
procedure Half(a: Integer);
begin
MoveTo(a, 0);
for i := 1 to 4 do
begin LineRel(0, Abs(a)); LineRel(a, Abs(a)) end;
LineRel(0, Abs(10 * a)); LineRel(-5 * a, 0)
end;
procedure Obstacle(x, Y: Integer);
begin
MoveTo(x, y);
LineRel(d, -d); LineRel(0, -2 * d); LineRel(-d, -d);
LineRel(-d, d); LineRel(0, 2 * d); LineRel(d, d);
FloodFill(x, y - d, 10)
end;
begin
Half(2 * d); {pravaya polovina}
Half(-2 * d); {leveya polovina}
for i := 1 to 4 do
for j := 1 to i do
begin
Obstacle(2 * (2 * i - j - 4) * d, (23 - 4 * j) * d); {prepyatstviya}
if j = 1 then LineRel(0, 17 * d) {peregorodki}
end
end; {board}
procedure Ball;
var size: Word;
begin
SetColor(13); SetFillStyle(1, 13); FillEllipse(3, 3, r, r);
size := ImageSize(0, 0, 6, 6);
GetMem(b, size); GetImage(0, 0, 6, 6, b^);
SetColor(0); FillEllipse(3, 3, r, r);
FreeMem(b, size)
end; {Ball}
procedure PutBall;
const v = 5; {konstanta,vliyaushaya na skorost dvigeniya sharika}
begin
PutImage(x, y, B^, XorPut); Delay(v); PutImage(x, y, B^, XorPut);
Inc(y)
end; {PutBall}
procedure Upper; {prohojdenie verhney chasty doski}
var dx: - 1..1;
procedure Choise; {vibor puti}
begin
dx := -1 + 2 * Random(2); {pirashenie abscisi:1 ili -1}
Sound(40); Delay(1); NoSound
end; {Choise}
begin
Inc(n); Str(n, z);
SetColor(0); OutTextXY(0, -10, del);
SetColor(13); OutTextXY(0, -10, z);
Str(16 * k - n, z);
SetColor(0); OutTextXY(12 * d, -10, del);
x := 0; y := 0;
for j := 1 to 4 do
begin
for i := 1 to 2 * d do PutBall; {vniz}
Choise; {nflevo ili napravo?}
for i := 1 to 2 * d do begin PutBall; Inc(x, dx) end {naiskos}
end
end; {Upper}
procedure Lower; {prohojdenie nijnei chasty doski}
const bottom = 36 * d - 2 * r - 2; {ordinata centrov sharov nijnego ryada}
var top: Word; {ordinata verhnego ryada v tekeshem otdelenii}
num: 1..5; {nomer otdeleniya}
begin
num := x div (4 * d) + 3; {opredelenie nomera otdeleniya}
top := bottom - (Q[num] div 5) * 3 * r;
if top < 19 * d then top := 19 * d;
repeat PutBall; {Inc(y)} until y = top; {vniz}
Sound(3000); Delay(2); NoSound;
SetColor(0); OutTextXY(x, 37 * d, del);
Str(Q[num] + 1, z);
SetColor(13); OutTextXY(x, 37 * d, z);
x := x - d + (Q[num] mod 5) * (3 * r + 1); {abscissa fiksiryemogo}
FillEllipse(x, y, r, r); {v otdelenii sharika}
Inc(Q[num]) {podschet sharikov v otdeleniyah}
end; {Lower}
begin
Init; Board; Ball;
repeat Upper; Lower until (n = 16 * k) or KeyPressed;
Write(#7); Readln; CloseGraph
end.