Turbo Pascal Examples

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


 Пример четвертый.

Вам никогда не приходилось извлекать текст из HTML-документа? Если да, то возможно вам знакомы проблемы переформатирования текста. При обработке большого объема однообразной информации, легче написать небольшую программку, которая сделает за вас "черную работу".
В приведенном ниже примере решается следующая задача.
Есть HTML-файл (1220.htm), в котором находится особым образом оформленная информация, разбитая на блоки. Каждый блок представляет из себя некое историческое событие (понятно, для примера, реально может быть все что угодно) описанное в одной или более строках HTML документа. Блок текста, относящийся к одному событию, начинается с номера года, заключенного в тег <strong>, например: <strong>1658</strong>, а заканчивается с началом следующего (такого же) блока. Встречающиеся в тексте фамилии выделены ПРОПИСНЫМИ буквами. Необходимо из этого HTML-файла сформировать текстовый файл, содержащий список событий, отформатированный согласно правилам обарботки (см. ниже), и содержащий только те события, в тексте которых встречается заданное ключевое слово (в примере "амолет").

Правила обработки таковы:

1. Удаляются все HTML-теги и информация данная внутри квадратных скобок (вместе со скобками)
2. Фамилии преобразуются из прописных в строчные с прописной. ПЕТРОВ==>Петров.
3. Текст должен быть оформлен в выходном файле в виде одной строки, начинающейся с даты, заданной в формате ГГГГ-ММ-ДД (год, месяц, день). День и месяц определяются по имени входного файла (20 декабря - "-12-20"). Дата и текст к ней относящийся должны быть разделены знаком табуляции.

uses Dos;
const MaxSN=220;
var f,event:text; { Входной и выходной файлы }
    s1,s_win,s_dos:string; { s_win,s_dos строки для перекодировки WIN<=>DOS }
    s2:array[1..MaxSN] of string; { Массив, в котором хранится блок текста (несколько строк) }
{ Правильнее было бы конечно организовать связанный список, но для упрощения используется массив }
    i,k2:byte;
    q:boolean;
    search_st,st:string;
    date,delim:string[20]; { delim содержит список разделителей слов }
    d,er_code:integer;
    s_u,s_l:string; { строки для перевода в верхний/нижний регистры }
function Win2Dos(s:string):string;
{ Конвертируем из кодировки Windows в кодировку DOS }
var
  sr:string;
  i,k,L:byte;
  begin
  L:=Length(s);sr:=s;
  for i:=1 to L do
    begin
    k:=pos(s[i],s_win);
    if (k>0) then sr[i]:=s_dos[k]
             else sr[i]:=s[i];
    end;
  Win2Dos:=sr;
  end;
function Dos2Win(s:string):string;
{ Конвертируем из кодировки DOS в кодировку Windows }
var
  sr:string;
  i,k,L:byte;
  begin
  L:=Length(s);sr:=s;
  for i:=1 to L do
    begin
    k:=pos(s[i],s_dos);
    if (k>0) then sr[i]:=s_win[k]
             else sr[i]:=s[i];
    end;
  Dos2Win:=sr;
  end;
function DeleteFromString(patt,st:string):string;
{ Удаляет из строки st все вхождения patt }
var k:byte;
  begin
  k:=Pos(patt,st);
  while (k>0) do
    begin
    Delete(st,k,length(patt));
    k:=Pos(patt,st);
    end;
  DeleteFromString:=st;
  end;
function IsStartString(st:string):boolean;
{ Возвращает истину, если строка является первой строкой блока }
var q:boolean; k:byte;
    d,code:integer;
  begin
  k:=Pos('<strong>',st);
  q:=(k>0);
  if q then
    begin
    val(copy(st,k+8,2),d,code);
    q:=(code=0);
    end;
  IsStartString:=q;
  end;
function MyUpCase(ch:char):char;
{ Переводит символ из нижнего регистра в верхний. Отличается от стандартного обработкой кириллицы }
var k:byte;
  begin
  k:=Pos(ch,s_l);
  if (k>0) then MyUpCase:=s_u[k]
           else MyUpCase:=UpCase(ch);
  end;
