Функции
Procedure GetBkColor; Word Возвращает текущий фоновый цвет.
Procedure GetColor; Word Возвращает текущий цвет.
Procedure GetDriverName; String Возвращает строку с именем текущего драйвера.
Procedure GetGraphMode: Integer Возвращает текущий графический режим.
Procedure GetMaxColor; Word Возвращает максимальный цвет, который можно задать в SetColor.
Procedure GetMaxMode: Integer Возвращает номер максимального режима текущего загруженного драйвера.
Procedure GetMaxX: Integer Возвращает максимальную горизонтальную координату графического экрана.
Procedure GetMaxY; Integer Возвращает максимальную вертикальную координату графического экрана.
Procedure GetModeName(ModeNum; Word) ; String Возвращает строку с именем указанного графического режима.
Procedure GetPaletteSize: Integer Возвращает размер таблицы палитры.
Procedure GetPixel (X, Y; Integer) : Word Возвращает цвет пикселя с координатами X,Y.
Procedure GetX: Integer Возвращает координату X текущего указателя.
Procedure GetY; Integer Возвращает координату У текущего указателя.
Procedure GraphErrorMsgtErrorCode: Integer): String Возвращает строку сообщения об ошибке для заданного кода ErrorCode.
Procedure GraphResult: Integer Возвращает код ошибки для последней графической операции.
Procedure ImageSize(X1, Y1, X2, Y2: Integer) Возвращает число байт, требуемое для сохранения прямоугольной области экрана.
Procedure InstallUserDriver(Name: String; AutoDetectPtr; Pointer): Integer
Устанавливает пользовательский драйвер устройства в таблицу драйверов устройств.
Procedure InstallUserFont (FontFileName: String): Integer Устанавливает новый шрифт, который не встроен в BGI систему.
Procedure RegisterBGIdriver (Driver: Pointer); Integer Регистрирует драйвер для графической системы.
Procedure RegisterBGIfont (Font: Pointer): Integer Регистрирует шрифт для графической системы.
Procedure TextHeight (TextStr: String) : Word Возвращает высоту строки в пикселах.
Procedure TextWidth(TextStr: String): Word Возвращает ширину строки в пикселах.
Function KeyPressed; Boolean Возвращает True, если на клавиатуре была нажата клавиша, и False в противном случае. Не задерживает исполнение программы.
Function ReadKey: char Читает символ с клавиатуры без эхоповтора на экране. Приостанавливает исполнение программы до нажатия на любую клавишу, кроме Shift, Ctrl, Alt, CapsLock, NumLock, ScrollLock.
Function WhereX: Byte Возвращает горизонтальную координату текущей позиции курсора относительно текущего окна.
Function WhereY: Byte Возвращает вертикальную координату текущей позиции курсора относительно текущего окна.
Процедуры
Procedure AssignCrt (var F: Text) Связывает с файловой переменной устройство CON (клавиатуру для ввода и экран для вывода).
Procedure ClrEol Удаляет все символы от текущей позиции курсора до конца строки без перемещения курсора.
Procedure ClrScr Очищает экран (окно) и помещает курсор в верхний левый угол.
Procedure Delay (D: word) Приостанавливает работу программы на указанное число D миллисекунд.
Procedure DelLine Удаляет строку, на которой находится курсор, и перемещает все строки ниже этой строки на строку вверх. Нижняя строка очищается.
Procedure GotoXY(X, Y; Byte) Перемещает курсор в нужное место экрана (окна).
Procedure Highvideo Устанавливает высокую яркость символов.
Procedure InsLine Вставляет пустую строку в позицию курсора. ,
Procedure LowVideo Устанавливает низкую яркость символов.
Procedure NormVideo Устанавливает нормальную яркость символов.
Procedure NoSound Выключает звуковой генератор.
Procedure Sound (F: word) Включает звуковой генератор. F - частота звука (Гц).
Procedure TextBackground (Color: Byte) Устанавливает цвет фона.
Procedure TextColor (Color: Byte) Устанавливает цвет символов.
Procedure TextMode (Mode: Word) Устанавливает нужный текстовый режим.
Procedure Window(X1, Y1, X2, Y2 : Byte) Определяет текстовое окно на экране. X1, Y1 - координаты левого верхнего угла, Х2, Y2 - правого нижнего угла.
Константы
OvrCodeList, OvrHeapSize, OvrDebugPtr, OvrHeapOrg, OvrHeapPtr, OvrHeapEnd, OvrHeapList, OvrDosHandle и OvrEmsHandle используются модулем Overlay для реализации администратора оверлеев. Буфер оверлеев размещается между сегментом стека и кучей и OvrHeapOrg и OvrHeapEnd содержат адреса начала и конца сегмента. Размер буфера оверлеев по умолчанию соответствует размеру максимального оверлея в программе; если в программе нет оверлеев, то размер оверлейного буфера равен нулю.
HeapOrg, HeapPtr, HeapEnd, FreeList, HeapError используются администратором кучи для реализации распределения динамической памяти.
Переменные ExitProc, ExitCode и ErrorAddr реализуют процедуры выхода.
PrefixSeg содержит сегментную часть адреса префикса программного сегмента (PSP).
StackLimit содержит смещение от нижней границы сегмента стека, соответствующее наименьшему допустимому значению регистра SP. Обычно StackLimit равен нулю; если программа откомпилирована с опциями {$N+.E+}, компилятор будет устанавливать его равным 224 для резервирования рабочего пространства на нижней границе сегмента стека, используемого для эмуляции сопроцессора.
InOutRes используется встроенными программами ввода/вывода для запоминания значения, возвращаемого при последующем вызове стандартной функции IOResult.
RandSeed содержит опорное число генератора случайных чисел. При присваивании конкретного значения этой переменной функция Random будет генерировать строго определенную последовательность псевдослучайных чисел. Процедура Randomize заносит в переменную RandSeed текущее системное время и тем самым обеспечивает новую псевдослучайную последовательность при очередном прогоне программы.
FileMode позволяет изменить режим доступа, с которым открываются типизированные и нетипизированные файлы стандартной процедурой RESET. Текстовые файлы этой процедурой открываются только для чтения.
Seg0040 хранит сегмент участка памяти, который MS-DOS использует для размещения своих переменных.
SegA000 содержит сегмент начала видеопамяти для графического режима работы, a SegB000 и SegB800 -сегменты видеопамяти для текстового режима.
Selectorlnc используется как шаг наращивания т.н. селекторов - указателей, обеспечивающих линейную модель памяти.
Test8086 хранит результат теста автообнаружения процессора Intel 80x86, a Test8087 - сопроцессора.
Константы регистра флагов
Следующие константы используются для проверки отдельных битов флага в регистре Flags после вызова Intr или MSDOS:
const
FCarry= $0001; FAuxiliary = $0010; FSign = $0080;
FParity= $0004; FZero = $0040; FOverFlow = $0800;
Константы режима доступа к файлу
const
fmClosed =$D7BO; {Маска режима файл закрыт}
fmInput =$D7B1; {Маска режима открыт для чтения}
fmOutput =$D7B2; {Маска режима открыт для записи}
fmInOut =$D7B3; {Маска режима открыт для чтения и записи}
Константы атрибутов файла
const
Readonly = $01;{Маска только для чтения}
Hidden = $02;{Маска скрытого файла}
SysFile = $04;{Маска системного файла}
VolumelD = $08;{Маска заголовка тома}
Directory= $10;{Маска каталога}
Archive = $20;{Маска архивного, файла}
AnyFile = $3F;{Маска любого файла}
Константы регистра флагов
Следующие константы используются для проверки отдельных битов флага в регистре Flags после вызова Intr или MSDOS:
const
FCarry= $0001; FAuxiliary = $0010; FSign = $0080;
FParity= $0004; FZero = $0040; FOverFlow = $0800;
Константы режима доступа к файлу
const
fmClosed =$D7BO; {Маска режима файл закрыт}
fmInput =$D7B1; {Маска режима открыт для чтения}
fmOutput =$D7B2; {Маска режима открыт для записи}
fmInOut =$D7B3; {Маска режима открыт для чтения и записи}
Константы атрибутов файла
const
Readonly = $01;{Маска только для чтения}
Hidden = $02;{Маска скрытого файла}
SysFile = $04;{Маска системного файла}
VolumelD = $08;{Маска заголовка тома}
Directory= $10;{Маска каталога}
Archive = $20;{Маска архивного, файла}
AnyFile = $3F;{Маска любого файла}
Константы режима работы
Константы цветов
const
Black = 0;{Черный}
Blue = 1;{Синий}
Green = 2;{Зеленый}
Cyan = 3;{Голубой}
Red = 4;{Красный}
Magenta = 5;{Фиолетовый}
Brown = 6;{Коричневый}
LightGray = 7;{Светло-серый}
DarkGray = 8;{Темно-серый}
LightBlue = 9;{Ярко-синий}
LightGreen = 10;{Ярко-зеленый}
LightCyan = 11;{Ярко-голубой}
LightRed = 12;{Розовый}
LightMagenta= 13;{Малиновый}
Yellow = 14;{Желтый}
White = 15;{Белый}
Blink = 128;{Мерцание символа}
Значения ошибок, возвращаемые GraphResult
const
grOk = 0;{Нет ошибок}
grNoInitGraph = -1;{Графика не инициализирована}
grNotDetected = -2;{Графическое устройство не обнаружено}
grFileNotFound = -3;{Файл драйвера устройства не найден}
grInvalidDriver= -4;{Неправильный файл драйвера устройства}
grNoLoadMem = - 5;{Нет памяти для загрузки драйвера}
grNoScanMem = - 6;{Нет памяти для просмотра областей}
grNoFloodMem = -7;{Нет памяти для закраски областей}
grFontNotFound = -8;{Файл шрифта не найден}
grNoFontMem = - 9;{Нет памяти для загрузки шрифта}
grInvalidMode =-10;{Недопустимый графический режим}
grError =-11;{Общая ошибка}
grIOerror =-12;{Ошибка графического ввода/вывода}
grInvalidFont =-13;{Неверный файл шрифта}
grInvalidFontNum=-14;{Неверный номер шрифта}
Константы цвета
LightMagenta= 13;{Малиновый}
Yellow = 14;{Желтый}
White = 15;{Белый}
Следующие константы цветов могут быть использованы с SetRGBPalette для выбора цветов на графическом адаптере IBM 8514:
const
EGABlack = 0;{Темные цвета}
EGABlue = 1;
EGAGreen = 2;
EGACyan = 3;
EGARed = 4;
EGAMagenta = 5;
EGALightGray = 7;
EGABrown = 20;
EGADarkGray = 56;{Светлые цвета}
EGALightBlue = 57;
EGALightGreen = 58;
EGALightCyan = 59;
EGALightRed = 60;
EGALightMagenta = 61;
EGAYellow = 62;
EGAWhite =63;
Константы типов и толщины линий
const
SolidLn=0;{Сплошная}
DottedLn=1;{Точечная}
CenterLn=2;{Штрихпунктирная}
DashedLn=3;{Пунктирная}
UserBitLn=4;{Тип определяется пользователем}
NormWidth=1;{Нормальная толщина}
ThickWidth= 3;{Тройная толщина}
Константы управления шрифтом
const
DefaultFont = 0;{Матричный шрифт 8x8}
TriplexFont = 1;{Шрифт триплекс; файл TRIP.CHR}
SmallFont = 2;{Мелкий шрифт; файл LITT.CHR}
SansSerifFont= 3;{Прямой шрифт; файл SANS.CHR}
GothicFont = 4;{Готический шрифт; файл GOTH.CHR}
HorizDir = 0;{Горизонтальное направление}
Модуль CRT
Модуль Сrt содержит подпрограммы управления текстовым выводом на экран дисплея, звуковым генератором и чтения клавиатуры.
В режиме текстового вывода используются следующие координаты экрана: левый верхний угол экрана имеет координаты 1,1; горизонтальная координата возрастает слева направо, вертикальная - сверху вниз. Если на экране определено окно, все координаты определяются относительно границ окна. Исключением являются координаты процедуры Window установки границ окна, которые всегда задаются относительно границ экрана.
Для чтения клавиатуры используются две функции - KeyPressed и ReadKey. Функция KeyPressed определяет факт нажатия на любую клавишу и не приостанавливает дальнейшее исполнение программы. Функция
KeyPressed читает расширенный код нажатой клавиши. Если к моменту обращения к функции не была нажата ни одна клавиша, программа приостанавливает свою работу, ожидая действий пользователя.
Управление звуковым генератором строится по схеме Sound - Delay - NoSound. Процедура Sound включает звуковой генератор и заставляет его непрерывно генерировать звук нужного тона. Процедура Delay приостанавливает работу программы на заданное число миллисекунд реального времени. Процедура NtfSound отключает звуковой генератор.
Модуль DOS
>Модуль Dos реализует ряд очень полезных программ операционной системы и обработки файлов. Ни одна из программ модуля Dos не определена в стандартом Паскале и поэтому они размещены в собственном модуле.
Модуль Graph
Модуль Graph представляет собой мощную библиотеку графических подпрограмм универсального назначения, рассчитанную на работу с наиболее распространенными графическими адаптерами IBM-совместимых ПК. Подпрограммы модуля Graph обеспечивают различные режимы работы многорежимных адаптеров, полностью используют их цветовые возможности и разрешающую способность.
При исполнении графических программ требуется автономный драйвер графического адаптера (BGI-файл). Если программа использует штриховые шрифты, то кроме того нужен один или несколько шрифтовых файлов (CHR-файлы). При необходимости драйвер и шрифты могут быть включены в тело программы еще на этапе компиляции.
Графические драйверы поддерживают следующие графические адаптеры (и полностью совместимые с ними):
Для поддержки этих аппаратных средств используются следующие драйверы:
Во время выполнения программы процедура InitGraph автоматически распознает графический адаптер, установленный на ПК, загружает и инициализирует соответствующий графический драйвер, переводит адаптер в графический режим и возвращает управление вызывающей программе. Процедура CloseGraph выгружает драйвер из памяти и восстанавливает текстовый режим работы адаптера.
Подпрограммы модуля Graph позволяют адресоваться к любому элементу (пикселю) растрового графического экрана и управлять светимостью этого элемента. Для указания пикселя используется следующая система координат: верхний левый угол графического экрана имеет координаты 0,0; горизонтальная координата X увеличивается слева направо, вертикальная координата У увеличивается сверху вниз. Например, в режиме 640x480 (адаптер VGA) правый нижний угол экрана имеет координаты 639, 479, а центр экрана -координаты 319,239.
Некоторые графические подпрограммы используют понятие текущего указателя. Указатель содержит координаты того пикселя, начиная с которого будет строиться изображение подпрограммами LineTo, LineRel, OutText и др. В этом смысле указатель подобен текстовому курсору, но, в отличие от него, не имеет видимого изображения на экране.
Для вывода текстовых сообщений на графический экран модуль Graph предоставляет один матричный и 4 штриховых шрифтов. Каждый символ матричного шрифта на экране реализуется в виде матрицы из 8x8 пикселей. Штриховые шрифты для каждого символа определяют набор штрихов (векторов), с помощью которых на экране создается (вычерчивается) соответствующий символ. Штриховые шрифты позволяют изменять размеры текстовых надписей в широких пределах без существенного ухудшения качества изображения символов. Однако стандартные штриховые шрифты не содержат символы кириллицы.
В модуле Graph имеется несколько процедур для рисования элементарных графических фигур - точек, линий, окружностей, дуг и т.п. При необходимости замкнутые фигуры могут быть закрашены различными цветами и стилями (образцами закраски).
Процедура SetViewPort создает на экране графическое окно. Если окно определено, весь дальнейший графический вывод осуществляется относительно координат этого окна и отсекается его границами.
В модуле имеются средства сохранения и выдачи изображений, работы с несколькими графическими страницами, установки необходимых цветов.
Модуль SYSTEM
Модуль SYSTEM является основной библиотекой Турбо Паскаля. Он реализует подпрограммы для всех встроенных возможностей, таких как ввод/вывод, обработка строк, эмуляция арифметического сопроцессора, управление оверлеями и динамическое распределение памяти. Модуль SYSTEM используется автоматически любым модулем или программой и никогда не указывается в предложении USES.
Переменные
var
Input : Text;{Стандартный файл ввода}
Output : Text;{Стандартный файл вывода}
SaveInt00: Pointer;{Сохранение вектора $00}
.....
SaveInt75: Pointer;{Сохранение вектора $75}
Input и Output - стандартные файлы, необходимые в каждой реализации языка Паскаль. По умолчанию они ссылаются на стандартные входные и выходные файлы ДОС: Input - на клавиатуру, Output - на экран.
В момент загрузки среда Турбо Паскаля изменяет значения 18 векторов прерывания (векторы $00, $02, $1N, $21, $23, $24, $35, $36, $37, $38, $39, $ЗА, $ЗВ, $ЗС, $3D, $3E, $3F и $75). В переменных SaveIntXX сохраняются старые значения этих векторов (XX - номер вектора: SavelntOO - для вектора $00, SaveIntlB - для вектора $1В и т.д.).
var
GraphGetMemPrt : Pointer;{Распределение кучи}
GraphFreeMemPrt: Pointer;{Освобождение кучи}
Эти переменные указывают на программы управления кучей модуля Graph. Если Ваша программа использует собственный алгоритм управления памятью, присвойте адреса Ваших программ распределения и освобождения памяти переменным GraphGetMemPrt и GraphFreeMemPrt.
var
DosError : Integer;
Значение, запомненное в DosError, представляет собой код ошибки операционной системы:
0 - нет ошибки
2 - файл не найден
3 - путь не найден
5 - доступ запрещен
6 - неверный обработчик
8 - нет памяти
10 - неправильная среда
11 - неправильный формат
18 - больше нет файлов
var
DosError : Integer;
Значение, запомненное в DosError, представляет собой код ошибки операционной системы:
0 - нет ошибки
2 - файл не найден
3 - путь не найден
5 - доступ запрещен
6 - неверный обработчик
8 - нет памяти
10 - неправильная среда
11 - неправильный формат
18 - больше нет файлов
var
CheckBreak:Boolean;{Разрешает/запрещает контроль Ctrl-Break}
CheckEof:Boolean; {Разрешает/запрещает контроль Ctrl-Z}
CheckSnow:Boolean {Разрешает/запрещает контроль "снега"}
Directvideo:Boolean; {Разрешает/запрещает прямой доступ к видеопамяти}
LastMode:Word; {Хранит последний текстовый режим}
TextAttr:Byte; {Хранит текущий байт атрибутов}
WindMin:Word; {Координаты левого верхнего угла текущего окна} .
WindMax:Word; {Координаты правого нижнего угла}
Процедуры
Procedure Arc(X, Y: Integer; StAngle, EndAngle, Radius: Word) Рисует дугу радиусом Radius от начального угла StAngle к конечному EndAngle, используя X, Y как координаты центра.
Procedure Bar (X1, Y1, X2, Y2 : Integer) Рисует полосу заданного размера, используя текущий стиль и цвет.
Procedure Bar3D(X1, Y1, X2, Y2: Integer; Depth: Word; Top: Boolean) Рисует трехмерную полосу, используя текущий стиль и цвет.
Procedure Circle (X, Y: Integer; R: word) Рисует окружность радиуса R, используя X,Y как координаты центра.
Procedure ClearDevice Очищает экран.
Procedure ClearViewPort Очищает окно.
Procedure CloseGraph Закрывает графический режим.
Procedure DetectGraph (var Driver, Mode: Integer) Возвращает тип Driver установленного драйвера и текущий режим Mode его работы.
Procedure DrawPoly (NumPoints: Word; var PolyPoints) Рисует многоугольник из NumPoints вершин с координатами в PolyPoints текущим цветом и типом линии.
Procedure Ellipse (X, Y; Integer; StAngle, EndAngle, XR, YR: Word) Рисует эллиптическую дугу от начального угла StAngle к конечному углу EndAngle, используя X, Y как координаты центра и XR. YR - как горизонтальный и вертикальный радиусы.
Procedure FillEllipse(X, Y; Integer; XR, YR: Word) Рисует заштрихованный эллипс, используя X, Y как центр uXR, YR как горизонтальный и вертикальный радиусы.
Procedure FillPoly (NumPoints: word; var PolyPoints) Рисует и штрихует многоугольник, содержащий NPoints вершин с координатами в PolyPoints.
Procedure FloodFill (X, Y; Integer; Border; Word) Штрихует замкнутую область, содержащую внутреннюю точку с координатами X, Y и ограниченную линией с цветом Border. Используется текущий образец штриховки и цвет.
Procedure GetArcCoords (var ArcCoo: ArcCoordsType) Возвращает координаты центра, начала и конца дуги.
Procedure GetAspectRatio (var XAsp, YAsp: Word) Возвращает два числа, позволяющие оценить отношение сторон графического экрана (XAsp/YAsp).
Procedure GetDefaultPalette(var Palette; PaletteType) Возвращает текущую палитру в записи PaletteType.
Procedure GetFillPattern( var FillPatt: FillPatternType) Возвращает текущий образец штриховки.
Procedure GetFillSettings (var FillInfo: FillSettingsType) Возвращает текущий образец и цвет штриховки.
Procedure GetImage(X1, Y1, X2, Y2; Integer; var BitMap) Сохраняет в переменной BitMap битовый образ указанной части экрана.
Procedure GetLineSettings (var LineInfo; LineSettingsType) Возвращает текущий стиль, шаблон и толщину линии.
Procedure GetModeRange(GraphDriver: Integer; var LoMode, HiLode: Integer) Для графического драйвера GraphDriver возвращает диапазон возможных режимов работы.
Procedure GetPalette (var Palette: PaletteType) Возвращает текущую палитру и ее размер.
Procedure GetTextSettings (var TextInfo; TextSettingsType) Возвращает текущий шрифт, направление, размер и выравнивание текста, установленные процедурами SetTextStyle и SetTextJustify.
Procedure GetViewSettings (var viewport: NiewPortType) Возвращает координаты и признак отсечки текущего окна.
Procedure GraphDefaults Устанавливает стандартные параметры графического режима.
Procedure InitGraph(var Driver, Mode; Integer; Path: String) Инициализирует графический режим. Переменные Driver и Mode должны содержать тип графического драйвера и его режим работы. Допускается указать Driver = 0 для автоматического определения этих параметров по результатам тестирования аппаратуры. Параметр Path определяет маршрут поиска файла графического драйвера.
Procedure Line (X1, Y1, Х2, Y2: Integer) Рисует линию от точки X1, Y1 до точки Х2, Y2.
Procedure LineRel(DX, DY: Integer) Рисует линию от текущего указателя к точке, заданной приращением координат.
Procedure LineTo(X, Y: Integer) Рисует линию от текущего указателя к точке X, Y.
Procedure MoveRel (DX, DY) Смещает текущий указатель к точке, заданной приращением координат.
Procedure MoveTo(X, Y: Integer) Смещает текущий указатель к точкеX,Y.
Procedure OutText (TextString: String) Выводит текстовую строку на экран.
Procedure OutTextXY(X, Y: Integer; TextString: String) Выводит текст в заданное место экрана.
Procedure PieSlice(X, Y: Integer; StAngle, EndAngle, Radius: Word) Рисует и штрихует сектор окружности радиусом Radius с центром в X.Y от начального угла StAngle к конечному углу EndAngle.
Procedure PutImage(X, Y: Integer; var BitMap; BitBlt: Word) Выводит битовый образ на экран.
Procedure PutPixel(X, Y; Integer; Color: Word) Выводит точку цветом Color с координатами X. Y.
Procedure Rectangle (XI, Yl, X2, Y2: Integer) Рисует прямоугольник, используя текущий цвет и тип линии.
Procedure RestoreCRTMode Восстанавливает текстовый режим работы экран.
Procedure Sector(X, Y: Integer; StAngle, EndAngle, XR, YR: Word) Рисует и штрихует сектор эллипса радиусами XR, YR с центром в X, Y от начального угла StAngle к конечному углу EndAngle.
Procedure SetActivePage(Page; Word) Устанавливает активную страницу для графического вывода.
Procedure SetAllPalette(var Palette) Изменяет все цвета палитры.
Procedure SetAspectRatio(XAsp, YAsp: Word) Изменяет масштабный коэффициент отношения сторон графического экрана.
Procedure SetBkColor (Color: Word) Устанавливает цвет фона.
Procedure SetColor (Color: Word) Устанавливает основной цвет, которым будет осуществляться рисование.
Procedure SetFillPattern (Pattern: FillPatternType; Color: Word) Устанавливает произвольный образец штриховки.
Procedure SetFillStyle (Pattern, Color: Word) Устанавливает образец штриховки и цвет.
Procedure SetGraphBuf Size (Size: Word) Позволяет изменить размер буфера для функций штриховки.
Procedure SetGraphMode(Mode: Integer) Устанавливает новый графический режим и очищает экран.
Procedure SetLineStyle(LineStyle, Pattern, Thickness: Word) Устанавливает толщину и стиль линии.
Procedure SetPalette(ColorNum, Color: Word) Заменяет цвет палитры с номером ColorNum на цвет Color.
Procedure SetRGBPallete(ColorNum, Red, Green, Blue: Integer) Позволяет модифицировать палитру для IBM 8514 и VGA.
Procedure SetText Justify (Horiz, Vert: Word) Устанавливает выравнивание текста, ис: пользуемое в процедурах OutText и OutTextXY.
Procedure SetTextStyle (Font, Direction, CharSize; Word) Устанавливает текущий шрифт, стиль и размер текста.
Procedure SetUserCharSize(MultX, DivX, MultY, DivY: Word) Изменяет пропорции шрифта.
Procedure SetViewPort (X1, Y1, X2, Y2: Integer; ClipOn; Boolean) Устанавливает текущее окно для графического вывода.
SetVisualPage(PageNo: Word) Устанавливает номер видимой графической страницы.
SetWriteMode(WriteMode; Integer) Устанавливает режим вывода (копирование или XOR) для линий, рисуемых процедурами DrawPoly, Line, LineRel, LineTo, Rectangle.
Стандартные библиотечные модули
Модуль SYSTEM
Константы
Переменные
Стандартные процедуры и функции
Модуль DOS
Константы
Типы
Переменные
Процедуры и функции
Модуль CRT
Константы
Переменные
Процедуры и функции
Модуль GRAPH
Константы
Типы
Переменные
Процедуры
Функции
Стандартные процедуры и функции
Процедуры управления
Procedure Break Обеспечивает немедленный выход из операторов повторения.
Procedure Continue Завершает очередной итерационный цикл операторов повторения.
Procedure Exit Позволяет немедленно выйти из текущей подпрограммы. При вызове из тела основной программы завершает ее работу.
Procedure Halt [ (ExitCode: Word)] Останавливает выполнение программы и возвращает управление в операционную систему. Необязательный параметр ExitCode определяет код завершения программы.
Procedure RunError [ (ErrorCode: Byte)] Останавливает выполнение программы и генерирует ошибку периода выполнения программы. Необязательный параметр ErrorCode определяет код ошибки.
Процедуры динамического распределения памяти
Procedure Dispose(var P: Pointer [,Destructor]) Уничтожает динамическую переменную, связанную с указателем Р. Необязательный параметр Destructor определяет метод-деструктор для динамического объекта.
Procedure FreeMem(var P: Pointer; Size: Word) Уничтожает динамическую переменную P размером Size байт.
Procedure GetMemtvar Р: Pointer; Size: Word) Создает новую динамическую переменную Р заданного размера Size.
Procedure Mark(var P: Pointer) Записывает в указателе Р текущее состояние кучи.
Procedure New(var P; Pointer [,Constructor]) Создает новую динамическую переменную, связанную с указателем Р. Необязательный параметр Constructor определяет метод-конструктор для динамического объекта.
Procedure Release (var P: Pointer) Возвращает кучу в состояние, которое было сохранено в указателе Р процедурой Mark.
Функции динамического распределения памяти
Function MaxAvail: LongInt Возвращает размер наибольшего непрерывного свободного блока кучи, соответствующий размеру наибольшей динамической переменной, которая может быть помещена в кучу.
Function MemAvail; LongInt Возвращает количество имеющихся в куче свободных байт памяти.
Функции преобразования
Процедуры Pack и UnPack, определенные в стандартном Паскале, в Турбо Паскале не реализованы. Function Chr(X: Byte): Char Возвращает символ с заданным порядковым номером X.
Function Ord(X) : LongInt Возвращает порядковый номер, соответствующий значению X порядкового типа.
Function Round (R: Real) : LongInt Округляет значение R вещественного типа до ближайшего целого.
Function Trunc(R: Real): LpngInt Усекает значение вещественного типа до значения типа LongInt путем отбрасывания дробной части.
Арифметические функции
При компиляции в режиме использования сопроцессора или его эмуляции арифметические функции возвращают значение типа EXTENDED, в противном случае - типа REAL.
Function Abs(R; Real): Real Возвращает абсолютное значение аргумента.
Function ArcTan(R: Real): Real Возвращает арктангенс аргумента.
Function Cos(R: Real): Real Возвращает косинус аргумента.
Function Exp(R; Real): Real Возвращает экспоненту аргумента.
Function Frac(R; Real): Real Возвращает дробную часть аргумента.
Function Int(R; Real): Real Возвращает целую часть аргумента.
Function Ln(R: Real) : Real Возвращает натуральный логарифм аргумента.
Function Pi: Real Возвращает значение числа pi=3.1415926535897932385.
Function Sin(R: Real): Real Возвращает синус аргумента.
Function Sqr(R: Real): Real Возвращает аргумент в квадрате.
Function Sqrt(R; Real): Real Возвращает квадратный корень аргумента.
Процедуры порядкового типа
Procedure Dec (var X [; DX: LongInt] ) Уменьшает значение переменной X на величину DX, а если параметр DX не задан - на 1.
Procedure Inc (var X [; DX: LongInt]) Увеличивает значение переменной X на величину DX, а если параметр DX не задан - на 1.
Функции порядкового типа
Function Odd(X) : Boolean Проверяет, является ли аргумент нечетным числом.
Function Pred(X) Возвращает предшествующее значение аргумента. Тип результата совпадает с типом аргумента.
Function Succ(X) Возвращает последующее значение аргумента. Тип результата совпадает с типом аргумента.
Строковые процедуры
Procedure Delete (var S: String; Index, Count: Integer) Удаляет Count символов из строки S, начиная с позиции Index.
Procedure Insert (SubS: String; var S: String; Index: Integer) Вставляет подстроку SubS в строку 5, начиная с позиции Index.
Procedure Str(X [: width [: Decimals]]; var S: String) Преобразует численное значение X в его строковое представление S.
Procedure Val(S; String; var X; var Code: Integer) Преобразует строковое значение S в его численное представление X. Параметр Code -содержит признак ошибки преобразования (0 - нет ошибки).
Строковые функции
Function Concat(S1 [, S2,...,SN]): String Выполняет конкатенацию последовательности строк.
Function Copy(S: String; Index, Count: Integer): String Возвращает подстроку из строки S, начиная с позиции Index и длиной Count символов.
Function Length(S: String): Byte Возвращает текущую длину строки S.
Function Pos(SubS, S: String): Byte Возвращает позицию, начиная с которой в строке S располагается подстрока SubS (О - S не содержит SubS).
Функции для работы с указателями и адресами
Function Addr (X) : Pointer Возвращает адрес заданного объекта X.
Function Assigned: (var P) : Boolean Проверяет, хранит ли ли указатель Р значение, отличное от NIL, и возвращает TRUE в этом случае.
Function CSeg: Word Возвращает текущее значение регистра CS. Function DSeg: Word Возвращает текущее значение регистра DS. Function Of s (X) ; Word Возвращает смещение заданного объекта.
Function Ptr(Seg, 0£s: Word): Pointer Преобразует сегмент Seg и смещение Ofs в значение типа указатель.
Function Seg (X) : Word Возвращает сегмент для заданного объекта X.
Function SPtr: Word Возвращает текущее значение регистра SP.
Function SSeg: Word Возвращает текущее значение регистра SS.
Процедуры разного назначения
Procedure Exclude (var S: set of Т; I: T) Исключает элемент T из множества S.
Procedure FillChar(var X; Count: Word; Value) Заполняет заданное количество Count последовательных байт переменной X указанным значением Value (выражение любого порядкового типа).
Procedure Include (var S: set of Т; I; T) Включает элемент T во множество 5.
Procedure Move (var X, Y,- Count: Word) Копирует заданное количество последовательных байт из источника X в переменную Г.
Procedure Randomize Инициализирует случайным значением ( текущим системным временем) встроенный генератор псевдослучайных чисел.
Функции разного назначения
Function Hi(X; Word) : Byte Возвращает старший байт аргумента X. Function High (X) Возвращает максимальное значение порядкового типа. Function Lo(X: Word): Byte Возвращает младший байт аргумента X. Function Low(X) Возвращает минимальное значение порядкового типа.
Function ParamCount: Word Возвращает число параметров, переданных программе в командной строке (строке вызова).
Function ParamStr(N; Byte): String Возвращает N-ый параметр командной строки.
Function Random [ (Range: Word)] Возвращает псевдослучайное число. Если параметр Range опущен, функция возвращает вещественное число в диапазоне от 0 до 1, если указан - целое число в диапазоне от 0 до Range-1.
Function SizeOf(X): Word Возвращает число байт, занимаемых аргументом.
Function Swap(X) Производит перестановку старших и младших байт двухбайтного аргумента X. Тип функции соответствует типу аргумента.
Function UpCase(C: char): Char Преобразует латинскую букву в заглавную.
Процедуры ввода/вывода
Procedure Assign (var F; Name: String) Связывает внешний файл Name с файловой переменной F.
Procedure ChDir(S: String) Устанавливает текущий каталог.
Procedure Close (var F) Закрывает открытый файл.
Procedure Erase (var F) Удаляет внешний файл.
Procedure GetDir(D: Byte; var S: String) Возвращает каталог по умолчанию S на заданном диске D.
Procedure MkDirtS: String) Создает подкаталог S.
Procedure Rename (var F) Переименовывает внешний файл.
Procedure Reset (var F) Открывает существующий файл для чтения или изменения.
Procedure Rewrite (var F) Создает и открывает новый файл.
Procedure RmDir(S: String) Удаляет пустой подкаталог.
Procedure Seek (var F; N: LongInt) Устанавливает текущую позицию файла на указанный элемент (не используется с текстовыми файлами).
Procedure Truncate (var F) Усекает размер файла до текущей позиции в файле (не используется с текстовыми файлами)
Функции ввода/вывода
Function EOF (var F) ; Boolean Возвращает для файла F признак конца файла.
Function FilePos (var F) : LongInt Возвращает текущую позицию в файле (не используется с текстовыми файлами)
Function FileSize(var F) : LongInt Возвращает текущий размер файла (не используется с текстовыми файлами).
Function IQResult; Integer Возвращает целое значение, являющееся состоянием последней выполненной операции ввода/вывода.
Процедуры для текстовых файлов
Procedure Append (var F: Text) Открывает существующий файл для расширения.
Procedure Flush (var F: Text) Выталкивает буфер файла вывода.
Procedure Read ([var F: Text;] V1 [, V2,...,VN]) Считывает одно или более значений из текстового файла в одну или более переменных.
Procedure Readln Выполняет те же действия, что и Read, а потом делает пропуск до начала следующей строки файла.
Procedure SetTextBuf (var F: Text; var Buf [; Size: Word]) Назначает буфер ввода/вывода для текстового файла. Параметр Size определяет длину буфера в байтах (если Size опущен, длина буфера равна 128 байтам).
Procedure Write([var F: Text;] V1 [, V2,...,VN]) Записывает в текстовый файл одно или более значений.
Procedure WriteLn Выполняет те же действия, что и Write, а затем добавляет к файлу маркер конца строки.
Функции для текстовых файлов
Function Eolntvar F: Text): Boolean Возвращает признак конца строки.
Function SeekEof [ (var F: Text)]: Boolean Возвращает признак конца файла. Предварительно пропускает все пробелы, символы табуляции и признаки конца строк.
Function SeekEoln [ (var F: Text)]: Boolean Возвращает признак конца строки. В отличие от Eoln предварительно пропускает все пробелы и символы табуляции.
Процедуры для нетипизированных файлов
Procedure BlockRead(var F: File; var Buf; Count; Word [;var Result; Word])
Считывает в переменную Buf Count записей из файла F. Необязательный параметр Result содержит истинное количество считанных записей.
Procedure BlockWrite(var F; File; var Buf; Count: Word [;var Result: Word])
Передает Count записей из переменной Bufe файл F. Необязательный параметр Result содержит истинное количество переданных записей.
Типы
type
{Типизированные и нетипизированные файлы}
FileRec = record
Handle : Word;
Mode : Word;
RecSize : Word;
Private : array [1..6] of Byte;
UserData : array [1..16] of Byte;
Name : array [0..79] of Char;
end ;
{Текстовые файлы}
TextBuf = array [0..127] of Char;
TextRec = record
Registers = record
case Integer of
0: (AX, BX, CX, DX, BP, SI, DI, DS, ES, Flags: Word);
1: (AL, AH, BL, BH, CL, CH, DL, DH: Byte);
end;
DataTime = record
Year, Month, Day, Hour, Min, Sec: Integer;
end;
SearchRec = record
File: array [1..21] of Byte;
Attr: Byte;
Time: Longlnt;
Size: Longlnt;
Name: String [12] ;
end;
DirStr = String [67];{Диск и каталог}
NarneStr = String [8] ;{Имя файла}
ExtStr = String [4];{Расширение файла}
ComStr = String [127] ;{Командная строка}
PathStr = String [79];{Полный маршрут поиска файла}
type
{Типизированные и нетипизированные файлы}
FileRec = record
Handle : Word;
Mode : Word;
RecSize : Word;
Private : array [1..6] of Byte;
UserData : array [1..16] of Byte;
Name : array [0..79] of Char;
end ;
{Текстовые файлы}
TextBuf = array [0..127] of Char;
TextRec = record
Registers = record
case Integer of
0: (AX, BX, CX, DX, BP, SI, DI, DS, ES, Flags: Word);
1: (AL, AH, BL, BH, CL, CH, DL, DH: Byte);
end;
DataTime = record
Year, Month, Day, Hour, Min, Sec: Integer;
end;
SearchRec = record
File: array [1..21] of Byte;
Attr: Byte;
Time: Longlnt;
Size: Longlnt;
Name: String [12] ;
end;
DirStr = String [67];{Диск и каталог}
NarneStr = String [8] ;{Имя файла}
ExtStr = String [4];{Расширение файла}
ComStr = String [127] ;{Командная строка}
PathStr = String [79];{Полный маршрут поиска файла}
type
PaletteType = record {Используется в GetPallete}
Size : Byte;
Colors : array [0..MaxColors] of Shortlnt;
end;
LineSettingsType = record {Используется в GetLineSettings}
LineStyle Word;
Pattern Word;
Thickness Word;
end;
TextSettingsType = record {Используется в GetTextSettings}
Font :Word;
Direction : Word;
CharSize : Word;
Horiz : Word;
Vert : Word;
end;
FillSettingsType = record {Используется в GetFillSettings}
Pattern : Word;
Color : Word;
end;
FillPatternType = array [1..8] of Byte;
PointType = record {Для задания координат многоугольников}
X,Y: Integer;
end;
ViemPortType = record {Используется в GetViewSettings}
X1, Y1, X2, Y2: Integer;
Clip : Boolean;
end;
ArcCoordsType = record {Используется в GetArcCoords}
X, У : Integer;
Xstart, Ystart: Integer;
Xend, Yend : Integer;
end;
Игра Ним
Описание программы см, п.2.7.3.
Uses CRT; {Подключение библиотеки дополнительных
процедур и функций для управления экраном}
const
MAXROW = 14; {Максимальное количество рядов}
MAXCOL = 20; {Максимальное количество фишек в ряду}
type
ColType = array [1.. MAXROW] of Integer;
var
exit : Boolean; {Признак окончания работы}
change : Boolean; {Признак изменения условий игры}
nrow : Integer; { Количество рядов}
ncol : ColType; {Максимальное количество фишек по рядам}
col : ColType; {Текущее количество фишек по рядам}
{-----------------}
Procedure ShowField;
{Отображает на экране текущее состояние игрового поля}
const
FISH = #220; {Символ-указатель фишки}
Х0 =4; {Левая колонка номеров рядов}
X1 = 72; {Правая колонка количества фишек}
X =20; {Левый край игрового поля}
var
i,j : Integer;
begin {ShowField}
for i := 1 to nrow do
begin
GotoXY(X0,i+4) ;
write(i); {Номер ряда}
GotoXY(Xl,i+4) ;
write (col [i] :2) ; {Количество фишек в ряду}
for j := 1 to ncol [i] do {Вывод ряда фишек:}
begin
GotoXY(X+2*j,i+4) ;
if j<=col[i] then write (FISH) else write ( ' . ' )
end
end
end; {ShowField}
{---------------}
Procedure Prepare;
{ Подготовка данных и формирование экрана }
const
Header0='ИГРА НИМ';
Header1=' Вы можете взять любое число фишек из любого ряда.';
Header2='Выигрывает тот, кто возьмет последнюю фишку.';
Header3='Номер ряда';
Header4='Кол-во фишек';
var
i : Integer;
begin {Prepare}
ClrScr;{Очищаем экран }
{Выводим заголовок:}
GotoXY( (80 -Length (Header0))div 2,1);
write (Header0) ;
GotoXY( (80-Length(Headerl))div 2,2);
write (Header1) ;
GotoXY( (80-Length(Header2))div 2,3);
writeln(Header2) ;
write (Header3) ;
GotoXY (80- Length ( Header 4 ) , 4 ) ;
write (Header4) ;
{Подготовить начальную раскладку: }
for i := 1 to nrow do col [i] := ncol [i]
end; {Prepare}
{-----------------}
Procedure GetPlayerMove;
{Получить, проконтролировать и отобразить ход игрока }
const
ТЕХТ1 = 'Введите Ваш ход в формате РЯД КОЛИЧ ' +
'(например, 2 3 - взять из 2 ряда 3 фишки)';
ТЕХТ2='или введите 0 0 для выхода из игры; -1 0 для настройки
игры'; ТЕХТЗ=' Ваш ход: ';
Y=20; {номер строки для вывода сообщений}
var
correctly : Boolean;{признак правильности сделанного хода}
xl,x2 : Integer;{вводимый ход}
{-------------------}
Procedure GetChange;
{ Ввести новую настройку игры (количество рядов и количество
фишек в каждом ряду}
const
t1= 'НАСТРОЙКА ИГРЫ';
t2= '(ввод количества рядов и количества фишек в каждом ряду)';
var
correctly : Boolean;
i : Integer;
begin {GetChange}
clrscr;
GotoXY((80-Length (t1)) div 2,1);
write(t1);
GotoXY((80-Length(t2)) div 2,2);
write(t2);
repeat
GotoXY(1,3);
write('Введите количество рядов (максимум ',MAXROW,'): ');
GotoXY(WhereX-6,WhereY);
readln(nrow);
correctly := (nrow<=MAXROW) and (nrow>1);
if not correctly then
write (#7)
until correctly;
for i : = 1 to nrow do
repeat
GotoXY(1,i+3) ;
write ('ряд',i,',количество фишек(максимум',MAXCOL,'): ');
GotoXY (Wherex- 6, WhereY) ;
readlntncol [i] ) ;
correctly := (ncol [i] <=MAXCOL) and (ncol [i] >0) ;
if not correctly then
write (#7)
until correctly
end; {GetChange}
{-------------------}
begin {GetPlayerMove}
ShowField; {Показать начальное состояние поля }
{ Сообщить игроку правила ввода хода: }
GotoXY ( (80 -Length (TEXT1) ) div 2,Y);
write (TEXT1) ;
GotOXY( (80-Length(TEXT2) ) div 2, Y+1);
write (TEXT2) ;
repeat
{ Пригласить игрока ввести ход: }
GotoXY (1, Y+2) ;
Write (ТЕХТЗ ); {вывести приглашение и стереть предыдущий ход}
GotoXY (WhereX-1 6, Y+2) ; {курсор влево на 16 позиций}
ReadLn (x1 , х2 ) ; {ввести очередной ход}
exit := x1=0; {контроль команды выхода}
change := x1=-1; {контроль команды изменения}
if not (exit or change) then
begin
correctly := (x1>0) and (x1<=nrow) and
(x2<=col [x1] ) and (x2>0) ;
if correctly then
begin {ход правильный: }
col [x1] := col[x1]-x2; {изменить раскладку фишек}
ShowField {показать поле}
end
else
write (#7) { ход неправильный: дать звуковой сигнал }
end
else
correctly := true {случай EXIT или CHANGE}
until correctly;
if change then
GetChange
end; {GetPlayerMove}
{--------------------------------}
Procedure SetOwnerMove;
{ Найти и отобразить очередной ход программы }
{------------------}
Function CheckField : Integer;
{ Проверка состояния игры. Возвращает 0, если нет ни одной
фишки (победа игрока) , 1 - есть один ряд (победа машины) и
количество непустых рядов в остальных случаях }
var
i,j : Integer;
begin {CheckField}
j := 0;
for i := 1 to nrow do if col[i]>0 then inc(j);
CheckField := j
end; {CheckField}
{--------------------}
Procedure CheckPlay;
{ Контроль окончания игры }
var
i : Integer;
begin {CheckPlay}
GotoXY(1,25) ;
write ( 'Введите 1, если хотите сыграть еще раз, 0 - выход:');
readln(i);
if i=l then change := true else exit := true
end; {CheckPlay}
{--------------------}
Procedure PlayerVictory;
{ Поздравить игрока с победой и усложнить игру }
const
t1 = 'ПОЗДРАВЛЯЮ С ОТЛИЧНОЙ ПОБЕДОЙ!'; var i : Integer; begin
GotoXY( (80-Length(t1) ) div 2,24);
writeln(t1,#7) ;
for i : = 1 to nrow do
if ncol [i] <MAXROW then inc (ncol [i] ) ;
CheckPlay
end; {PlayerVictory}
{---------------------}
Procedure OwnVictory;
{ Победа машины }
const
t1 = 'ВЫ ПРОИГРАЛИ: СЛЕДУЮЩИМ ХОДОМ Я БЕРУ ВЕСЬ РЯД';
var
i : Integer;
begin {OwnVictory}
i := 1;
while col[i]=0 do inc(i);
GotoXY( (80-Length(t1) ) div 2,24);
write(t1,i,#7);
delay (2000); {задержка на 2 секунды}
col [i] := 0;
ShowField;
CheckPlay
end; {OwnVictory}
{--------------------}
Procedure ChooseMove;
{ Выбор очередного хода }
const
BIT = 6; {количество двоичных разрядов}
type
BitType = array [1..BIT] of Integer;
var
ncbit : array [1..MAXROW] of BitType;
i,j,k : Integer;
nbit : BitType;
{------------------}
Procedure BitForm(n : Integer; var b : BitType);
{ Формирует двоичное представление b целого числа n }
var
i : Integer;
begin {BitForm}
for i := BIT downto 1 do
begin
if odd(n) then b[i] := 1 else b[i] := 0;
n := n shr 1
end
end; {BitForm}
{------------------}
begin {ChooseMove}
{ Найти двоичное представление количества фишек во всех рядах:}
for i := 1 to nrow do BitForm(col [i] ,ncbit [i] ) ;
{Найти сумму разрядов по модулю 2:}
for i := 1 to BIT do
begin
nbitti] := 0;
for j := 1 to nrow do nbitti] := nbitti] xor ncbit [j / i]
end;
{Найти i = старший ненулевой разряд суммы}
i := 1;
while nbitti] =0 do inc(i);
if i>BIT then
{Опасный вариант}
begin j := 1;
while col[j]=0 do inc(j); {найти ненулевой ряд}
k := 1 {взять из него 1 фишку}
end
else
{Безопасный вариант}
begin j := 1;
while ncbit [j,i]=0 do inc(j); {найти нужный ряд}
for i := i to BIT do
if nbit[i] =1 then
ncbit [j,i] := ord (ncbit [j , i] =0) ; {инверсия разрядов}
k := 0;
for i := 1 to BIT do
begin
if ncbit [j,i]=1 then inc(k);
if i<BIT then k := k shl 1
end;
k := col [j] - k
end;
GotoXY(1,23);
write('Мой ход: ');
GotoXY(WhereX-8,WhereY);
delay (.1000) ;
write (j, ' ' ,k) ;
col[j] := col[j] -k
end; {ChooseMove}
{-------------------}
begin {SetOwnerMove}
case CheckField of {проверить количество непустых рядов}
0 : PlayerVictory; {все ряды пусты - Победа игрока}
1 : OwnVictory; {один непустой ряд - победа машины}
else
ChooseMove; {выбрать очередной ход}
end;{case}
end; {SetOwnerMove}
{--------------}
begin {Главная программа}
nrow : = 3 ; { Подготовить игру }
ncol [1] := 3; { на поле из трех }
ncol [2] := 4; { рядов фишек }
ncol [3] := 5;
repeat{ Цикл изменения условий игры }
Prepare; { Подготовить экран }
repeat { Игровой цикл }
GetPlayerMove; { Получить ход пользователя }
if not (exit or change) then
SetOwnerMove { Определить собственный ход }
until exit or change
until exit
end.
Определение биоритмов
{Программа для определения физической, эмоциональной и интеллектуальной активности человека. Вводится дата рождения и текущая дата. Программа вычисляет и выводит на экран общее количество дней, часов, минут и секунд, разделяющих обе даты, а также прогнозирует на месяц вперед даты, соответствующие максимуму и минимуму биоритмов. Описание программы см. п. 2. 7. 2.}
const
Size_of_Month: array [1..12] of Byte =
(31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31);
var
d0, d,{Дни рождения и текущий}
m0, m,{Месяцы рождения и текущий}
y0, y,{Годы рождения и текущий}
dmin,{Наименее благоприятный день}
dmax,{Наиболее благоприятный день}
days: Integer;{Количество дней от рождения}
{--------------------------}
Procedure InputDates(var d0,m0,y0,d,m,y : Integer);
{Вводит дату рождения и текущую дату. Контролирует правильность дат и их непротиворечивость(текущая дата должна быть позже
даты рождения)}
var
correctly: Boolean; {Признак правильного ввода}
{-------------------}
Procedure InpDate(text: String; var d,m,y: Integer);
{Выводит приглашение TEXT, вводит дату в формате ДД ММ ГГГГ и
проверяет ее правильность}
const
YMIN =1800; {Минимальный правильный год}
YMAX =2000; {Максимальный правильный год}
begin {InpDate}
repeat
Write(text);
ReadLn(d,m,y);
correctly := (y >= YMIN) and (Y <= YMAX) and (m >= 1)
and (m <= 12) and (d > 0);
if correctly then
if (m = 2) and (d = 29) and (y mod 4=0)
then
{Ничего не делать: это 29 февраля високосного года!}
else
correctly := d <= Size_of_Month[m];
if not correctly then
WriteLn('Ошибка в дате!')
until correctly
end; {InpDate}
{----------------}
begin {InputDates}
repeat
InpDate('Введите дату рождения в формате ДД ММ ГГГГ:',d0,m0,y0);
InpDate(' Введите текущую дату: ', d, m, у);
{Проверяем непротиворечивость дат:}
correctly := у > у0;
if not correctly and (y = y0) then
begin
correctly := m > m0;
if not correctly and (m = m0) then
correctly := d >= d0
end
until correctly
end; {InputDates}
{-----------------}
Procedure Get_number s_of_days (d0,m0, y0,d,m, у : Integer; var days: Integer);
{ Определение полного количества дней, прошедших от одной даты до другой }
{-------------------}
Procedure Variant2 ;
{Подсчет количества дней в месяцах, разделяющих обе даты }
var
mm : Integer;
begin {Variant2}
mm : = m0 ;
while mm < m do
begin
days := days + Size_of_Month[mm] ;
if (mm = 2) and (y0 mod 4=0) then
inc(days) ;
inc (mm)
end
end; {Variant2}
{---------------}
Procedure Variant3 ;
{Подсчет количества дней в месяцах и годах,
разделяющих обе даты}
var
mm, yy : Integer;
begin {variant3}
mm := m0 + 1;
while mm <= 12 do {Учитываем остаток года рождения:}
begin
days := days+Size_of_Month[mm] ;
if (mm = 2) and (yO mod 4=0) then
inc (days) ;
inc (mm)
end;
yy := y0 + 1;
while yy < у do {Прибавляем разницу лет:}
begin
days := days + 365;
if yy mod 4=0 then
inc (days) ;
inc (yy)
end;
mm : = 1 ;
while mm < m do {Прибавляем начало текущего года:}
begin
days := days + Size_of_Month[mm] ;
if (y mod 4=0) and (mm = 2) then
inc (days) ;
inc (mm)
end
end; {Variant3}
{--------------------}
begin {Get_numbers_of_days}
if (y = y0) and (m = m0) then {Даты отличаются только днями:}
days := d - d0
else {Даты отличаются не только днями: }
begin
days := d + Size_of_Month[m0] - d0;
{Учитываем количество дней в текущем месяце и количество дней
до конца месяца рождения}
if (y0 mod 4=0) and (m0 = 2) then
inc (days) ; {Учитываем високосный год}
if у = y0 then
Variant2 {Разница в месяцах одного и того же года}
else
Variant3 {Даты отличаются годами}
end
end; {Get_numbers_of_days}
{-------------------}
Procedure FindMaxMin(var dmin, dmax: Integer; days: Integer) ;
{Поиск критических дней}
const
TF = 2*3.1416/23.6884; {Период физической активности}
ТЕ = 2*3.1416/28.4261; {Период эмоциональной активности}
TI = 2*3.1416/33.1638; {Период интеллектуальной активности}
INTERVAL = 30;{Интервал прогноза}
var
min,{Накапливает минимум биоритмов}
max,{Накапливает максимум биоритмов}
x : Real;{Текущее значение биоритмов}
i : Integer;
begin {FindMaxMin}
max := sin(days*TF)+sin(days*TE)+sin(days*TI);
min := max; {Начальное значение минимума и максимума
равно значению биоритмов для текущего дня}
dmin := days;
dmax := days ;
for i := 0 to INTERVAL do
begin
x := sin((days+i)*TF) + sin((days+i)*TE) +
sin((days+i)*TI);
if x > max then
begin
max := x;
dmax := days + i
end
else
if x < min then
begin
min := x;
dmin := days + i
end
end;
end; {FindMaxMin}
{----------------}
Procedure WriteDates (dmin, dmax, days : Integer);
{Определение и вывод дат критических дней. Вывод дополнительной
информации о количестве прожитых дней, часов, минут и секунд }
{-------------}
Procedure WriteDatettext: String; dd: Integer);
{Определение даты для дня DD от момента рождения. В глобальных
переменных d, m и у имеется текущая дата, в переменной DAYS -
количество дней, прошедших от момента рождения до текущей даты.
Выводится сообщение TEXT и найденная дата в формате ДД-МЕС-ГГГГ}
const
Names_of_Monthes : array [1..12] of String [3] = ( ' янв ' , ' фев ' , ' мар ' , ' апр ' , ' мая '' июн ',
' июл ' , ' авг ' , ' сен ' , ' окт ' , ' ноя ',' дек ' ) ;
var
d0,m0,y0,ddd : Integer;
begin {WriteDate}
d0 := d;
m0 := m;
y0 := y;
ddd := days;
while ddd<>dd do
begin
inc(d0); {Наращиваем число}
if (y0 mod 4 <> 0) and (d0 > Size_of_Month [m0] ) or
(y0 mod 4=0) and (d0=30) then
begin{Корректируем месяц}
d0 := 1;
inc(m0);
if m0 = 13 then{Корректируем год}
begin
m0 := 1;
inc(y0)
end
end;
inc(ddd)
end;
WriteLn(text,d0, ' - ' , Names_of_Monthes [m0] , ' - ' ,y0)
end; {WriteDate}
{------------------}
var
LongDays: Longlnt; {"Длинная" целая переменная для часов,
минут и секунд }
begin {WriteDates}
LongDays := days;
WriteLn ( ' Пропшо : ', LongDays,' дней, ' , longDays*24,
' часов, ',LongDays*24*60,'минут,',LongDays*24*60*60,'секунд');
WriteDate (' Наименее благоприятный день: ',dmin);
WriteDate ( 'Наиболее благоприятный день: ',dmax)
end ; { WriteDates}
{------------------}
begin {Главная программа}
InputDates (d0,m0,y0,d, m, у) ;
Get_numbers_of_days (d0,m0,y0,d,m,y,days) ;
FindMaxMin (dmin, dmax, days) ;
WriteDates (dmin, dmax, days)
end .
Программа Notebook
Описание программы см. п.. 15.
Program Notebook;
{Программа обслуживает файлы данных "записной книжки". Описание программы см. в гл.15}
Uses App, Objects, Menus, Drivers, Views, StdDlg,
DOS, Memory, Dialogs; type
{Объект TWorkWin создает рамочное окно с полосами скроллинга для управления встроенным в него объектом TInterior}
PWorkWin =TWorkWin;
TWorkWin = object (TWindow)
Constructor Init(Bounds: TRect);
end;
{Объект TDlgWin создает диалоговое окно для
выбора режима работы}
PDlgWin =TDlgWin;
TDlgWin = object (TDialog)
Procedure HandleEvent(var Event: TEvent); Virtual;
end;
{Следующий объект обслуживает внутреннюю часть рамочного
окна TWorkWin. Он создает скроллируемое окно с записями из
архивного файла и с помощью диалогового окна TDlgKin
управляет работой с этими записями}
PInterior =TInterior;
TInterior = object (TScroller)
PS: PStringCollection;
Location: Word;
Constructor Init(var Bounds: TRect; HS,VS: PScrollBar);
Procedure Draw; Virtual;
Procedure ReadFile;
Destructor Done; Virtual;
Procedure HandleEvent(var Event: TEvent); Virtual;
end;
{Объект-программа TNotebook поддерживает работу с меню и
строкой статуса}
TNotebook = object (TApplication)
Procedure InitStatusLine; Virtual;
Procedure InitMenuBar; Virtual;
Procedure HandleEvent(var Event: TEvent); Virtual;
Procedure FileSave;
Procedure ChangeDir;
Procedure DOSCall;
Procedure FileOpen;
Procedure Work;
end;
const
{Команды для обработчиков событий:}
cmChDir = 202; {Сменить каталог}
cmWork = 203; {Обработать данные}
cmDOS= 204; {Временно выйти в ДОС}
cmCan= 205; {Команда завершения работы}
cmDelete= 206; {Уничтожить текущую запись}
cmSearch = 207;{Искать нужную запись}
cmEdit = 209;{Редактировать запись}
cmAdd = 208;{Добавить запись}
{Множество временно недоступных команд:}
WinCom1: TCommandSet = [cmSave,cmWork];
WinCom2: TCommandSet = [cmOpen];
LName = 25; {Длина поля Name}
LPhone= 11; {Длина поля Phone}
LAddr =40; {Длина поля Addr}
LLine = LName+LPhone+LAddr; {Длина строки}
type
DataType = record {Тип данных в файле}
Name : String [LName]; {Имя}
Phone: String [LPhone]; {Телефон}
Addr : String [LAddr] {Адрес}
end;
var
DataFile: file of DataType; {Файловая переменная}
OpFileF : Boolean; {Флаг открытого файла}
{-----------------------}
Реализация объекта TWorkWin
{-----------------------}
Constructor TWorkWin.Init(Bounds: TRect);
{Создание окна данных}
var
HS,VS: PScrollBar; {Полосы-указатели}
Interior: PInterior; {Указатель на управляемое текстовое окно}
begin
TWindow.Init(Bounds,0);{Создаем новое окно с рамкой}
GetClipRect(Bounds); {Получаем в BOUNDS координаты минимальной перерисовываемой части окна}
Bounds.Grow(-1,-1);{Устанавливаем размеры окна с текстом}
{Включаем стандартные по размеру и положению полосы-указатели:}
VS := StandardscrollBar (sbVertical+sbHandleKeyBoard) ;
HS := StandardscrollBar (SbHorizontal+sbHandleKeyBoard) ;
{Создаем текстовое окно:}
Interior := New (PInterior, Init (Bounds, HS, VS) ) ;
Insert (Interior) {Включаем его в основное окно}
end; {TWorkWin.Init}
{----------------------}
Procedure TDlgWin.HandleEvent;
begin
Inherited HandleEvent (Event) ;
if Event. What=evCommand then
EndModal (Event. Command)
end;
{-----------------}
Procedure TNotebook.FileOpen;
{Открывает файл данных}
var
PF: PFileDialog; {Диалоговое окно выбора файла}
Control: Word;
s: PathStr;
begin
{Создаем экземпляр динамического объекта:}
New(PF, Init('*.dat','Выберите нужный файл:',
'Имя файла',fdOpenButton,0))
{С помощью следующего оператора окно выводится на экран
и результат работыпользователя с ним помещается в переменную
Control:}
Control := DeskTop.ExecView(PF);
{Анализируем результат запроса:}
case Control of
StdDlg.cmFileOpen,cmOk:
begin {Пользователь указал имя файла:}
PF.GetFileName(s); {s содержит имя файла}
Assign(DataFile,s);
{$I-}
Reset(DataFile) ;
if IOResult <> 0 then
Rewrite(DataFile);
OpFileF := IOResult=0;
{$I+}
if OpFileF then
begin
DisableCommands(WinCom2);
EnableCommands(WinCom1);
Work {Переходим к работе}
end
end;
end; {case Control}
Dispose(PF, Done) {Уничтожаем экземпляр}
end; {FileOpen}
{-----------------}
Procedure TNotebook.FileSave; { Закрывает файл данных} begin
Close(DataFile);
OpFileF := False;
EnableCommands(WinCom2); {Разрешаем открыть файл)
DisableCommands(WinCom1) {Запрещаем работу и сохранение}
end; {TNotebook.FileSave}
{------------------}
Procedure TNotebook.ChangeDir;
{Изменяет текущий каталог}
var
PD: PChDirDialog; {Диалоговое окно смены каталога/диска}
Control: Word; begin
New(PD, Init(cdNormal,0)); {Создаем диалоговое окно}
Control := DeskTop.ExecView(PD); {Используем окно}
Choir(PD.DirInput.Data); {Устанавливаем новый каталог}
Dispose(PD, Done) {Удаляем окно из кучи}
end; {TNotebook.ChangeDir}
{---------------------}
Procedure TNotebook.DOSCall;
{Временный выход в ДОС}
const
txt ='Для возврата введите EXIT в ответ'+ ' на приглашение ДОС...';
begin
DoneEvents; {Закрыть обработчик событий}
DoneVideo; {Закрыть монитор экрана}
DoneMemory; {Закрыть монитор памяти}
SetMemTop(HeapPtr); {Освободить кучу}
WriteLn(txt); {Сообщить о выходе}
SwapVectors; {Установить стандартные векторы}
{Передать управление командному процессору ДОС:}
Exec(GetEnv('COMSPEC'),''); {Вернуться из ДОС:}
SwapVectors; {Восстановить векторы}
SetMemTop(HeapEnd); {Восстановить кучу}
InitMemory;{Открыть монитор памяти}
InitVideo; {Открыть монитор экрана}
InitEvents; {Открыть обработчик событий}
InitSysError; {Открыть обработчик ошибок}
Redraw {Восстановить вид экрана}
end; {DOSCall}
{---------------}
Constructor TInterior.Init;
{Создает окно скрроллера}
begin
TScroller.Init(Bounds, Hs, VS);
ReadFile;
GrowMode := gfGrowHiX+gfGrowHiY;
SetLimit(LLine, РS.Count)
end;
{--------------}
Destructor TInterior. Done;
begin
Dispose (PS, Done) ;
Inherited Done
end ;
{--------------}
Procedure TInterior. ReadFile;
{Читает содержимое файла данных в массив LINES}
var
k: Integer;
s: String;
Data: DataType;
f: text;
begin
PS := New(PStringGollection, Init (100, 10) );
seek(DataFile,0) ;
while not (EOF(DataFile) or LowMemory) do
begin
ReadfDataFile, data) ;
with data do
begin
s : = Name ;
while Length (s) < LName do
s : = s+ ' ' ;
s := s+Phone;
while Length (s) < LName+LPhone do
s : = s+ ' ' ;
s := s+Addr
end;
if so'' then PS. insert (NewStr (S) )
end;
Location := 0;
end; {ReadFile}
{-----------}
Procedure TInterior.Draw;
{ Выводит данные в окно просмотра}
var
n, {Текущая строка экрана}
k: Integer; {Текущая строка массива}
В: TDrawBuffer;
Color: Byte;
p: PString;
begin
if Delta.Y>Location then
Location := Delta.Y;
if Location>Delta.Y+pred(Size.Y) then
Location := Delta. Y+pred (Size. Y) ;
for n := 0 to pred(Size.Y) do
{Size. Y - количество строк окна}
begin
k := Delta. Y+n;
if k=Location then
Color := GetColor(2)
else
Color := GetColor(1);
MoveCharfB,' ', Color, Size. X) ;
if k < pred(PS. count) then
begin
p := PS.At(k) ;
MoveStr(B, Copy (р, Delta. X+1, Size. X) , Color) ;
end;
WriteLine(0,N,Size.X,1,B)
end
end; {Tlnterior.Draw}
{---------------}
Function Control: Word;
{ Получает команду из основного диалогового окна}
const X = 1;
L = 12;
DX= 13;
But: array [0..4] of String [13] = {Надписи на кнопках:}
('~l~ Выход ' , ' ~2~ Убрать ','~3~ Искать ','~4~ Изменить ','~5~ Добавить');
Txt: array [0..3] of String [52] = (
{Справочный текст:}
'Убрать - удалить запись, выделенную цветом ',
'Искать - искать запись, начинающуюся нужными буквами',
'Изменить - изменить поле (поля) выделенной записи',
'Добавить - добавить новую запись');
var
R: TRect;
D: PDlgWin;
k: Integer;
begin
R.Assign(7,6,74,15) ;
D := New (PDlgWin, Init (R, 'Выберите продолжение:'));
with D do begin
for k := 0 to 3 do{Вставляем поясняющий текст}
begin
R.Assign(1,1+k,65,2+k) ;
Insert (New(PStaticText, Init (R,#3+Txt [k] ) ) )
end;
for k := 0 to 4 do {Вставляем кнопки:}
begin
R.Assign(X+k*DX,6,X+k*DX+L,8) ;
Insert (New (PButton, Init(R,But [k] ,cmCan+k,bf Normal) ) )
end;
SelectNext (False) ; {Активизируем первую кнопку}
end;
Control := DeskTop.ExecView(D) ; {Выполняем диалог}
end; {Control}
{-----------------}
Procedure TInterior.HandleEvent;
Procedure DeleteItem;
{Удаляет указанный в Location элемент данных}
var
D: Integer;
PStr: PString;
s: String;
Data: DataType;
begin
PStr := PS.At(Location); {Получаем текущую запись}
s := copy(PStr,1,LName);
seek(DataFile,0);
D := -1; {D - номер записи в файле}
repeat { Цикл поиска по совпадению поля Name:}
inc(D) ;
read(DataFile,Data);
with Data do while Length(Name) < LName do
Name := Name+' '
until Data.Name=s;
seek(DataFile,pred(FileSize(DataFile)));
read(DataFile,Data); {Читаем последнюю запись}
seek(DataFile,D);
write(DataFile,Data); {Помещаем ее на место удаляемой}
seek(DataFile,pred(Filesize(DataFile)));
truncate(DataFile); {Удаляем последнюю запись}
with PS do D := IndexOf(At(Location));
PS.AtFree(D); {Удаляем строку из коллекции}
Draw {Обновляем окно}
end; {DeleteItem}
{-------------}
Procedure AddItemfEdit: Boolean);
{Добавляет новый или редактирует старый элемент данных}
const у = 1;
dy= 2;
L = LName+LPhone+LAddr;
var
Data: DataType;
R: TRect;
InWin: PDialog;
BName,BPhone,BAddr: PInputLine;
Control: Word;
OldCount: Word;
s: String;
p: PString;
begin
Seek(DataFile,Filesize(DataFile));{Добавляем записи
в конец файла}
repeat {Цикл ввода записей}
if Edit then {Готовим заголовок}
s := 'Редактирование:'
else
begin
Str(Filesize(DataFile)+1,s);
while Length(s) < 3 do
s := '0'+s;
s := 'Вводится запись N '+s
end;
FillChar(Data,SizeOf(Data),' ');{Заполняем поля пробелами}
R.Assign(15,5,65,16);
InWin := New(PDialog, Init(R, s));{Создаем окно}
with InWin do
begin
R.Assign(2,y+1,2+LName,y+2); {Формируем окно:}
BName := New(PInputLine, Init(R,LName))
Insert(BName); {Поле имени}
R.Assign(2,y,2+LName,y+1) ;
Insert(New(PLabel, Init(R, 'Имя',BName)));
R.Assign(2,y+dy+1,2+LPhone,y+dy+2);
BPhone := NewtPInputLine, Init(R,LPhone));
Insert(BPhone); {Поле телефон}
R.Assign(2,y+dy,2+LPhone,y+dy+1);
Insert(New(PLabel, Init(R, 'Телефон',BPhone)));
R.Assign(2,y+2*dy+1,2+LAddr,y+2*dy+2) ;
BAddr := New(pinputLine, Init(R,LAddr));
Insert(BAddr); {Поле адреса}
R.Assign)2,y+2*dy,2+LAddr,y+2*dy+1);
Insert(New(PLabel, Init(R, 'Адрес',BAddr)));
{Вставляем две командные кнопки:}
R.Assign(2,y+3*dy+1,12,y+3*dy+3);
Insert(New(PButton, Init(R, 'Ввести',cmOK,bfDefault))) ;
R.Assign(2+20,y+3*dy+1,12+20,y+3*dy+3) ;
Insert(NewfPButton, Init(R, 'Выход',cmCancel,bfNormal)
SelectNext(False) {Активизируем первую кнопку}
end; {Конец формирования окна}
if Edit then with Data do
begin {Готовим начальный текст:}
p := PS.At(Location); {Читаем данные из записи}
s := p;
Name := copy(s,1,LName);
Phone:= copy(s,succ(LName),LPhone);
Addr := copy(s,succ(LName+LPhone),LAddr);
InWin.setData(Data) {Вставляем текст в поля ввода}
end;
Control := DeskTop.ExecView(InWin); {Выполняем диалог}
if Control=cmOk then with Data do
begin
if Edit then
DeleteItem; { Удаляем старую запись}
Name := BName.Data;
Phone:= BPhone.Data;
Addr := BAddr.Data;
s[0] := chr(L) ;
FillChar(s [1] , L, ' ') ;
move (Name [1] ,s [1] ,Length (Name)) ;
move(Phone[1],s[succ(LName)],Length(Phone));
move(Addr[1],s[succ(LName+LPhone)],Length(Addr)
OldCount := PS. Count; {Прежнее количество записей}
PS . Insert (NewStr (s) ) ; {Добавляем в коллекцию}
{Проверяем добавление }
if OldCount <> PS. Count then
Write (DataFile, Data) {Да - добавляем в файл}
end
until Edit or (Control=cmCancel) ;
Draw
end; {AddItem}
{-----------------}
Procedure SearchItem;
{Ищет нужный элемент}
Function UpString(s: String): String;
{Преобразует строку в верхний регистр}
var
k: Integer;
begin
for k := 1 to Length(s) do
if s[k] in ['a'..'z'] then
s[k] := chr(ord('A')+ord(s [k] ) -ord('a') )
else if s[k] in ['a'..'n'] then
s[k]:= chr(ord('A')+ord(s[k] )-ord('a') )
else if s[k] in ['p'..'я'] then
s[k] := chr(ord('P')+ord(s [k] ) -ord('p') )
UpString := s
end; {UpString}
var
InWin: PDialog;
R: TRect;
s: String;
p: PInputLine;
k: Word;
begin {SearchItem}
R.Assign(15,8,65,16) ;
InWin := New (PDialog, Init (R, 'Поиск записи:'))
with InWin do
begin
R.Assign(2,2,47,3) ;
p := New (PInputLine,Init(R,50));
Insert (p) ; R.Assign(1,1,40,2) ;
Insert (New (PLabel, Init(R,'Введите образец для поиска:',р)));
R.Assign(10,5,20,7) ;
Insert (New (PButton,Init(R,'Ввести',cmOk,bfDefault)));
R.Assign(25,5,35,7) ;
Insert (New (PButton,Init (R,' Выход' ,cmCancel,bf Normal)));
SelectNext (False)
end;
if DeskTop.ExecView(InWin) = cmCancel then
exit; s :=p.Data;
Location := 0;
while (UpString(s) >= UpString (PString(PS. At (Location))))
and (Location < pred(PS. Count) ) do
inc (Location) ;
if (Location < Delta.Y) or (Location > Delta.Y+pred(Size.Y)) then
ScrollTo (Delta.X, Location)
else
Draw
end; {SearchItem}
{-----------------}
var
R: TPoint;
label Cls;
begin
TScroller. HandleEvent (Event) ;
case Event. What of
evCommand :
case Event.Command of
cmClose:
begin
Cls:
case Control of { Получить команду из основного диалогового окна}
cmCan,
cmCancel: EndModal (cmCancel) ;
cmEdit : AddItem(True) ;
cmDelete: DeleteItem;
cmSearch: SearchItem;
cmAdd : AddItem(False);
end
end;
cmZoom: exit;
end;
evMouseDown: {Реакция на щелчок мышью}
begin
MakeLocal(MouseWhere, R);{Получаем в R локальные координаты указателя мыши}
Location := Delta.Y+R.Y;
Draw
end;
evKeyDown: {Реакция на клавиши + -}
case Event.KeyCode of
kbEsc: goto Cls;
kbGrayMinus: if Location > Delta.Y then
begin
dec(Location); Draw
end;
kbGrayPlus: if Location < Delta.Y+pred(Size.Y)then
begin
inc(Location);
Draw
end;
end
end
end; {Tlnterior.HandleEvent}
{------------------}
Procedure TNotebook.Work;
{Работа с данными}
var
R : TRect ;
PW : PWorkWin ;
Control: Word;
begin
R.Assign(0,0,80,23) ;
PW := New (PWorkWin, Init (R) ) ;
Control := DeskTop.ExecView(PW) ;
Dispose (PW, Done)
end;
{-------------------}
Procedure TNOtebook.HandleEvent (var Event: TEvent) ;
{Обработчик событий программы}
begin {TNOtebook.HandleEvent}
TApplication.HandleEvent (Event) ;{Обработка стандартных команд cmQuit и cmMenu}
if Event.What = evCommand then
case Event.Command of
{Обработка новых команд:}
cmOpen: FileOpen; {Открыть файл}
cmSave: FileSave; {Закрыть файл}
cmChangeDir : ChangeDir; {Сменить диск}
cmDOSShell : DOSCall; {Временный выход в ДОС}
cmWork : Work; {Обработать данные}
else
exit {Не обрабатывать другие команды}
end;
ClearEvent(Event) {Очистить событие после обработки}
end; {TNOtebook.HandleEvent}
{-------------}
Procedure TNotebook. InitMenuBar;
{Создание верхнего меню}
var
R: TRect;
begin
GetExtent(R) ;
R.B.Y := succ (R.A.Y) ; {R - координаты строки меню}
MenuBar := New(PMenuBar, Init(R,
NewMenu ( {Создаем меню}
{ Первый элемент нового меню представляет собой подменю (меню второго уровня) . Создаем его} NewSubMenu ( '~F~/Файл' , hcNoContext,
{Описываем элемент главного меню}
NewMenu ( {Создаем подменю}
NewItem( {Первый элемент}
'~1~/ Открыть', 'F3 ', kbF3,cmOpen, hcNoContext,
NewItem( {Второй элемент}
'~2~/ Закрыть', 'F2',kbF2,cmSave,hcNoContext,
NewItem( {Третий элемент}
'~3~/ Сменить диск1 , ' ' , 0, cmChangeDir, hcNoContext,
NewLine( {Строка-разделитель}
NewItem( '~4~/ Вызов ДОС' , ' ' , 0, cmDOSShell, hcNoContext,
NewItem( '~5~/ Конец работы' , 'Alt-X' , kbAltX, cmQuit,hcNoContext,
NIL)))))) {Нет других элементов подменю} ),
{Создаем второй элемент главного меню}
NewItem('~W~/ Работа', ' ', kbF4,cmWork, hcNoContext,
NIL) {Нет других элементов главного меню}
))))
end; {TNotebook. InitMenuBar}
{-----------------}
Procedure TNotebook. InitStatusLine;
{Формирует строку статуса}
var
R: TRect; {Границы строки статуса}
begin
GetExtent (R) ; {Получаем в R координаты всего экрана}
R.A.Y := pred(R.B.Y) ;
StatusLine := New(PStatusLine,
Init(R, {Создаем строку статуса}
NewStatusDef (0, $FFFF, {Устанавливаем максимальный диапазон контекстной справочной службы}
NewStatusKey('~Alt-X~ Выход1, kbAltX, cmQuit,
NewStatusKey(I~F2~ Закрыть', kbF2, cmSaveFile,
NewStatusKey ( '~F3~ Открыть', kbF3, cmOpenFile,
NewStatusKey ( '~F4~ Работа', kbF4, cmWork,
NewStatusKey ( '~F10~ Меню1, kbF10, craMenu,
NIL) ) ) ) ) , {Нет других клавиш}
NIL) {Нет других определений}
));
DisableCommands (WinCom1) {Запрещаем недоступные команды}
end; {TNotebook . InitStatusLine}
{------------------}
var
Nbook: TNotebook;
begin
Nbook. Init ;
Nbook. Run;
Nbook . Done
end.
Программа определения дня недели
{Эта программа вводит дату в формате ДЦ ММ ГГГГ к выводит на экран соответствующий этой дате день недели. Описание программы см. п. 2. 7.1.}
var
IsCorrectDate: Boolean; {Признак правильной даты}
d,m,y : Integer; {Вводимая дата - день, месяц и год}
{---------------}
Procedure InputDate (var d,m,y : Integer; var correctly : Boolean);
{Вводит в переменные d, m и у очередную дату и проверяет ее. Если дата правильная, устанавливает correctly=true, иначе correctly= false }
begin {InputDate}
Write ( 'Введите дату в формате ДД ММ ГГГГ: ');
ReadLn(d,m,y) ;
correctly := (d>=l) and (d<=31) and (m>=l)
and (m<=12) and (y>=1582) and (y<=4903)
end; {InputDate}
{----------------}
Procedure WriteDay (d,m,y : Integer) ;
const
Days_of_week : array [0..6] of String [11] =
( ' воскресенье ' , ' понедельник ' , ' вторник ' ,
' среда ' , ' четверг ' , ' пятница ' , ' суббота ' ) ;
var
с, w : Integer;
begin
if m < 3 then
begin {Месяц январь или февраль}
m := m + 10;
у := у - 1
end
else
m := m - 2; {Остальные месяцы}
с := у div 100; {Вычисляем столетие}
y := y mod 100; {Находим год в столетии}
w := abs(trunc(2.6*m-0.2)+d+y div 4+y+c div 4-2*c) mod 7;
WriteLn (Days_of_week [w] )
end;
{------------}
begin
repeat
InputDate (d,m,y, IsCorrectDate) ;
if IsCorrectDate then
WriteDay (d,m, у )
until not IsCorrectDate
end.
Тнексты программ
Программа определения дня недели
Определение биоритмов
Игра НИМ
Программа NOTEBOOK
