Задача про пассажиров

const mm=9;//обьявляем константу
type
mat=record
q,q1:array[0..10] of integer;
w,w1:array[0..10] of real;
min:integer;
end;
var m:mat;
i, j, k: integer;
s:real;
count:integer;
number:real;
c:integer;
begin
m.min:=30;
Randomize;
for i:=0 to 10 do//заполняем массивы
begin
m.q[i]:=random(10);
if m.q[i]=0 then m.q[i]:=i+1;
m.w[i]:=0.4*random(10);
if m.w[i]=0 then m.w[i]:=(i+1)*0.4;
write(m.q[i]);
writeln(' ',m.w[i]);
end;
writeln('--------------');
Writeln('Итог');
for i := 0 to mm-1 do
for j := 0 to mm-i do
if m.q[j] > m.q[j+1] then begin //сортируем массив методом пузырька
k:= m.q[j];
m.q[j] := m.q[j+1];
m.q[j+1] := k;
s := m.w[j]; 
m.w[j] := m.w[j+1];
m.w[j+1] := s;
end;
for i:=0 to 10 do
begin
writeln(m.q[i],' ',m.w[i]);//выводим отсортированный массив
end;
For i:=0 to 10 do begin
For K:=i+1 to 10 do begin
if (m.q[i]=m.q[k]) and (abs(m.w[i]-m.w[k])<=0.5) then inc(count);//ну тут все понятно
end;
end;
if count<>0 then writeln('Есть 2 пассажира!','Совпадений: ',count) else writeln('Пассажиров не найдено');
writeln('Введите свое число,если не хотите,то введите 0');
Readln(number);
if number<>0 then
For i:=0 to 10 do 
begin
if number=m.w[i] then inc(c);//поиск по введенному числу
if number=m.q[i] then inc(c); 
end;
if number<>0 then writeln('Совпадений по введенному числу: ',c);
end.

калькулятор для Pascal (Паскаль)

var snd1,snd2,a,b,d:integer;
    c:real;
begin
writeln('Введите первое число');
read(a);
write('Введите знак-1(плюс)2(минус)3(умножить)4(делить)');
read(d);
write('Введите второе число');
read(b);
if d=1 then c:=a+b;
if d=2 then c:=a-b;
if d=3 then c:=a*b;
if d=4 then c:=a/b;
write('Ответ:  ',c);
end.

Калькулятор (расширенная функциональность)

uses crt;

var 
a:char;
c1,c2,i:real;
n:string;
l1,l2:byte;
b:boolean:=true;

label tobegin;


procedure addition(c1,c2:real; var sum:real);
begin
sum:=c1+c2;
end;

procedure subtraction(c1,c2:real; var dif:real);
begin
dif:=c1-c2;
end;

procedure multiply(c1,c2:real; var pr:real);
begin
pr:=c1*c2;
end;

procedure division(c1,c2:real; var q:real);
begin
if c2<>0 then q:=c1/c2 else
begin writeln; writeln('Деление на 0!'); end;
end;

procedure exponentiation(c1,c2:real; var pw:real);
begin
pw:=exp(c2*ln(c1));
end;

procedure squareroot(c1:real; var sq:real);
begin
if c1>=0 then sq:=sqrt(c1) else
begin writeln; writeln('Невозможно извлечь квадратный корень из отрицательного числа!'); end;
end;

procedure sine(c1:real; var s:real);
begin
s:=sin(c1);
end;

procedure cosine(c1:real; var c:real);
begin
c:=cos(c1);
end;


begin

crt.setwindowsize(80,30);
crt.setwindowtitle('PasCALC');
crt.textcolor(crt.black);
crt.textbackground(white);
crt.clrscr;

crt.gotoxy(crt.wherex+30,crt.wherey);
writeln('PacCALC, version 1.6, 2014');
crt.gotoxy(crt.wherex+3,crt.wherey+1); writeln('Для выбора действия используйте клавиши ниже. Для ввода используйте Enter.');
crt.gotoxy(crt.wherex+20,crt.wherey); writeln('Буквенные клавиши не зависят от раскладки.');
crt.gotoxy(crt.wherex+17,crt.wherey+1); write('Сложение: + и p');
crt.gotoxy(crt.wherex+17,crt.wherey); writeln('Вычитание: - и m');
crt.gotoxy(crt.wherex+18,crt.wherey); write('Умножение: * и x');
crt.gotoxy(crt.wherex+18,crt.wherey); writeln('Деление: / и :');
crt.gotoxy(crt.wherex+6,crt.wherey); write('Возведение в степень: ^ и 6');
crt.gotoxy(crt.wherex+6,crt.wherey); writeln('Нахождение квадратного корня: √ и q'); 
crt.gotoxy(crt.wherex+20,crt.wherey); write('Синус: s');
crt.gotoxy(crt.wherex+20,crt.wherey); write('Косинус: c');
crt.gotoxy(crt.wherex,crt.wherey+2);

