Mail

В этот день много лет назад...
25 апреля. В 1908 году (116 лет назад) - Крупнейшее московское наводнение.

Turbo Pascal Examples

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

Выдача контекстной подсказки.

Лирическое отступление.
История написания этой программы на расстоянии кажется забаной. Это была первая безуспешная попытка заработать деньги собственным умом. :-)
Написана была под новый год в начале 90-х. Я тогда первый год преподавал программирование и вычмат в Политехе. Пришел от знакомых человек, которому была нужна лаба. Сговорились на бутылку шампанского, которое тогда стоило от 30 до 50 рублей (еще старых советских). Программу я написал, отдал и объяснил как работает, а вот ни Шампанского, ни денег не дождался. Очень было обидно. Но зато программа осталась.

Задача сводится к написанию системы выдачи контестной подсказки, наподобие той, что работает в стандартном борландовском турбо паскале - чтобы любое слово в статье подсказки могло служить "ссылкой" на другую статью (такое слово будем называть Ключевым). Файл подсказок (hlp-файл) является текстовым и его можно легко редактировать. Каждая статья начинается с ее номера заключенного в знаки #, например ###2#. А чтобы создать ссылку внутри статьи достаточно заключить слово или фразу в те же # с двух сторон и в конце добавить номер статьи, на который должен быть осуществлен переход, например: #слово#21#. Вот собственно и все. Программа позволяет менять цвета вывода ключевых слов и типа рамки. Текст программы ниже. Единственное - символы псевдографики отображаются в веб-кодировках неверно. Вариант программы для компиляции вместе с примером hlp-файла лежит здесь.

uses Crt;
const MaxNumberStrings=5;
      MaxLenSt=60;
      HelpColorConst={3*16+1}48;
      KeyWordColorConst=58;
type HelpType=record
       St:array[1..MaxNumberStrings] of String[MaxLenSt];
       NS:byte
       end;
     PStack=^StackHelpType; { Для организации стека окон меню }
     StackHelpType=record
       Num,PosX,PosY:byte;
       Next:PStack
       end;
     ScrPtr=array[1..25,1..80] of
     record   ch,at:char; end;
     WindowObj=object
       x1,y1,x2,y2,ValWindow:byte; { ValWindow - Высота окна(количесто строк)}
       WindowColor:char;
       WindowScrBufer:array[1..25,1..80,1..2] of char;
       Procedure SetXY(InitX1,InitY1,InitX2,InitY2:byte);
       Procedure SetWindowColor(Color:byte);
       Procedure InitWindow;
       Procedure WriteXY(PosNum:byte;St:string);
       Procedure HideWindow;
       end;
var scr:^ScrPtr; p:^byte;
    CurFrame:String[11]; Frame:array[1..6] of String[11]; { типы рамки }
