Игра-стрелялка для PascalABC.net
uses
graphABC, ABCobjects, timers;
var
f, fn: text;
t,check: Timer;
base_color, cgr: Color;
ug, time_play_sec,take_speed,time: real;
login, Str, str2, str3, st1, ch, password, zs, ks: string;
chapter, level, n, xgr, ygr, rgr, x_power, y_power,spin, time_play_sec2,chapter_test: integer;
xb, yb, xg, yg, power, ww, wh, shot, time_play_min, shot_max,level_test: integer;
Basa: RegularPolygonABC;
show4, target, target_bad: ObjectABC;
show, show2, show3, registr_but, login_but, status_box: RectangleABC;
Star, sun: StarABC;
show_pos: CircleABC;
Average_ugol: array of integer;
Average_power: array of integer;
mb: array[1..62] of string;
ground: array [1..9] of CircleABC;
panel: array [1..5] of RectangleABC;
lvlup_b, play, Cont, login_next, regist_next, from_0, from_6: boolean;
procedure pfile;
begin
Assign(fn, login + '.txt');
append(fn);
writeln(fn, '0');
write(fn, '0');
close(fn);
end;
procedure prewrite;
begin
Assign(f, login + '.txt');
Rewrite(f);
writeln(f, level);
Write(f, chapter);
Close(f);
end;
procedure pread;
var
level_s, chapter_s: string;
begin
Assign(f, login + '.txt');
Reset(f);
repeat
Readln(f, level_s);
level := StrToInt(level_s);
readln(f, chapter_s);
chapter := StrToInt(chapter_s);
until Eof(f);
Close(f);
end;
procedure pgenerate;
begin
var show_login: RectangleABC := new RectangleABC(0, 51, 150, 35, clorangeRed);
show_login.Text := 'Ваш логин: ' + Login;
st1 := 'AaBbCcDdEeFfGgHhIiJjKkLlMmNnOoPpQqRrSsTtUuVvWwXxYyZz0123456789.';
for var it := 1 to st1.length - 1 do
begin
mb[it] := st1[it];
end;
status_box.Text := 'Введите пароль: ';
readln(ch);
password := ch;
status_box.text := 'Вы создали нового пользователя!';
show_login.Destroy;
pfile;
end;
procedure pcreate;
begin
var show_login: RectangleABC := new RectangleABC(0, 51, 150, 25, clorangeRed);
assign(F, 'users.txt');
append(f);
close(f);
reset(f);
show_login.text := 'Введите логин: ';
status_box.Text := 'Введите логин: ';
readln(login);
while not eof(f) do
begin
if (str <> str2) then eof(f);
readln(f, str);
if pos(login, str) > 0 then begin
str2 := str;
readln(f, str);
str3 := str;
if (str <> str2) then eof(f);
end;
end;
close(f);
if login = str2 then begin
status_box.Text := 'Это имя уже занято!';
regist_next := false;
end
else begin
Append(F);
status_box.text := 'Помощь: Если ввести /gen, то пароль будет сгенерирован автоматически.';
pgenerate;
zs := '';
ks := ',.!@?-:;+';
for var i := 1 to password.Length do
begin
n := pos(password[i], ks);
zs := zs + inttostr(n);
end;
zs := '';
ks := ',.!@?-:;+Zqazwsxedc90rfvtgbhnu7jAmiklop345QWERTYSXDCyFVG1BUHNMJI2OPKL68';
for var i := 1 to password.Length do
begin
n := pos(password[i], ks);
zs := zs + inttostr(n);
end;
password := zs;
writeln(f, login);
writeln(f, password);
close(f);
end;
show_login.Destroy;
end;
procedure plogin;
begin
Assign(f, 'users.txt');
append(f);
Close(f);
Assign(f, 'users.txt');
reset(f);
var show_login: RectangleABC := new RectangleABC(0, 51, 150, 35, clorangeRed);
show_login.Text := 'Ваш логин: ';
status_box.Text := 'Введите логин';
readln(Login);
show_login.Text += Login;
while not eof(f) do
begin
if (str <> str2) then eof(f);
readln(f, str);
if pos(login, str) > 0 then begin
str2 := str;
readln(f, str);
str3 := str;
if (str <> str2) then eof(f);
end;
end;
status_box.Text := 'введите пароль';
readln(password);
zs := '';
ks := ',.!@?-:;+Zqazwsxedc90rfvtgbhnu7jAmiklop345QWERTYSXDCyFVG1BUHNMJI2OPKL68';
for var i := 1 to password.Length do
begin
n := pos(password[i], ks);
zs := zs + inttostr(n);
end;
password := zs;
if (str3 = password) then begin
status_box.Text := 'Выполнен вход в учетную запись: ' + Login;
end
else begin status_box.Text := 'Ошибка входа: Неверный логин или пароль'; login_next := false; end;
close(f);
show_login.Destroy;
end;
procedure stats;
var
x, y, w, h: integer;
begin
x := 0;
y := wh - 30;
w := 160;
h := 30;
for var i := 1 to 5 do //Создаем нижнюю панель
begin
if i < 5 then panel[i] := new RectangleABC(x, y, w + 1, h, RGB(120 + 15 * i, 50 + level * 5, 100));
if i = 5 then panel[i] := new RectangleABC(x, y, w, h, RGB(120 + 15 * i, 50 + level * 5, 100));
panel[i].BorderWidth := 2;
x += w;
end;
end;
procedure Start;
begin
SetWindowSize(800, 600);
ClearWindow(clWhite);
wh := WindowHeight;
ww := WindowWidth;
if level = 0 then level := 0;
if chapter = 0 then chapter := 0;
Window.IsFixedSize := true;
sun := new StarABC(35, 35, 20, 25, 16, clGold);
SetLength(Average_power, 0);
SetLength(Average_ugol, 0);
shot := 0;
time_play_min := 0;
time_play_sec := 0;
end;
procedure basegen(xb, yb: integer);//создаем базу
begin
Line(xb - 50, yb, xb + 50, yb);
Line(xb, yb - 50, xb, yb + 50);
Line(xb - 50, yb - 1, xb + 50, yb - 1);
Line(xb - 1, yb - 50, xb - 1, yb + 50);
Line(xb - 50, yb, xb + 50, yb);
Line(xb, yb - 50, xb, yb + 50);
Line(xb - 50, yb - 1, xb + 50, yb - 1);
Line(xb - 1, yb - 50, xb - 1, yb + 50);
basa := new RegularPolygonABC(xb, yb, 30, 5, base_color);
end;
procedure mapgen(level_p: integer);//генерируем карту
begin
target_bad := new RectangleABC(0, 0, 0, 0, clWhite);
shot_max := 5;
xb := 100;
yb := 300;
xgr := 0;
ygr := 530;
rgr := 100;
cgr := clLavender;
for var i := 1 to 9 do
begin
ground[i] := new CircleABC(xgr, ygr, rgr, cgr);
ground[i].bordered := false;
xgr += 100;
end;
xgr := 0;
for var i := 1 to 9 do
begin
Arc(xgr, ygr - 1, 100, 60, 120);
xgr += 100;
end;
basegen(xb, yb);//добавляем базу
if level_p=-2 then begin target := new rectangleABC(650, 100, 10, 300, clRed); end;
if level_p = 0 then begin
from_0 := true;
show := new RectangleABC(100, 0, ww - 100, 20, clwheat);
show.Text := 'Кликните в любом месте мышкой и удерживая перетащите в любое другое место, так вы сможете выбрать силу.';
show2 := new RectangleABC(100, 20, ww - 100, 20, clwheat);
show2.Text := 'Внизу на панеле отображается ваши текущие угол и сила, При соприкосновении с поверхностью ядро взрывается';
show3 := new RectangleABC(100, 40, ww - 100, 20, clwheat);
show4 := new RectangleABC(0, 60, ww, 20, cllime);
show3.Text := 'На каждом уровне есть ограниченное кол-во выстрелов, если вы не успели попасть в цель, вы переходите на уровень назад';
show4.text := 'Чтобы пройти уровень надо попадать по красным мишеням. Сейчас попадите в красную стенку';
show3.TextScale := 0.9;
target := new rectangleABC(650, 100, 10, 300, clRed);
end;
stats;//добавляем нижнюю панель
panel[3].Text := 'Глава: ' + IntToStr(chapter);
panel[4].Text := 'Уровень: ' + IntToStr(level);
if level_p = 1 then begin
if (from_0 = true) then begin
show.Destroy;
show2.Destroy;
show3.Destroy;
show4.Destroy;
end;
target := new CircleABC(300, 200, 30, clRed);
end;
if level > 1 then panel[5].Text := 'Выстрел ' + IntToStr(shot) + ' из ' + IntToStr(shot_max);
if (level_p = 2) then target := new CircleABC(400, 400, 30, clRed);
if (level_p = 3) then target := new CircleABC(100, 50, 30, clRed);
if (level_p = 4) then target := new CircleABC(500, 110, 30, clRed);
if (level_p = 5) and (from_6 = false) then target := new CircleABC(700, 330, 20, clRed);
if (level_p = 5) and (from_6 = true) then begin show.Destroy; target := new CircleABC(700, 330, 20, clRed); end;
if (level_p = 6) then begin
from_6 := true; show := new RectangleABC(100, 0, ww - 100, 20, clwheat);
show.Text := 'Черные цели перенаправляют вас сразу на уровень назад!';
target := new CircleABC(720, 350, 30, clred); target_bad := new CircleABC(720, 150, 30, clblack);
end;
time_play_min := 0;
time_play_sec := 0;
if level > 6 then begin
if (from_6 = true) then begin
from_6 := false;
show.Destroy;
end;
target := new CircleABC(Random(100, ww - 50), Random(100, wh - 250), 30, clRed);
end;
end;
procedure lvldown;
begin
target.Destroy;
target_bad.Destroy;
ClearWindow(clWhite);
var stat_box := new RoundRectABC(10, 10, ww - 20, wh - 20, 15, clslateblue);
stat_box.BorderWidth := 2;
var box: array[1..5] of RoundRectABC;
var x_box, y_box: integer;
x_box := 20;
y_box := 20;
for var i := 1 to 5 do
begin
box[i] := new RoundRectABC(x_box, y_box, ww - 40, 100, 15, RGB(100 + 20 * i, 100, 100));
box[i].BorderWidth := 2;
y_box += 105;
if i = 1 then begin box[i].Color := clred; box[i].Text := 'Вы не прошли уровень: ' + IntToStr(level); end;
if i = 2 then box[i].Text := 'Средняя сила: ' + IntToStr(Round(Average_power.Average)) + 'p';
if i = 3 then box[i].Text := 'Средний угол: ' + IntToStr(Round(Average_ugol.Average));
if i = 4 then box[i].Text := 'Выстрелов: ' + IntToStr(shot);
if i = 5 then begin
if time_play_min = 0 then box[i].Text := 'Время: ' + time_play_sec.ToString + 'c.'
else box[i].Text := 'Время: ' + time_play_min.ToString + 'm. ' + time_play_sec.ToString + 'c.';
end;
end;
Sleep(5000);
for var i := 1 to 5 do box[I].Destroy;
stat_box.destroy;
level -= 1;
SetLength(Average_power, 0);
SetLength(Average_ugol, 0);
shot := 0;
prewrite;
mapgen(level);
Basa.RedrawNow;
for var i := 1 to 5 do panel[i].RedrawNow;
sun.RedrawNow;
for var i := 1 to 9 do ground[i].RedrawNow;
end;
procedure lvlup;
begin
lvlup_b := false;
ClearWindow(clWhite);
target.Destroy;
target_bad.Destroy;
var stat_box := new RoundRectABC(10, 10, ww - 20, wh - 20, 15, clslateblue);
stat_box.BorderWidth := 2;
var box: array[1..5] of RoundRectABC;
var x_box, y_box: integer;
x_box := 20;
y_box := 20;
for var i := 1 to 5 do
begin
box[i] := new RoundRectABC(x_box, y_box, ww - 40, 100, 15, RGB(100, 100 + 20 * i, 170));
box[i].BorderWidth := 2;
y_box += 105;
if i = 1 then begin box[i].Color := cllime; box[i].Text := 'Вы прошли уровень: ' + IntToStr(level); end;
if i = 2 then box[i].Text := 'Средняя сила: ' + IntToStr(Round(Average_power.Average)) + 'p';
if i = 3 then box[i].Text := 'Средний угол: ' + IntToStr(Round(Average_ugol.Average));
if i = 4 then box[i].Text := 'Выстрелов: ' + IntToStr(shot);
if i = 5 then begin
if time_play_min = 0 then box[i].Text := 'Время: ' + time_play_sec.ToString + 'c.'
else box[i].Text := 'Время: ' + time_play_min.ToString + 'm. ' + time_play_sec.ToString + 'c.';
end;
end;
Sleep(5000);
for var i := 1 to 5 do box[I].Destroy;
stat_box.destroy;
level += 1;
if (level = 1) and (chapter = 0) then chapter += 1;
if (level mod 6 = 0) and (level > 1) then chapter += 1;
SetLength(Average_power, 0);
SetLength(Average_ugol, 0);
shot := 0;
prewrite;
mapgen(level);
Basa.RedrawNow;
for var i := 1 to 5 do panel[i].RedrawNow;
sun.RedrawNow;
for var i := 1 to 9 do ground[i].RedrawNow;
end;
function myfunc(xr, yr, p, ug: real): real;//функция полета
var
t: real;
begin
play := true;
t := 0;//Время
xg := 0;//Коориданата Х
yg := 0;//Коориданата У
Star := new StarABC(Round(xr), Round(yr), 20, 10, 10, clRandom);//Создаем объект-ядро
if level < 0 then Check.Start;
repeat
if level < 0 then TextOut(0,500,'ПРОРИСОВКА: '+time_play_sec2.ToString+' ');
xg := Round((xr) + ((p * t * cos(ug)) / 2));
yg := Round((yr) - (p * t * sin(ug) - (9.8 * t * t / 2)));
xg -= 2;
Star.MoveTo(xg, yg);//перемещения ядра в (xg,yg)
Star.Angle += spin;//Вращаем ядро
MoveTo(xg, yg);
PutPixel(xg, yg, clRed);//рисуем путь
t += time;//Прибавляем время
sleep(2);//Задержка в 2 милисекунды
if (Star.Intersect(target) = true) then lvlup_b := true;
if (Star.Intersect(target_bad) = true) then begin lvlup_b := false; shot += shot_max * 2; end;
if (Star.Intersect(target) = true) then take_speed := time_play_sec2;
until (star.Intersect(ground[1]) = true) or (star.Intersect(ground[2]) = true)
or (star.Intersect(ground[3]) = true) or (star.Intersect(ground[4]) = true)
or (star.Intersect(ground[5]) = true) or (star.Intersect(ground[6]) = true)
or (star.Intersect(ground[8]) = true) or (star.Intersect(ground[8]) = true)
or (star.Intersect(ground[9]) = true) or (xg > ww + 10) or (Star.Intersect(target) = true)
or (star.Intersect(target_bad) = true);
if level < 0 then check.Stop;
if level < 0 then time_play_sec2:=0;
Star.Destroy;//убираем звезду
shot += 1;
if level > 1 then panel[5].Text := 'Выстрел ' + IntToStr(shot) + ' из ' + IntToStr(shot_max);
//подсчет средних
setLength(Average_ugol, shot);
Average_ugol[shot - 1] := Round(RadToDeg(ug));
setLength( Average_power, shot);
Average_power[shot - 1] := Round(power);
if (shot > shot_max - 1) and (lvlup_b = false) and (level > 1) then lvldown;
if (level > 0) then if (lvlup_b = true) and (shot < shot_max + 1) then lvlup;
if (level < 2) and (lvlup_b = true) then lvlup;
myfunc := t;
Play := false;
end;
procedure MouseMove(xm, ym, mb: integer);
var
a, b, c: real;
begin
a := Abs(xm - xb);
b := Abs(ym - yb);
c := Sqrt(Sqr(a) + Sqr(b));
ug := (arcsin(b / c));
panel[1].Text := 'Угол: ' + IntToStr(Round(RadToDeg(ug)));
if mb = 1 then panel[2].Text := 'Сила: ' + IntToStr(Round(sqrt(sqr((xm - x_power)) + sqr((ym - y_power))))) + 'p';//Показываем силу
end;
procedure MouseDown(xm, ym, mb: integer);
begin
show_pos := new CircleABC(xm, ym, 2, clwheat);
x_power := xm;
y_power := ym;
end;
procedure MouseUp(xm, ym, mb: integer);
var
a, b, c: real;
begin
a := Abs(xm - xb);
b := Abs(ym - yb);
c := Sqrt(Sqr(a) + Sqr(b));
ug := (arcsin(b / c));
power := Round(sqrt(sqr((xm - x_power)) + sqr((ym - y_power))));//Высчитывем силу
panel[1].FontColor := clWhite;
panel[1].text := 'Угол полета: ' + IntToStr(Round(RadToDeg(ug)));
panel[2].FontColor := clWhite;
panel[2].text := 'Сила полета: ' + IntToStr(Round(power)) + 'p';
if (mb = 1) and (play = false) and (power > 0) then myfunc(xb, yb, power, ug);//запускаем ядро
panel[2].FontColor := clBlack;
panel[1].FontColor := clBlack;
panel[2].Text := '';
show_pos.Destroy;
end;
procedure rotate;
begin
sun.Angle += 1;
time_play_sec += 0.5;
if time_play_sec = 60.0 then begin time_play_min += 1; time_play_sec := 0; end;
end;
procedure MouseDownS(xm, ym, mb: integer);
begin
if mb = 1 then base_color := GetPixel(xm, ym);
end;
procedure Hello;
begin
SetWindowSize(800, 600);
Window.IsFixedSize := true;
var start1 := new RoundRectABC(8, 8, windowwidth - 16, WindowHeight - 15, 10, clLavender);
start1.BorderWidth := 3;
var start1_name := new RoundRectABC(15, 15, windowwidth - 30, 50, 10, clGreenYellow);
start1_name.BorderWidth := 2;
start1_name.Text := 'Добро пожаловать, ' + Login + '!';
Sleep(200);
var start1_color := new RoundRectABC(15, 70, WindowWidth - 30, 50, 10, clFirebrick);
start1_color.BorderWidth := 2;
start1_color.Text := 'Выберите цвет базы';
for var iy := 1 to 18 do
begin
Rectangle(50, 105 + iy * 25, 151, 135 + iy * 25);
FloodFill(52, 105 + iy * 25 + 2, clRandom);
end;
for var iy := 1 to 18 do
begin
Rectangle(50 + 100 * 1, 105 + iy * 25, 151 + 100 * 1, 135 + iy * 25);
FloodFill(52 + 100 * 1, 105 + iy * 25 + 2, clRandom);
end;
for var iy := 1 to 18 do
begin
Rectangle(50 + 100 * 2, 105 + iy * 25, 151 + 100 * 2, 135 + iy * 25);
FloodFill(52 + 100 * 2, 105 + iy * 25 + 2, clRandom);
end;
for var iy := 1 to 18 do
begin
Rectangle(50 + 100 * 3, 105 + iy * 25, 151 + 100 * 3, 135 + iy * 25);
FloodFill(52 + 100 * 3, 105 + iy * 25 + 2, clRandom);
end;
for var iy := 1 to 18 do
begin
Rectangle(50 + 100 * 4, 105 + iy * 25, 151 + 100 * 4, 135 + iy * 25);
FloodFill(52 + 100 * 4, 105 + iy * 25 + 2, clRandom);
end;
for var iy := 1 to 18 do
begin
Rectangle(50 + 100 * 5, 105 + iy * 25, 151 + 100 * 5, 135 + iy * 25);
FloodFill(52 + 100 * 5, 105 + iy * 25 + 2, clRandom);
end;
for var iy := 1 to 18 do
begin
Rectangle(50 + 100 * 6, 105 + iy * 25, 151 + 100 * 6, 135 + iy * 25);
FloodFill(52 + 100 * 6, 105 + iy * 25 + 2, clRandom);
end;
OnMouseDown := MouseDownS;
var timerShow := new RoundRectABC(WindowWidth - 55, 70, 40, 50, 10, clcyan);
timerShow.BorderWidth := 2;
timerShow.Text := '3';
Sleep(1000);
timerShow.Text := '2';
Sleep(1000);
timerShow.Text := '1';
Sleep(1000);
timerShow.Destroy;
start1.Destroy;
start1_color.Destroy;
start1_name.Destroy;
end;
procedure MouseDownBeg(xm, ym, mb: integer);
begin
if login_but.PtInside(xm, ym) = true then login_next := true;
if registr_but.PtInside(xm, ym) = true then regist_next := true;
end;
procedure timer_check;
begin
time_play_sec2 += 1;
end;
begin
base_color:=clRandom;
SetWindowCaption('TimeKiller v0.2');
target_bad := new RectangleABC(0, 0, 0, 0, clWhite);
SetWindowSize(800, 600);
cont := false;
from_0 := false;
from_6 := false;
OnMouseDown := MouseDownBeg;
var main: RectangleABC := new RectangleABC(0, 0, WindowWidth, windowheight, clLavender);
login_but := new RectangleABC(0, 0, 401, 50, clolive);
registr_but := new RectangleABC(399, 0, 400, 50, clOliveDrab);
login_but.BorderWidth := 2;
registr_but.BorderWidth := 2;
login_but.FontColor := clwhite;
registr_but.FontColor := clgold;
login_but.Text := 'Войти';
registr_but.Text := 'Зарегистрироваться';
status_box := new RectangleABC(0, WindowHeight - 30, WindowWidth, 30, clgold);
status_box.BorderWidth := 2;
status_box.Color := ARGB(120, 255, 215, 0);
status_box.Text := 'Вам необходимо войти или зарегистрироваться';
repeat
Sleep(1000);
if login_next = true then begin plogin; end;
if regist_next = true then begin pcreate; end;
until (login_next = true) or (regist_next = true);
pread;
cont := true;
if Cont = true then begin
main.Destroy;
status_box.Destroy;
login_but.Destroy;
registr_but.Destroy;
Hello;
start;
TextOut(0,0,'Подождите идет загрузка данных. Прорисовка.');
time := 0.02;
spin := 1;
time_play_sec := 0;
level_test:=level;
chapter_test:=chapter;
chapter:=0;
level:=-2;
mapgen(level);
Check := new Timer(1, timer_check);
myfunc(xb, yb, 200, Pi / 10);//Проверка медленной скорости;
if take_speed > 100 then begin time := 0.08; spin := 2; end;
check.Stop;
Check := new Timer(1, timer_check);
time_play_sec := 0;
target.Destroy;
level:=-2;
mapgen(level);
TextOut(0,0,'Подождите идет загрузка данных. Прорисовка.');
myfunc(xb, yb, 200, Pi / 10);//Проверка быстрой скорости;
if take_speed < 50 then begin time := 0.02; spin := 1; end;
target.Destroy;
level:=level_test;
chapter:=chapter_test;
mapgen(level);
T := new Timer(500, rotate);
T.Start;
OnMouseMove := MouseMove;
OnMouseDown := MouseDown;
OnMouseUp := MouseUp;
end;
end.