|
Pers.narod.ru. Обучение. Учебник по Паскалю. Приложение 4 |
1. Решение системы линейных алгебраических уравнений Ax=b методом Гаусса.
program Slau;
uses crt;
const size=30; {максимально допустимая размерность}
type matrix=array [1..size,1..size+1]
of real;
type vector=array [1..size] of real;
function GetNumber (s:string;
a,b:real):real;
{Ввод числа из интервала a,b.
Если a=b, то число любое}
var n:real;
begin
repeat
write (s);
{$I-}readln (n);{$I+}
if (IoResult<>0) then
writeln ('Введено не число!')
else if (a<b) and ((n<a) or (n>b)) then
writeln ('Число не в интервале от ',
a,' до ',b)
else break;
until false;
GetNumber:=n;
end;
procedure GetMatrix (n,m:integer;
var a:matrix); {ввод матрицы}
var i,j:integer; si,sj: string [3];
begin
for i:=1 to n do begin
str (i,si);
for j:=1 to m do begin
str (j,sj);
a[i,j]:=GetNumber ('a['+ si+ ','+ sj+
']=', 0,0);
end;
end;
end;
procedure GetVector (n:integer;
var a:vector); {ввод вектора}
var i:integer; si:string [3];
begin
for i:=1 to n do begin
str (i,si);
a[i]:=GetNumber ('b['+si+']=',0,0);
end;
end;
procedure PutVector (n:integer;
var a:vector); {вывод вектора}
var i:integer;
begin
writeln;
for i:=1 to n do writeln (a[i]:10:3);
end;
procedure MV_Mult (n,m:integer;
var a:matrix;var x,b:vector);
{умножение матрицы на вектор}
var i,j:integer;
begin
for i:=1 to n do begin
b[i]:=0;
for j:=1 to m do b[i]:=b[i]+a[i,j]*x[j];
end;
end;
function Gauss (n:integer; var a:matrix;
var x:vector):boolean;
{метод Гаусса решения СЛАУ}
{a - расширенная матрица системы}
const eps=1e-6; {точность расчетов}
var i,j,k:integer;
r,s:real;
begin
for k:=1 to n do begin {перестановка
для диагонального преобладания}
s:=a[k,k];
j:=k;
for i:=k+1 to n do begin
r:=a[i,k];
if abs(r)>abs(s) then begin
s:=r;
j:=i;
end;
end;
if abs(s)<eps then begin
{нулевой определитель, нет решения}
Gauss:=false;
exit;
end;
if j<>k then
for i:=k to n+1 do begin
r:=a[k,i];
a[k,i]:=a[j,i];
a[j,i]:=r;
end; {прямой ход метода}
for j:=k+1 to n+1 do a[k,j]:=a[k,j]/s;
for i:=k+1 to n do begin
r:=a[i,k];
for j:=k+1 to n+1 do
a[i,j]:=a[i,j]-a[k,j]*r;
end;
end;
if abs(s)>eps then begin {обратный ход}
for i:=n downto 1 do begin
s:=a[i,n+1];
for j:=i+1 to n do s:=s-a[i,j]*x[j];
x[i]:=s;
end;
Gauss:=true;
end
else Gauss:=false;
end;
var a,a1:matrix;
x,b,b1:vector;
n,i,j:integer;
begin
n:=trunc(GetNumber
('Введите размерность матрицы: ',2,size));
GetMatrix (n,n,a);
writeln ('Ввод правой части:');
GetVector (n,b);
for i:=1 to n do begin
{делаем расширенную матрицу}
for j:=1 to n do a1[i,j]:=a[i,j];
a1[i,n+1]:=b[i];
end;
if Gauss (n,a1,x)=true then begin
write ('Решение:');
PutVector (n,x);
write ('Проверка:');
MV_Mult (n,n,a,x,b1);
PutVector (n,b1);
end
else write ('Решения нет');
reset (input); readln;
end.
2. Процедурно-ориентированная реализация задачи сортировки одномерного массива по возрастанию.
program sort;
const size=100;
type vector=array [1..size] of real;
procedure GetArray (var n:integer;
var a:vector);
var i:integer;
begin
repeat
writeln ('Введите размерность массива:');
{$I-}readln (n); {$I+}
if (IoResult<>0) or (n<2) or (n>size)
then writeln
('Размерность должна быть от 2 до ',size);
until (n>1) and (n<size);
for i:=1 to n do begin
write (i,' элемент=');
readln (a[i]);
end;
end;
procedure PutArray (n:integer;
var a:vector);
var i:integer;
begin
writeln;
for i:=1 to n do writeln (a[i]:10:3);
end;
procedure sortArray (n:integer;
var a:vector);
var i,j:integer; buf:real;
begin
for i:=1 to n do
for j:=i+1 to n do if a[i]>a[j] then begin
buf:=a[i]; a[i]:=a[j]; a[j]:=buf;
end;
end;
var a:vector;
n:integer;
begin
GetArray (n,a);
sortArray (n,a);
write ('Отсортированный массив:');
PutArray (n,a);
end.
3. Вычисление всех миноров второго порядка в квадратной матрице.
program minor2_count;
const size=10;
type Matrix= array [1..size,1..size]
of real;
function minor2 (n:integer;
i,j,l,k:integer; a:matrix):real;
begin
minor2:=a[i,j]*a[l,k]-a[l,j]*a[i,k];
end;
procedure Input2 (var n:integer;
maxn:integer; var a:matrix);
var i,j:integer;
begin
repeat
writeln;
write ('Введите размерность матрицы ',
'(от 2 до ',size,' включительно):');
readln (n);
until (n>1) and (n<size);
for i:=1 to n do begin
writeln;
write ('Введите ',i,' строку матрицы:');
for j:=1 to n do read (a[i,j]);
end;
end;
var i,j,k,l,n:integer;
s:real;
a:matrix;
begin
Input2 (n,size,a);
for i:=1 to n do
for j:=1 to n do
for l:=i+1 to n do
for k:=j+1 to n do begin
s:=minor2 (n,i,j,l,k,a);
writeln;
writeln ('Минор [',i,',',j,']');
writeln (' [',l,',',k,']=',s:8:3);
end;
end.
4. Учебная база данных "Студенты".
type student = record
{Определение записи "Студент"}
name:string[20];
balls:array [1..4] of integer;
end;
const filename='students.dat';
{Имя базы данных}
var s:student; {Текущая запись}
f:file of student; {Файл базы данных}
kol,current:longint;
{Количество записей и текущая запись}
size:integer; {Размер записи в байтах}
st1,st2:string;
{Буферные строки для данных}
procedure Warning (msg:string);
{Сообщение-предупреждение}
begin
writeln; writeln (msg);
write ('Нажмите Enter для продолжения');
reset (input); readln;
end;
procedure out; {Закрытие базы и выход}
begin
close (f); halt;
end;
procedure Error (msg:string);
{Сообщение об ошибке + выход из программы}
begin
writeln; writeln (msg);
write ('Нажмите Enter для выхода');
reset (input); readln; out;
end;
procedure open; {открыть, при необходимости
создать файл записей}
begin
assign (f,filename);
repeat
{$I-} reset (f); {$I+}
if IoResult <> 0 then begin
Warning
('Не могу открыть файл '+filename+
'... Будет создан новый файл');
{$I-}rewrite (f);{$I+}
if IoResult <> 0 then
Error ('Не могу создать файл! '+
'Проверьте права и состояние диска');
end
else break;
until false;
end;
procedure getsize (var kol:longint;
var size:integer);
{Вернет текущее число записей kol и
размер записи в байтах size}
begin
reset (f);
size:=sizeof(student);
if filesize(f)=0 then kol:=0
else begin
seek(F, Filesize(F));
kol:=filepos (f);
end;
end;
function getname (s:string):string;
{Переводит строку в верхний регистр
c учетом кириллицы DOS}
var i,l,c:integer;
begin
l:=length(s);
for i:=1 to l do begin
c:=ord(s[i]);
if (c>=ord('а')) and (c<=ord('п'))
then c:=c-32
else if (c>=ord('р')) and (c<=ord('я'))
then c:=c-80;
s[i]:=Upcase(chr(c));
end;
getname:=s;
end;
procedure prints;
{Вспомогательная процедура печати -
печатает текущую s}
var i:integer;
begin
write (getname(s.name),': ');
for i:=1 to 4 do begin
write (s.balls[i]);
if i<4 then write (',');
end;
writeln;
end;
procedure print (n:integer); {Вывести
запись номер n (с переходом к ней)}
begin
seek (f,n-1); read (f,s); prints;
end;
procedure go (d:integer); {Перейти на d
записей по базе}
begin
writeln;
write ('Текущая запись: ');
if current=0 then writeln ('нет')
else begin
writeln (current);
print (current);
end;
current:=current+d;
if current<1 then begin
Warning ('Не могу перейти на запись '+
'с номером меньше 1');
if kol>0 then current:=1
else current:=0;
end
else if current>kol then begin
str (kol,st1);
Warning ('Не могу перейти на запись '+
'с номером больше '+st1);
current:=kol;
end
else begin
writeln ('Новая запись: ',current);
print (current);
end;
end;
procedure search;
{Поиск записи в базе по фамилии}
var i,found,p:integer;
begin
if kol<1 then
Warning ('База пуста! Искать нечего')
else begin
writeln;
write ('Введите фамилию (часть фамилии)',
' для поиска, регистр символов любой:');
reset (input);
readln (st1);
st1:=getname(st1);
seek (f,0);
found:=0;
for i:=0 to kol-1 do begin
read (f,s);
p:=pos(st1,getname(s.name));
if p>0 then begin
writeln ('Запись номер ',i+1);
prints;
found:=found+1;
if found mod 10 = 0 then
Warning ('Пауза...');
{Пауза после вывода 10 найденных}
end;
end;
if found=0 then
Warning ('Ничего не найдено...');
end;
end;
procedure add;
{Добавить запись в конец базы}
var i,b:integer;
begin
repeat
writeln;
write ('Введите фамилию студента ',
'для добавления:');
reset (input);
readln (st1);
if length(st1)<1 then begin
Warning ('Слишком короткая строка!'+
' Повторите ввод');
continue;
end
else if length(st1)>20 then begin
Warning ('Слишком длинная строка! '+
'Будет обрезана до 20 символов');
st1:=copy (st1,1,20);
end;
s.name:=st1;
break;
until false;
for i:=1 to 4 do begin
repeat
writeln; {следовало бы предусмотреть
возможность ввода не всех оценок}
write ('Введите оценку ',i,' из 4:');
{$I-}readln (b);{$I+}
if (IoResult<>0) or (b<2) or (b>5)
then begin
Warning ('Неверный ввод! Оценка - '+
'это число от 2 до 5! Повторите.');
continue;
end
else begin
s.balls[i]:=b; break;
end;
until false;
end;
seek (f,filesize(f));
write (f,s); kol:=kol+1; current:=kol;
end;
procedure delete; {Удаление текущей записи}
var f2:file of student; i:integer;
begin
if kol<1 then
Warning ('База пуста! Удалять нечего')
else begin
assign (f2,'students.tmp');
{$I-}rewrite(f2);{$I+}
if IoResult<>0 then begin
Warning ('Не могу открыть новый файл '+
'для записи!'+#13+#10+
' Операция невозможна. Проверьте '+
'права доступа и текущий диск.');
Exit;
end;
seek (f,0);
for i:=0 to kol-1 do begin
if i+1<>current then begin
{переписываем все записи, кроме текущей}
read (f,s); write (f2,s);
end;
end;
close (f); {закрываем исходную БД}
erase (f); {Удаляем исходную БД,
проверка IoResult опущена!}
rename (f2,filename); {Переименовываем f2
в имя БД}
close (f2); {Закрываем
переименованный f2}
open; {Связываем БД с прежней
файловой переменной f}
kol:=kol-1;
if current>kol then current:=kol;
end;
end;
procedure sort;
{сортировка базы по фамилии студента}
var i,j:integer;
s2:student;
begin
if kol<2 then
Warning ('В базе нет 2-х записей!'+
' Сортировать нечего')
else begin
for i:=0 to kol-2 do begin
{Обычная сортировка}
seek (f,i); {только в учебных целях -
работает неоптимально}
read (f,s);{и много обращается к диску!}
for j:=i+1 to kol-1 do begin
seek (f,j);
read (f,s2);
if getname(s.name)>getname(s2.name)
then begin
seek (f,i); write (f,s2);
seek (f,j); write (f,s);
s:=s2; {После перестановки в s уже
новая запись!}
end;
end;
end;
end;
end;
procedure edit; {редактирование записи
номер current}
var i,b:integer;
begin
if (kol<1) or (current<1) or (current>kol)
then Warning ('Неверный номер '+
'текущей записи! Не могу редактировать')
else begin
seek (f,current-1);
read (f,s);
repeat
writeln ('Запись номер ',current);
writeln ('Выберите действие:');
writeln ('1. Фамилия (',s.name,')');
for i:=1 to 4 do
writeln (i+1,'. Оценка ',i,
' (',s.balls[i],')');
writeln ('0. Завершить редактирование');
reset (input);
{$I-}readln (b);{$I+}
if (IoResult<>0) or (b<0) or (b>5) then
Warning ('Неверный ввод! Повторите')
else begin
if b=1 then begin
write ('Введите новую фамилию:');
{для простоты здесь нет}
{проверок корректности}
reset (input); readln (s.name);
end
else if b=0 then break
else begin
write ('Введите новую оценку:');
reset (input); readln (s.balls[b-1]);
end;
end;
until false;
seek (f,current-1);
{Пишем, даже если запись не менялась -}
write (f,s); {в реальных проектах
так не делают}
end;
end;
procedure menu; {Управление главным меню и
вызов процедур}
var n:integer;
begin
repeat
writeln;
writeln ('Выберите операцию:');
writeln ('1 - вперед');
writeln ('2 - назад');
writeln ('3 - поиск по фамилии');
writeln ('4 - добавить в конец');
writeln ('5 - удалить текущую');
writeln ('6 - сортировать по фамилии');
writeln ('7 - начало базы');
writeln ('8 - конец базы');
writeln ('9 - изменить текущую');
writeln ('0 - выход');
reset (input);
{$I-}read (n);{$I+}
if (IoResult<>0) or (n<0) or (n>9)
then begin
Warning ('Неверный ввод!');
continue;
end
else break;
until false;
case n of
1: go (1);
2: go (-1);
3: search;
4: add;
5: delete;
6: sort;
7: go (-(current-1));
8: go (kol-current);
9: edit;
0: out;
end;
end;
begin {Главная программа}
open;
getsize (kol,size);
str(kol,st1);
str(size,st2);
writeln;
writeln('==============================');
writeln('Учебная база данных "Студенты"');
writeln('==============================');
Warning ('Файл '+FileName+
' открыт'+#13+#10+
'Число записей='+st1+#13+#10+
'Размер записи='+st2+#13+#10);
{+#13+#10 - добавить к строке символы
возврата каретки и первода строки}
if kol=0 then current:=0
else current:=1;
repeat
menu;
until false;
end.
5. Программа содержит коды часто используемых клавиш и печатает их названия.
uses crt;
const ESC=#27; ENTER=#13; F1=#59;
F10=#68; TAB=#9; SPACE=#32;
UP=#72; DOWN=#80; LEFT=#75; RIGHT=#77;
HOME=#71; END_=#79;
PAGE_UP=#73; PAGE_DN=#81;
var ch:char;
begin
clrscr;
repeat
ch:=Upcase(readkey);
case ch of
'A'..'z': write ('Letter');
SPACE: write ('SPACE');
ENTER: write ('ENTER');
TAB: write ('TAB');
#0: begin
ch:=readkey;
case ch of
F1: write ('F1');
F10: write ('F10');
LEFT: write ('LEFT');
RIGHT: write ('RIGHT');
UP: write ('UP');
DOWN: write ('DOWN');
HOME: write ('HOME');
END_: write ('END');
PAGE_UP: write ('PgUp');
PAGE_DN: write ('PgDn');
end;
end;
else begin
end;
end;
until ch=Esc;
end.
6.1. Программа позволяет двигать по текстовому экрану "прицел" с помощью клавиш со стрелками.
uses crt;
{$V-} {отключили строгий контроль типов}
const ESC=#27; UP=#72; DOWN=#80;
LEFT=#75; RIGHT=#77;
var ch:char;
procedure Draw (x,y:integer;mode:boolean);
{mode определяет, нарисовать или стереть}
var sprite:array [1..3] of string [3];
{"прицел", заданный массивом sprite}
i:integer;
begin
sprite[1]:='/|\';
sprite[2]:='-=-';
sprite[3]:='\|/';
if mode=true then textcolor (White)
else textcolor (Black);
for i:=y to y+2 do begin
gotoxy (x,i); write (sprite[i-y+1]);
end;
gotoxy (x+1,y+1);
end;
procedure status (n:integer; s:string);
{рисует строку статуса
внизу или вверху экрана}
begin
textcolor (Black); textbackground (White);
gotoxy (1,n); write (' ':79);
gotoxy (2,n); write (s);
textcolor (White); textbackground (Black);
end;
var x,y:integer;
begin
textMode (cO80);
status (1,'Пример управления движением!');
status(25,'Стрелки-управление;ESC-выход');
x:=10; y:=10;
repeat
Draw (x,y,true);
ch:=Upcase(readkey);
case ch of
#0: begin
ch:=readkey;
Draw (x,y,false);
case ch of
LEFT: if x>1 then x:=x-1;
RIGHT: if x<77 then x:=x+1;
UP: if y>2 then y:=y-1;
DOWN: if y<22 then y:=y+1;
end;
end;
end;
until ch=ESC;
clrscr;
end.
6.2. Эта версия программы 6.1 позволяет "прицелу" продолжать движение до тех пор, пока он не натолкнется на край экрана.
uses crt;
{$V-}
const ESC=#27; UP=#72; DOWN=#80;
LEFT=#75; RIGHT=#77;
const goleft=1; GoRight=2; goup=3;
godown=4; gostop=0;
{возможные направления движения}
const myDelay=1000; {задержка для Delay}
var ch:char; LastDir:integer;
{последнее направление движения}
procedure Draw (x,y:integer;mode:boolean);
var sprite:array [1..3] of string [3];
i:integer;
begin
sprite[1]:='/|\';
sprite[2]:='-=-';
sprite[3]:='\|/';
if mode then textcolor (White)
else textcolor (Black);
for i:=y to y+2 do begin
gotoxy (x,i);
write (sprite[i-y+1]);
end;
gotoxy (x+1,y+1);
end;
procedure status (n:integer; s:string);
begin
textcolor (Black); textbackground (White);
gotoxy (1,n); write (' ':79);
gotoxy (2,n); write (s);
textcolor (White); textbackground (Black);
end;
var x,y:integer;
begin
clrscr;
status(1,'Управление движением-2');
status(25,'Стрелки-управление;ESC-выход');
x:=10; y:=10; LastDir:=goleft;
repeat {бесконечный цикл работы программы}
repeat {цикл до нажатия клавиши}
Draw (x,y,true); Delay (myDelay);
Draw (x,y,false);
case LastDir of
goLeft:
if x>1 then Dec(x)
else begin
x:=1; LastDir:=gostop;
end;
GoRight:
if x<77 then inc(x)
else begin
x:=77; LastDir:=gostop;
end;
goUp:
if y>2 then Dec(y)
else begin
y:=2; LastDir:=gostop;
end;
goDown:
if y<22 then inc(y)
else begin
y:=22; LastDir:=gostop;
end;
end;
until keyPressed;
{обработка нажатия клавиши}
ch:=Upcase(readkey);
case ch of
#0: begin
ch:=readkey;
case ch of
LEFT: LastDir:=goLeft;
RIGHT: LastDir:=GoRight;
UP: LastDir:=goUp;
DOWN: LastDir:=goDown;
end;
end;
ESC: halt;
end;
until false;
end.
7. Демо-программа для создания несложного двухуровневого меню пользователя. Переопределив пользовательскую часть программы, на ее основе можно создать собственный консольный интерфейс.
uses crt; { Глобальные данные: }
const maxmenu=2; {количество меню}
maxpoints=3; {макс. количество пунктов}
var x1,x2,y: array [1..maxmenu] of integer;
{x1,x2- начало и конец каждого меню,
y- строка начала каждого меню}
kolpoints, points: array [1..maxmenu] of
integer;{Кол-во пунктов и текущие пункты }
text: array [1..maxmenu,1..maxpoints]
of string[12]; { Названия пунктов }
txtcolor, textback, cursorback:integer;
{ Цвета текста, фона, курсора}
mainhelp:string[80]; { Строка помощи }
procedure DrawMain (s:string); {Очищает
экран, рисует строку главного меню s }
begin Window (1,1,80,25);
textcolor (txtcolor);
textbackground (textback);
clrscr; gotoxy (1,1); write (s);
end;
procedure DrawHelp (s:string);
{ Выводит подсказку s }
var i:integer; begin
textcolor (txtcolor);
textbackground (textback); gotoxy (1,25);
for i:=1 to 79 do write (' ');
gotoxy (1,25); write (s);
end;
procedure doubleFrame (x1,y1,x2,y2:integer;
Header: string);
{ Процедура рисует двойной рамкой окно }
var i,j: integer;
begin gotoxy (x1,y1);
write ('╔');
for i:=x1+1 to x2-1 do write('═');
write ('╗');
for i:=y1+1 to y2-1 do begin
gotoxy (x1,i); write('║');
for j:=x1+1 to x2-1 do write (' ');
write('║');
end;
gotoxy (x1,y2); write('╚');
for i:=x1+1 to x2-1 do write('═');
write('╝');
gotoxy (x1+(x2-x1+1-Length(Header))
div 2,y1);
write (Header); {Выводим заголовок}
gotoxy (x1+1,y1+1);
end;
procedure clearFrame (x1,y1,x2,y2:integer);
var i,j:integer;
begin textbackground (textback);
for i:=y1 to y2 do begin
gotoxy (x1,i);
for j:=x1 to x2 do write (' ');
end;
end;
procedure cursor (Menu,Point: integer;
Action: boolean);{ Подсвечивает (если
Action=true) или гасит п. Point меню Menu}
begin textcolor (Txtcolor);
if Action=true then
textbackground (cursorBack)
else textbackground (textBack);
gotoxy (x1[Menu]+1,y[Menu]+Point);
write (text[Menu][Point]);
end;
procedure DrawMenu (Menu:integer;
Action: boolean);{Рисует меню с номером
Menu, если Action=true, иначе стирает }
var i:integer;
begin
if Action=true then textcolor (Txtcolor)
else textcolor (textBack);
textbackground (textBack);
doubleFrame (x1[Menu], y[Menu], x2[Menu],
y[Menu]+1+KolPoints[Menu],'');
for i:=1 to KolPoints[Menu] do begin
gotoxy (x1[Menu]+1, y[Menu]+i);
writeln (text[Menu][i]);
end;
end;
{Часть, определяемая пользователем}
procedure Init; { Установка глобальных
данных и начальная отрисовка }
begin
txtcolor:=yELLOW; textback:=BLUE;
cursorback:=LIGHTcyAN;
kolpoints[1]:=2; kolpoints[2]:=1;
{пунктов в каждом меню}
points[1]:=1; points[2]:=1;
{выбран по умолчанию в каждом меню}
x1[1]:=1; x2[1]:=9; y[1]:=2;
text[1,1]:='Запуск'; text[1,2]:='Выход ';
x1[2]:=9; x2[2]:=22; y[2]:=2;
text[2,1]:='О программе';
DrawMain ('Файл Справка');
MainHelp:='ESC - Выход из программы '+
'ENTER - выбор пункта меню '+
'Стрелки - перемещение';
DrawHelp(MainHelp);
end;
procedure Work; { Рабочая процедура }
var i,kol:integer; ch:char;
begin
DrawHelp('Идет расчет...');
{ Строка статуса }
textcolor (LIGHTGRAY);
textbackground (BLACK);
{ Выбираем цвета для работы в окне }
doubleFrame (2,2,78,24,' Расчет ');
Window (3,3,77,23);
{Секция действий, выполняемых программой}
writeln;
write ('Введите число шагов: ');
{$I-}read (kol);{$I+}
if IoResult<>0 then writeln
('Ошибка! Вы ввели не число')
else if kol>0 then begin
for i:=1 to kol do
writeln ('Выполняется шаг ',i);
writeln ('Все сделано!');
end
else writeln ('Ошибка! Число больше 0');
{Восстановление окна и выход}
Window (1,1,80,25);
DrawHelp('Нажмите любую клавишу...');
ch:=readkey;
clearFrame (2,2,78,24); { Стираем окно }
end;
procedure Out; { Очистка экрана и выход}
begin
textcolor (LIGHTGRAY);
textbackground (BLACK); clrscr; halt(0);
end;
procedure Help; {Окно с информацией}
var ch:char;
begin
textcolor (Txtcolor);
textbackground (textback);
doubleFrame (24,10,56,13,' О программе ');
DrawHelp ('Нажмите клавишу...');
gotoxy (25,11);
writeln(' Демонстрация простейшего меню');
gotoxy (25,12);
write ( ' Новосибирск, НГАСУ');
ch:=readkey;
clearFrame (24,10,58,13);
end;
procedure command (Menu,Point:integer);
{Вызывает процедуры после выбора в меню }
begin
if Menu=1 then begin
if Point=1 then Work
else if Point=2 then Out;
end
else begin
if Point=1 then Help;
end;
end;
{Конец части пользователя }
procedure MainMenu (Point,
HorMenu:integer); { Поддерживает систему
одноуровневых меню }
var ch: char; funckey:boolean;
begin
Points[HorMenu]:=Point;
DrawMenu (HorMenu,true);
repeat
cursor (HorMenu,Points[HorMenu],true);
ch:=readkey;
cursor (HorMenu,Points[HorMenu],false);
if ch=#0 then begin
funckey:=true; ch:=readkey;
end
else funckey:=false;
if funckey=true then begin
ch:=Upcase (ch);
if ch=#75 then begin { Стрелка влево }
DrawMenu (HorMenu,false);
HorMenu:=HorMenu-1;
if (HorMenu<1) then HorMenu:=maxMenu;
DrawMenu (HorMenu,true);
end
else if ch=#77 then begin
{ Стрелка вправо }
DrawMenu (HorMenu,false);
HorMenu:=HorMenu+1;
if (HorMenu>maxMenu) then HorMenu:=1;
DrawMenu (HorMenu,true);
end
else if ch=#72 then begin
{ Стрелка вверх }
Points[HorMenu]:=Points[HorMenu]-1;
if Points[HorMenu]<1 then
Points[HorMenu]:=Kolpoints[HorMenu];
end
else if ch=#80 then begin
{ Стрелка вниз }
Points[HorMenu]:=Points[HorMenu]+1;
if (Points[HorMenu]>KolPoints[HorMenu])
then Points[HorMenu]:=1;
end;
end
else if ch=#13 then begin
{ Клавиша ENTER }
DrawMenu (HorMenu,false);
command (HorMenu,Points[HorMenu]);
DrawMenu (HorMenu,true);
DrawHelp (MainHelp);
end;
until (ch=#27) and (funckey=false);
{ Пока не нажата клавиша ESC }
end;
{ Основная программа }
begin
Init;
MainMenu (1,1);
Out;
end.
8. Простейший "генератор" программы на Паскале. Из входного файла, содержащего текст, генерируется программа для листания этого текста.
program str2Pas;
uses crt; label 10,20;
var ch:char;str:string;
I,J,Len,count:word; InFile,OutFile:text;
procedure Error (ErNum:char);
begin
case ErNum of
#1: writeln
('Запускайте с 2 параметрами -',#13,#10,
'именами входного и выходного файла.',
#13,#10,
'Во входном файле содержится текст',
#13,#10,
'в обычном ASCII-формате,',#13,#10,
'в выходном будет программа на Паскале');
#2:
writeln
(' Не могу открыть входной файл!');
#3:
writeln
(' Не могу открыть выходной файл!');
else writeln (' Неизвестная ошибка!');
end;
halt;
end;
begin
if Paramcount<>2 then Error (#1);
assign (InFile,Paramstr(1));
reset (InFile);
if (IoResult<>0) then Error (#2);
assign (OutFile,Paramstr(2));
rewrite (OutFile);
if (IoResult<>0) then Error (#3);
{ Вписать заголовок программы }
writeln (OutFile,'uses crt;');
write (OutFile,'const colstr=');
{ Узнать число строк текста }
count:=0;
while not Eof (InFile) do begin
readLn (InFile,str);
count:=count+1;
end;
reset (InFile);
writeln (OutFile,count,';');
{ Следующий сегмент программы: }
writeln (OutFile,'var ch:char;');
writeln (OutFile,' List:boolean;');
writeln (OutFile,
' I,start,endstr:word;');
writeln (OutFile,
' ptext:array [1..colstr] of string;');
writeln (OutFile,'begin');
{ Строки листаемого текста: }
for I:=1 to count do begin
Len:=0;
repeat
if (Eof (InFile)=true) then goto 10;
read (InFile,ch);
if ch=#39 then begin
Len:=Len+1; str[Len]:=#39;
Len:=Len+1; str[Len]:=#39;
end
else if ch=#13 then begin
read (InFile,ch);
if (ch=#10) then goto 10
else goto 20;
end
else begin
20:
Len:=Len+1; str[Len]:=ch;
end;
until false;
10:
write (OutFile,' ptext[',I,']:=''');
for J:=1 to Len do
write (OutFile,str[J]);
writeln (OutFile,''';');
end;
{ Сегмент программы }
writeln (OutFile,' textcolor (YELLOW);');
writeln (OutFile,
' textbackground (Blue);');
writeln (OutFile,
' List:=true; start:=1;');
{ Последняя строка на экране: }
if (count>25) then
writeln (OutFile,' endstr:=25;')
else writeln (OutFile,' endstr:=colstr;');
writeln (OutFile,' repeat');
writeln (OutFile,
' if (List=true) then begin');
writeln (OutFile,' clrscr;');
writeln (OutFile,
' for I:=start to endstr-1 do ',
'write (ptext[I],#13,#10);');
writeln (OutFile,
' write (ptext[endstr]);');
writeln (OutFile,' List:=false;');
writeln (OutFile,' end;');
writeln (OutFile,' ch:=readkey;');
writeln (OutFile,
' if ch= #0 then begin');
writeln (OutFile,' ch:=readkey;');
writeln (OutFile,' case ch of');
writeln (OutFile,' #72: begin');
writeln (OutFile,
' if start>1 then begin');
writeln (OutFile,' start:=start-1;');
writeln (OutFile,
' endstr:=endstr-1;');
writeln (OutFile,' List:=true;');
writeln (OutFile,' end;');
writeln (OutFile,' end;');
writeln (OutFile,' #80: begin');
writeln (OutFile,
' if endstr<colstr then begin');
writeln (OutFile,' start:=start+1;');
writeln (OutFile,
' endstr:=endstr+1;');
writeln (OutFile,' List:=true;');
writeln (OutFile,' end;');
writeln (OutFile,' end;');
{ Листание PgUp и PgDn }
if (count>25) then begin
writeln (OutFile,' #73: begin');
writeln (OutFile,
' if start>1 then begin');
writeln (OutFile,
' start:=1; endstr:=25;');
writeln (OutFile,' List:=true;');
writeln (OutFile,' end;');
writeln (OutFile,' end;');
writeln (OutFile,' #81: begin');
writeln (OutFile,
' if endstr<colstr then begin');
writeln (OutFile,
' start:=colstr-24; endstr:=colstr;');
writeln (OutFile,' List:=true;');
writeln (OutFile,' end;');
writeln (OutFile,' end;');
end;
{ Заключительный сегмент }
writeln (OutFile,' else begin end;');
writeln (OutFile,' end;');
writeln (OutFile,' end');
writeln (OutFile,' else begin');
writeln (OutFile,' case ch of');
writeln (OutFile,' #27: begin');
writeln (OutFile,
' textcolor (LightGray);');
writeln (OutFile,
' textbackground (Black);');
writeln (OutFile,' clrscr;');
writeln (OutFile,' halt;');
writeln (OutFile,' end;');
writeln (OutFile,' else begin');
writeln (OutFile,' end;');
writeln (OutFile,' end;');
writeln (OutFile,' end;');
writeln (OutFile,' until false;');
writeln (OutFile,'end.');
close (InFile); close (OutFile);
writeln ('OK.');
end.
9. Шаблон программы для работы с матрицами и текстовыми файлами.
program Files;{ Программа демонстрирует
работу с текстовыми файлами и матрицами }
const rows=10; cols=10;
type matrix=array [1..rows,1..cols]
of real;
var f1,f2:text; a,b:matrix;
Name1,Name2:string; n,m:integer;
procedure Error (msg:string);
begin
writeln; writeln (msg);
writeln ('Нажмите Enter для выхода');
reset (Input); readln; halt;
end;
procedure readDim (var f:text;
var n,m:integer);{ Читает из файла f
размерности матрицы: n - число строк,
m - число столбцов. Если n<0 или n>rows
(число строк) или m<0 или m>cols (число
столбцов), прервет работу. }
var s:string;
begin
{$I-}read (f,n);{$I+}
if (IoResult<>0) or (n<0) or (n>rows)
then begin
str (rows,s);
Error ('Неверное число строк '+
'в файле данных!'+#13+#10+
'должно быть от 1 до '+s);
end;
{$I-}read (f,m);{$I+}
if (IoResult<>0) or (m<0) or (m>cols)
then begin
str (cols,s);
Error ('Неверное число столбцов '+
'в файле данных!'+#13+#10+
'должно быть от 1 до '+s);
end;
end;
procedure readMatrix (var f:text;
n,m:integer; var a:matrix);
{ Читает из файла f матрицу a
размерностью n*m }
var i,j:integer; er:boolean;
begin
er:=false;
for i:=1 to n do
for j:=1 to m do begin
{$I-}read (f,a[i,j]);{$I+}
if IoResult<>0 then begin
er:=true; a[i,j]:=0;
end;
end;
if er=true then begin
writeln;
writeln
('В прочитанных данных есть ошибки!');
writeln ('Неверные элементы матрицы',
' заменены нулями');
end;
end;
procedure writeMatrix (var f:text;
n,m:integer; var a:matrix);
{ Пишет в файл f матрицу a[n,m] }
var i,j:integer;
begin
for i:=1 to n do begin
for j:=1 to m do write (f,a[i,j]:11:4);
writeln (f);
end;
end;
procedure Proc1 (n,m:integer;
var a,b:matrix);
{ Матрицу a[n,m] пишет в матрицу b[n,m],
меняя знаки элементов }
var i,j:integer;
begin
for i:=1 to n do
for j:=1 to m do b[i,j]:=-a[i,j]
end;
begin
if Paramcount<1 then begin
writeln ('Имя файла для чтения:');
readLn (Name1);
end
else Name1:=Paramstr(1);
if Paramcount<2 then begin
writeln ('Имя файла для записи:');
readLn (Name2);
end
else Name2:=Paramstr(2);
assign (f1,Name1);
{$I-}reset (f1);{$I+}
if IoResult<>0 then
Error ('Не могу открыть '+Name1+
' для чтения');
assign (f2,Name2);
{$I-}rewrite (f2);{$I+}
if IoResult<>0 then
Error ('Не могу открыть '+Name2+
' для записи');
readDim (f1,n,m);
readMatrix (f1,n,m,a);
Proc1 (n,m,a,b);
writeMatrix (f2,n,m,b);
close (f1); close (f2);
end.
10. Подсчет количества дней от введенной даты до сегодняшнего дня.
program Days;
uses Dos;
const mondays: array [1..12] of integer =
(31,28,31, 30,31,30, 31,31,30, 31,30,31);
var d,d1,d2,m1,m2,y1,y2:word;
function Leapyear (year:word):boolean;
begin
if (year mod 4 =0) and (year mod 100 <>0)
or (year mod 400 =0) then Leapyear:=true
else Leapyear:=false;
end;
function correctDate
(day,mon,year:integer):boolean;
var maxday:integer;
begin
if (year<0) or (mon<1) or (mon>12) or
(day<1) then correctDate:=false
else begin
maxday:=mondays[mon];
if (Leapyear (year)=true) and (mon=2)
then maxday:=29;
if (day>maxday) then correctDate:=false
else correctDate:=true;
end;
end;
function KolDays (d1,m1,d2,m2,y:word):word;
var i,f,s:word;
begin
s:=0;
if m1=m2 then KolDays:=d2-d1
else for i:=m1 to m2 do begin
f:=mondays[i];
if (Leapyear (y)=true) and (i=2)
then f:=f+1;
if i=m1 then s:=s+(f-d1+1)
else if i=m2 then s:=s+d2
else s:=s+f;
KolDays:=s;
end;
end;
function countDays (day1, mon1, year1,
day2, mon2, year2:word):word;
var f,i:word;
begin
f:=0;
if year1=year2 then countDays:=
KolDays (day1, mon1, day2, mon2, year1)
else for i:=year1 to year2 do begin
if i=year1 then f:=
KolDays (day1, mon1, 31, 12, year1)
else if i=year2 then f:=f+
KolDays (1,1,day2,mon2,year2)-1
else f:=f+KolDays (1,1,31,12,i);
countDays:=f;
end;
end;
begin
getdate (y2,m2,d2,d);
writeln ('Год Вашего рождения?');
readln (y1);
writeln ('Месяц Вашего рождения?');
readln (m1);
writeln ('День Вашего рождения?');
readln (d1);
if correctDate (d1,m1,y1)=false then begin
writeln ('Недопустимая дата!'); halt;
end;
if (y2<y1) or ( (y2=y1) and
( (m2<m1) or ( (m2=m1) and (d2<d1))))
then begin writeln ('Введенная дата',
' позднее сегодняшней!'); halt;
end;
d:=countDays (d1,m1,y1,d2,m2,y2);
writeln ('Количество дней= ',d);
end.
11.1. Исходный текст модуля для поддержки мыши.
unit Mouse;
{Примеры использования -
см. mousetst.pas в графике,
mousetxt.pas в текстовом режиме 80*25}
interface
var MousePresent:boolean;
function MouseInit(var nb:integer):boolean;
{ Инициализация мыши - вызывать первой.
Вернет true, если мышь обнаружена }
procedure Mouseshow; {Показать курсор мыши}
procedure MouseHide; {Скрыть курсор мыши}
procedure Mouseread(var x,y,bMask:integer);
{Прочитать позицию мыши.
Вернет через x,y координаты курсора
(для текстового режима см. пример),
через bmask - состояние кнопок
(0-отпущены,1-нажата левая,2-нажата правая,
3-нажаты обе) }
procedure MousesetPos(x,y:word);
{Поставить курсор в указанную позицию}
procedure Mouseminxmaxx(minx,maxx:integer);
{Установить границы перемещения по x}
procedure Mouseminymaxy(miny,maxy:integer);
{Установить границы перемещения по y}
procedure setVideoPage(Page:integer);
{Установить нужную видеостраницу}
procedure GetVideoPage(var Page:integer);
{Получить номер видеостраницы}
function MouseGetb(bMask:word; var count,
Lastx, Lasty:word):word;
procedure MousekeyPreset
(var key,sost,x,y:integer);
implementation
uses Dos;
var r: registers;
Mi:pointer;
function MouseInit(var nb:integer):boolean;
begin
if MousePresent then begin
r.Ax:=0; Intr($33,r);
if r.Ax=0 then begin
nb:=0; MouseInit:=false
end
else begin
nb:=r.Ax; MouseInit:=true
end
end
else begin
nb:=0; MouseInit:=false
end
end;
procedure Mouseshow;
begin
r.Ax:=1; Intr($33,r)
end;
procedure MouseHide;
begin
r.Ax:=2; Intr($33,r)
end;
procedure Mouseread(var x,y,bMask:integer);
begin
r.Ax:=3; Intr($33,r);
x:=r.cx; y:=r.dx; bMask:=r.Bx
end;
procedure MousesetPos(x,y:word);
begin
r.Ax:=4; r.cx:=x; r.dx:=y;
Intr($33,r)
end;
function MouseGetb(bMask:word;
var count,Lastx,Lasty:word):word;
begin
r.Ax:=5; r.Bx:=bMask;Intr($33,r);
count:=r.Bx; Lastx:=r.cx;
Lasty:=r.dx; MouseGetb:=r.Ax
end;
procedure Mouseminxmaxx(minx,maxx:integer);
begin
r.Ax:=7; r.cx:=minx;
r.dx:=maxx; Intr($33,r)
end;
procedure Mouseminymaxy(miny,maxy:integer);
begin
r.Ax:=8; r.cx:=miny;
r.dx:=maxy; Intr($33,r)
end;
procedure setVideoPage(Page:integer);
begin
r.Ax:=$1D; r.Bx:=Page; Intr($33,r)
end;
procedure GetVideoPage(var Page:integer);
begin
r.Ax:=$1E; Intr($33,r); Page:=r.Bx;
end;
procedure MousekeyPreset
(var key,sost,x,y:integer);
begin
r.Ax:=$6; r.Bx:=key; Intr($33,r);
key:=r.Ax; sost:=r.Bx;
x:=r.cx; y:=r.dx;
end;
begin
GetIntVec($33,Mi);
if Mi=nil then
MousePresent:=false
else if byte(Mi^)=$cE then
MousePresent:=false
else MousePresent:=true
end.
11.2. Тест модуля mouse.pas в графическом режиме (mousetst.pas).
program MouseTst;
uses graph,Mouse,crt;
var grDriver : integer; grMode : integer;
Errcode : integer;
procedure init;
begin
grDriver:=VGA;grMode:=VGAHi;
initgraph(grDriver, grMode, '');
Errcode:=graphresult;
if Errcode <> grOk then begin
writeln('Ошибка инициализации графики:',
grapherrormsg(Errcode)); halt;
end;
end;
var n,x,y,x0,y0,b:integer; s1,s2:string;
begin
init;
mouseinit(n);
mouseshow;
setfillstyle (solidfill,BLACK);
setcolor (WHITE);
settextJustify(centertext, centertext);
x0:=-1; y0:=-1;
repeat
mouseread (x,y,b);
if (x<>x0) or (y<>y0) then begin
str (x,s1); str (y,s2);
bar (getmaxx div 2-50,
getmaxy-15,getmaxx div 2+50,getmaxy-5);
outtextxy (getmaxx div 2,
getmaxy-10,s1+' '+s2);
x0:=x; y0:=y;
end;
until keypressed;
mousehide;
closegraph;
end.
11.3. Тест модуля mouse.pas в текстовом режиме (mousetxt.pas).
program MouseTxt;
uses crt,mouse;
var n,x,y,b:integer;
n1,k,lastx,lasty:word;
begin
textmode(3);
mouseinit (n);
mouseshow;
repeat
mouseread (x,y,b);
gotoxy (1,25);
write ('x=',(x div 8 + 1):2,
' y=',(y div 8 + 1):2,' b=',b:2);
until keypressed;
mousehide;
end.
12.1. Учебная игра, использующая собственный файл ресурсов. Первый листинг содержит утилиту для создания файла ресурсов resfile из файлов *.bmp текущей директории, список которых находится в файле filelist.txt. Файлы *.bmp должны быть сохранены в режиме 16 цветов. При необходимости следует изменить в программе константу пути к Паскалю.
uses graph,crt;
const VGAPath='c:\TP7\egavga.bgi';
FileList='filelist.txt';
resfile='attack.res';
const width=32; height=20;
const color: array [0..15] of byte=
(0,4,2,6,1,5,3,7,8,12,10,14,9,13,11,15);
const maxx=639; maxy=479;
cx=MAxx div 2; cy=maxy div 2;
type bmpinfo=record
h1,h2:char;
size,reserved,offset,b,width,
height: longint;
plans,bpp:word;
end;
var Driver, Mode: integer;
DriverF: file; List,res:text;
DriverP: pointer; s:string;
procedure Wait;
var ch:char;
begin
reset (Input); repeat until keyPressed;
ch:=readkey; if ch=#0 then readkey;
end;
procedure closeMe;
begin
if DriverP <> nil then begin
FreeMem(DriverP, Filesize(DriverF));
close (DriverF);
end;
closegraph;
end;
procedure graphError;
begin
closeMe;
writeln('graphics error:',
grapherrormsg(graphresult));
writeln('Press any key to halt ');
Wait;
halt (graphresult);
end;
procedure InitMe;
begin
assign(DriverF, VGAPath);
reset(DriverF, 1);
getmem(DriverP, Filesize(DriverF));
Blockread(DriverF, DriverP^,
Filesize(DriverF));
if registerBGIdriver(DriverP)<0 then
graphError;
Driver:=VGA; Mode:=VGAHi;
initgraph(Driver, Mode,'');
if graphresult < 0 then graphError;
end;
procedure clearscreen;
begin
setfillstyle (solidfill, White);
bar (0,0,maxx,maxy);
end;
procedure Window
(x1,y1,x2,y2,color,Fillcolor:integer);
begin
setcolor (color);
setfillstyle (1,Fillcolor);
bar (x1,y1,x2,y2);
rectangle (x1+2,y1+2,x2-2,y2-2);
rectangle (x1+4,y1+4,x2-4,y2-4);
setfillstyle (1,DArKGrAy);
bar (x1+8,y2+1,x2+8,y2+8);
bar (x2+1,y1+8,x2+8,y2);
end;
procedure Error (code:integer; str:string);
begin
Window (cx-140,cy-100,cx+140,
cy-70,Black,YELLOW);
case code of
1: s:='Файл '+str+' не найден!';
2: s:='Файл '+str+' не формата BMP-16';
3: s:='Файл '+str+' испорчен!';
end;
settextjustify (Lefttext, toptext);
settextstyle(DefaultFont, HorizDir, 1);
outtextxy (cx-136,cy-92,s);
Wait;
halt(code);
end;
function Draw (x0,y0:integer; fname:string;
transparent:boolean):integer;
var f:file of bmpinfo;
bmpf:file of byte;
res:integer; info:bmpinfo;
x,y:integer; b,bh,bl:byte;
nb,np:integer; tpcolor:byte;
i,j:integer;
begin
assign(f,fname);
{$I-} reset (f); {$I+}
res:=IoResult;
if res <> 0 then Error (1,fname);
read (f,info);
close (f);
if info.bpp<>4 then Error(2,fname);
x:=x0;
y:=y0+info.height;
nb:=(info.width div 8)*4;
if (info.width mod 8) <> 0 then nb:=nb+4;
assign (bmpf,fname);
reset (bmpf);
seek (bmpf,info.offset);
if transparent then begin
read (bmpf,b);
tpcolor:=b shr 4;
seek (bmpf,info.offset);
end
else tpcolor:=17;
for i:=1 to info.height do begin
np:=0;
for j:=1 to nb do begin
read (bmpf,b);
if np<info.width then begin
bh:=b shr 4;
if bh <> tpcolor then
putpixel (x,y,color[bh]);
inc (x);
inc(np);
end;
if np<info.width then begin
bl:=b and 15;
if bl <> tpcolor then
putpixel (x,y,color[bl]);
inc(x);
inc(np);
end;
end;
x:=x0;
dec(y);
end;
close (bmpf);
Draw:=info.height;
end;
var i,j:word;
b:char;
r:integer;
begin
InitMe;
clearscreen;
assign (List,FileList);
{$I-}
reset (List);
{$I+}
if IoResult <> 0 then Error (1,FileList);
assign (res,resfile);
{$I-}
rewrite (res);
{$I+}
if IoResult <> 0 then Error (1,resfile);
settextjustify (centertext,toptext);
while not eof(List) do begin
readLn (List,s);
clearscreen;
Draw (0,0,s,true);
for j:=1 to height do
for i:=1 to width do begin
b:=chr(getpixel (i,j));
write (res,b);
end;
setcolor (BLACK);
outtextxy (cx,maxy-20,'Файл '+s+' ОК');
Wait;
end;
closeMe;
close (res);
close (List);
end.
12.2. Листинг содержит исходный текст игры в стиле Invaders. Компилировать в Паскаль 7. При необходимости изменить константу пути к Паскалю. Требует файла ресурсов, созданного утилитой из листинга 12.1. Требует установленного графического шрифта trip.chr.
uses graph,crt,Dos;
const width=32; height=20;
type Picture=array [0..width-1,0..height-1]
of char;
type sprite=record
state,x,y,Pnum,PREDir: word;
end;
const VGAPath='c:\TP7\egavga.bgi';
FontPath='c:\TP7\Trip.chr';
sprName='attack.res';
const ESC=#27; F1=#59; SPACE=#32;
UP=#72; DOWN=#80; LEFT=#75; RIGHT=#77;
const maxx=639; maxy=479;
cx=maxx div 2; cy=maxy div 2;
maxsprites=11; maxPictures=11;
maxshoots=100;
const LeftDir=0; RightDir=1;
UpDir=2; DownDir=3;
Delta=2; shootradius=5;
var ch:char; s:string;
Hour,min,sec,sec1,secN,secN1,
sec100,secI,secI1:word;
var Driver, Mode, Font1,
currentsprites, currentBottom,
currentshoots, shootx, Lives,
Enemyshooter, Enemies,
shootsProbability: integer;
score,Level:longint;
DriverF,FontF: file;
DriverP,FontP: pointer;
spr: array [1..maxsprites] of sprite;
Pict: array [1..maxPictures] of Picture;
shoots: array [1..maxshoots] of sprite;
shooter,DieMe,InGame,Initshoot:boolean;
procedure Wait;
var ch:char;
begin
reset (Input); repeat until keyPressed;
ch:=readkey; if ch=#0 then readkey;
end;
procedure closeAll;
begin
if FontP <> nil then begin
FreeMem(FontP, Filesize(FontF));
close (FontF);
end;
if DriverP <> nil then begin
FreeMem(DriverP, Filesize(DriverF));
close (DriverF);
end;
closegraph;
end;
procedure graphError;
begin
closeAll;
writeln('graphics error:',
grapherrormsg(graphresult));
writeln('Press any key to halt');
Wait; halt (graphresult);
end;
procedure InitAll;
begin
assign(DriverF, VGAPath);
reset(DriverF, 1);
getmem(DriverP, Filesize(DriverF));
Blockread(DriverF, DriverP^,
Filesize(DriverF));
if registerBGIdriver(DriverP)<0 then
graphError;
Driver:=VGA; Mode:=VGAHi;
initgraph(Driver, Mode,'');
if graphresult < 0 then graphError;
assign(FontF, FontPath);
reset(FontF, 1);
getmem(FontP, Filesize(FontF));
Blockread(FontF, FontP^, Filesize(FontF));
Font1:=registerBGifont(FontP);
if Font1 < 0 then graphError;
end;
procedure clearscreen;
begin
setfillstyle (solidfill, White);
bar (0,0,maxx,maxy);
end;
procedure Window
(x1,y1,x2,y2,color,Fillcolor:integer);
begin
setcolor (color);
setfillstyle (1,Fillcolor);
bar (x1,y1,x2,y2);
rectangle (x1+2,y1+2,x2-2,y2-2);
rectangle (x1+4,y1+4,x2-4,y2-4);
setfillstyle (1,DArKGrAy);
bar (x1+8,y2+1,x2+8,y2+8);
bar (x2+1,y1+8,x2+8,y2);
end;
procedure outtextcxy (y:integer; s:string);
begin
settextjustify (centertext,centertext);
outtextxy (cx ,y,s);
end;
procedure start;
begin
clearscreen;
Window (10,10,maxx-10,maxy-10,Blue,White);
settextstyle(Font1, HorizDir, 4);
outtextcxy (25,'Атака из космоса');
settextstyle(Font1, HorizDir, 1);
outtextcxy (maxy-25,
'Нажмите клавишу для начала');
Wait;
end;
procedure restorescreen
(sNum,Dir,Delta:word);
var x,y:word;
begin
x:=spr[sNum].x; y:=spr[sNum].y;
setfillstyle (solidfill,White);
case Dir of
LeftDir: begin
bar(x+width-Delta,y,x+width-1,
y+height-1);
end;
RightDir: begin
bar (x,y,x+Delta,y+height-1);
end;
UpDir: begin
bar (x,y+height-Delta,
x+width-1,y+height-1);
end;
DownDir: begin
bar (x,y,x+width-1,y+Delta);
end;
end;
end;
procedure Drawsprite (sNum:word);
var i,j,x,y,n,b:integer;
begin
N:=spr[sNum].PNum;
x:=spr[sNum].x; y:=spr[sNum].y;
for j:=y to y+height-1 do
for i:=x to x+width-1 do begin
b:=ord(Pict[n,i-x,j-y]);
putpixel(i,j,b);
end;
end;
procedure GoLeft;
var x,d2:word;
begin
x:=spr[1].x; d2:=delta*4;
if x>d2 then begin
restorescreen (1,LeftDir,d2);
Dec(spr[1].x,d2); Drawsprite (1);
end;
end;
procedure GoRight;
var x,d2:word;
begin
x:=spr[1].x;
d2:=delta*4;
if x+width < maxx then begin
restorescreen (1,RightDir,d2);
Inc(spr[1].x,d2);
Drawsprite (1);
end;
end;
procedure showLives;
begin
str(Lives,s);
setfillstyle (solidfill,White);
setcolor (RED); bar (80,0,110,10);
outtextxy (82,2,s);
end;
procedure showscore;
begin
str(score,s);
setfillstyle (solidfill,White);
setcolor (Blue); bar (150,0,250,10);
outtextxy (152,2,s);
end;
procedure showshoots;
begin
str(currentshoots,s);
setfillstyle (solidfill,White);
setcolor (Black); bar (20,0,50,10);
outtextxy (20,2,s);
end;
procedure showLevel;
begin
str(Level,s);
setfillstyle (solidfill,White);
setcolor (Blue); bar (251,0,350,10);
outtextxy (253,2,'Level '+s);
end;
procedure shoot;
var i:integer;
begin
if currentshoots>0 then begin
for i:=1 to maxshoots do
if (sec<>sec1) and (shoots[i].state=0)
then begin
Dec(currentshoots);
showshoots;
spr[1].PNum:=6; Drawsprite (1);
GetTime(Hour,min,sec,sec100);
shootx:=spr[1].x; shooter:=true;
shoots[i].x:=spr[1].x+ (width div 2);
shoots[i].y:=spr[1].y - 5;
shoots[i].PNum:=UpDir;
shoots[i].state:=1;
break;
end;
end;
end;
procedure Help(s:string);
begin
setfillstyle (solidfill,White);
setcolor (Blue);
bar (10,maxy-10,maxx-10,maxy);
outtextxy (10,maxy-9,s);
end;
procedure Error (code:integer; str:string);
begin
Window (cx-120,cy-100,cx+120,cy-70,
Black,YELLOW);
case code of
1: s:='Файл '+str+' не найден!';
end;
settextjustify (Lefttext, toptext);
settextstyle(DefaultFont, HorizDir, 1);
outtextxy (cx-116,cy-92,s);
Wait; closeAll; halt(code);
end;
procedure DrawField;
var i,x,y:integer;
begin
clearscreen;
with spr[1] do begin
state:=1; Pnum:=1;
x:=maxx div 2;
y:=maxy - 10 - height;
Drawsprite (1);
end;
x:=100;
y:=10;
for i:=2 to currentsprites do begin
spr[i].state:=1;
spr[i].PNum:=7;
spr[i].x:=x; spr[i].y:=y;
Drawsprite (i);
inc(x,50);
if x>maxx-width then begin
x:=100;
if y<currentBottom-height then
Inc(y,height)
else y:=10;
end;
end;
for i:=1 to maxshoots do
shoots[i].state:=0;
shooter:=false;
Enemyshooter:=-1;
sec:=0; secN:=0;
secI1:=100; sec1:=100; secN1:=100;
setfillstyle (solidfill,RED);
FillEllipse (10,5,5,4);
showshoots;
setfillstyle (solidfill,Green);
bar (60,1,72,10);
setfillstyle (solidfill,LightGreen);
bar (62,3,70,8);
showLives;
setfillstyle (solidfill,YELLOW);
setcolor (Black);
for i:=1 to 3 do begin
circle (126+i*2,5,4);
FillEllipse (126+i*2,5,4,4);
end;
showscore;
showLevel;
InGame:=true;
end;
procedure Loadsprites;
var F:text;
n,i,j,r:integer;
b:char;
begin
assign (f,sprName);
{$I-}
reset (f);
{$I+}
if IoResult<>0 then Error (1,sprName);
for n:=1 to maxPictures do
for j:=0 to height-1 do
for i:=0 to width-1 do begin
read (f,b);
Pict [n,i,j]:=b;
end;
close (f);
end;
procedure Deltas (sNum,Dir:integer;
var dx,dy:integer);
var x,y:integer;
begin
x:=spr[sNum].x; y:=spr[sNum].y;
case Dir of
LeftDir: begin
Dec(x,Delta);
if x<0 then x:=0;
end;
RightDir: begin
Inc(x,Delta);
if x>maxx-width then x:=maxx-width;
end;
UpDir: begin
Dec (y,Delta);
if y<10 then y:=10;
end;
DownDir: begin
Inc(y,Delta);
if y>currentBottom then
y:=currentBottom;
end;
end;
dx:=x; dy:=y;
end;
function Between (a,x,b:integer):boolean;
begin
if (x>a) and (x<b) then Between:=true
else Between:=false;
end;
procedure shootMovies;
var i,d,n:integer;
x,y:word;
found:boolean;
begin
for i:=1 to maxshoots do
if shoots[i].state=1 then begin
x:=shoots[i].x; y:=shoots[i].y;
d:=shoots[i].PNum;
setfillstyle (solidfill,White);
setcolor (White);
fillellipse(x,y,shootradius,shootradius);
if d=updir then begin
setfillstyle (solidfill,RED);
if y<15 then begin
shoots[i].state:=0; continue;
end;
found:=false;
for n:=2 to currentsprites do begin
if spr[n].state=1 then begin
if (Between(spr[n].x,x,
spr[n].x+width)) and
(Between(spr[n].y,y,
spr[n].y+height)) then begin
shoots[i].state:=0;
found:=true;
spr[n].state:=2;
Inc(spr[n].PNum);
Inc(score,10+5*n);
showscore;
break;
end;
end;
end;
if not found then Dec(y,Delta);
end
else begin
setfillstyle (solidfill,Blue);
if y>maxy-10-(height div 2) then begin
shoots[i].state:=0;
continue;
end;
found:=false;
if Between(spr[1].x,x,spr[1].x+width)
and
Between(spr[1].y,y,spr[1].y+height)
then begin
shoots[i].state:=0; found:=true;
Inc(spr[1].Pnum); DieMe:=true;
Help ('you are missed one life :-(');
Drawsprite (1);
end;
if not found then Inc(y,Delta);
end;
if not found then begin
fillellipse(x,y,shootradius,shootradius);
shoots[i].x:=x; shoots[i].y:=y;
end;
end;
end;
procedure Enemiesstep;
var i,k,Dir,dx,dy,n:integer;
begin
Enemies:=0;
for i:=2 to currentsprites do begin
if spr[i].state=1 then begin
Inc(Enemies);
for k:=1 to 3 do begin
dir:=random(4);
if dir=spr[i].pREDir then break;
end;
spr[i].pREDir:=dir;
Deltas (i, dir, dx, dy);
restorescreen (i,Dir,Delta);
spr[i].x:=dx; spr[i].y:=dy;
Drawsprite (i);
Initshoot:=false;
GetTime(Hour,min,secN1,sec100);
if (secN1<>secN) and
(1+random(100)<shootsProbability) then
Initshoot:=true;
if Initshoot then begin
secN:=secN1;
for n:=1 to maxshoots do
if (shoots[n].state=0) and
(Enemyshooter<>i) then begin
Enemyshooter:=i;
shoots[n].x:=dx+ (width div 2);
shoots[n].y:=dy +height +5;
shoots[n].PNum:=DownDir;
shoots[n].state:=1;
break;
end;
end;
end
else if spr[i].state=2 then begin
GetTime (Hour,min,secI,sec100);
Drawsprite (i);
if secI<>secI1 then begin
secI1:=secI;
if (spr[i].PNum<11) then
Inc(spr[i].PNum)
else begin
spr[i].state:=0;
setfillstyle (solidfill, White);
bar (spr[i].x,spr[i].y,
spr[i].x+width-1,spr[i].y+height-1);
end;
end;
end;
end;
end;
procedure Timefunctions;
var i:integer;
begin
if not InGame then Exit;
GetTime(Hour,min,sec1,sec100);
if (shooter) and (sec<>sec1) then begin
spr[1].PNum:=1;
if shootx=spr[1].x then Drawsprite (1);
shooter:=false;
end;
if (DieMe) and (sec<>sec1) then begin
if spr[1].Pnum<5 then begin
sec:=sec1; Inc(spr[1].PNum);
Drawsprite (1); DieMe:=true;
end
else begin
DieMe:=false;
if Lives>0 then begin
Dec(Lives); showLives;
spr[1].PNum:=1;
Drawsprite (1);
end
else InGame:=false;
end;
end;
end;
function getlongintTime:longint;
{Вернет системное время как longint}
var Hour,minute,second,sec100: word;
var k,r:longint;
begin
GetTime (Hour, minute, second, sec100);
k:=Hour; r:=k*360000;
k:=minute; Inc (r,k*6000);
k:=second; Inc(r,k*100);
Inc(r,sec100); getlongintTime:=r;
end;
procedure Delay (ms:word);
var endTime,curTime : longint;
cor:boolean;
begin
cor:=false;
endTime:=getlongintTime + ms div 10;
if endTime>8639994 then cor:=true;
repeat
curTime:=getlongintTime;
if cor=true then begin
if curTime<360000 then
Inc (curTime,8639994);
end;
until curTime>endTime;
end;
label 10,20;
begin
randomize; InitAll; InGame:=false;
start;
settextstyle (DefaultFont,HorizDir,1);
settextjustify (Lefttext,toptext);
Loadsprites;
currentBottom:=200; currentshoots:=50;
Lives:=3; score:=0; Level:=1;
shootsProbability:=5;
currentsprites:=5;
10:
DrawField;
if Level>1 then begin
str(Level-1,s);
Help ('cool, you''re complete level '+s);
end
else Help
('Let''s go! Kill them, invaders!');
repeat
if InGame then repeat
Enemiesstep;
if Enemies=0 then begin
Inc(score,100+Level*10);
if shootsProbability<100 then
Inc (shootsProbability);
if currentsprites<maxsprites then
Inc(currentsprites);
if currentBottom<maxy-10-4*height then
Inc(currentBottom,10);
currentshoots:=50;
Delay(1000);{Пауза перед след. уровнем}
Inc(Level);
goto 10;
end;
shootMovies;
if not InGame then begin
Help ('sorry, you''re dead');
end;
Timefunctions;
until keypressed;
ch:=readkey;
case ch of
SPACE:
if not DieMe and InGame then shoot;
#0: begin
ch:=readkey;
case ch of
F1: Help
('Sorry, there''s no help here :-)');
LEFT: if not DieMe and InGame
then GoLeft;
RIGHT: if not DieMe and InGame
then GoRight;
UP: if not DieMe and InGame
then shoot;
end;
end;
end;
until ch=ESC;
closeAll;
end.
 гостевая; E-mail
|
