Как найти строку в файле паскаль

Как найти строку в текстовом файле?

Рассмотрим простейший способ поиска строки в текстовом файле с помощью READLN и прямого сравнения строк, либо нахождения подстроки в строке.

var t:text; s,s1:string;
    count:word;
begin
  readln(s); { Вводим строку для поиска }
  assign(t,'text.txt');reset(t);
  s1:=''; count:=0;
  while not eof(t) and (s<>s1) do begin
    readln(t,s1); inc(count);
  end;
  writeln('искомая строка является ',count,' строкой в файле');
  close(t);
end.
 
{ Hайти подстроку (слово) }
var 
  t:text; 
  s,s1:string;
  count:word;
begin
  readln(s); {вводим подстроку}
  assign(t,'text.txt'); reset(t);
  s1:=''; count:=0;
  while not eof(t) and (pos(s,s1)=0) do begin
    readln(t,s1);
    inc(count);
  end;
  writeln('буквосочетание "',s,'" найдено в строке N ',count,':');
  writeln(s1);
  close(t);
end.

15. Процедуры и функции для работы с файлами

Ниже описываются процедуры и функции, которые можно использовать с файлами любого вида. Специфика работы с типизированными, текстовыми и нетипизированными файлами рассматривается в следующих разделах.
1. Процедура CLOSE закрывает файл, однако связь файловой переменной с именем файла, установленная ранее процедурой ASSIGN, сохраняется. Формат обращения:
Close (<ф.п>)

При создании нового или расширении старого файла процедура обеспечивает сохранение в файле всех новых записей и регистрацию файла в каталоге.
Функции процедуры CLOSE выполняются автоматически по отношению ко всем открытым файлам при нормальном завершении программы. Поскольку связь файла с файловой переменной сохраняется, файл можно повторно открыть без дополнительного использования процедуры ASSIGN.
2. Процедура RENAME. Переименовывает файл. Формат обращения:
RENAME (<ф.п.>, <новое имя»)
Здесь <новое имя> – строковое выражение, содержащее новое имя файла.
Перед выполнением процедуры необходимо закрыть файл, если он ранее был открыт процедурами RESET, REWRITE или APPEND.
Процедура ERASE. Уничтожает файл. Формат обращения: ERASE (<ф.п.>)
Перед выполнением процедуры необходимо закрыть файл, если он ранее был открыт процедурами RESET, REWRITE или APPEND.
Следующий фрагмент программы показывает, как можно использовать процедуры RENAME и CLOSE при работе с файлами. Предположим, что требуется отредактировать файл, имя которого содержит переменная NAME. Перед редактированием необходимо убедиться, что нужный файл имеется на диске, и переименовать его – заменить расширение этого файла на .ВАК (страховочная копия). Если файл с таким расширением уже существует, его надо стереть.
Var
F1 : text;
F0: text;
Name : String;
Name_Bak : String;
K, i :word;
Const
Bak = ‘.bak’;
……………

{Получить в Name_bak имя файла с расширением .bak:}

k:=pos (‘.’, name);
if k=0 then k:= length(name)+ 1;
name_bak := copy(name,1, k-1)+ bak;
{Проверить существование исходного файла:}
assign (f i , name);
{$1-}
reset(fi);
{Проверить существование BAK-файла:}
assign(f0, name_bak);
reset(f0);
{$1+}
if IOResult = 0 then
Begin {Файл Bak существует}

Close(f0);
Erase(f0)
End;
{Проверки закончены, подготовка к работе}

rename(fi, name_bak);
reset(fi);
assign(f0, name);
rewrite(f0);
………..

Проверка на существование ВAК-файла в данном примере необходима, так как обращение
rename(fi, name_bak);
вызовет ошибку в случае, если такой файл существует.
3. Процедура FLUSH. Очищает внутренний буфер файла и, таким образом, гарантирует сохранность всех последних изменений файла на ” диске. Формат обращения:
FLUSH(<ф.п>)
Любое обращение к файлу в Турбо Паскале осуществляется через некоторый буфер, что необходимо для согласования внутреннего представления файлового компонента (записи) с принятым в ДОС форматом ; хранения данных на диске. В ходе выполнения процедуры FLUSH все новые записи будут действительно записаны на диск. Процедура игнорируется, если файл был инициирован для чтения процедурой RESET.
4. Функция EOF (<ф.п.>) : BOOLEAN. Логическая функция, тестирующая конец файла. Возвращает TRUE, если файловый указатель стоит в конце файла. При записи это означает, что очередной компонент будет добавлен в конец файла, при чтении что файл исчерпан.
5. Процедура CHDIR. Изменение текущего каталога. Формат обращения:
CHDIR (<путь>)
Здесь <путь> – строковое выражение, содержащее путь к устанавливаемому по умолчанию каталогу.
6. Процедура GETDIR. Позволяет определить имя текущего каталога (каталога по умолчанию). Формат обращения:
MKDIR(<каталог>)
Здесь <каталог> – выражение типа STRING, задающее путь к каталогу. Последним именем в пути, т.е. именем вновь создаваемого каталога не может быть имя уже существующего каталога.
7. Процедура RMDIR. Удаляет каталог. Формат обращения:
RMDIR(<каталог>)
Удаляемый каталог должен быть пустым, т.е. не содержать файлов или имен каталогов нижнего уровня.
8. Функция IORESULT : WORD. Возвращает условный признак последней операции ввода-вывода.
Еcли операция завершилась успешно, функция возвращает ноль. Коды ошибочных операций ввода-вывода представлены в прил. З. Следует помнить, что IORESULT становится доступной только при отключенном автоконтроле ошибок ввода-вывода.
Директива компилятора {$!-} отключает, а директива {$!+} включает автоконтроль. Если автоконтроль отключен, а операция ввода-вывода привела к возникновению ошибки, устанавливается флаг ошибки и все последующие обращения к вводу-выводу блокируются, пока не будет вызвана функция IORESULT.
Ряд полезных файловых процедур и функций становится доступным при использовании библиотечного модуля DOS.TPU, входящего в стандартную библиотеку TURBO.TPL . Эти процедуры и функции указаны ниже. Доступ к ним возможен только после объявления USES DOS в начале программы (подробнее о работе с модулями см. гл.9).
9. Функция DISKFREE (<диск>) : LONGINT. Возвращает объем в байтах свободного пространства на указанном диске. При обращении к функции выражение <диск> типа BYTE определяет номер диска: 0 -устройство по умолчанию, 1 – диск А, 2 – диск В и т.д. Функция возвращает значение -1, если указан номер несуществующего диска.
10. Функция DISKSIZE (<диск>) : LONGINT. Возвращает полный объем диска в байтах или -1 , если указан номер несуществующего диска.
11. Процедура FINDFIRST. Возвращает атрибуты первого из файлов, зарегистрированных в указанном каталоге. Формат обращения: FINDFIRST (<маска>, <атрибуты>, <имя>)
Здесь <маска> – строковое выражение, содержащее маску файла;
<атрибуты> – выражение типа BYTE, содержащее уточнение к маске (атрибуты);
<имя> – переменная типа SEARCHREC, в которой будет возвращено имя файла.
При формировании маски файла используются следующие символы-заменители ДОС:
• означает, что на месте этого символа может стоять сколько угодно (в том числе ноль)
• разрешенных символов имени или расширения файла;
• означает, что на месте этого символа может стоять один из разрешенных символов.

Например:

*.* – выбирает все файлы из каталога;
с*.* – выбирает все файлы с именами, начинающимися на c(c1.pas, сс12345, c.dat и т.д.);
a?.dat – выбирает имена файлов типа a0.dat, az.dat и т.д.
Маске может предшествовать путь. Например, команда

c:dirsubdir*. Pas
означает выбирать все файлы с расширением .PAS из каталога SUBDIR, находящегося на диске С; каталог SU3DJR зарегистрирован в каталоге верхнего уровня DIR, который, в свою очередь, входит в корневой каталог.
Байт <атрибуты> содержит двоичные разряды (биты), уточняющие, к каким именно файлам разрешен доступ при обращении к процедуре FINDFIRST . Вот как объявляются файловые атрибуты в модуле DOS. TPU
Const

ReadOnly = $01; {только чтение}
Hidden = $02; {скрытый файл}
SysFile = $04; {системный файл}
VolumeID = $08 {идентификатор тома}
Direcfory = $10 {имя подкаталога}
Archive = $20 {Архивный файл}
AnyFile = $3F {любой файл}
Комбинацией бит в этом байте можно указывать самые разные варианты, например $06 – выбирать все скрытые и/или системные файлы.
Результат работы процедуры FINDFIRST возвращается в переменной типа SEARCHREC. Этот тип в модуле DOS. TPU определяется следующим образом

