Пример первый.
Вы когда-нибудь пользовались записной книжкой?
Когда-то давным-давно мне пришлось создавать базу
данных. А поскольку никаких доступных СУБД (систем
управления базами данных) тогда еще не было, то мне
пришлось создавать базу на Паскале. Говоря "доступных"
я имею в виду такие СУБД, которые бы позволяли работать
с базой не только администраторам, но и рядовым
пользователям, причем с практически нулевым знанием ПК.
И вот я стал создавать свою программу-СУБД с "дружественным"
интерфейсом. Поначалу программа работала только на того
заказчика, для которого я ее писал, но потом я понял,
что не слишком сильным её усложнением, можно достичь достаточной
универсальности, и я сделал из нее программу "Электронная картотека".
Конечно, я не смею ее даже сравнивать с сегодняшними монстрами
управления базами данных, но рассматривать её как пример
программы на Паскале вполне уместно. В конечном виде она имела свыше
7500 строк текста которые располагались в 20 tpu-модулях.
Если вам интересно, вы можете посмотреть, как она работает скачав ее
отсюда.
Запустив ее вы
попадете в основное меню. Первое что нужно сделать, это выбрать
"рабочую карту", т. е. Картотеку, с которой вы хотите работать.
В качестрве примера приведены две картотеки: телефонная записная книжка
и каталог моих видеофильмов. Вы можете изменять, дополнять данные базы.
Обратите внимание, что телефонная база данных защищена паролем (hello).
Когда вы набираете пароль, то обрабатываются только последние символы,
которые вы ввели. Так, например, в данном случае обрабатываются только
последние 5 символов и верным паролем будет также и anythinghello.
Когда "рабочая карта" выбрана, можно выбрать "просмотр образцов".
Вы увидите список карточек находящихся в данный момент в картотеке.
По Enter можно просматривать содержимое каждой карточки, выводить ее на
принтер (F5), заносить в текстовый файл (F6) и т. д.
Вы можете делать с данными следующие операции: добавлять, удалять,
редактировать, фильтровать (до 6 уровней), распечатывать, создавать
отчеты (списки), экспортировать в dbf и импортировать из dbf формата.
При наборе текста можно использовать ранее введенные слова и фразы
(F1, Shift-F1, Alt-F3, Alt-F4, Alt-F5, Alt-F6).
Пример второй.
Вычисление аркосинуса функции. При вычислении использовалась формула:
tg(a)*tg(a) = 1/(cos(a)*cos(a)) - 1
Функция арктангенса присутствует в Турбо-Паскале: ArcTan. Через нее и
выражается искомый арккосинус. Единственное, что необходимо отметить, что
выдаваемое значение лежит в пределах от 0 до Pi. Если известно, что значение
лежит в другом диапазоне (например, от Pi до 2*Pi), то необходимо применить
сдвиг (в указанном случае: rs= 2*Pi - r, где r - полученное значение, rs -
значение со сдвигом).
var ca,al,albeg: real;
function ArcCos(arg:real):real;
{ Returns the value from 0 to Pi }
var r:real;
begin
if (abs(arg)>1) then
begin
writeln(' Unavailable argument ');
halt;
end;
if abs(arg)<0.000001
then r := pi/2
else r := ArcTan(sqrt(1/arg/arg-1)); { arccos }
if arg<0 then r:=pi-r;
ArcCos := r;
end;
begin
albeg:=pi/2+0.2;
ca := cos(albeg);
al := arccos(ca);
writeln('ArcCos(',ca:10:7,')=',al:10:7,' AlBeg=',albeg:10:7,
' ChekSum =',al-albeg,' Must be sero');
end.
Пример третий.
Устали? Давайте поиграем. Играть в собственноручно написанные игры всегда
приятней - вы в любой момент можете изменить условия игры! Итак, простейшая
игра - "питон". Правила просты: надо бегать по полю, засеянному капустой и
пожирать ее. При каждом съеденном качане длина вашего питона увеличивается
на единицу. Натыкаться на стены (границы экрана) нельзя. Нельзя также
натыкаться и на свой собственный хвост. Шрифт для экранной заставки лежит
здесь в текстовом виде, а здесь
в архиве вместе с текстом программы. Файл font.txt должен лежать в той же директории, что и
скомпилированная программа. Текст программы:
uses crt;
const
ScreenColor=#32;
PitColor =#79;
MaxLen =600;
Kapusta =200;
type
lettype='A'..'Z';
var
i,j,left,width,dx,dy:integer;
scr:array[1..25,1..80] of
record
ch,at:char;
end absolute $b800:0000;
Pitx,PitY:array[1..MaxLen] of byte;
ch:char;
x,y,CurrX,CurrY,PitLen,Pause,CurrK:word;
Quit:boolean;
St:string;
{===== Draw Message Block ===}
const
twodegree:array[0..8] of word=(1,2,4,8,16,32,64,128,256);
var
letters:array[lettype,1..7] of byte;
textfile:text;
l:char;
procedure drawletter(let:lettype;x,y:Shortint);
var i,j:word;
begin x:=x-6; y:=y-6;
for i:=1 to 7 do for j:=1 to 7 do
if (y+i-1>0) and (x+j-1>0) and (y+i-1<26) and (x+j-1<81) then
if letters[let,i] mod twodegree[8-j] div twodegree[7-j]=1 then
scr[y+i-1,x+j-1].at:=chr(64) else scr[y+i-1,x+j-1].at:=chr(48);
delay(20)
end;
procedure eraseletter(let:lettype;x,y:Shortint);
var i,j:word;
begin x:=x-6; y:=y-6;
for i:=1 to 7 do for j:=1 to 7 do
if (y+i-1>0) and (x+j-1>0) and (y+i-1<26) and (x+j-1<81) then
scr[y+i-1,x+j-1].at:=chr(48);
end;
procedure wrtmsg(s:string);
var i,l,b:word;
j:Shortint;
begin
l:=ord(s[0]);b:=(80-7*l) div 2;
for i:=1 to l do
begin
for j:=1 to 14 do
begin
drawletter(s[i],b+(i-1)*8,j);
eraseletter(s[i],b+(i-1)*8,j);
end;
drawletter(s[i],b+(i-1)*8,15);
end
end;
procedure DrawMessage(Msg:string);
var
s:integer;
begin
for i:=1 to 25 do
for j:=1 to 80 do
begin
scr[i,j].ch:=' ';
scr[i,j].at:=chr(48)
end;
assign(textfile,'font.txt');
{$I-}
reset(textfile);
{$I+}
if IOResult<>0 then
begin
writeln('Cann''t find file "font.txt" in current dir. Scipping output');
Delay(2000); exit;
end;
l:='A';j:=1;
while (not eof(textfile)) and (l<='Z') and (st[1]<>'E') do
begin
repeat readln(textfile,st) until (ord(st[0])>0) or eof(textfile);
s:=0;
for i:= 1 to 7 do if st[i]='*' then
s:=s+twodegree[7-i];
letters[l,j]:=s;j:=j+1;if j>=8 then begin l:=Succ(l);j:=1 end
end;
left:=5;
width:=9;
For i:=1 to Length(Msg) do Msg[i]:=UpCase(Msg[i]);
wrtmsg(msg);
end;
{============}
procedure InitWindow(x1,y1,x2,y2,WColor:word);
begin
Window(x1-1,y1-1,x2+1,y2+1);
TextAttr:=WColor;
ClrScr;
Window(1,1,80,25);
for i:=X1 to X2 do
begin
scr[Y1-1,i].ch:='-';
scr[Y2+1,i].ch:='-';
with scr[y2+2,i+1] do
begin
at:=chr(7);
if ord(ch) in [176..178] then ch:=' '
end
end;
for i:=Y1 to Y2 do
begin
scr[i,X1-1].ch:='¦';
scr[i,X2+1].ch:='¦';
with scr[i,X2+2] do
begin
at:=chr(7);
if ord(ch) in [176..178] then ch:=' '
end;
with scr[i,X2+3] do
begin
at:=chr(7);
if ord(ch) in [176..178] then ch:=' '
end
end;
scr[Y1-1,X1-1].ch:='-';scr[Y1-1,X2+1].ch:='¬';
scr[Y2+1,X1-1].ch:='L';scr[Y2+1,X2+1].ch:='-';
for i:=2 to 3 do for j:=1 to 2 do with scr[y2+j,X2+i] do
begin at:=chr(7);
if ord(ch) in [176..178] then ch:=' ' end;
end;
procedure Message(Msg:string);
var
l,lw,x,y,k,i,lm:word;
x1,y1,x2,y2:word;
MsgW:string;
begin
lm:=Length(Msg);
y:=lm div 60 + 1; { Размер окна по вертикали }
if y=1 then begin x:=(80-lm) div 2; lw:=lm end
else begin x:=10; lw:=60 end;
x1:=x-1; y1:=7;
x2:=x+lw; y2:=6+y;
InitWindow(x1,y1,x2,y2,16*4+15);
l:=1;
while lw>0 do
begin
MsgW:=copy(Msg,1,lw);
k:=Length(MsgW);
if (lm>58) and (k<58) then
for i:=1 to (60-k) div 2 do MsgW:=' '+MsgW;
MsgW:=' '+MsgW;
if k < X2-X1+1 then
for i:=1+Length(MsgW) to X2-X1+2 do MsgW:=MsgW+' ';
for i:=x1 to x2 do
scr[L+y1-1,i].ch:=MsgW[i-X1+1];
inc(l); Delete(Msg,1,lw);
lw:=Length(Msg);if Lw>60 then Lw:=60;
end;
end;
{=====================}
Procedure PutPit(Color:char);
begin
for i:=1 to PitLen do
begin
Scr[ord(Pity[i]),ord(PitX[i])].at:=Color;
end
end;
Procedure MovPit;
var st:string;
begin
scr[PitY[PitLen],PitX[PitLen]].at:=ScreenColor;
scr[CurrY,CurrX].at:=PitColor;
for i:=PitLen downto 2 do
begin
PitX[i]:=PitX[i-1];
PitY[i]:=PitY[i-1]
end;
PitX[1]:=CurrX;
PitY[1]:=CurrY
end;
Procedure StepPit;
begin
CurrX:=CurrX+dx;
CurrY:=CurrY+dy;
if (CurrX>80) or (CurrX<1) or (CurrY>25) or (CurrY<1) then
begin
Str(PitLen,st);
Message('Вы попеpхнулись забоpом! Ваша длина '+st);
halt
end;
if (Scr[CurrY,CurrX].at=PitColor) then
begin
Str(PitLen,st);
Message('Нельзя быть таким жадным! Ваша длина '+st);
halt
end;
if Scr[CurrY,CurrX].ch='-' then
begin
Scr[CurrY,CurrX].ch:=' ';
Scr[CurrY,CurrX].at:=PitColor;
Inc(PitLen);Dec(CurrK);Quit:=Currk=0;
for i:=PitLen downto 2 do
begin
PitX[i]:=PitX[i-1];
PitY[i]:=PitY[i-1]
end;
PitX[1]:=CurrX;
PitY[1]:=CurrY
end
else MovPit;
if dx<>0 then delay(Pause) else Delay(Pause*2);
end;
begin
DrawMessage('Piton');
GotoXY(20,20);
TextAttr:=48;
Write(' Питон пpоснулся голодным ...');
delay(12000);
for i:=1 to 25 do for j:=1 to 80 do scr[i,j].at:=ScreenColor;
for i:=1 to 25 do for j:=1 to 80 do scr[i,j].ch:=' ';
Randomize;
CurrK:=Kapusta;
repeat
x:=Random(80);
y:=Random(25);
if Scr[y,x].ch<>'-' then
begin
Scr[y,x].ch:='-';
Dec(CurrK)
end
until Currk=0;
CurrK:=Kapusta;
PitLen:=1;CurrX:=1;CurrY:=12;dx:=1;dy:=0;Pause:=1200;
PitX[1]:=CurrX;
PitY[1]:=CurrY;
For i:=1 to PitLen do
begin
PitX[i]:=CurrX-i+1;
PitY[i]:=CurrY;
end;
PutPit(PitColor);
Quit:=false;
repeat
if KeyPressed then
begin
scr[CurrY,CurrX].at:=ScreenColor;
ch:=readkey;
case ord(ch) of
0: begin
ch:=readkey;
case ord(ch) of
{ < } 75:
if dx<>1 then
begin
dx:=-1;dy:=0;
end;
{ > } 77:
if dx<>-1 then
begin
dx:=1;dy:=0;
end;
{ V } 80:
if dy<>-1 then
begin
dx:=0;dy:=1;
end;
{ ^ } 72:
if dy<>1 then
begin
dx:=0;dy:=-1;
end;
end;{ case }
end;
13: Quit:=true;
27:
begin
halt
end;
else { Нажата буквенно-цифровая клавиша }
end;{ case }
scr[CurrY,CurrX].at:=PitColor;
StepPit;
end{ if KeyPressed }
else StepPit;
until Quit;
if CurrK=0 then Message(' Поздpавляем! А тепеpь можно и поспать!');
end.
|