function StUpCase(st:string):string;
{ Переводит строки из нижнего регистра в верхний. }
var L:byte absolute st;
    i:byte;
  begin
  for i:=1 to L do
    st[i]:=MyUpCase(st[i]);
  end;
function MyLowCase(ch:char):char;
{ Переводит символ из верхнего регистра в нижний. }
var k:byte;
  begin
  k:=Pos(ch,s_u);
  if (k>0) then MyLowCase:=s_l[k]
           else MyLowCase:=ch;
  end;
function StLowCase(st:string):string;
{ Переводит строку из верхнего регистра в нижний. }
var L:byte absolute st;
    i:byte;
  begin
  for i:=2 to L do
    st[i]:=MyLowCase(st[i]);
  StLowCase:=st;
  end;
function WordNotSpecial(w:string):boolean;
{ Обработка исключений. Для всех слов написанных прописными буквами происходит }
{ перевод в состояние "строчные с прописной". Для абревиатур этого делать не надо }
var RimNum:boolean;
    i:byte;
  begin
  RimNum:=true;
  for i:=1 to length(w) do
    if RimNum then RimNum:=(w[i] in ['I','V','X','L']);
  WordNotSpecial:=not RimNum and
  (w<>'ВГИК') and
  (w<>'ВКП') and
  (w<>'ВКПБ') and
  (w<>'ВЦИК') and
  (w<>'ГЭС') and
  (w<>'ЕЭС') and
  (w<>'КГБ') and
  (w<>'КНР') and
  (w<>'КПСС') and
  (w<>'НИИ') and
  (w<>'НКВД') and
  (w<>'ООН') and
  (w<>'РФ') and
  (w<>'РСФСР') and
  (w<>'СНГ') and
  (w<>'СНК') and
  (w<>'СССР') and
  (w<>'США') and
  (w<>'ФРГ') and
  (w<>'ЦИК') and
  (w<>'ЦК') and
  (w<>'ЭВМ')
  ;
  end;
function DoString(st:string):string;
{ Обработка строки. Выделяем слова, в случае, если встречается слово ПРОПИСНЫМИ буквами,
  заменяем его на слово с Прописной }
var w,wt,st_t:string;
    k:byte;
  function GetNextDelim(st:string):byte;
  { Получить следующий разделитель }
  var L:byte absolute delim;
      i,m,k:byte;
    begin
    m:=255; if (st='') then m:=0;
    for i:=1 to L do
      begin
      k:=Pos(delim[i],st);
      if (0<k) and (k<m) then m:=k;
      end;
    GetNextDelim:=m;
    end;
  begin
  k:=Pos('&nbsp;',st);
  while (k>0) do
    begin
    Delete(st,k,1);
    k:=Pos('&nbsp;',st);
    end;
  st_t:='';
  k:=GetNextDelim(st);
  if (k=255) then
    begin
    k:=0;
    st_t:=st_t+st;
    end;
  while (k>0) do
    begin
    w:=copy(st,1,k-1);
    wt:=StUpCase(w);
    if (wt=w) and WordNotSpecial(w)
      then st_t:=st_t+StLowCase(w)+st[k]
      else st_t:=st_t+w+st[k];
    Delete(st,1,k);
    k:=GetNextDelim(st);
    if (k=255) then
      begin
      k:=0;
      st_t:=st_t+st;
      end
    end;
  DoString:=st_t;
  end;
