П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.

П5.2. ОПРЕДЕЛЕНИЕ БИОРИТМОВ

{Программа для определения физической, эмоциональной и интеллектуальной активности человека. Вводится дата рождения и текущая дата. Программа вычисляет и выводит на экран общее количество дней, часов, минут и секунд, разделяющих обе даты, а также прогнозирует на месяц вперед даты, соответствующие максимуму и минимуму биоритмов. Описание программы см. п. 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 .

П5.3. ИГРА НИМ

Описание программы см, п.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.

П5.4. ПРОГРАММА 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.

Содержание