Type
SerchRec = record
Fill : array [1..21] of byte;
Attr : byte ;
Time : longint;
Size : longint;
Name : String [12]
End;
Здесь Attr – атрибуты файла (см. выше);
Time – время создания или последнего обновление файла; возвращается в упакованном формате; распаковать параметр можно процедурой VNPACKTIME (см.ниже);
Size – длина файла в байтах
Name – имя и расширение файла.
Для распаковки параметра TIME используется процедура NPACKTJME(Time:longint; var T:DateTime). В модуле DOS.TPU объявлен cедующий тип:

Type
DateTime = record
Year : word; {год в формате 19ХХ}
Manth : word; {месяц 1..12}
Day : word; {день 1..31}
Hour : word; {час 0..23}
Min : word; {минуты 0..59}
Sec : word {секунды 0..59}
Результат обращения к процедуре FINDFIRST можно проконтролировать с помощью функции DOSERROR типа WORD, которая возвращает значения:

О – нет.ошибок;
2 – не найден каталог,
18- каталог пуст (нет указанных файлов).

12. Процедура FINDNEXT. Возвращает имя следующего файла в каталоге. Формат обращения:
FINDNEXT (<слфай>)

Здесь <сл.файл – запись типа SEARCHREC (см. выше), в которой возвращается информация о файле.
Следующая простая программа иллюстрирует способ использованная процедур FINDFIRST и FINDNEXT. Программа выводит на экран список всех PAS-файлов текущего каталога:
Uses DOS;
Var
S: SearchRec;
Begin
FindFirst (‘*.pas’, AnyFile, S);
While DosEror = 0 do
Begin
With S do Writeln (Name: 12, Size:12);
FindNext(S)
End
End.

13. Процедура GETFTIME. Возвращает время создания или последнего обновления файла. Формат обращения:

GETFTIME (<ф.п.>, <время»

Здесь <время> – переменная типа LONGINT, в которой возвращается время в упакованном формате.

14. Процедура SETPTIME. Устанавливает новую дату создания или обновления файла. Формат обращения:

SETFTIME (<ф.п.>, <время»

Здесь <время> – время и дата в упакованном формате.

15. Упаковать запись типа DATETIME в переменную типа LONGINT можно процедурой
PACKTIMEf
var
T:DateTime;
varTime.-longint). (Описание типа
DATETIME см. выше).

16. Процедура GETFATT8. Позволяет получить атрибуты файла. Формат обращения:
GETFATTR (<ф.п.>, <атрибуты>)

Здесь <атрибуты> – переменная типа WORD, в младшем байте которой возвращаются устанавливаемые атрибуты файла.
17. Процедура SETFATTR. Позволяет установить атрибуты файла. Формат обращения:
SETFATTR (<ф.п.>, <атрибуты>)
18. Функция FSEARCH типа PATHSTR Ищет файл в списке каталогов. Формат вызова:
FSEARCH (<имя>, <сп.каталогов>)

Здесь <имя> – имя отыскиваемого файла (строковое выражение или переменная типа PATHSTR-STRING[79]; имени может предшествовать путь);

<сп.каталогов> – список каталогов, в которых отыскивается файл (строковое выражение или переменная типа STRING); имена каталогов разделяются точкой с запятой.
Результат поиска возвращается функцией FSEARCH в виде строки типа PATHSTR
– STRING[79]. В строке содержится путь и имя файла, если поиск был успешным,
– в противном случае возвращается пустая строка.

Следует учесть, что поиск файла всегда начинается в текущем каталоге и только после этого продолжается в тех, что перечислены в <сп.ка-палогов>. Если файл обнаружен, дальнейший поиск прекращается, даже если часть каталогов осталась не просмотренной. В частности, если файл зарегистрирован в текущем каталоге, он «заслонит» собой одноименные}файлы в других каталогах.

Пусть, например, на диске имеется файл SUBDIRMYFILE.PAS
Тогда в случае, если текущий каталог – корневой, обращение FSEARCH (‘MYFILE,PAS’,’ SUB; SUBDIR1) вернет строку SUBDIRMYFILE.PAS, а обращение
FSEARCH(‘MYFILE.PAS’,ЛSUB1)
вернет пустую строку. Однако, если текущим установлен каталог: SUBDIR, то в обоих случаях вернется строка MYFJLE.PAS (если файл) находится в текущем каталоге, в выходной строке путь к нему не указывается). ;
19. Процедура FSPLIT. «Расщепляет» имя файла, т.е. возвращает «в качестве отдельных параметров путь к файлу, его имя и расширение.- Формат обращения:
FSPLIT (<файл>, <путь>, <имя>, <расширение>)
Здесь <файл> – строковое выражение, содержащее спецификацию файла (имя с расширением и, возможно, с предшествующим путем);
<путь> – переменная типа DIRSTR-STRING[67}, в которой возвращается путь к файлу;
<имя> – переменная типа NAMESTR-STR1NG[8], в которой возвращается имя файла;
<расширение> – переменная типа EXTSTR-STRING[4], в которой возвращается расширение с предшествующей ему точкой.
Процедура не проверяет наличие на диске указанного файла. В: качестве входного параметра может использоваться переменная типа PATHSTR-STRING[79].
20. Функция FEXPAND типа PATHSTR. Дополняет файловое имя до полной спецификации , т.е. с указания устройства и пути. Формат вызова:
FEXPAND(<файл>)

Здесь <файл>- строковое выражение или переменная типа PATHSTR.

Функция не проверяет наличие указанного файла на диске, а просто дополняет имя файла недостающим параметрами- текущим устройством и путём к текущему каталогу. Результат возвращается в строке типа PATHSTR=STRING[79]

---

Наверх

16. ОДНОМЕРНЫЕ И ДВУМЕРНЫЕ МАССИВЫ (ТАБЛИЦЫ)

Массив — это пронумерованная последовательность величин одинакового типа, обозначаемая одним именем. Элементы массива располагаются в последовательных ячейках памяти, обозначаются именем массива и индексом. Каждое из значений, составляющих массив, называется его компонентой (или элементом массива).

Массив данных в программе рассматривается как переменная структурированного типа. Массиву присваивается имя, посредством которого можно ссылаться как на массив данных в целом, так и на любую из его компонент.

Переменные, представляющие компоненты массивов, называются переменными с индексами в отличие от простых переменных, представляющих в программе элементарные данные. Индекс в обозначении компонент массивов может быть константой, переменной или выражением порядкового типа.

Если за каждым элементом массива закреплен только один его порядковый номер, то такой массив называется линейным. Вообще количество индексов элементов массива определяет размерность массива. По этом признаку массивы делятся на одномерные (линейные), двумерные, трёхмерные и т.д.


Пример: числовая последовательность четных натуральных чисел 2, 4, 6, …, N представляет собой линейный массив, элементы которого можно обозначить А[1]=2, А[2]=4, А[3]=6, …, А[К]=2*(К+1), где К — номер элемента, а 2, 4, 6, …, N — значения. Индекс (порядковый номер элемента) записывается в квадратных скобках после имени массива.

Например, A[7] — седьмой элемент массива А; D[6] — шестой элемент массива D.

Для размещения массива в памяти ЭВМ отводится поле памяти, размер которого определяется типом, длиной и количеством компонент массива. В языке Pascal эта информация задается в разделе описаний. Массив описывается так:
имя массива : Array [начальное значение индекса..конечное значение индекса] Of базовый тип;

Например,
Var B : Array [1..5] Of Real, R : Array [1..34] Of Char;
— описывается массив В, состоящий из 5 элементов и символьный массив R, состоящий из 34 элементов. Для массива В будет выделено 5*6=30 байт памяти, для массива R — 1*34=34 байта памяти.

Базовый тип элементов массива может быть любым, за исключением файлового.

Заполнить массив можно следующим образом:

1) с помощью оператора присваивания. Этот способ заполнения элементов массива особенно удобен, когда между элементами существует какая-либо зависимость, например, арифметическая или геометрическая прогрессии, или элементы связаны между собой реккурентным соотношением.

Задача 1. Заполнить одномерный массив элементами, отвечающими следующему соотношению:
a1=1; a2=1; ai=ai-2+ai-1 (i = 3, 4, …, n).
Read(N); {Ввод количества элементов}
A[1]:= 1;
A[2]:= 1;
FOR I := 3 TO N DO
A[I] := A[I – 1] + A[I – 2];

Другой вариант присваисвания значений элементам массива — заполнение значениями, полученными с помощью датчика случайных чисел.