procedure DoFile(fname:string);
{ Обработка файла fname }
var sdat:string[20];
    st,head_st,foot_st:string;
    ks:byte absolute st;
    t_op,t_cl,TagOpen,BrOpen:byte;
    BlockEnd:boolean;
  procedure DelTagContent2(ch_op,ch_cl:char);
  { Удаление содержимого тегов. Удаляет от символа открывающего тег ch_op до }
  { символа закрывающего тег ch_cl. Несколько упрощенный вариант процедуры, предполагающий }
  { что не бывает ситуаций, когда внутри тега открывается еще один тег. }
  var TagCount,i,k,j:byte;
      Q:boolean;
    begin
    Q:=false;
    repeat
      i:=1;
      t_op:=Pos(ch_op,s2[i]);
      while (t_op=0) and (i<k2) do
        begin
        inc(i);
        t_op:=Pos(ch_op,s2[i]);
        end;
      if (t_op>0) then
        begin
        t_cl:=Pos(ch_cl,s2[i]);
        j:=i;
        while (j<=k2) and not (((i=j) and (t_cl>t_op)) or ((j>i) and (t_cl>0))) do
          begin
          inc(j);
          t_cl:=Pos(ch_cl,s2[j]);
          end;
        if (j<=k2)
          then if (i=j)
            then Delete(s2[i],t_op,t_cl-t_op+1)
            else {i               begin
              Delete(s2[i],t_op,255);
              Delete(s2[j],1,t_cl);
              for k:=i+1 to k2-j+1 do
                s2[k]:=s2[k+j];
              Dec(k2,j-i-1);
              end
          else Q:=true;
        end { if (t_op>0)... }
      else Q:=true;
    until Q;
    end;

  procedure DoBlock(foot_st:string);
  var warning:string[40];
    begin
    BlockEnd:=false;
    while (not eof(f) and not BlockEnd) do
      begin
      k2:=0; q:=false;
      { Читаем блок, пока снова не встретится первая строка}
      repeat
        { Занесение строки }
        inc(k2);
        if (k2>MaxSN) then BlockEnd:=true
        else
          begin
          s2[k2]:=s1;
          if not q then q:=(Pos(search_st,s1)>0);
          { Конец занесения строки }
          readln(f,s1);{ Читаем следующую строку и проверяем на конец блока }
          s1:=Win2Dos(s1);
          if not BlockEnd then BlockEnd:=(Pos(foot_st,s1)>0);
          end;
      until IsStartString(s1) or (eof(f)) or BlockEnd;
      if (k2>MaxSN) then
        begin
        writeln('Too big topic! truncated!');
        k2:=MaxSN; warning:='Too big topic! truncated!';
        end
      else warning:='';
      { Снова встретилась первая строка, обрабатываем строки массива }
      if q then { слово поиска нашлось в блоке }
        begin { Обрабатываем и записываем блок строк }
        DelTagContent2('<','>');
        DelTagContent2('[',']');
        for i:=1 to k2 do
          begin
          st:=s2[i];
          while (st[1]=' ') and (ks>0) do Delete(st,1,1);
          st:=DeleteFromString('&nbsp;',st);
          while (st[1]=' ') and (ks>0) do Delete(st,1,1);
          if (i=1) then
            begin
            date:=copy(st,1,4);
            val(date,d,er_code);
            if ((er_code=0) and (i=1)) then
              begin
              while (st[5]=' ') and (ks>5) do Delete(st,5,1);
              insert(sdat,st,5);
              end;
            end;
          while (st[ks]=' ') do Dec(ks);
          if (i<>k2) then st:=st+' ';
          st:=warning+DoString(st);

          write(event,st);

          warning:='';
          end;
        writeln(event);
        end; { конец записи блока строк }
      end; { прочитан конец блока событий }
    end;
  begin { начало процедуры DoFile }
  sdat:='-'+copy(fname,1,2)+'-'+copy(fname,3,2)+#9;
  assign(f,fname);
  reset(f);
  { Пропускаем все до заголовка событий }

  head_st:=Dos2Win('СОБЫТИЯ:');
  readln(f,s1);
  while (not eof(f)) and (Pos(head_st,s1)=0) do
    begin
    readln(f,s1);
    end;
  { Читаем строки до первой строки блока}
  s1:=Win2Dos(s1);
  while (not eof(f)) and (not IsStartString(s1)) do
    begin
    readln(f,s1);
    s1:=Win2Dos(s1);
    end;
  DoBlock('</html>');
  close(f);
  end;

begin { начало основной программы }

s_u:='АБВГДЕЁЖЗИЙКЛМНОПРСТУФХЦЧШЩЪЫЬЭЮЯABCDEFGHIJKLMNOPQRSTUVWXYZ';
s_l:='абвгдеёжзийклмнопрстуфхцчшщъыьэюяabcdefghijklmnopqrstuvwxyz';
delim:=' "''().,-'#9;
writeln('========');
assign(event,'event_file.txt');
rewrite(event);

search_st:='амолет';
DoFile('1220.htm');

close(event);
end.