HOME ПРИМЕРЫ THANKS НОВИЧКАМ ДОКИ LINKS JavaScript Mail


 
В этот день много лет назад...
19 марта. В 1474 году (550 лет назад) - В Венеции принимается закон об охране изобретений - первый в мире закон об охране авторского права.
 
 

Turbo Pascal Examples

Графика:
Построение графика функции
Прыгающий по экрану мячик.
Качание маятника.
Вложенные цветные круги.
Броуновское движение. Использование объектов.
Матрицы и массивы:
Сортировка элементов массива.
Удаление одинаковых элементов.
Простой пример на поворот матрицы.
Сортировка методом Шелла. +функции измерения временных интервалов.
Проверка выпуклости многоугольника.
Перемоножение матриц
Вычисление определителя матрицы. Рекурсия.
Нахождение обратной матрицы.
Задача об автостоянке.
Рекурсия. Подземелье сокровищ.
Численные методы:
Задачка на определение угла между стрелками часов.
Проверка на принадлежность точки многоугольнику.
Нахождение точки пересечения двух отрезков на плоскости.
Сортировка методом Шелла. +функции измерения временных интервалов.
Сортировка методом "пузырька". Пример на динамические структуры данных. Связанные списки.
Нахождение корня функции методом половинного деления.
Вычисление арккосинуса
Нахождение суммы цифр натурального числа.
Работа с фалами:
Рекурсивное сканирование директорий.
Работа со строками:
Работа со словами в предложении с разделителями.
Простейший синтаксический анализатор для распознавания и вычисления многчлена.
Синтаксический анализатор для распознавания и вычисления многчлена.
Работа со строками: смена кодировки, удаление тегов из HTML текста, обработка
Переименование файлов из кириллицы в латиницу.
Выдача контекстной подсказки.
Частотный словарь символов.
Подсчет повторяющихся символов в строке.
Ссылочные переменные:
Моделирование стека.
Пасьянс "Косынка".
Игры:
Пасьянс "Косынка".
Игра "Питон"
Игра "Анацефал". Пример использования объектов.
Игра "Минное поле"
Большие проекты:
Электронная картотека (без исходника)


 Пример первый.

Вы когда-нибудь пользовались записной книжкой? Когда-то давным-давно мне пришлось создавать базу данных. А поскольку никаких доступных СУБД (систем управления базами данных) тогда еще не было, то мне пришлось создавать базу на Паскале. Говоря "доступных" я имею в виду такие СУБД, которые бы позволяли работать с базой не только администраторам, но и рядовым пользователям, причем с практически нулевым знанием ПК.

И вот я стал создавать свою программу-СУБД с "дружественным" интерфейсом. Поначалу программа работала только на того заказчика, для которого я ее писал, но потом я понял, что не слишком сильным её усложнением, можно достичь достаточной универсальности, и я сделал из нее программу "Электронная картотека". Конечно, я не смею ее даже сравнивать с сегодняшними монстрами управления базами данных, но рассматривать её как пример программы на Паскале вполне уместно. В конечном виде она имела свыше 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.

 

 

 

 

 

 

 


HOME