while (b=true) do begin

writeln;

try

tobegin:
write('Выберите математическое действие: ');
a:=crt.readkey;

if (a='+') or (a='p') or (a='P') or (a='з') or (a='З') then begin
writeln('сложение'); writeln('Введите слагаемые'); read(c1);
str(c1,n); l1:=length(n); crt.gotoxy(crt.wherex+l1,crt.wherey-1); write('+');
read(c2); str(c2,n); l2:=length(n); crt.gotoxy(crt.wherex+l1+l2+1,crt.wherey-1);
addition(c1,c2,i); writeln('=',i);
end
else

if (a='-') or (a='m') or (a='M') or (a='ь') or (a='Ь') then begin
writeln('вычитание'); writeln('Введите уменьшаемое и вычитаемое'); read(c1);
str(c1,n); l1:=length(n); crt.gotoxy(crt.wherex+l1,crt.wherey-1); write('-');
read(c2); l2:=length(n); crt.gotoxy(crt.wherex+l1+l2+1,crt.wherey-1);
subtraction(c1,c2,i); writeln('=',i);
end
else

if (a='*') or (a='x') or (a='X') or (a='ч') or (a='Ч') then begin
writeln('умножение'); writeln('Введите множители'); read(c1);
str(c1,n); l1:=length(n); crt.gotoxy(crt.wherex+l1,crt.wherey-1); write('x');
read(c2); str(c2,n); l2:=length(n); crt.gotoxy(crt.wherex+l1+l2+1,crt.wherey-1);
multiply(c1,c2,i); writeln('=',i);
end
else

if (a=':') or (a='/') then begin
writeln('деление'); writeln('Введите делимое и делитель'); read(c1);
str(c1,n); l1:=length(n); crt.gotoxy(crt.wherex+l1,crt.wherey-1); write(':');
read(c2); str(c2,n); l2:=length(n); crt.gotoxy(crt.wherex+l1+l2+1,crt.wherey-1);
division(c1,c2,i); if c2<>0 then writeln('=',i);
end
else

if (a='^') or (a='6') or (a='e') then begin
writeln('возведение в степень'); writeln('Введите число'); read(c1);
str(c1,n); l1:=length(n); crt.gotoxy(crt.wherex+l1,crt.wherey-1); write('^');
read(c2); str(c2,n); l2:=length(n); crt.gotoxy(crt.wherex+l1+l2+1,crt.wherey-1);
exponentiation(c1,c2,i); writeln('=',i);
end
else

if (a='q') or (a='Q') or (a='й') or (a='Й') then begin
writeln('нахождение квадратного корня'); writeln('Введите число'); write('√'); read(c1);
str(c1,n); l1:=length(n); crt.gotoxy(crt.wherex+l1+1,crt.wherey-1);
squareroot(c1,i); if c1>=0 then writeln('=',i);
end
else

if (a='s') or (a='S') or (a='ы') or (a='Ы') then begin
writeln('синус'); writeln('Введите число'); write('sin('); read(c1);
str(c1,n); l1:=length(n); crt.gotoxy(crt.wherex+l1+4,crt.wherey-1); write(')');
sine(c1,i); writeln('=',i);
end
else

if (a='c') or (a='C') or (a='с') or (a='С') then begin
writeln('косинус'); writeln('Введите число'); write('cos('); read(c1);
str(c1,n); l1:=length(n); crt.gotoxy(crt.wherex+l1+4,crt.wherey-1); write(')');
cosine(c1,i); writeln('=',i);
end

else 
begin crt.clearline; goto tobegin; end;

except on system.formatexception do writeln('Неверный формат ввода! Попробуйте еще раз.'); end;

