vbrus.narod.ru
Последнее обновление: 3 Ноября 2007 г.
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:\dir\subdir\*. 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]. В строке содержится путь и имя файла, если поиск был успешным, - в противном случае возвращается пустая строка. Следует учесть, что поиск файла всегда начинается в текущем каталоге и только после этого продолжается в тех, что перечислены в <сп.ка-палогов>. Если файл обнаружен, дальнейший поиск прекращается, даже если часть каталогов осталась не просмотренной. В частности, если файл зарегистрирован в текущем каталоге, он «заслонит» собой одноименные}файлы в других каталогах. Пусть, например, на диске имеется файл \SUBDIR\MYFILE.PAS Тогда в случае, если текущий каталог - корневой, обращение FSEARCH ('MYFILE,PAS','\ SUB; \ SUBDIR1) вернет строку \SUBDIR\MYFILE.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 1Program 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. Как найти строку в текстовом файле. - Паскаль
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 - Паскаль
{ Как вывести изображение на 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
strng:string; int:integer; begin int:=1029384756; str(int,strng); {Преобразуем из INTEGER(число) в STRING(строку)} Writeln(strng); {Выводим результат на экран} Readln; End. Наверх 29. Как преобразовать из String в Integer - Pascal
st:string; begin st:='1029384756'; val(st,int,error);{Преобразуем из STRING в INTEGR} Writeln(int); {Выводим резульат на экран} readln; End. Наверх 30. Работа с дробями, Сокращение, Сложение, Вычитание, Умножение, Деление. - Паскаль
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х(двух) квадратных матриц - Паскаль
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. Транспортировка матрицы - Паскаль
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 и.т.д.) - Паскаль
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
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; - Паскаль
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. Как сделать русские буквы заглавными. - Паскаль
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. Выводим на экран квадрат Пифагора(Таблица умножения) - Паскаль
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 для Паскаля и не только - Паскаль
Ну и не надо! Мы ведь не чайники? Конечно, не чайники! Сами напишем. При написании программ последовательный код стараются обединить в цыклы. Код, повторяющийся в програме выносят в отдельные процедуры и функции. А код, который явно будет использоватся не в одной программе, выносят в модули. Мы так и сделаем. Давайте создадим в Паскале файл 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'е? - Паскаль
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. Сортировка массива(Ранжирование) - Паскаль
Сортировка массива методом пузырька - медленная, но если скорость не главное, можно применить и его. Алгоритм очень прост - если два соседних элемента расположены не по порядку, то меняем их местами. Так повторяем до тех пор, пока в очередном проходе не сделаем ни одного обмена, т.е. массив будет упорядоченным. Ниже текст процедуры, реализующей алгоритм сортировки методом пузырька (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 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?
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
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] 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 quicsort(size-1,0); for (i=0; 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 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
Вот ещё два способа вывода строки. В них не используются стандартные команды паскаля (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.
Наверх | ||