Задача 2. Заполнить одномерный массив с помощью датчика случайных чисел таким образом, чтобы все его элементы были различны.
Program Create;
Type Mas = Array[1..100] Of Integer;
Var A : Mas; I, J, N : Byte; Log : Boolean;
Begin
Write(”); ReadLn(N);
randomize; A[1] := -32768 + random(65535);
For I := 2 To N Do
Begin
Log := True;
Repeat
A[i] := -32768 + random(65535); J := 1;
While Log and (j <= i – 1) Do
begin Log := a[i] <> a[j]; j := j + 1 End
Until Log
End;
For i := 1 to N Do Write(a[i]:7); writeln
End.

2) ввод значений элементов массива с клавиатуры используется обычно тогда, когда между элементами не наблюдается никакой зависимости. Например, последовательность чисел 1, 2, -5, 6, -111, 0 может быть введена в память следующим образом:
Program Vvod;
Var N, I : Integer;
A : Array [1..20] Of Integer;
Begin
Write(‘Введите количество элементов массива ‘); ReadLn(N);
FOR I := 1 TO N DO
Begin
Write(‘Введите A[‘, I, ‘] ‘); ReadLn(A[I])
End.

Над элементами массивами чаще всего выполняются такие действия, как

а) поиск значений;

б) сортировка элементов в порядке возрастания или убывания;

в) подсчет элементов в массиве, удовлетворяющих заданному условию.

Cумму элементов массива можно подсчитать по формуле S=S+A[I] первоначально задав S=0. Количество элементов массива можно подсчитать по формуле К=К+1, первоначально задав К=0. Произведение элементов массива можно подсчитать по формуле P = P * A[I], первоначально задав P = 1.

Задача 3. Дан линейный массив целых чисел. Подсчитать, сколько в нем различных чисел.
{Подсчет количества различных чисел в линейном массиве.
ИДЕЯ РЕШЕНИЯ: заводим вспомогательный массив, элементами
которого являются логические величины (False – если элемент
уже встречался ранее, True – иначе)}
Program Razlichnye_Elementy;
Var I, N, K, Kol : Integer;
A : Array [1..50] Of Integer;
Lo : Array [1..50] Of Boolean;
Begin
Write(‘Введите количество элементов массива: ‘); ReadLn(N);
FOR I := 1 TO N DO
Begin
Write(‘A[‘, I, ‘]=’); ReadLn (A[I]);
Lo[I] := True; {Заполняем вспомогательный массив значениями True}
End;
Kol := 0; {переменная, в которой будет храниться количество различных чисел}
FOR I := 1 TO N DO
IF Lo[I] THEN
Begin
Kol := Kol + 1;
FOR K := I TO N DO
{Во вспомогательный массив заносим значение False,
если число уже встречалось ранее или совпадает с текущим элементом A[I]}
Lo[K] := (A[K] <> A[I]) And Lo[K];
End;
WriteLn(‘Количество различных чисел: ‘, Kol)
END.

Тест: N = 10; элементы массива – 1, 2, 2, 2, -1, 1, 0, 34, 3, 3. Ответ: 6.

Задача 4. Дан линейный массив. Упорядочить его элементы в порядке возрастания.
{Сортировка массива выбором (в порядке возрастания).
Идея решения: пусть часть массива (по K-й элемент включительно)
отсортирована. Нужно найти в неотсортированной части массива
минимальный элемент и поменять местами с (K+1)-м}
Program Sortirovka;
Var N, I, J, K, Pr : Integer; A : Array [1..30] Of Integer;
Begin
Write(‘Введите количество элементов: ‘); ReadLn(N);
For I := 1 To N Do
Begin
Write(‘Введите A[‘, I, ‘] ‘); Readln(A[I]);
End;
WriteLn;
For I := 1 To N – 1 Do
Begin
K := I;
For J := I + 1 To N Do If A[J] <= A[K] Then K := J;
Pr := A[I]; A[I] := A[K]; A[K] := Pr;
End;
For I := 1 To N Do Write(A[I], ‘ ‘);
End.

Тест: N = 10; элементы массива – 1, 2, 2, 2, -1, 1, 0, 34, 3, 3.

Ответ: -1, -1, 0, 1, 2, 2, 2, 3, 3, 34.

Если два массива являются массивами эквивалентых типов, то возможно присваивание одного массива другому. При этом все компоненты присваиваемого массива копируются в тот массив,оторому присваивается значение. Типы массивов будут эквивалентными, если эти массивы описываются совместно или описываются идентификатором одного и того же типа. Например, в описании
Type Massiv = Array[1..10] Of Real;
Var A, B : Massiv; C, D : Array[1..10] Of Real; E : Array[1..10] Of Real;
типы переменных A, B эквивалентны, и поэтому данные переменные совместимы по присваиванию; тип переменных C, D также один и тот же, и поэтому данные переменные также совместны по присваиванию. Но тип переменных C, D не эквивалентен типам переменных A, B, E, поэтому, например, A и D не совместны по присваиванию. Эти особенности необходимо учитывать при работе с массивами.

При решении практических задач часто приходится иметь дело с различными таблицами данных, математическим эквивалентом которых служат матрицы. Такой способ организации данных, при котором каждый элемент определяется номером строки и номером столбца, на пересечении которых он расположен, называется двумерным массивом или таблицей.

Например, данные о планетах Солнечной системы представлены следующей таблицей:Планета Расст. до Солнца Относ. обьем Относ. масса

Меркурий	57.9	0.06	0.05
Венера	108.2	0.92	0.81
Земля	149.6	1.00	1.00
Марс	227.9	0.15	0.11
Юпитер	978.3	1345.00	318.40
Сатурн	1429.3	767.00	95.20

Их можно занести в память компьютера, используя понятие двумерного массива. Положение элемента в массиве определяется двумя индексами. Они показывают номер строки и номер столбца. Индексы разделяются запятой. Например: A[7, 6], D[56, 47].

Заполняется двумерный массив аналогично одномерному: с клавиатуры, с помощью оператора присваивания. Например, в результате выполнения программы:
Program Vvod2;
Var I, J : Integer;
A : Array [1..20, 1..20] Of Integer;
Begin
FOR I := 1 TO 3 DO
FOR J := 1 TO 2 DO A[I, J] := 456 + I
End.
элементы массива примут значения A[1, 1] = 457; A[1, 2] = 457; A[2, 1] = 458; A[2, 2] = 458; A[3, 1] = 459; A[3, 2] = 459.

При описании массива задается требуемый объем памяти под двумерный массив, указываются имя массива и в квадратных скобках диапазоны изменения индексов.

При выполнении инженерных и математических расчетов часто используются переменные более чем с двумя индексами. При решении задач на ЭВМ такие переменные представляются как компоненты соответственно трех-, четырехмерных массивов и т.д.

Однако описание массива в виде многомерной структуры делается лишь из соображений удобства программирования как результат стремления наиболее точно воспроизвести в программе объективно существующие связи между элементами данных решаемой задачи. Что же касается образа массива в памяти ЭВМ, то как одномерные, так и многомерные массивы хранятся в виде линейной последовательности своих компонент, и принципиальной разницы между одномерными и многомерными массивами в памяти ЭВМ нет. Однако порядок, в котором запоминаются элементы многомерных массивов, важно себе представлять. В большинстве алгоритмических языков реализуется общее правило, устанавливающее порядок хранения в памяти элементов массивов: элементы многомерных массивов хранятся в памяти в последовательности, соответствующей более частому изменению младших индексов.

Задача 5. Заполнить матрицу порядка n по следующему образцу:

1	2	3	...	n-2	n-1	n
2	1	2	...	n-3	n-2	n-1
3	2	1	...	n-4	n-3	n-2
...	...	...	...	...	...	...
n-1	n-2	n-3	...	2	1	2
n	n-1	n-2	...	3	2	1

Program Massiv12;
Var I, J, K, N : Integer; A : Array [1..10, 1..10] Of Integer;
Begin
Write(‘Введите порядок матрицы: ‘); ReadLn(N);
For I := 1 To N Do
For J := I To N Do
Begin
A[I, J] := J – I + 1; A[J, I] := A[I, J];
End;
For I := 1 To N Do
Begin
WriteLn;
For J := 1 To N Do Write(A[I, J]:4);
End
End.

