П5. Тексты программ
П5.1. ПРОГРАММА ОПРЕДЕЛЕНИЯ ДНЯ НЕДЕЛИ
{Эта программа вводит дату в формате ДЦ ММ ГГГГ к выводит на экран соответствующий этой дате день недели. Описание программы см. п. 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.
{Программа для определения физической, эмоциональной и интеллектуальной активности человека. Вводится дата рождения и текущая дата. Программа вычисляет и выводит на экран общее количество дней, часов, минут и секунд, разделяющих обе даты, а также прогнозирует на месяц вперед даты, соответствующие максимуму и минимуму биоритмов. Описание программы см. п. 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 .
Описание программы см, п.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.
Описание программы см. п.. 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.