procedure MainWindow; begin Window(1,1,80,25) end;
{ *************************************************************** }
{      Секция описания правил для об'екта типа WindowObj          }
{ *************************************************************** }
procedure WindowObj.SetXY(InitX1,InitY1,InitX2,InitY2:byte);
  begin
  if InitX1>= 2 then X1:=InitX1+1  else X1:=3;
  if InitY1>= 2 then Y1:=InitY1+1  else Y1:=3;
  if InitX2<=78 then X2:=InitX2-1  else X2:=77;
  if InitY2<=24 then Y2:=InitY2-1  else Y2:=23;
  end;
procedure WindowObj.SetWindowColor(Color:byte);
  begin  WindowColor:=chr(color) end;
procedure WindowObj.InitWindow;
var i,j:word;
  begin
  { Запомнить окно в буфер }
  for i:=x1-1 to x2+3 do
  for j:=y1-1 to y2+2 do with scr^[j,i] do
    begin WindowScrBufer[j,i,1]:=ch; WindowScrBufer[j,i,2]:=at end;
  Window(x1-1,y1-1,x2+1,y2+1); TextAttr:=ord(windowcolor); ClrScr; MainWindow;
  for i:=X1 to X2 do
    begin
    scr^[Y1-1,i].ch:=CurFrame[11];  scr^[Y2+1,i].ch:=CurFrame[11];
    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:=CurFrame[10];  scr^[i,X2+1].ch:=CurFrame[10];
    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:=CurFrame[1];scr^[Y1-1,X2+1].ch:=CurFrame[3];
  scr^[Y2+1,X1-1].ch:=CurFrame[7];scr^[Y2+1,X2+1].ch:=CurFrame[9];
  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;
  ValWindow:=Y2-Y1+1;
  end;
procedure WindowObj.WriteXY(PosNum:byte;St:string);
var l:byte;
  begin
  if PosNum<1 then PosNum:=1;
  if PosNum>ValWindow then PosNum:=ValWindow;
  if Length(st)< X2-X1+1 then
  for l:=1+Length(st) to X2-X1+2 do st:=st+' ';
  for l:=x1 to x2 do with scr^[PosNum+y1-1,l] do
    begin ch:=st[l-X1+1]; at:=WindowColor end
  end;
Procedure WindowObj.HideWindow;
var i,j:byte;
  begin { Восстановление окна }
  for i:=x1-1 to x2+3 do
  for j:=y1-1 to y2+2 do with scr^[j,i] do
    begin ch:=WindowScrBufer[j,i,1]; at:=WindowScrBufer[j,i,2] end;
  end;
{ ************************************************** }

var WHelp,WInfo:WindowObj;
    NameHelpFile,StH:String;
    f:text;
    i,j,HelpColor,KeyWordColor:byte;
    ch:Char;
    CurHlp:HelpType;
    helps:array[1..20] of { массив ключевых слов данной подсказки }
      record
        N:byte;  { Номер подсказки ключевого слова }
        y,xb,xe:byte; { Диапазон координат на экране }
      end;
    HN:byte; { Число ключевых слов }
    CurW:PStack; { указатель на текущую подсказку }

function AskFile(f:string):boolean;
var fl:file of byte;
begin
{$I-} Assign(fl,f); Reset(fl); Close(fl); {$I+}
AskFile:=(IOResult=0);
end;  { AskFile }
Function CenterString(St:String;Width:byte;Ch:Char):String;
{ Располагает строку по центру поля шириной Width, по краям символы Ch }
{ Если длина строки больше Width она обрезается }
  begin
  while Pos(' ',St)=1 do Delete(St,1,1);
  while St[Length(st)]=' ' do Dec(St[0]);
  while Length(St)   CenterString:=Copy(St,1,Width)
  end;
Procedure FullScreen;
var i,j:byte;
  begin
  for i:=1 to 25 do for j:=1 to 80 do with scr^[i,j] do
    begin ch:='-'; at:=chr(19); end;
  end;
Procedure GetHelpNum(Num:byte);
{ Считывает из файла подсказку с номером Num в CurHlp }
var NumSt,StH:String[80];
  begin
  Reset(f);
  Str(Num:1,NumSt);StH:='rrr';
  NumSt:='###'+NumSt+'#';
  while not eof(f) and (Pos(NumSt,StH)=0) do Readln(f,StH);
  if Pos(NumSt,StH)=0 then with CurHlp do
    begin
    NS:=1; St[1]:='Нет такой подсказки в файле '+NameHelpFile;
    close(f); exit
    end; CurHlp.NS:=0; StH:='rrr';
  with CurHlp do While not eof(F) and (Pos('###',StH)=0) and
    (NS     Readln(f,StH);
    if Pos('###',StH)=0 then begin Inc(NS);St[NS]:=StH end
    end;
  Close(f);
  end;
Procedure OutHelp;
  procedure Error;
    begin clrscr;writeln('Ошибочный формат .hlp файла');halt end;
var i,j,k,n,sn:byte; cd:integer; StH,NumSt:String;
    keywords:array[1..6,1..2] of byte;
    WrP:PStack;
  begin
  with WHelp do with CurHlp do
    begin
    SetXY(10,7,71,8+NS);  SetWindowColor(HelpColor);
    InitWindow; n:=0; hn:=0; with CurW^ do GotoXY(PosX,PosY);
    for i:=1 to NS do
      begin
      StH:=St[i]; Sth:=CenterString(StH,60,' '); k:=Pos('#',StH);
      sn:=hn; n:=0;
      while k<>0 do
        begin
        For j:=sn+1 to sn+n do with Helps[j] do
          begin inc(xb,2); inc(xe,2) end;
        Inc(n); Delete(StH,k,1);  inc(HN); Insert('  ',StH,1); Inc(k,2);
        Helps[hn].xb:=x1+k-1;
        Helps[hn].y:=y1+i-1;
        k:=Pos('#',StH);
        Helps[hn].xe:=x1+k-2; if k=0 then Error;
        NumSt:=Copy(StH,k+1,2); if NumSt[2]='#' then Dec(NumSt[0]);
        Val(NumSt,Helps[hn].n,cd); if cd<>0 then Error;
        Delete(Sth,k,3);
        if Sth[k]='#' then Delete(Sth,k,1); { двузначное число }
        k:=Pos('#',StH);
        end;
      writeXY(i,StH);
      if n>0 then for j:=sn+1 to sn+n do with Helps[j] do
        for k:=xb to xe do
          with scr^[y1+i-1,k] do begin at:=chr(KeyWordColor) end
      end
    end;
  end;
Function GetNumFromWindow:byte;
{ Возвращает номер подсказки на которую указывает курсор }
var i,j,n:byte; Quit:Boolean;
  begin
  GetNumFromWindow:=0; i:=0; if HN<1 then exit; Quit:=False;
  j:=WhereX;
  repeat
    inc(i);
    with Helps[i] do
      if (WhereY=y) and (xb<=j) and (j<=xe) then Quit:=true;
  until (i=HN) or Quit;
  if Quit then GetNumFromWindow:=Helps[i].n;
  end;
Procedure PutInStack(Num:byte);
{ Заносит в стек номер страницы подсказки }
var Wr:PStack;
  begin
  New(Wr);
  Wr^.Next:=CurW;
  CurW^.PosX:=WhereX;  CurW^.PosY:=WhereY;
  CurW:=Wr;
  CurW^.Num:=Num;
  with WHelp do
    begin  CurW^.PosX:=X1;  CurW^.PosY:=Y1;  end;
  end;
Procedure DelFromStack; { Удаляет вершину стека }
var Wr:PStack;
  begin
  if CurW^.Next=nil then exit; { Нижний (первый) элемент стека не удалять }
  Wr:=CurW;
  CurW:=CurW^.Next; { Текущий указатель перевести на следующий за вершиной
  стека элемент }
  Dispose(Wr)
  end;
Procedure WriteHelpString(StH:String);
var i:byte;
  begin
  for i:=1 to 80 do with Scr^[25,i] do if i<=Length(StH) then
    begin ch:=StH[i]; if ch in ['А'..'п','р'..'ё','-']
      then at:=#112 else at:=#116 end
    else begin ch:=' ';at:=#112 end
  end;
Procedure OnLineHelp(Last:boolean);
var ch:char;
  begin
  if Last then GetHelpNum(CurW^.Num) else begin
    if CurW^.Num<>1 then PutInStack(1);
    GetHelpNum(1)
    end;
  OutHelp;
  repeat
    WriteHelpString('Alt-F1 Прошлая подсказка '#24','#25','#26','#27' -выбор '
    +'и '#17+'- просмотр ключевого слова ESC-выход');
    ch:=ReadKey; if Ch=#0 then Ch:=ReadKey;
    case ch of
    #77: if WhereX<80 then GotoXY(WhereX+1,WhereY) else GotoXY( 1,WhereY);
    #75: if WhereX>1  then GotoXY(WhereX-1,WhereY) else GotoXY(80,WhereY);
    #80: if WhereY<25 then GotoXY(WhereX,WhereY+1) else GotoXY(WhereX,1);
    #72: if WhereY>1  then GotoXY(WhereX,WhereY-1) else GotoXY(WhereX,25);
    #13: begin  { нажата клавиша ENTER }
i:=GetNumFromWindow;
if i<>0 then begin
   if CurW^.Num<>i then PutInStack(i);
   GetHelpNum(i);
   WHelp.HideWindow;
   OutHelp
   end
end;
    #104: begin { Alt-F1 pressed }
          DelFromStack;
          GetHelpNum(CurW^.Num);
          WHelp.HideWindow;
          OutHelp
  end;
    #116: begin { Ctrl-LeftArrow pressed }
          with Whelp do if (WhereX in [x1..x2]) and (WhereY in [y1..y2]) then
    if scr^[WhereY,WhereX].ch=' ' then
      while scr^[WhereY,WhereX].ch=' ' do GotoXY(WhereX+1,WhereY) else
      begin
      while scr^[WhereY,WhereX].ch<>' ' do GotoXY(WhereX+1,WhereY);
      while scr^[WhereY,WhereX].ch=' ' do GotoXY(WhereX+1,WhereY);
              end
          end;
    #115: begin { Ctrl-RightArrow pressed }
  with Whelp do if (WhereX in [x1..x2]) and (WhereY in [y1..y2]) then
    if scr^[WhereY,WhereX].ch=' ' then
      while scr^[WhereY,WhereX].ch=' ' do GotoXY(WhereX-1,WhereY) else
      begin
      while scr^[WhereY,WhereX].ch<>' ' do GotoXY(WhereX-1,WhereY);
      while scr^[WhereY,WhereX].ch=' ' do GotoXY(WhereX-1,WhereY);
              end
          end;
    #71:  GotoXY(WHelp.x1,WhereY); { Home pressed }
    #79:  GotoXY(WHelp.x2,WhereY); { End  pressed }
      end; { case }
  until ch=#27;
  WHelp.HideWindow;
  end;
begin
NameHelpFile:='Data.hlp';
if not AskFile(NameHelpFile) then
  begin writeln(' Не найден файл ',NameHelpFile);halt end;
Assign(f,NameHelpFile);
p:=Ptr($40, $49); { Адрес байта, хранящего текущую моду (режим экрана) }
if p^=7 then Scr:=Ptr($b000,0) else Scr:=Ptr($b800,0);
Frame[1]:='-T¬+++L+-¦-';  Frame[2]:='гT¬¦+¦L¦-¦=';  Frame[3]:='гT¬¦+¦L¦-¦-';
Frame[4]:='-T¬¦+¦L¦-¦=';  Frame[5]:='+++++++++!-';  Frame[6]:='           ';
CurFrame:=Frame[1];
New(CurW);CurW^.Num:=1;CurW^.Next:=nil;clrscr;
CurW^.PosX:=WhereX; CurW^.PosY:=WhereY;
FullScreen;HelpColor:=HelpColorConst;KeyWordColor:=KeyWordColorConst;
with WInfo do
  begin
  SetXY(15,5,65,20);
  SetWindowColor(7*16+1);
  InitWindow;
  writeXY(3,'       Это основное окно программы. Здесь ');
  writeXY(4,'     должны выполняться некоторые действия. ');
  writeXY(5,'       Для просмотра подсказки нажмите F1. ');
  writeXY(12,'         Для завершения нажмите ESC. ');
  end;
repeat
  WriteHelpString('F1 Подсказка Alt-F1 Прошлая подсказка C,K-смена цветов '+
  'T-смена рамок ESC-выход');
  ch:=ReadKey; if Ch=#0 then Ch:=ReadKey; TextAttr:=ord(WInfo.WindowColor);
  case ch of
  ';' :OnLineHelp(False);
  #104:OnLineHelp(True);
  'c','C': with WInfo do begin
writeXY(7,'Введите номер аттрибута экрана [0..255]  ');
GotoXY(40+x1,y1+6);readln(HelpColor);
writeXY(7,'');
end;
  'k','K': with WInfo do begin
writeXY(7,'Введите номер цвета ключевого слова [0..255]  ');
GotoXY(45+x1,y1+6);readln(KeyWordColor);
writeXY(7,'');
end;
  't','T': with WInfo do begin
writeXY(7,'Введите номер рамки [1..6]               ');
GotoXY(28+x1,y1+6);readln(i);
if i in [1..6] then CurFrame:=Frame[i];
writeXY(7,'');
end;
    end; { case }
until ch=#27;
WHelp.HideWindow;
end.