Задача 6. Дана целочисленная квадратная матрица. Найти в каждой строке наибольший элемент и поменять его местами с элементом главной диагонали.
Program Obmen;
Var N, I, J, Max,Ind, Vsp : Integer;A : Array [1..15, 1..15] Of Integer;
Begin
WRITE(‘Введите количество элементов в массиве: ‘); READLN(N);
FOR I := 1 TO N DO
FOR J := 1 TO N DO
Begin
WRITE(‘A[‘, I, ‘,’, J, ‘] ‘); READLN(A[I, J])
End;
FOR I := 1 TO N DO
Begin
Max := A[I, 1]; Ind := 1;
FOR J := 2 TO N DO
IF A[I, J] > Max THEN
Begin
Max := A[I, J]; Ind := J
End;
Vsp := A[I, I]; A[I, I] := A[I, Ind]; A[I, Ind] := Vsp
End;
FOR I := 1 TO N DO
Begin
WriteLn;
FOR J := 1 TO N Do Write(A[I, J] : 3);
End; WriteLn
End.

© Шестаков А.П., 2001

---

Наверх

22. Как определить сколько слов и сколько цифр в указанном текстовом файле – Pascal

{Дан файл,содержащий текст.
Сколько слов в тексте?
Сколько цифр в тексте?}
{Andrey Sharov}
{web www.borlpasc.narod.ru}
Program file3;
Const mn=[‘0’..’9′];
Var f3:text;
i,j,ch,sl:integer;
name:string;
s:char;
wrd :string;
Begin
writeln(‘введите имя файла’);
readln(name);
assign(f3,name);
reset(f3);
s:=’ ‘;
sl:=0;
ch:=0;
while not eof(f3) do
begin
readln(f3,wrd);
i:=1;
While i<=length(wrd) do
begin
if wrd[i]<>’ ‘ then sl:=sl+1;
while (wrd[i]<>’ ‘) and (i<=length(wrd)) do inc(i);
inc(i)
end;
end;
close(f3);
reset(f3);
while not eof(f3) do
begin
while not eoln(f3) do
begin read(f3,s);
if (s in mn) then ch:=ch+1;
end;
readln(f3);
end;
writeln(‘число слов: ‘,sl,’ число цифр: ‘,ch);
close(f3);
End.

---

Наверх

23. Как определить сколько раз встречается самое длинное слово указанном текстовом файле – Pascal

{Дан файл, содержащий текст на русском языке.
Определить сколько раз встречается в нем самое длинное слово}
{Andrey Sharov}
{web www.borlpasc.narod.ru}
program pr6c;
const razd=[‘ ‘,’.’,’,’,’?’,’!’,’:’,’)’,'(‘];
var f:text;
s,slo,slovo,name:string;
k,i:integer;
begin write(‘Введите имя файла:’);
readln(Name);
assign(f,name);
reset(f);
slovo:=”;k:=0;
while not(EOF(F)) do
begin
readln(f,s);slo:=”;
for i:=1 to length(s) do
begin
if s[i] in razd
then
begin
if (i>1)and not(s[i-1]in razd)
then begin
if (length(slo)=length(slovo))and
(slo=slovo)
then k:=k+1;
if length(slo)>length(slovo)
then
begin
slovo:=slo;
k:=1
end;
end;
slo:=”
end
else
begin
slo:=slo+s[i]
end;
end;
if (length(slo)=length(slovo))and
(slo=slovo)
then k:=k+1;
if length(slo)>length(slovo)
then slovo:=slo;
end;
writeln(‘слово ‘,slovo,’ встречается ‘,k,’ раз’);
close(f);
readln
end.

---

Наверх

24. Как найти строку в текстовом файле. – Паскаль

{ Hайти строку }
var t:text; s,s1:string;
count:word;
begin
readln(s); { Вводим строку для поиска }
assign(t,’text.txt’);reset(t);
s1:=”; count:=0;
while not eof(t) and (s<>s1) do begin
readln(t,s1); inc(count);
end;
writeln(‘искомая строка является ‘,count,’ строкой в файле’);
close(t);
end.