writeln;
writeln('Нажмите любую клавишу, чтобы продолжить работу, пробел, чтобы очистить окно, или Esc, чтобы выйти');
a:=crt.readkey; if (a=#27) then b:=false; if (a=#32) then crt.clrscr;

end;

end.

Генератор паролей

Генерируется пароль из 16 символов, состоящий из больших/маленьких латинских букв, цифр и символов.

var
e:array [1..73] of char:=('a','b','c','d','e','f','g','h','i','j','k','l','m','n','o','p','q','r','s','t','u','v','w','x','y','z','A','B','C','D','E','F','G','H','I','J','K','L','M','N','O','P','Q','R','S','T','U','V','W','X','Y','Z','!','@','#','$','%','^','&','*','"','.',',','0','1','2','3','4','5','6','7','8','9');
k:array [1..16] of integer;

i:integer;
pswd:string;
f:text;

begin
randomize;

for i:=1 to 16 do begin
k[i]:=random(72)+1;
insert(e[k[i]],pswd,i);
end;

assign(f,'password.txt');
rewrite(f);
write(f,pswd);
close(f);
exec('password.txt');

end.

Простий калькулятор на Pascal

program Calculator;
uses CRT;
var a, b, r: real;
c: char;
ok: boolean;
begin
clrscr;
repeat
ok:=true;
writeln('Перше число.');
readln(a);
writeln('Друге число.');
readln(b);
writeln('Обери дію: "+" - додавання, "-" - віднімання, "*" - множення, "/" - ділення.');
c:=readkey;
case c of
'+': r:=a+b;
'-': r:=a-b;
'*': r:=a*b;
'/': r:=a/b;
else ok:=false;
end;
if ok then writeln(r:0:5);
writeln('"Q" - завершуй, будь яка інша кнопка - повернутись докалькулятора.');
c:=readkey;
until (c='q') or (c='Q');
end.

Игра 2048

Program _2048_;
Uses Crt;
Var
  v,h,sc,won,i,eng,ent:integer;
  a:array[1..5,1..5] of integer;
  n,k:string;
label
  m1,endgame,r1,w1;
begin
writeln('Вводите W,A,S,D для передвижения блоков');
m1:
  randomize;
    h:=random(4)+1;
    v:=random(4)+1;
if a[h,v]=0 then
  a[h,v]:=2
else
  goto m1;
writeln('Счет:',sc);
for h:=1 to 4 do
  writeln(a[h,1],'  ',a[h,2],'  ',a[h,3],'  ',a[h,4]);
r1:
eng:=0;
repeat
  n:=readkey;
until (n='w') or (n='a') or (n='s') or (n='d');
clrscr;
if (n='w') then
begin
  for i:=1 to 2 do
  for h:=2 to 4 do
  for v:=1 to 4 do
  begin
    if (a[h,v]=0) or (a[h-1,v]<>0) then
      eng+=1;
    if a[h,v]<>0 then
      if a[h-1,v]=0 then
        begin
          a[h-1,v]:=a[h,v];
          a[h,v]:=0;
        end;
  end;
  for h:=2 to 4 do
  for v:=1 to 4 do
  begin
    if (a[h,v]=0) or (a[h-1,v]<>a[h,v]) then
      eng+=1;
    if a[h,v]<>0 then
      if a[h-1,v]=a[h,v] then
         begin
           a[h-1,v]:=a[h,v]*2;
           a[h,v]:=0;
           sc:=sc+a[h-1,v];
         end;
  end;
  for h:=2 to 4 do
  for v:=1 to 4 do
  begin
    if (a[h,v]=0) or (a[h-1,v]<>0) then
      eng+=1;
    if a[h,v]<>0 then
      if a[h-1,v]=0 then
        begin
          a[h-1,v]:=a[h,v];
          a[h,v]:=0;
        end;
   end;
end;
if (n='s') then
begin
  for i:=1 to 2 do 
  for h:=3 downto 1 do
  for v:=1 to 4 do
  begin
    if (a[h,v]=0) or (a[h+1,v]<>0) then
      eng+=1;
    if a[h,v]<>0 then
      if a[h+1,v]=0 then
        begin
          a[h+1,v]:=a[h,v];
          a[h,v]:=0;
        end;
  end;
  for h:=3 downto 1 do
  for v:=1 to 4 do
  begin
    if (a[h,v]=0) or (a[h+1,v]<>a[h,v]) then
      eng+=1;
    if a[h,v]<>0 then
     if a[h+1,v]=a[h,v] then
       begin
         a[h+1,v]:=a[h,v]*2;
         a[h,v]:=0;
         sc:=sc+a[h+1,v];
       end;
  end;
  for h:=3 downto 1 do
  for v:=1 to 4 do
  begin
    if (a[h,v]=0) or (a[h+1,v]<>0) then
      eng+=1;
    if a[h,v]<>0 then
      if a[h+1,v]=0 then
        begin
          a[h+1,v]:=a[h,v];
          a[h,v]:=0;
        end;
   end;
end;
if (n='a') then
begin 
  for i:=1 to 2 do
  for v:=2 to 4 do
  for h:=1 to 4 do
  begin
    if (a[h,v]=0) or (a[h,v-1]<>0) then
      eng+=1;
    if a[h,v]<>0 then
      if a[h,v-1]=0 then
        begin
          a[h,v-1]:=a[h,v];
          a[h,v]:=0;
        end;
  end;
  for v:=2 to 4 do
  for h:=1 to 4 do
  begin
    if (a[h,v]=0) or (a[h,v-1]<>a[h,v]) then
      eng+=1;
    if a[h,v]<>0 then
      if a[h,v-1]=a[h,v] then
        begin
          a[h,v-1]:=a[h,v]*2;
          a[h,v]:=0;
          sc:=sc+a[h,v-1];
        end;
  end;
  for v:=2 to 4 do
  for h:=1 to 4 do
  begin
    if (a[h,v]=0) or (a[h,v-1]<>0) then
      eng+=1;
    if a[h,v]<>0 then
      if a[h,v-1]=0 then
        begin
          a[h,v-1]:=a[h,v];
          a[h,v]:=0;
        end;
   end;
end;
if (n='d') then
begin
  for i:=1 to 2 do
  for v:=3 downto 1 do
  for h:=1 to 4 do
  begin
    if (a[h,v]=0) or (a[h,v+1]<>0) then
      eng+=1;
    if a[h,v]<>0 then
      if a[h,v+1]=0 then
        begin
          a[h,v+1]:=a[h,v];
          a[h,v]:=0;
        end;
  end;
  for v:=3 downto 1 do
  for h:=1 to 4 do
  begin
    if (a[h,v]=0) or (a[h,v+1]<>a[h,v]) then
      eng+=1;
    if a[h,v]<>0 then
      if a[h,v+1]=a[h,v] then
        begin
          a[h,v+1]:=a[h,v]*2;
          a[h,v]:=0;
          sc:=sc+a[h,v+1];
        end;
  end;
  for v:=3 downto 1 do
  for h:=1 to 4 do
  begin
    if (a[h,v]=0) or (a[h,v+1]<>0) then
      eng+=1;
    if a[h,v]<>0 then
      if a[h,v+1]=0 then
        begin
          a[h,v+1]:=a[h,v];
          a[h,v]:=0;
        end;
   end;
end;
  if eng=48 then
  begin
    writeln('Счет:',sc);
    for h:=1 to 4 do
      writeln(a[h,1],'  ',a[h,2],'  ',a[h,3],'  ',a[h,4]);
    i:=0;
    for h:=1 to 4 do
    for v:=1 to 4 do
      if a[h,v]=0 then
      i:=1;
    if i=0 then
      goto endgame
    else
      i:=0;
    goto r1;
  end
  else
    eng:=0;
for h:=1 to 4 do
for v:=1 to 4 do
  if (a[h,v]=2048) and (won=0) then
    begin
    writeln('!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!');
    writeln('!!!!!!!!!!Вы Выиграли!!!!!!!!!!');
    writeln('!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!');
    won:=1;
    end
  else
    if a[h,v]<>0 then
      ent+=1;
goto m1;
endgame:
  writeln('Вы Проиграли, ваш счет:',sc);
  writeln('Заново? Да + Нет - ');
  repeat
    k:=readkey;
  until (k='+') or (k='-');
  if k='+' then
    begin
      clrscr;
      for h:=1 to 4 do
      for v:=1 to 4 do
      a[h,v]:=0;
      goto m1;
    end;
end.

Игра-стрелялка для 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.

Определение дня недели по дате (версия 1.2)

var
  m: array [1..10] of char;
  d1, m1, i, d: byte;                                                           {d1 - day_1; m1 - month_1; d - day}
  y1, ys, yt, yf, dsNY: integer;                                                {y1 - year_1; ys - years_between_4_and_1; yt - number_of_true_years_between_4_and_1; yf - number_of_false_years_between_4_and_1; dsNY - days_in_year_1_to_NY (NY - новый год)}
  ds: longint;                                                                  {ds - days_between_4_and_1}
  ty: boolean;{ty - type_of_year_1}

begin
  writeln('Данная программа определяет в какой день недели родился человек по заданной дате рождения. Введите дату рождения в формате ДД.ММ.ГГГГ (обозначения формата: Д - день, М - месяц, Г - год): ');
  for i := 1 to 10 do read(m[i]);  
  d1 := (ord(m[1]) - 48) * 10 + (ord(m[2]) - 48);
  m1 := (ord(m[4]) - 48) * 10 + (ord(m[5]) - 48);
  y1 := (ord(m[7]) - 48) * 1000 + (ord(m[8]) - 48) * 100 + (ord(m[9]) - 48) * 10 + (ord(m[10]) - 48);  
  if ((d1 > 31) or (d1 < 1)) and ((m1 > 12) or (m1 < 1)) then begin writeln('Вы неправильно ввели день и месяц.'); halt end;
  if (d1 > 31) or (d1 < 1) then begin writeln('Вы неправильно ввели день.'); halt end;
  if (m1 > 12) or (m1 < 1) then begin writeln('Вы неправильно ввели месяц.'); halt end;
  ty := false;                                                                  {False - невисокосный, true - високосный}
  if (y1 mod 4 = 0) then ty := true;
  if (d1 > 29) and (m1 = 2) then begin writeln('Вы неправильно ввели день и/или месяц.'); halt end;
  if (d1 > 28) and (m1 = 2) and (not ty) then begin writeln('Вы неправильно ввели и/или день, и/или месяц, и/или год.'); halt end;
  ys := y1 - 4;
  yt := ys div 4;
  yf := ys - yt;
  ds := yt * 366 + yf * 365;                                                    {Включая все дни в последнем году, то есть в нашем}
  case m1 of 01: dsNY := 365 - d1;
    02: dsNY := 365 - (d1 + 31);
    03: begin if ty then dsNY := 365 - (d1 + 60) else dsNY := 365 - (d1 + 59) end;
    04: begin if ty then dsNY := 365 - (d1 + 91) else dsNY := 365 - (d1 + 90) end;
    05: begin if ty then dsNY := 365 - (d1 + 121) else dsNY := 365 - (d1 + 120) end;
    06: begin if ty then dsNY := 365 - (d1 + 152) else dsNY := 365 - (d1 + 151) end;
    07: begin if ty then dsNY := 365 - (d1 + 182) else dsNY := 365 - (d1 + 181) end;
    08: begin if ty then dsNY := 365 - (d1 + 213) else dsNY := 365 - (d1 + 212) end;
    09: begin if ty then dsNY := 365 - (d1 + 244) else dsNY := 365 - (d1 + 243) end;
    10: begin if ty then dsNY := 365 - (d1 + 274) else dsNY := 365 - (d1 + 273) end;
    11: begin if ty then dsNY := 365 - (d1 + 305) else dsNY := 365 - (d1 + 304) end;
    12: begin if ty then dsNY := 365 - (d1 + 60) else dsNY := 365 - (d1 + 59) end;
  else begin writeln( 'Вы ввели неправильно месяц.'); halt end end;  
  ds := ds - (dsNY + 4);                                                        {Включая только нужное количество дней в последнем году, то есть в нашем}
  d := ds mod 7;
  case d of 0: writeln('Данный день является понедельником.');
    1: writeln('Данный день является вторником.');
    2: writeln('Данный день является средой.');
    3: writeln('Данный день является четвергом.');
    4: writeln('Данный день является пятницей.');
    5: writeln('Данный день является субботой.');
    6: writeln('Данный день является воскресеньем.')
  end
end.

Определение дня недели по дате (версия 1.1)

program day_of_week_version_1;

var
  m: array [1..10] of char;
  d1, m1, i, d: byte;                                                           {d1 - day_1; m1 - month_1; d - day}
  y1, ys, yt, yf, dsNY: integer;                                                {y1 - year_1; ys - years_between_4_and_1; yt - number_of_true_years_between_4_and_1; yf - number_of_false_years_between_4_and_1; dsNY - days_in_year_1_to_NY (NY - новый год)}
  ds: longint;                                                                  {ds - days_between_4_and_1}
  ty: boolean;                                                                  {ty - type_of_year_1}

begin
  writeln('Данная программа определяет в какой день недели родился человек по заданной дате рождения. Введите дату рождения в формате ДД.ММ.ГГГГ (обозначения формата: Д - день, М - месяц, Г - год): ');
  for i := 1 to 10 do read(m[i]);  
  d1 := (ord(m[1]) - 48)*10 + (ord(m[2]) - 48);
  m1 := (ord(m[4]) - 48)*10 + (ord(m[5]) - 48);
  y1 := (ord(m[7]) - 48) * 1000 + (ord(m[8]) - 48) * 100 + (ord(m[9]) - 48) * 10 + (ord(m[10]) - 48);
  ty := false;                                                                  {False - невисокосный, true - високосный}
  if (y1 mod 4 = 0) then ty := true;
  ys := y1 - 4;
  yt := ys div 4;
  yf := ys - yt;
  ds := yt * 366 + yf * 365;                                                    {Включая все дни в последнем году, то есть в нашем}
  case m1 of 01: dsNY := 365 - d1;
    02: dsNY := 365 - (d1 + 31);
    03: begin if ty then dsNY := 365 - (d1 + 60) else dsNY := 365 - (d1 + 59) end;
    04: begin if ty then dsNY := 365 - (d1 + 91) else dsNY := 365 - (d1 + 90) end;
    05: begin if ty then dsNY := 365 - (d1 + 121) else dsNY := 365 - (d1 + 120) end;
    06: begin if ty then dsNY := 365 - (d1 + 152) else dsNY := 365 - (d1 + 151) end;
    07: begin if ty then dsNY := 365 - (d1 + 182) else dsNY := 365 - (d1 + 181) end;
    08: begin if ty then dsNY := 365 - (d1 + 213) else dsNY := 365 - (d1 + 212) end;
    09: begin if ty then dsNY := 365 - (d1 + 244) else dsNY := 365 - (d1 + 243) end;
    10: begin if ty then dsNY := 365 - (d1 + 274) else dsNY := 365 - (d1 + 273) end;
    11: begin if ty then dsNY := 365 - (d1 + 305) else dsNY := 365 - (d1 + 304) end;
    12: begin if ty then dsNY := 365 - (d1 + 60) else dsNY := 365 - (d1 + 59) end;
  else begin writeln( 'Вы ввели неправильно месяц.'); halt end end;  
  ds := ds - (dsNY + 4);                                                        {Включая только нужное количество дней в последнем году, то есть в нашем}
  d := ds mod 7;
  case d of 0: writeln('Данный день является понедельником.');
    1: writeln('Данный день является вторником.');
    2: writeln('Данный день является средой.');
    3: writeln('Данный день является четвергом.');
    4: writeln('Данный день является пятницей.');
    5: writeln('Данный день является субботой.');
    6: writeln('Данный день является воскресеньем.')
  end
end.

Определение дня недели по дате (версия 1)

program day_of_week_version_1;

var
  m: array [1..10] of char;
  d1, m1, i, d: byte;                                                           {d1 - day_1; m1 - month_1; d - day}
  y1, ys, yt, yf, dsNY: integer;                                                {y1 - year_1; ys - years_between_1920_and_1; yt - number_of_true_years_between_1920_and_1; yf - number_of_false_years_between_1920_and_1; dsNY - days_in_year_1_to_NY (NY - новый год)}
  ds: longint;                                                                  {ds - days_between_1920_and_1}
  ty: boolean;                                                                  {ty - type_of_year_1}

begin
  writeln('Данная программа определяет в какой день недели родился человек по заданной дате рождения. Введите дату рождения в формате ДД.ММ.ГГГГ (обозначения формата: Д - день, М - месяц, Г - год): ');
  for i := 1 to 10 do read(m[i]);  
  d1 := (ord(m[1]) - 48) + (ord(m[2]) - 48);
  m1 := (ord(m[4]) - 48) + (ord(m[5]) - 48);
  y1 := (ord(m[7]) - 48) * 1000 + (ord(m[8]) - 48) * 100 + (ord(m[9]) - 48) * 10 + (ord(m[10]) - 48);
  ty := false;                                                                  {False - невисокосный, true - високосный}
  if (y1 mod 4 = 0) then ty := true;
  ys := y1 - 1920;
  yt := ys div 4;
  yf := ys - yt;
  ds := yt * 366 + yf * 365;                                                    {Включая все дни в последнем году, то есть в нашем}
  case m1 of 01: dsNY := 365 - d1;
    02: dsNY := 365 - (d1 + 31);
    03: begin if ty then dsNY := 365 - (d1 + 60) else dsNY := 365 - (d1 + 59) end;
    04: begin if ty then dsNY := 365 - (d1 + 91) else dsNY := 365 - (d1 + 90) end;
    05: begin if ty then dsNY := 365 - (d1 + 121) else dsNY := 365 - (d1 + 120) end;
    06: begin if ty then dsNY := 365 - (d1 + 152) else dsNY := 365 - (d1 + 151) end;
    07: begin if ty then dsNY := 365 - (d1 + 182) else dsNY := 365 - (d1 + 181) end;
    08: begin if ty then dsNY := 365 - (d1 + 213) else dsNY := 365 - (d1 + 212) end;
    09: begin if ty then dsNY := 365 - (d1 + 244) else dsNY := 365 - (d1 + 243) end;
    10: begin if ty then dsNY := 365 - (d1 + 274) else dsNY := 365 - (d1 + 273) end;
    11: begin if ty then dsNY := 365 - (d1 + 305) else dsNY := 365 - (d1 + 304) end;
    12: begin if ty then dsNY := 365 - (d1 + 60) else dsNY := 365 - (d1 + 59) end;
  else writeln( 'Вы ввели неправильно месяц.') end;  
  ds := ds - (dsNY + 3);                                                        {Включая только нужное количество дней в последнем году, то есть в нашем}
  d := ds mod 7;
  case d of 0: writeln('Данный день является понедельником.');
    1: writeln('Данный день является вторником.');
    2: writeln('Данный день является средой.');
    3: writeln('Данный день является четвергом.');
    4: writeln('Данный день является пятницей.');
    5: writeln('Данный день является субботой.');
    6: writeln('Данный день является воскресеньем.')
  end
end.

Игра для TP и FPC (версия 1)

program game;
uses crt;
var a,b,c,k:integer;
d:char;
begin
clrscr;
write('„ ў ©вҐ Ї®ЁЈа Ґ¬. ');
write('‡ ¤г¬ ©вҐ 楫®Ґ зЁб«® Ё ­ЁЄ®¬г ­Ґ Ј®ў®аЁвҐ ҐЈ®. Ђ п Ї®б।бвў®¬ ў иЁе ®вўҐв®ў ­  ¬®Ё ў®Їа®бл гЈ ¤ о ҐЈ®. ');
write('‚ўҐ¤ЁвҐ ¤ў  楫ле зЁб« , в ЄЁе, зв® ЇҐаў®Ґ ¬Ґ­миҐ ўв®а®Ј®, Ё ¬Ґ¦¤г Є®в®ал¬Ё «Ґ¦Ёв § ¤г¬ ­­®Ґ ў ¬Ё зЁб«®: ');
readln(a,b);
k:=0;
repeat
k:=k+1;
c:=(a+b) div 2;
write('‚ иҐ зЁб«® ¬Ґ­миҐ, Ў®«миҐ Ё«Ё а ў­® ',c,'? ‚ Є зҐб⢥ ®вўҐв  ­ ЇЁиЁвҐ бЁ¬ў®« <, > Ё«Ё = ᮮ⢥вб⢥­­®: ');
readln(d);
case d of
'=':writeln('‚ иҐ зЁб«® а ў­® ',c,'.');
'<':b:=c;
'>':a:=c;
else writeln('‚л ­ҐЇа ўЁ«м­® ­ ЇЁб «Ё ®вўҐв ­  § ¤ ­л© ў®Їа®б.');
end;
until d='=';
writeln('џ гЈ ¤ « ў иҐ зЁб«® §  Є®«ЁзҐбвў® и Ј®ў, а ў­®Ґ ',k,'.');
readln
end.

Игра для PascalABC.NET (версия 1.1)

var
  a, b, c, c1, k: integer;
  d: char;

begin
  write('Давайте поиграем. Задумайте целое число и никому не говорите его. А я посредством ваших ответов на мои вопросы угадаю его. Введите два целых числа, таких, что первое меньше второго, и между которыми лежит задуманное вами число: ');
  readln(a, b);
  k := 0;
  c := 1;
  c1 := 0;
  repeat
    k := k + 1;
    c := (a + b) div 2;
    if c = c1 then begin writeln('Ваше число равно ', c + 1, '.'); break end;
    write('Ваше число меньше, больше или равно ', c, '? В качестве ответа напишите символ <,> или = соответственно: ');
    readln(d);
    case d of
      '=': writeln('Ваше число равно ', c, '.');
      '<': b := c;
      '>': a := c;
    else writeln( 'Вы неправильно написали ответ на заданый вопрос.');
    end;
    c1 := c;
  until d = '=';
  if d = '=' then writeln('Я угадал ваше число за количество шагов, равное ', k, '.') else writeln('Я угадал ваше число за количество шагов, равное ', k - 1, '.')
end.

Игра для PascalABC.NET (версия 1)

var
  a, b, c, c1, k: integer;
  d: char;

begin
  write('Давайте поиграем. Задумайте целое число и никому не говорите его. А я посредством ваших ответов на мои вопросы угадаю его. Введите два целых числа, таких, что первое меньше второго, и между которыми лежит задуманное вами число: ');
  readln(a, b);
  k := 0;
  c := 1;
  c1 := 0;
  repeat
    k := k + 1;
    c := (a + b) div 2;
    if c = c1 then begin writeln('Ваше число равно ', c + 1, '.'); break end;
    write('Ваше число меньше, больше или равно ', c, '? В качестве ответа напишите символ <,> или = соответственно: ');
    readln(d);
    case d of
      '=': writeln('Ваше число равно ', c, '.');
      '<': b := c;
      '>': a := c;
    else writeln( 'Вы неправильно написали ответ на заданый вопрос.');
    end;
    c1 := c;
  until d = '=';
  if d = '=' then writeln('Я угадал ваше число за количество шагов, равное ', k, '.') else writeln('Я угадал ваше число за количество шагов, равное ', k - 1, '.')
end.

Решение квадратных уравнений

var
  a, b, c: integer;
  xf, xs, dis: real;
  znakf,znaks:string;
begin
  writeln('введите a,b и с');
  readln(a, b, c);
  writeln('Вы ввели : a=', a, ' b=', b, ' c=', c);
  if b>0 then znakf:='+'
  else znakf:='';
  if c>0 then znaks:='+'
  else znaks:='';
  writeln('Значит ваше уравнение имеет такой вид: ', a ,'x^2',znakf, b, 'x',znaks, c);
  b := -b;
  dis := sqr(b) - 4 * a * c;
  writeln('D = ', b, '^2 - 4*', a, '*', c, '=', sqr(b), '-(', 4 * a * c, ')');
  writeln('D = ', round(dis));
  writeln('Корень D равен ', sqrt(dis));
  if dis > 0 then begin
    writeln('Дискриминант больше нуля');
    xf := (b - sqrt(dis)) / (2 * a);
    xs := (b + sqrt(dis)) / (2 * a);
    writeln('x1=', round(xf), '   ||  x2=', round(xs));
    if (xf > 0) and (xs > 0) then writeln('Сокращение на линейные множители:(x-',xf,')(x-',xs,')')
    else begin if (xf < 0) and (xs > 0) then writeln('Сокращение на линейные множители:(x+',abs(xf),')(x-',xs,')')
    else begin if (xf < 0) and (xs < 0) then writeln('Сокращение на линейные множители: (x+',abs(xf),')(x+',abs(xs),')')
    else begin if (xf > 0) and (xs < 0) then writeln('Сокращение на линейные множители:(x-',xf,')(x+',abs(xs),')');
    
    end;
    end;
    end;
    end
  else begin
    if dis = 0 then begin
      writeln('Дискриминант равен нулю'); 
      xf := b / (2 * a);
      writeln('x=', xf);
      readln();
    end
    else begin
      writeln('Нет решений, дискриминант меньше нуля');
      readln();
    end;
  end;
  readln;
end.

Нахождение Дискриминанта (Решение квадратных уравнений)

var
  a, b, c: integer;
  xf, xs, dis: real;
  znakf,znaks:string;
begin
  writeln('введите a,b и с');
  readln(a, b, c);
  writeln('Вы ввели : a=', a, ' b=', b, ' c=', c);
  if b>0 then znakf:='+'
  else znakf:='';
  if c>0 then znaks:='+'
  else znaks:='';
  writeln('Значит ваше уравнение имеет такой вид: ', a ,'x^2',znakf, b, 'x',znaks, c);
  b := -b;
  dis := sqr(b) - 4 * a * c;
  writeln('D = ', b, '^2 - 4*', a, '*', c, '=', sqr(b), '-(', 4 * a * c, ')');
  writeln('D = ', round(dis));
  writeln('Корень D равен ', sqrt(dis));
  if dis > 0 then begin
    writeln('Дискриминант больше нуля');
    xf := (b - sqrt(dis)) / (2 * a);
    xs := (b + sqrt(dis)) / (2 * a);
    writeln('x1=', round(xf), '   ||  x2=', round(xs));
    if (xf > 0) and (xs > 0) then writeln('Сокращение на линейные множители:(x-',xf,')(x-',xs,')')
    else begin if (xf < 0) and (xs > 0) then writeln('Сокращение на линейные множители:(x+',abs(xf),')(x-',xs,')')
    else begin if (xf < 0) and (xs < 0) then writeln('Сокращение на линейные множители: (x+',abs(xf),')(x+',abs(xs),')')
    else begin if (xf > 0) and (xs < 0) then writeln('Сокращение на линейные множители:(x-',xf,')(x+',abs(xs),')');
    
    end;
    end;
    end;
    end
  else begin
    if dis = 0 then begin
      writeln('Дискриминант равен нулю'); 
      xf := b / (2 * a);
      writeln('x=', xf);
      readln();
    end
    else begin
      writeln('Нет решений, дискриминант меньше нуля');
      readln();
    end;
  end;
  readln;
end.