{ Hайти подстроку (слово) }
var
t:text;
s,s1:string;
count:word;
begin
readln(s); {вводим подстроку}
assign(t,’text.txt’); reset(t);
s1:=”; count:=0;
while not eof(t) and (pos(s,s1)=0) do begin
readln(t,s1);
inc(count);
end;
writeln(‘буквосочетание “‘,s,'” найдено в строке N ‘,count,’:’);
writeln(s1);
close(t);
end.

---

Наверх

25. Нахождение НОД и НОК.

Задача:
Нахождение НОД и НОК двух чисел по алгоритму Евклида.

program nodnok;
var a,b:longint;

function NOD(x,y:longint):longint;
begin
if x<>0 then NOD:= NOD(y mod x,x) else NOD:= y;
end;

function NOK(x,y:longint):longint;
begin
NOK:= (x div NOD(x,y)) * y;
end;

Begin
Write(‘Введите a и b: ‘);

Readln(a,b);
Writeln(‘НОД ‘,a,’ и ‘,b,’ = ‘, NOD(a,b));
Writeln(‘НОК ‘,a,’ и ‘,b,’ = ‘, NOK(a,b));
Readln;
End.

---

Наверх

26. Как вывести изображение на Printer – Паскаль

Вязто с: http://pascal.sources.ru/faq/grprint.htm

{ Как вывести изображение на Printer}
{Это из книжки Вальвачева пpо гpафикy с пpимеpами на Паскале.}
{Для контpоля: на Епсонах (LX-100, LQ-100) pаботает 😉 }
uses crt,printer,graph;
const
horisontal=0;
vertical=1;
esc=#$1b;
var
d,m:integer;

procedure Printing(turn:integer);
var
n1,n2,i,k,m,j:integer;
begin
sound(1000); delay(100);
sound(500); delay(100); nosound;
setviewport(0,0,639,479,false);
write(lst,esc,’A’,#$07);
IF turn=horisontal THEN
begin
n1:=639 and $00FF;
n2:=639 shr 8;
for j:=0 to 479 div 8 do
begin
write(lst,esc,’*’,char(1),char(n1),char(n2));
for i:=0 to 639 do
begin
m:=0;
for k:=0 to 7 do
begin
m:=m shl 1;
if getpixel(i,j*8+k)<>0 then inc(m)
end;
write(lst,char(m))
end;
write(lst,#$0d,#$0a)
end
end
ELSE
begin
n1:=479 and $00FF;
n2:=479 shr 8;
j:=0;
repeat
write(lst,esc,’*’,char(1),char(n1),char(n2));
for i:=479 downto 0 do
begin
m:=0;
for k:=0 to 7 do
begin
m:=m shl 1;
if getpixel(j+k,i)<>0 then inc(m)
end;
write(lst,char(m))
end;
write(lst,#$0d,#$0a);
inc(j,8)
until j>= 638
end;
write(lst,#$0c);
sound(500); delay(100);
sound(1000); delay(100);
nosound
end;

begin
d:=detect;
initgraph(d,m,”);
circle(639 div 2, 479 div 2,50);
line(200,200,250,270);
outtextxy(260,120,’Printing form the TURBO PASCAL’);
printing(horisontal);
repeat until keypressed;
closegraph
end.

---

Наверх

27. Как вывести текст на Printer – Паскаль

Пример вывода строки текста на принтер

Uses Printer;

begin
writeln(lst,’http://VBrus.narod.ru’);
{Выводим на принтер: http://VBrus.narod.ru }
end.

---

Наверх

28. Как преобразовать из Integer в String – Pascal

var
strng:string;
int:integer;
begin
int:=1029384756;
str(int,strng); {Преобразуем из INTEGER(число)
в STRING(строку)}
Writeln(strng); {Выводим результат на экран}
Readln;
End.

---

Наверх

29. Как преобразовать из String в Integer – Pascal

var int,error:integer;
st:string;
begin
st:=’1029384756′;
val(st,int,error);{Преобразуем из STRING в INTEGR}
Writeln(int); {Выводим резульат на экран}
readln;
End.

---

Наверх

30. Работа с дробями, Сокращение, Сложение, Вычитание, Умножение, Деление. – Паскаль

Var x,y, {числитель и знаменатель дроби }
p,q, {числитель и знаменатель дроби }
s,t:integer; {числитель и знаменатель дроби }
{ Ввод обыкновенной дроби }
procedure wwod(var a,b:integer);
begin
writeln;
write(‘Введите целые: числитель и знаменатель обыкновенной дроби ‘);
readln(a,b)
end;

{ Вывод результата }

procedure wywod(a,b:integer);
begin write(a,’/’,b);writeln end;
{ Вычисление НОД(x,y) }
function nod(x,y:integer):integer;
begin if (x=0) or (y=0)
then nod:=1
else begin while x<>y do
begin while x>y do x:=x-y;
while y>x do y:=y-x
end;
nod:=x
end
end;

{ Сокращение дроби }
procedure sokr(var c,d:integer);
var r:integer;
begin r:=nod(c,d);
c:=c div r;
d:=d div r
end;

{ Сложение двух дробей }
procedure sum(a,b,c,d:integer; var e,f:integer);
var r:integer;
begin e:=a*d+b*c;
f:=b*d;
sokr(e,f)
end;

{ Вычитание двух дробей }
procedure raz(a,b,c,d:integer; var e,f:integer);
var r:integer;
begin e:=a*d-b*c;
f:=b*d;
sokr(e,f)
end;

{ Умножение двух дробей }
procedure mult(a,b,c,d:integer; var e,f:integer);
var r:integer;
begin e:=a*c;
f:=b*d;
sokr(e,f)

end;

{ Деление двух дробей }
procedure del(a,b,c,d:integer; var e,f:integer);
var r:integer;
begin e:=a*d;
f:=b*c;
sokr(e,f)
end;
begin
write(‘Введите первую дробь ‘);
wwod(x,y);
write(‘Введите вторую дробь ‘);
wwod(p,q);
write(‘Сумма равна ‘); sum(x,y,p,q,s,t); wywod(s,t);
write(‘Разность равна ‘); raz(x,y,p,q,s,t); wywod(s,t);
write(‘Произведение равно ‘); mult(x,y,p,q,s,t); wywod(s,t);
write(‘Частное равно ‘); del(x,y,p,q,s,t); wywod(s,t);
Readln;
end.

---

Наверх

31. Вычисление произведения 2х(двух) квадратных матриц – Паскаль

uses crt;
const n=100; { максимальная размерность матриц }
type matrica=array[1..n,1..n] of integer;
var vibor,i,j,k:byte;
w,s:integer;
a,b,c:matrica;

procedure OutMatr(m:matrica); { процедура вывода матрицы на экран }
var i,j:byte;
begin
writeln;
for j:=1 to w do
begin
for i:=1 to w do write(m[i,j]:5);
writeln;
end;
end;

begin
ClrScr;
Writeln(‘Введите размерность матрицы’);
Write(‘-> ‘);
Readln(w);

{ инициализация матриц (случайными числами) }

randomize;
for i:=1 to w do
for j:=1 to w do
begin
a[i,j]:=random(w);
b[i,j]:=random(w);
end;

{ вывод матриц A и B}
writeln(‘A:’);
OutMatr(a);
writeln(‘B:’);
OutMatr(b);
Writeln;

{ вычисление произведения матриц }
for i:=1 to w do
for j:=1 to w do
begin
s:=0;
for k:=1 to n do s:=s+a[k,i]*b[j,k];
c[i,j]:=s;
end;
{ вывод результата }
writeln(‘a*b:’);
OutMatr(c);
readln;
end.

---

Наверх

32. Транспортировка матрицы – Паскаль

uses crt;
const n=100; { размерность матрицы }
type matrica=array[1..n,1..n] of integer;
var i,j:byte;
w:integer;
a:matrica;
procedure OutMatr; { процедура вывода матрицы на экран }
var i,j:byte;
begin
writeln;
for j:=1 to w do
begin
for i:=1 to w do write(a[i,j]:5);
writeln;
end;
end;

begin
ClrScr;
Writeln(‘Введите размерность матрицы’);
Write(‘-> ‘);
Readln(w);

{ инициализация матриц (случайными числами) }
randomize;
for i:=1 to w do
for j:=1 to w do
begin
a[i,j]:=random(w);
end;
OutMatr;
for i:=1 to w do
for j:=i+1 to w do
if a[i,j]<>a[j,i] then
begin
a[i,j]:=a[i,j] xor a[j,i];
a[j,i]:=a[i,j] xor a[j,i];
a[i,j]:=a[i,j] xor a[j,i]; Writeln;
end; Writeln(‘транспартировка матрицы’);
OutMatr;
Readln;
end.

---

Наверх

33. Как прочитать нажатия клавиш функциональных клавиш (Ctrl, Alt, Shift и.т.д.) – Паскаль

Q:> А как прочитать нажатия клавиш Ctrl, Alt и подобных?

A: Для функции ReadKey эти клавиши не генерируют никаких кодов.
Однако, информация о нажатии подобных клавиш все-таки
имеется и располагается в памяти (область данных BIOS)
по адресу:

Seg0040:$17 – Keyboard Status Flags #1 (основные флаги спец.клавиш)

Ячейка Seg0040:$0017:

                    <-+---- номера битов
   Њ7+6+5+4+3+2+1+0|
   |i|c|n|s|A|^|S|S| Бит Знач. Назначение бита
   Іs+s+s+s+-+-+L+R|  N
    | | | | | | | +-. 0:  01h  нажат Right-shift
    | | | | | | +---. 1:  02h  нажат Left-shift
    | | | | | +-----. 2:  04h  нажат Ctrl (любой)
    | | | | +-------. 3:  08h  нажат Alt (любой)
    | | | +---------. 4:  10h  состяние ScrollLock
    | | +-----------. 5:  20h  состяние NumLock
    | +-------------. 6:  40h  состяние CapsLock
    +---------------. 7:  80h  состяние Insert

В этих ячейках каждый бит отвечает за одну конкретную спец.клавишу –
если бит установлен, то клавиша нажата, если сброшен – то не нажата.
Исключение составляют клавиши ScrollLock, NumLock, CapsLock, Insert –
при первом нажатии соответствующий бит устанавливается в 1, а при
следующем – сбрасывается в 0.

Вот вам функция для вытаскивания этой информации
их байтов Seg040:$17.

Пример вызова: if GetLockKey(Ctrl) then {нажат Ctrl}

Type
Keytype=(Ins, Caps, Num, Scroll, Ctrl, Alt, LShift, RShift);

function GetLockKey(lock:Keytype):Boolean;
{Проверяет, нажата ли спец.клавиша}
var b:word;
begin
case lock of
Ins : b:=$0080;
Caps : b:=$0040;
Num : b:=$0020;
Scroll : b:=$0010;
Alt : b:=$0008;
Ctrl : b:=$0004;
LShift : b:=$0002;
RShift : b:=$0001;
end;
if (mem[0:$417] and b)=b then GetLockKey:=true
else GetLockKey:=false;
end;

Аналогично (домашнее задание! 😉 можно анализировать и байт по адресу
Seg040:$18 (Keyboard Status Flags #2)

Ячейка Seg0040:$0018:

                    <-+---- номера битов
   Њ7+6+5+4+3+2+1+0|
   |i|c|n|s|p|q|A|^| Бит Знач. Назначение бита
   Іd+d+d+d+-+d+l+l|  N
    | | | | | | | +-. 0:  01h нажат левый Ctrl
    | | | | | | +---. 1:  02h нажат левый Alt
    | | | | | +-----. 2:  04h SysReq DOWN
    | | | | +-------. 3:  08h hold/pause state
    | | | +---------. 4:  10h нажат ScrollLock
    | | +-----------. 5:  20h нажат NumLock
    | +-------------. 6:  40h нажат CapsLock
    +---------------. 7:  80h нажат Insert

Посмотрите на прилагаемый тест,
попробуйте нажать несколько клавиш сразу,
обратите внимание на то, что статус клавиатуры изменяется
как при нажатии на клавиши, так и при отпускании тоже!

—
* Origin: (2:5020/794.13)

{> Cut here. FileName= GETKEY.PAS }
{From: Valery Votintsev 2:5021/22}
{Alt, Shift, Ctrl test for 0040:0017 keyboard status}
Uses CRT;
Const
RightShift = $0001;
LeftShift = $0002;
AnyCtrl = $0004;
AnyAlt = $0008;
ScrollActive = $0010;
NumLockActive = $0020;
CapsLockActive= $0040;
InsActive = $0080;
LeftCtrl = $0100;
LeftAlt = $0200;
SysReq = $0400;
PauseKey = $0800;
ScrollLock = $1000;
NumLock = $2000;
CapsLock = $4000;
Insert = $8000;

const hex_num:array [0..15] of char=’0123456789ABCDEF’;

var
key:char; {код нажатой клавиши}
flags:word; {флаги состояния клавиатуры}
newflags:word;

function word2hex(w:word):string;
{перевод в 16-ричное число}
var
b:array[1..2] of byte absolute w;
begin
word2hex:=hex_num[b[2] shr 4]+hex_num[b[2] and $0F] +
hex_num[b[1] shr 4]+hex_num[b[1] and $0F]
end;

function GetFlags:Word;
{Считывает состояние флагов спец.клавиш}
begin
GetFlags:=memW[0:$417];
end;

function AnyKeyEvent:boolean;<
begin
AnyKeyEvent:= (KeyPressed or (newflags<>flags));
end;

function Pressed(lock:word):Boolean;
{Проверяет, нажата ли спец.клавиша с кодом LOCK}
begin
if (flags and word(lock))<>0 then Pressed:=true
else Pressed:=false;
end;

Procedure WriteKeyCode;
begin
TextAttr:=White;
If KeyPressed then begin
key:= ReadKey; {читаем код }
if Key = #0 then begin {код оказался расширенным}
Write(Ord(Key):3,’,’); {печатаем нулевой код }
key:= ReadKey; {читаем расширенный код }
end;
Write(Ord(Key):3); {печатаем основной код }
end
else write(‘ ‘);
end;

Procedure WriteFlags;
begin
TextAttr:=LightGray;
Write(‘ Flags:’,word2hex(memW[Seg0040:$17]));
{Теперь печатаем флаги спец.клавиш}
TextAttr:=Cyan;
If Pressed(RightShift) then Write(‘ RightShift’);
If Pressed(LeftShift ) then Write(‘ LeftShift’);
If Pressed(AnyAlt ) then Write(‘ AnyAlt’);
If Pressed(AnyCtrl ) then Write(‘ AnyCtrl’);
If Pressed(LeftCtrl ) then Write(‘ LeftCtrl’);
If Pressed(LeftAlt ) then Write(‘ LeftAlt’);
If Pressed(SysReq ) then Write(‘ SysReq’);
If Pressed(PauseKey ) then Write(‘ Pause’);
If Pressed(ScrollLock) then Write(‘ ScrollLock’);
If Pressed(NumLock ) then Write(‘ NumLock’);
If Pressed(CapsLock ) then Write(‘ CapsLock’);
If Pressed(Insert ) then Write(‘ Insert’);

{Теперь печатаем состояние переключателей}
TextAttr:=Yellow;
If Pressed(ScrollActive ) then Write(‘ ScrollLockActive’);
If Pressed(NumLockActive ) then Write(‘ NumLockActive’);
If Pressed(CapsLockActive) then Write(‘ CapsLockActive’);
If Pressed(InsActive ) then Write(‘ InsActive’);
Writeln;
TextAttr:=LightGray;
end;

begin
while keypressed do readkey; {Очистить буфер клавиатуры}
flags:=GetFlags; {начальное состояние флагов}
repeat
newflags:=GetFlags; {новое состояние флагов}
If AnyKeyEvent then begin {если чего-нибудь нажато}
WriteKeyCode;
flags:=newflags; {запомнить состояние флагов}
WriteFlags;
end;
until Key = #27; {Цикл, пока не нажмем Esc}
while keypressed do readkey; {Очистить буфер клавиатуры}
end.

---

Наверх

34. Как узнать состояние клавиш Shift, Alt, Ctrl, Num Lock, Caps Lock, Scroll Lock и искусственно переключать их? – Pascal

Состояние этих клавиш храниться в памяти по адресу 0:$417.
Каждой из этих клавиш в байте по этому адресу соответствует
свой бит. Следующие процедуры показывает как можно читать и
изменять состояния клавиш

Type
TKeytype=(ktCaps, ktNum, ktScroll, ktCtrl, ktAlt, ktLShift,
ktRShift);

function GetLock(lock:TKeytype):Boolean;
var
b:byte;
begin
case lock of
ktCaps : b:=$40;
ktNum : b:=$20;
ktScroll : b:=$10;
ktCtrl : b:=$04;
ktAlt : b:=$08;
ktLShift : b:=$02;
ktRShift : b:=$01;
end;
if (mem[0:$417] and b)<>0 then GetLock:=true
else GetLock:=false;
end;

procedure SetLock(lock:TKeytype; On:Boolean);
var
b:byte;
begin
case lock of
ktCaps : b:=$40;
ktNum : b:=$20;
ktScroll : b:=$10;
ktCtrl : b:=$04;
ktAlt : b:=$08;
ktLShift : b:=$02;
ktRShift : b:=$01;
end;
if On then
mem[0:$417]:=mem[0:$417] or b
Else
mem[0:$417]:=mem[0:$417] and not b;
end;

---

Наверх

35. Какой из опеpатоpов быстpее? INC(x); или x:=x+1; – Паскаль

Пишешь такyю вот пpогpаммy:

var
i:byte;
begin
inc (i);
i := i + 1;
end.

Компилиpyешь ее.
А затем смотpишь HIEW’ом и видишь:

0000005F: FE065000 inc b,[00050]

[skip]

00000063: A05000 mov al,[00050]
00000066: 30E4 xor ah,ah
00000068: 40 inc ax
00000069: A25000 mov [00050],al

В пеpвом слyчае – inc(i); во втоpом – i:=i+1. Тyт yже очевидно – инкpемент
быстpее. Тyт даже такты пpоцессоpа считать не надо 🙂

Взято с: http://www.dore.ru/perl/nntp.pl?f=1&gid=14&mid=14474

---

Наверх

36. Как сделать русские буквы заглавными. – Паскаль

Var
InString, OuString : String;

Function UpperCaseRus(RusChar : Char) : Char;
Begin
Case RusChar Of
‘а’..’п’: UpperCaseRus := Chr(Ord(RusChar)-32);
‘р’..’я’: UpperCaseRus := Chr(Ord(RusChar)-80);
‘ё’ : UpperCaseRus := ‘Ё’;
Else UpperCaseRus := UpCase(RusChar);
End;
End;

Function UpString(S : String) : String;
Var I : Integer;
NewString : String;
Begin
NewString:=”;
For I:=1 To Length(S) Do NewString := NewString + UpperCaseRus(S[I]);
UpString:=NewString;
End;

{==========================================================================}

Begin
If ParamCount = 0 Then Begin
WriteLn (‘Пропущен обязательный параметр – строка символов’);
Halt;
End;

InString := ParamStr(1);
OuString := UpString(InString);

WriteLn;
WriteLn(InString);
WriteLn(OuString);
End.

---

Наверх

37. Выводим на экран квадрат Пифагора(Таблица умножения) – Паскаль

var
i,j:integer; {номер строки и столбца таблицы}
begin
write(”:4); {левая верхняя клетка таблицы}
for j:=1 to 10 do {правая строка – номера столбцов}
write(j:4);
writeln;
for i:=1 to 10 do
begin
write(i:4); {номер строки}
for j:=1 to 10 do
write(i*j:4);
writeln;
end;
readln;
end.

---

Наверх

38. Обмен значений двух переменных без использования третьей – Паскаль

Чтобы обменять значения двух переменных без использования третьей переменной или ещё чего либо, воспользуйтесь следующим алгоритмом:

A:=A+B; B:=A-B; A:=A-B;

---

Наверх

39. Электронные часы – Паскаль

Пример реализации простейших часов

uses dos,crt;
var Time:string;

Function GetTime: string;
Var h, m, s, ms: Word;
begin
Dos.GetTime(h, m, s, ms);
str(h,’:’,m,’:’,s,’:’,ms,time);
GetTime:=time;
end;

begin
ClrScr;
while not keypressed do
begin
delay(100);
GoToXY(1,1);
WriteLn(‘TIME = ‘, GetTime);
end;
end.

---

Наверх

40. Модуль Timer для Паскаля и не только – Паскаль

Часто при программировании в некоторых местах программы необходимо замерять время исполнения кода, в других просто останавливать выполнение не некоторое время. Например, если писать игру, необходимо создавать код, который бы ограничивал скорость игры. Конечно, если игра очень тяжелоя, то некоторое время она может существовать без такого ограничителя. Но со временем вычислительная мощь компютеров растет (к сожелению не сама по себе) и в игры без ограничителя скорости играть становится невозможно. Или вы решили написать бенчмарк для процессора. Тут уже нужны очень точные средства для замера времени исполнения кода. Таких примеров можно привести уйму. Проще сказать, что в любой более – мение серезной программе измерение времени просто необходимо. К сожалению штатные средства в Паскале ограничиваются только процедурой Delay что описана в модуле CRT. Но она очень сильно зависит от производительности системы. Конечно, можно использовать процедуру GetTime, но она довольно громоздка. А стандартных процедур по замеру времени выполнения кода вобще нет.

Ну и не надо! Мы ведь не чайники? Конечно, не чайники! Сами напишем. При написании программ последовательный код стараются обединить в цыклы. Код, повторяющийся в програме выносят в отдельные процедуры и функции. А код, который явно будет использоватся не в одной программе, выносят в модули. Мы так и сделаем. Давайте создадим в Паскале файл TIMER.PAS и начнем. Как известно название модуля и файла должны совпадать, поетому пишем:

Unit Timer;

Далее необходимо создать интерфейсную часть модуля. Тут давайте остановимся и разберемся что нам нужно. Во-первых нам нужны средства для измерения времени исполнения кода. Во-вторых средства по остановке программы на определенное время. Кроме того, при остановке может, понадобится вывод времени, которое прошло.

interface
procedure Start (var T:longint);
procedure Stop (var T:longint);
procedure Pause (T:longint; Show:boolean);

Итак, мы обявили три процедуры. Процедуры Start и Stop будут служить для измерения времени выполнения кода, а Pause станет заменой Delay. Переменная T – будит служить для передачи данных о времени. Show – для разрешения или запрещения вывода времени на екран. Далее следует исполнительная часть. Она служит для обявления локальных констант, переменных и типов. В данном модуле они нам не нужны:

Implementation

Далее следует самое интересное. Вы еще не задумывались каким же способом мы будем производить замер времени? А почему бы не использавать аппаратный таймер? Темболее это очень просто:

SystemTimer:longint absolute $0040:$006C;

Вот и все! Нет, модуль не весь, но мы имеем полный доступ к аапаратному таймеру, расположеному по физическому адресу $0040:$006C. Значение двойного слова по этому адресу увеличивается на единицу 18.2 раза в секунду и независит от производительности системы. Нам осталось только написать примитивные процедуры для оперирования с таймером:

procedure Start (var T:longint);
begin
T:=SystemTimer;
end;
procedure Stop (var T:longint);
begin
T:=SystemTimer-T;
end;

procedure Pause (T:longint; Show:boolean);
var Xn,Xt:longint;
begin
Xt:=0;
Xn:=SystemTimer;
While ((Xt-Xn)/18.2)*1000 < T do
begin
Xt:=SystemTimer;
If Show then
writeln((xt-xn)/18.2:6:4)
end;
end;

Ну, и долгожданный

end.

Все, компилируем. Хочется сразу проверить работу, не так ли?

Program TimerPrimer;
uses timer;
Var i : integer;
a :Real;
Time : LongInt;
begin
Randomize;
Start(Time);
For i:=1 to 30000 do
a:=Sin(sqrt(i))*Cos(sqrt(Random(10000)));
Stop(Time);
Writeln(‘Время выполнения: ‘,Time/18.2:6:4);
Readln;
Pause(10000, True);
end.

Данная программа демонстрирует возможности модутя Timer. В начале она исполняет цыкл от 1 до 30000 в котором высчитывает значение а. Время выполнения этого цыкла и замеряют наши процедуры Start и Stop. После чего, дождавшись нажатия на Enter делаем паузу на 10.000 секунд с разрешаем процедуре Pause осуществлять вывод на екран.

Теперь вы сможете использовать точный таймер в своих программах. А почему же я не воспользовался процедурой GetTime? Только из-за ее громоздкости? Конечно нет. Посмотрите на код. Что мы собственно использовали? Только прямой доступ к физическому адресу аппаратного таймера. Так кто мешает использовать его в других языках программирования? Вот тут то и оно.

Автор: Владислав Путяк
Источник: http://docs.com.ru

---

Наверх

41. Как запустить внешний файл в Pascal’е? – Паскаль

{$M $4000, 0, 0 } { 16Kб стек, нет кучи }
Uses Dos;

Var ProgramName, CmdLine : String;
Begin
Write(‘Имя программы для запуска (с путем) : ‘);
ReadLn(ProgramName);
Write(‘Параметры командной строки ‘, ProgramName, ‘ : ‘);
ReadLn(CmdLine);
WriteLn(‘Пробую запустить…’);
SwapVectors;
Exec(ProgramName, CmdLine);
SwapVectors;
WriteLn(‘… вернулся из Exec’);
{ Была ошибка ? }
If DosError<>0 Then WriteLn(‘Ошибка DOS #’, DosError)
Else WriteLn(‘Запуск был удачным. Код выхода = ‘, DosExitCode);
End.

---

Наверх

42. Сортировка массива(Ранжирование) – Паскаль

Источник: http://articles.org.ru/docum/sort.php

Сортировка массива методом пузырька – медленная, но если скорость не главное, можно применить и его.
Алгоритм очень прост – если два соседних элемента расположены не по порядку,
то меняем их местами. Так повторяем до тех пор, пока в очередном проходе не сделаем ни одного обмена,
т.е. массив будет упорядоченным. Ниже текст процедуры, реализующей алгоритм сортировки методом пузырька
(Arr – массив для сортировки с начальным индексом 0, n – размерность массива)

procedure SortPuz (var Arr : array of Integer; n : Integer);
var
  i : Integer; 
  Temp : Integer; 
  Flag : Boolean; 
begin
  repeat
    Flag := False;
    for i := 0 to n - 1 do
      if Arr [i] > Arr [i + 1] then begin 
        Temp := Arr [i]; 
        Arr [i] := Arr [i + 1];
        Arr [i + 1] := Temp; 
        Flag := True; 
      end; 
  until Flag = False;
end;

Сортировка методом нахождения минимального элемента
Ещё один вариант сортировки, более быстрый, чем метод пузырька.
Заключается он в следующем: при каждом просмотре массива находим
минимальный элемент и меняем местами его с первым на первом проходе,
со вторым – на втором и т.д. Не забудьте только, что первый элемент массива должен иметь индекс 0.

procedure SortMin (var Arr : array of Integer; n : Integer);
var
  i, j : Integer;
  Min, Pos, Temp : Integer;
begin
  for i := 0 to n - 1 do begin
    Min := Arr [i];
    Pos := i;
    for j := i + 1 to n do
      if Arr [j] < Min then begin
        Min := Arr [j];
        Pos := j;
      end;
    Temp := Arr [i];
    Arr [i] := Arr [Pos];
    Arr [Pos] := Temp;
  end;
end;

Сортировка массива вставками
Более быстрый и оптимальный метод сортировки – сортировка вставками.

Суть её в том, что на n-ном шаге мы имеем упорядоченную часть массива из n элементов,

и следующий элемент встаёт на подходящее ему место.

Имейте в виду – первый индекс массива – 0.

procedure SortInsert (var Arr : array of Integer; n : Integer);
var
  i, j, Temp : Integer;
begin
  for i := 1 to n do begin
    Temp := Arr [i];
    j := i - 1;
    while Temp < Arr [j] do begin
      Arr [j + 1] := Arr [j];
      Dec (j);
      if j < 0 then
        Break;
    end;
    Arr [j + 1] := Temp;
  end;
end;

Поиск перебором
Чтобы найти какие-то данные в неупорядоченном массиве,

применяется алгоритм простого перебора элементов.
Следующая функция возвращает индекс заданного элемента массива.

Её аргументы: массив с первым индексом 0, количество элементов
в массиве и искомое число. Если число не найдено, возвращается -1.

function SearchPer (Arr : array of 
Integer; n, v : Integer) : Integer;
var
  i : Integer;
begin
  Result := -1;
  for i := 1 to n do
    if Arr [i] = v then begin
      Result := i;
      Exit;
    end;
end;

Бинарный поиск
При поиске в упорядоченном массиве можно применить гораздо
более быстрый метод поиска – бинарный.
Суть его в следующем: В начале переменная Up указывает на самый
маленький элемент массива (Up := 0), Down – на самый большой
(Down := n, где n – верхний индекс массива), а Mid – на средний.
Дальше, если искомое число равно Mid, то задача решена; если число меньше Mid,
то нужный нам элемент лежит ниже среднего, и за новое значение Up принимается Mid + 1;
и если нужное нам число меньше среднего элемента, значит, оно расположено
выше среднего элемента, и Down := Mid – 1. Затем следует новая итерация цикла,

и так повторяется до тех пор, пока не найдётся нужное число, или Up не станет больше Doun.

function SearchBin (Arr : array of 
Integer; v, n : Integer) : Integer;
var
  Up, Down, Mid : Integer;
  Found : Boolean;
begin
  Up := 0; Down := n;
  Found := False; Result := -1;
  repeat
    Mid := Trunc ((Down - Up) / 2) + Up;
    if Arr [Mid] = v then
      Found := True
    else
      if v < Arr [Mid] then
        Down := Mid - 1
      else
        Up := Mid + 1;
  until (Up > Down) or Found;
  if Found then
    Result := Mid;
end;

Способ быстрой сортировки Чарльза

program Quitsort;
uses
crt;
Const
N=10;
Type
Mas=array[1..n] of integer;
var
a: mas;
k: integer;
function Part(l, r: integer):integer;
var
v, i, j, b: integer;
begin
V:=a[r];
I:=l-1;
j:=r;
repeat
repeat
dec(j)
until (a[j]<=v) or (j=i+1);
repeat
inc(i)
until (a[i]>=v) or (i=j-1);
b:=a[i];
a[i]:=a[j];
a[j]:=b;
until i>=j;
a[j]:=a[i];
a[i]:= a[r];
a[r]:=b;
part:=i;
end;
procedure QuickSort(l, t: integer);
var i: integer;
begin
if l
begin
i:=part(l, t);
QuickSort(l,i-1);
QuickSort(i+1,t);
end;
end;
begin
clrscr;
randomize;
for k:=1 to 10 do
begin
write(‘BBEDITE ELEMENT ‘,k,’ = ‘);
Readln(a[k]);
end;
QuickSort(1,n);
writeln;
Writeln(‘MASSIV Posle Sortirovki’);
for k:=1 to n do
write(a[k]:3);
readln;
end.

---

Наверх

43. Как быстро очистить экран не используя модуль CRT?

procedure ClrScr;
begin
asm
mov ax,3
int 10h
end;
end;

begin
ClrScr;

end.

---

Наверх

44. Как убрать мигающий курсор в текстовом режиме? – Pascal

Убратьь:
Procedure CursorOff;

asm
mov ah,1
mov ch,20h
int 10h
end;
end;
begin
CursorOff;
end.

Включить:
Procedure CursorOn;
asm
mov ah,1
mov cx,607h
int 10h
end;
end;
begin
CursorOn;
end.

---

Наверх

45. Как сделать фиксированную задержку, вместо Delay()? – Pascal

Procedure Delay(x:longint);
var t:longint;
begin
t := MemL[Seg0040:$6c];
while MemL[Seg0040:$6c] < t+x do; {задержка на X тиков}
end;

---

Наверх

46. Сортировка(ранжирование) массива самым быстрым способом – Pascal

Метод разделением
Метод разделением был предложен Чарльзом Хоаром в 1962 году. И вы неповерите этот метод является досих пор один из самых быстрых и часто применяемых!!:-)

Профессор Чарльз Хоар (Charles Antony Richard Hoare) родился в 1934 г. в Англии. В 1980 г. получил престижную премию Алана Тьюринга за вклад в формальное определение языков программирования посредством аксиоматической семантики. Хоар известен своими работами в области алгебры программ. Превращение программирования в серьезную профессиональную дисциплину стало ведущим мотивом его научной деятельности.

А вот и собственно сам алгоритм:

#include (iostream.h)
#include (conio.h)

int array[1000];

void quicksort(long High,Long Low)
{
long i,j
int p,temp;
i=low;
j=high;
p=array[(Low+High)/2];
do
{
while (array[i]

while (array[j]>p j–;
if (i<=j)
{
temp=array[i];
array[i]=array[j];
array[j]=temp;
i++
j–
}
}

while (i<=j);
if (j>low) quicksort(j,low);
if (High>i) quicksort(High,i);
}

Main()
{
int size;

int i;

Cin>>size;

for (i=0;i

cin>>array[i];

quicsort(size-1,0);

for (i=0; i

cout << array[i]<<” “;

Getch();
return 0;
}

——————————————————————–
Ой ой ой это С++ а нам нужен Паскаль :-), вот вам Паскаль:

program Quitsort;
uses
crt;
Const
N=10;
Type
Mas=array[1..n] of integer;
var
a: mas;
k: integer;
function Part(l, r: integer):integer;
var
v, i, j, b: integer;
begin
V:=a[r];
I:=l-1;
j:=r;
repeat
repeat
dec(j)
until (a[j]<=v) or (j=i+1);
repeat
inc(i)
until (a[i]>=v) or (i=j-1);
b:=a[i];
a[i]:=a[j];
a[j]:=b;
until i>=j;
a[j]:=a[i];
a[i]:= a[r];
a[r]:=b;
part:=i;
end;
procedure QuickSort(l, t: integer);
var i: integer;

begin
if l

begin
i:=part(l, t);
QuickSort(l,i-1);
QuickSort(i+1,t);
end;
end;
begin
clrscr;
randomize;
for k:=1 to 10 do
begin
write(‘BBEDITE ELEMENT ‘,k,’ = ‘);
Readln(a[k]);
end;

QuickSort(1,n);
writeln;
Writeln(‘MASSIV Posle Sortirovki’);
for k:=1 to n do
write(a[k]:3);
readln;
end.

---

Наверх

47. Как вывести строку на экран не используя встроенные функции Write/writeln – Pascal

Источник: http://forum.sources.ru/index.php?showtopic=39965

Вот ещё два способа вывода строки.
В них не используются стандартные команды паскаля (write и writeln)
Обе команды в качестве параметра получают строку. Поэтому при помощи них нельзя напрямую вывести на экран любое числовое значение, не преобразовав его предварительно к строковому типу.

Первый способ:

{write через DOS} 
program wrDOS; 
{наверное можно компактнее} 
procedure writeS(s:string);assembler; 
asm 
  push ds {сохраняем сегмент данных} 
  mov ah,40h {номер функции прерывания} 
  mov bx,1{стандартный вывод это 1} 
  lds dx,s {адрес строки в ds:dx} 
  mov si,dx {адрес строки в ds:si для lodsb} 
  lodsb {длинну строки в al (первый байт
                в строке это ее длина!)} 
  inc dx{чтобы не напечатать первый байт} 
  xor cx,cx;mov cl,al{чтобы в сх была длинна строки} 
  int 21h {DOS} 
  pop ds {восстанавливаем ds} 
  {как видишь всё просто :) } 
end; 
 
begin 
  writeS('123456'#10#13); 
  {это типа writeLn если
   убрать последние символы получиться просто write} 
end.

Второй способ:
{write через BIOS} 
program wrBIOS; 
procedure writeXYS(x,y:byte;s:string);assembler; 
asm 
  mov dh,y{понятно} 
  mov dl,x{понятно} 
  mov ax,1301h{13h функция 1 подфункция }
              { Вместо mov ah,13h;mov al,1} 
  les bp,s {адрес s в es:bp} 
  mov bh,0{ номер страницы} 
  mov bl,16*2+15{атрибут символа} 
 
  xor ch,ch 
  mov cl,byte ptr es:[bp] {в сх положим длину строки} 
  inc bp {Чтобы не напечатать нулевой символ в s} 
  int 10h 
end; 
{------------} 
begin 
  writeXYS(40,10,'123456'); 
  readln; 
end.

Часто в университетах требуют, чтобы код программы не содержал ассемлерных вставок, и был бы написан полностью на паскале.
Вот возможное решение для таких случаев (использует аналог ассемблерных вставок, но написан при помощи исключительно паскалевских команд).

Первый способ:
program wrDOS;
uses DOS;
procedure writeS(s:string);
var
  R:registers;
begin
  R.AH:=$40;
  R.BX:=1;
  R.DX:=ofs(s);
  R.DS:=seg(s);
  R.SI:=R.DX;
  R.AL:=ord(s[0]);
  INC(R.DX);
  R.CX:=R.CX xor R.CX;
  R.CL:=R.AL;
  intr($21,R);
end;

begin
  writeS('123456'#10#13);
  readln;
end.

Второй способ:
program wrBIOS; 
uses DOS;
procedure writeXYS(x,y:byte;s:string);
var
  R:registers;
begin
  with R do
  begin
    DH:=Y;{mov dh,y понятно}
    DL:=X;{mov dl,x понятно}
    AX:=$1301;{mov ax,1301h 13h функция 1 подфункция }
    BP:=ofs(s);ES:=seg(s);{les bp,s  адрес s в es:bp}
    BH:=0;{mov bh,0  номер страницы}
    BL:=16*2+15;{mov bl,16*2+15 атрибут символа}
    CH:=CX xor CX;{xor ch,ch }
    CL:=mem[ES:BP];{mov cl,byte ptr es:[bp] в сх положим длину строки}
    INC(BP);{inc bp Чтобы не напечатать нулевой символ в s}
  end;
  intr($10,R);
end;
{------------}
begin
  writeXYS(40,10,'123456');
  readln; 
end.

---

Наверх

49. Заполнить весь экран сердечками – Pascal

   
label go;
begin
asm
    mov ax,0b800h
    mov es,ax
    mov di,0
    mov ah,29 {29 - цвет}
    mov al,3  {3-ASCll код символа}
    mov cx,2000
    go:
    mov es:[di],ax
    add di,2
    loop go
end;
readln;
end.

---

Наверх