Игры и полезные программы

54. Всем известна игра "15". Вот ее правила. В прямоугольной коробочке находятся 15 фишек, на которых написаны числа от 1 до 15. Размер коробочки — 4x4, таким образом в коробочке есть одна пустая ячейка. В начале игры фишки перемешаны (рис. 1.56). Задача игрока состоит в том, чтобы, не вынимая фишки из коробочки, выстроить фишки в правильном порядке (рис. 1.57).

Рис. 1.56. В начале игры фишки перемешаны

Рис. 1.57. Правильный порядок фишек

Напишите программу "Игра "15"". На рис. 1.58 приведена форма и окна программы.

Рис. 1.58. Форма и окна программы Игра 15

Игра "15"}
unit gamel5_;
interface
Windows, Messages, SysUtils, Variants, Classes,
Graphics, Controls, Forms, Dialogs;
type
TForml = class(TForm)
procedure FormCreate(Sender: TObject);
procedure FormMouseDovm (Sender: TObject;
Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure FormPaint(Sender: TObject);
// эти объявления вставлены сюда вручную
procedure ShowPole;
procedure Mixer;
private
I Private declarations }
public
f Public declarations }
end;
var
Forml: TForml;
implementation
{$R *.dfm}
const
H = 4; W = 4; // размер поля — 4x4
CH = 64; CW = 64; // размер клеток - 16x16
var
// правильное расположение фишек
stp : array[1..H, 1..W] of byte =
[( 1, 2, 3, 4),
( 5, 6, 7, 8),
( 9,10,11,12),
(13,14,15, 0));
// игровое поле
pole: array[l..H, 1..W] of byte;
ex,ey: integer; // координаты пустой клетки
// новая игра
procedure NewGame;
var
i,j: integer;
begin
// исходное (правильное) положение
for i:=0 to H+l do
for j:=0 to W+l do
pole[i,j] := stp[i,j];
Forml.Mixer; // перемешать фишки
Formi.ShowPole; // отобразить поле
end;
// проверяет, расположены ли
// фишки в нужном порядке
function Finish: boolean;
var
row,col: integer;
i: integer;
begin
row :=1; col :=1;
Finish := True; // пусть фишки в нужном порядке
for i:=l to 15 do
begin
if pole[row,col] <> i then
begin
Finish:= False;
break;
end;
// к следующей клетке
if col < 4
then inc(col)
else begin
col :=1;
inc(row);
end;
end;
end;
// "перемещает" фишку в соседнюю пустую клетку,
// если она есть, конечно
procedure Move(ex,су: integer);
// сх,су — клетка, в которой игрок сделал щелчок
var
г: integer; // выбор игрока
begin
// проверим, возможен ли обмен
if not (( abs(cx-ex) = 1) and (cy-ey = 0) or
( abs(cy-ey) = 1) and (cx-ex = 0))
then exit;
// Обмен. Переместим фишку из х,у в ех,еу
Ро1е[еу,ех] := Pole[су,сх];
Pole[су,сх] := 0;
ех:=сх;
еу:=су;
// отрисовать поле
Forml. ShowPole ;
if Finish then
begin
r := MessageDlg('Цель достигнута!'+ #13+
'Еше раз?1,mtInformation,[mbYes,mbNo],0);
if r = mrNo then Forml.Close; // завершить работу программы
end;
end;
// щелчок в клетке
procedure TForml.FormMouseDown(Sender: TObject;
Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
var
cx,cy: integer; // координаты клетки
begin
// преобразуем координаты мыши в координаты клетки
CSS := Trunc(X / CW) + 1;
су := Trunc(l' / СН) + 1;
Move(ex,су);
end;
// выводит игровое поле
procedure TForml.ShowPole;
var
i,j: integer;
x,y: integer; // к,у — координаты вывода
// текста в клетке
begin
m
// сетка: вертикальные линии
for i:= I to И- 1 do
begin
Canvas.MoveTo(i*CW,0);
Canvas.LineTo(i*CW,ClientHeight) ;
end;
// сетка: горизонтальные линии
for i:= 1 to H- Ido
begin
Canvas.MoveTo(0,i*CH);
Canvas.LineTo(ClientWidth, i*CH) ;
end;
// содержимое клеток
// x,y — координаты вывода текста
for i:= 1 to H do
begin
y:=(i-l)*CH + 15;
for j:=1 to W do
begin
x:= (j-l)*CK + 15;
case Pole[i,j] of
0: Canvas.TextOut(x,y,' ');
1..9: Canvas.TextOut(x,y,' '+
IntToStr(Pole[i,j])+' ');
10..15: Canvas.TextOut(x,y,IntToStr(Pole[i,j])
end;
end;
end;
end;
// "перемешивает" фишки
procedure TForml.Mixer;
var
xl,yl: integer; // пустая клетка
x2,y2: integer; // эту переместить в пустую
d: integer; // направление, относительно пустой
i: integer;
begin
xl:=4;
yl: =4 ;
randomize;
for i:= 1 to 150 do
begin
repeat
x2:=xl;
y2:=yl;
d:=random(4)+ 1;
case d of
1: ~dec(x2);
2: inc(x2);
3: dec(y2);
4: inc(y2);
end;
until (x2>=l) and (x2<=4) and (y2>=l) and (y2<=4);
// здесь определили фишку, которую
// надо переместить в пустую клетку
Pole[yl,xl] := Ро1е[у2,х2];
Ро1е[у2,х2] := 0;
xl:=x2;
У1:=у2;
end;
// запомним координаты пустой клетки
ех:= xl;
еу:= yl;
end;
// обработка события OnCreate
procedure TForml.FormCreate(Sender: TObject);
begin
ClientWidth := CW * W;
ClientHeight := CH * H;
Canvas.Font.Name := 'Times New Roman';
Canvas.Font.Size := 22;
NewGame;
end;
// обработка события OnPaint
procedure TForml.FormPaint(Sender: TObject);
begin
Forml.ShowPole;
end;
end. ,

55. Напишите программу "Собери картинку" — аналог игры "15", в которой игрок будет перемещать не цифры, а фрагменты кар тинки (рис. 1.59).

Рис. 1.59. Окно программы Собери картинку

Игра "Собери картинку" — игра "15" с графическим интерфейсом (вместо цифр — фрагменты картинки) . Картинка загружается из файла pic_l.bmp, который находится в том же каталоге что и выполняемый файл программы.

(с) Культин Н.Б., 2003.
}
unit soberi_;
interface
uses
Windows, Messages, SysUtils, Variants, Classes,
Graphics, Controls, Forms, Dialogs;
type
TForml = class(TForm)
procedure FormCreate(Sender: TObject);
procedure FormMouseDown(Sender: TObject; Button:
TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure FormPaint(Sender: TObject);
// эти объявления вставлены сюда вручную
procedure ShowPole;
procedure Mixer;
procedure NewGame;
private
I Private declarations I
public
{ Public declarations )
end;
var
Forml: TForml;
implementation
{$R +.dfm}
const
H = 4; W = 4; // размер поля - 4x4
we,he: integer; // ширина и высота клетки
// игровое поле
pole: array[1..H, 1..W] of byte;
ex,ey: integer; // координаты пустой клетки
// правильное расположение клеток
stp : array[1..H, 1..W] of byte =
(( 1, 2, 3, 4),
( 5, 6, 7, 8),
( 9,10,11,12) ,
(13,14,15, 0));
pic: TBitmap; // картинка
// новая игра
procedure TE'orml .NewGame;
var
fname: string[20]; // файл картинки
i,j: integer; •
begin
l сюда можно вставить инструкции,
обеспечивающие, например, случайный
выбор загружаемой картинки }
fname := 'pic_l.bmp1;
try
pic.LoadFromFile(fname);
except
on EFopenError do
begin
ShowMessage('Ошибка обращения к файлу ' + fname)
Forml.Close;
end;
end;
// установить размер формы,
// равный размеру картинки
// размер клетки
he := Pic.Height div H;
we := Pic.Width div W;
// размер формы
ClientWidth := we * W;
ClientHeight := he * H;
// исходное (правильное) положение
for i:=1 to H do
for j:=1 to W do
pole[i,j] := stp[i,j];
Forml.Mixer; // перемешать фишки
Forral.ShowPole; // отобразить поле
end;
// проверяет, расположены ли
// клетки (фрагменты картинки) в нужном порядке
function Finish: boolean;
var
row,col: integer;
i: integer;
begin
row :=1; col :=1;
Finish := True; // пусть фишки в нужном порядке
for i:=l to 15 do
begin
if pole[row,col] <> i then
begin
Finish:= False;
break;
end;
// к следующей клетке
if col < 4
then inc(col)
else begin
col :=1;
inc(row);
end;
end;
end;
// "перемещает" фишку в соседнюю пустую клетку,
// если она есть, конечно
procedure Move(ex,су: integer);
// сх,су - клетка, в которой игрок сделал щелчок
var
г: integer; // выбор игрока
begin
// проверим, возможен ли обмен
if not (( abs(cx-ex) = 1) and (cy-ey = 0) or
( abs(cy-ey) = 1) and (cx-ex = 0))
then exit;
// Обмен. Переместим фишку из х,у в ех,еу
Pole[ey,ex] := Pole[су,сх];
Pole[су,сх] := 0;
ех:=сх;
еу:=су;
// отрисовать поле
Forml.ShowPole;
if Finish then
begin
pole[4,4] := 16;
Forml.ShowPole;
r : = MessageDlg('Цель достигнута!'+ #13+
'Еше раз? ',mtlnformation,' [mbYes,mbNo], 0) ;
if г = mrNo then Forml.Close; // завершить работу
// программы
Forml.NewGame;
end;
end;
// щелчок в клетке
procedure TForml.FormMouseDown(Sender: TObject;
Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
var
cx,cy: integer; // координаты клетки
begin
// преобразуем координаты мыши в координаты клетки
сх := Trunc(X / we) + 1;
су := Trunc(Y / he) + 1;
Move(ex,су);
end;
// выводит игровое поле
procedure TForml.ShowPole;
var
Source, Dest: TRect; // области: источник и приемник
sx,sy: integer; // левый верхний угол области-источника
х,j: integer;
begin
// содержимое клеток
for i := 1 to W do
for j := 1 to H do
begin
// преобразуем номер картинки
// в координаты левого верхнего
// угла области-источника
sy := ((pole[i,j] -1) div W) * he;
sx := ((pole[i,j] -1) mod W) * we;
Source := Bounds(sx,sy,we,he);
Dest := Bounds ( (j-1) *wc, (i-1) *hc,wc,hc) ;
if polefi,j] <> 0
then Canvas.CopyRect(Dest,pic.Canvas,Source)
else Canvas.Rectangle)(j-1)*wc, (i-l)*hc,
j*wc, i*hc);
end;
end;
// "перемешивает" фишки
procedure TForml.Mixer;
var
xl,yl: integer; // пустая клетка
x2,y2: integer; // эту переместить в пустую
d: integer; . // направление, относительно пустой
1; integer;
begin
xl:=4; yl:=4; // см. описание массива stp
randomize;
for i:= 1 to 150 do // кол-во перестановок
begin
repeat
x2:=xi;
y2:=yl;
d:=random(4)+1;
бЗак. 939
case d of
1: dec(x2);
2: inc(x2);
3: dec(y2);
4: inc(y2);
end;
until (x2>=l) and (x2<=4) and (y2>=l) and (y2<=4);
// здесь определили фишку, которую
// надо переместить в пустую клетку
Pole[yl,xl] :- Ро1е[у2,х2];
Ро1е[у2,х2] := 0;
xl:=x2;
У1:=у2;
end;
// запомним координаты пустой клетки
ех:= xl;
еу:= yl;
end;
// обработка события OnCreate
procedure TForml.FormCreate(Sender: TObject);
begin
pic := TBitMap.Create;
NewGame;
end;
// обработка события OnPaint
procedure TForml.FormPaint(Sender: TObject);
begin
Forml.ShowPole;
end;
end.

56. Напишите программу, используя которую можно оценить способность игрока (испытуемого) запоминать числа. Програм ма должна выводить числа, а испытуемый — вводить эти числа с клавиатуры. Время, в течение которого игрок будет видеть число, ограничьте, например, одной секундой. По окончании теста программа должна вывести результат: количество показан ных чисел и количество чисел, которые испытуемый запомнил и ввел правильно. Вид формы приведен на рис. 1.60.

Рис. 1.60. Форма программы Тест памяти

implementation
const
КС = 5; // разрядность числа (кол-во цифр)
LT = 10; // количество чисел (длина теста)
var
numb: integer; // число, которое должен запомнить испытуемый
right: integer; // количество правильных чисел
n: integer; // счетчик чисел
($R *.dfm}
// генерирует к — разрядное число
function GetNumb(k: integer) : integer;
var
n: integer; // генерируемое число
i: integer;
begin
// процедура генерирует число по разрядам
// начиная со старшего
n:= Random(9).+1; // старший разряд не может быть нулем
// остальные разряды
for i := 1 to (k-1) do
n := n*10 + Random(lO);
GetNumb := n;
end;
// создание формы
procedure TForml.FormCreate(Sender: TObject);
begin
Editl.Visible := False; // скрыть поле ввода Editl
Editl.MaxLength := КС; // кол-во символов, которое
// можно ввести
Labell.Wordwrap : = True; // разрешить перенос слов на
// следующую строку
Labell.Caption :=
'Сейчас на экране будут появляться числа. ' +
'Вы должны запомнить число, набрать его на клавиатуре '+
'и нажать <Enter>'; .
Buttonl.Caption := 'Начать';
Timerl.Enabled := False; // таймер остановлен
Timerl.Interval := 1000; // время показа числа — 1 секунда
right := 0; // кол-во правильных
п := 0; // счетчик чисел
Randomize; •// инициализация ГСЧ
end;
// щелчок на кнопке "Начать/Завершить"
procedure TForml.ButtonlClick(Sender: TObject);
begin
if Buttonl.Caption = 'Завершить' then
Forml.Close; // закрыть окно программы
*
if Buttonl.Caption = 'Начать' then
begin
Buttonl.Caption := 'Завершить';
Buttonl.Visible := False; // скрыть кнопку
// кнопка Buttonl станет доступной после того,
// как испытание закончится
Labell.Caption : = '';
Labell. Font .Size := 24; //размер шрифта поля Labell
Editl.Font.Size : = 24; // размер шрифта поля Editl
// сгенерировать и вывести число
numb := GetNumb(KC);
Labell.Caption := IntToStr(numb);
Timerl.Enabled := True; // запуск таймера
// процедура обработки сигнала от таймера
// "сотрет" число
end;
end;
// обработка события таймера
procedure TForml.TimerlTimer(Sender: TObject);
begin
Timerl.Enabled := False; // остановить таймер
Labell.Visible := False; // скрыть число
Editl.Visible := True; // сделать доступным поле Editl
Editl.SetFocus; // установить курсор в поле Editl
end;
// нажатие клавиш в поле Editl
procedure TForml.EditlKeyPress(Sender: TObject; var Key: Char);
var
igrok: integer; // число, которое ввел испытуемый
begin
case Key of
10'..'9',#8: ; // клавиши "0"-"9", клавиша <Backspace>
#13: // клавиша <Enter>
begin
igrok := StrToInt(Editl.Text) ;
if (igrok = numb)
then right := right + 1;
n := n + 1; // счетчик чисел
Editl.Text := '';
Editl.Visible := False; // скрыть поле Editl
if n < LT then
begin
numb := GetNumb(KC); // сгенерировать следующее
// число
Labell.Caption : = IntToStr(numb); // отобразить
// число
end
Labell.Visible := True;
Timerl.Enabled := True; // пуск таймера
else begin
// испытание закончено
// вывести результат
Labell.Font.Size := 10;
Labell.Caption := 'Результат:1 + #13 +
'Показано чисел: ' + IntToStr(LT) + #13 +
'Правильных: ' + IntToStr(right);
Labell.Visible := True;
Buttonl.Visible := True; // показать кнопку Завершить
end;
end;
else Key := Chr(0);
end;
end;
end.

57. Напишите программу, используя которую можно оценить способность игрока (испытуемого) запоминать числа. Програм ма должна выводить числа, а испытуемый — вводить эти числа с клавиатуры. Время, в течение которого игрок будет видеть число, ограничьте, например, одной секундой. Программа должна быть "интеллектуальной". Сначала она должна предлагать запо минать четырехразрядные числа, затем пяти, шести и т. д. Ко личество чисел одной разрядности — 10. Переход на следующий уровень сложности (увеличение разрядности числа) должен вы полняться, если количество правильных чисел больше, напри мер, восьми, или количество подряд правильно введенных чисел больше шести. По окончании теста программа должна вывести результат по каждой подгруппе: количество показанных чисел и количество чисел, которые испытуемый запомнил и ввел пра вильно.

58. Игра "Парные картинки" развивает внимание. Вот ее прави ла. Игровое поле разделено на клетки, за каждой из которых скрыта картинка. Картинки — парные, т. е. на игровом поле есть две клетки, в которых находятся одинаковые картинки. В начале игры все клетки "закрыты". Щелчок левой кнопкой мыши "открывает" клетку, в клетке появляется картинка. Теперь надо найти клетку, в которой находится такая же картинка, как и в открытой клетке. Щелчок к другой клетке открывает вторую картинку (рис. 1.61). Если картинки в открытых клетках одина ковые, то эти клетки "исчезают". Если разные — то клетки ос таются открытыми. Очередной щелчок закрывает открытые клетки и открывает следующую. Следует обратить внимание, что две открытые клетки закрываются даже в том случае, если от крытая картинка такая же, как и одна из двух открытых. Игра заканчивается, когда игрок откроет ("найдет") все пары картинок.
Новая игра ?

Рис. 1.61. Игровое поле программы Парные картинки

Разработайте программу, реализующую игру "Парные картинки". Картинки должны загружаться из файла.

В приведенной реализации игры все картинки квадратные и на ходятся в одном файле (рис. 1.62). Это позволило сделать про грамму "интеллектуальной" — размер игрового поля (количество клеток по горизонтали и вертикали) определяется количеством картинок в файле: зная высоту и ширину картинки в файле, программа вычисляет размер картинок, их количество и уста навливает соответствующий размер игрового поля.

Вид формы программы "Парные картинки" приведен на рис. 1.63.

Рис. 1.62. Все картинки находятся в одном файле

Рис. 1.63. Форма программы Парные картинки

unit dblpic_;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics,
Controls, Forms, Dialogs, StdCtrls, jpeg, ExtCtrls, Menus;
type
TForml = class (TForm)
Timerl: TTimer;
MainMenul: TMainMenu;
HI; TMenuItem;
N2: TMenuItem;
N3: TMenuItem;
N4: TMenuItem;
procedure FormCreate(Sender: TObject);
procedure FormPaint(Sender: TObject);
procedure FormMouseDown(Sender: TObject; Button:
TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure TimerlTimer(Sender: TObject);
procedure NIClick(Sender: TObject);
private
I Private declarations }
public
I Public declarations }
end;
// объявление нового типа col_row
col_row = record
col: integer;
row: integer;
end;
const

MAX_SIZE = 32; // максимальное кол-во парных картинок
МАХ_Н =8; // максимальный размер поля — 8x8
M.AXJJ = 8;
var
Forml: TForml;
Pole: array [1..MAX_H,1..MftXJW] of integer;
{ Pole[i,j] < 100 — код картинки, клетка закрыта;
Pole[i,j) > 100 и < 200 - клетка открыта,
игрок видит картинку;
Pole[i,j) > 200 — игрок нашел пару для этой картинки )
Pictures: TBitmap; // картинки, загруженные из файла
n : integer; .// кол-во открытых пар картинок
count: integer; // кол-во открытых в данный момент клеток
openl: col_row; // координаты 1-й открытой клетки
open2: col_row; // координаты 2-й открытой клетки
W: integer; // кол-во клеток по горизонтали
Н: integer; // кол-во клеток по вертикали
// произведение VI и Н должно быть кратно двум
WK: integer; // ширина клетки
НК: integer; // высота клетки
implementation
(SR *.dfm}
// рисует клетку поля
procedure Kletka(col,row: integer);
var
x,y: integer; // левый верхний угол клетки (координаты)
src, dst : Trect; // источник и получатель битового образа
begin
// преобразуем координаты клетки
// в координаты на поверхности формы
х : = (col-l)*WK;
у := (row-l)*HK;
if Pole[col,row] > 200 then
// для этой клетки найдена пара
// клетку надо убрать с поля
begin
// установить цвет границы, закраски и текста
Forml.Canvas.Brush.Color := clBtnFace;
Forml.Canvas.Pen.Color := clBtnFace;
Forml.Canvas.Font.Color : = clBtnFace;
end;
if (Pole[col,row] > 100) and (Pole[col,row] < 200)
then
// клетка открыта — вывести картинку
begin •
// Pole[col,row] = номер картинки + 100,
// где 100 — признак того, что клетка открыта
// определим положение картинки в Pictures
src := Bounds((Pole[col,row]-100 -1)*WK,0,WK,HK);
// координаты картинки (клетки) на форме
dst := Bounds(х,у,HK-2,WK-2) ;
// вывести картинку в клетку
Forml.Canvas.CopyRect(dst,Pictures.Canvas,src) ;
// установить цвет границы и цифры
Forml.Canvas.Pen.Color := clBlack;
Forml.Canvas.Font.Color := clBlack;
Forml.Canvas.Brush.Style := bsClear;
end;
if (Pole[col,row] > 0) and (Pole[col,row] < 100) then
// клетка закрыта, рисуем только контур
begin
Forml.Canvas.Brush.Color := clBtnFace;
Forml.Canvas.Pen.Color := clBlack;
Forml.Canvas.Font.Color := clBtnFace;
end;
// отрисовать клетку
Forml.Canvas.Rectangle(x,у,x+WK-2,y+HK-2);
//Forml. Canvas. TextOut (x+15,y+15, IntToStr (Pole [col, row])),
Forml.Canvas.Brush.Color := clBtnFace;
end;
// отрисовывает поле
procedure ShowPole;
var
row,col: integer;
begin
for row: =1 to H do
for col:=l to W do
Kletka(row,col);
end;
// новая игра
Procedure NewGame;
var
k: integer; // кол-во парных, картинок
r: integer; // случайное число
buf: array[l..MAX_SIZE] of integer;
// в buf[i] записываем, сколько чисел i
// записали в массив Pole
i,j: integer; // индексы массивов
begin
Randomize;
k := Trunc(H*W/2);
for i:=l to k do
buf[i] := 0;
// запишем в массив Pole случайные числа
// от 1 до 2
// каждое число должно быть записано два раза
for i: =1 to H do
for j:=1 to W do
begin
repeat
r := random (k) + 1;
until buf[r] < 2;
Pole[i,j] := r; // код картинки
inc(buf [г] ) ;
end;
// здесь поле сгенерировано
n:=0;
ShowPole;
end;
// создание формы
procedure TForml.FormCreate(Sender: TObject);
var
np: integer; // кол-во парных картинок
begin
Pictures := TBitmap.Create;
// загрузить картинки из файла
Pictures.LoadFromFile('pictures.bmp');
•
HK := Pictures.Height-1; // высота картинки
WK := HK; // ширина картинки
np:= Round(Pictures.Width / WK);
if np <= 15
then H := 4
else H :=5;
W := Round(np*2/H);
// установить размеры поля
Forml.ClientHeight := H * HK;
Forml.ClientWidth := W * WK;
Forml.Timerl.Enabled := False;
Forml.Timerl.Interval := 200;
n := 0;
NewGame;
end;
// прорисовка клеток на поле
procedure TForml.FormPaint(Sender: TObject);
begin
ShowPole;
end;
// щелчок в клетке
procedure TForml.FormMouseDown(Sender: TObject;
Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
var
col_: integer; // номер клетки по горизонтали
row_: integer; // номер клетки по вертикали
begin
col_ := Trunc(X/WK) + 1;
row__ := Trunc(Y/HK) + 1;
if Pole[col_,row_] > 200 then
// щелчок в месте одной из двух
// уже найденных парных картинок
exit;
// открытых клеток нет
if count = 0 then
begin
count : = 1;
openl.col := col_;
openl. row : = row__;
// клетка помечается как открытая
Pole[openl.col,openl.row] := Pole[openl.col,openl.row] + 100;
Kletka(openl.col,openl.row);
exit;
end;
// открыта одна клетка, надо открыть вторую
if count = 1 then begin
open2.col := col_;
open2.row := row_;
// если открыта одна клетка и щелчок сделан
// в этой клетке, то ничего не происходит
if (openl.col = open2.col) and (openl.row = open2.row)
then exit
else begin
count := 2; // теперь открыты две клетки
Pole[open2.col,open2.row] :=
Pole[open2.col,open2.row] + 100;
Kletka(open2.col,open2.row); // отрисуем вторую клетку
// проверим, открытые картинки одинаковые?
if Pole[openl.col,openl.row] = Pole[open2.col,open2.row] then
// открыты две одинаковые картинки
begin
n := n+1;
Forml.Timerl.Enabled := True; // запустить таймер
// процедура обработки события OnTimer
// "сотрет" две одинаковые картинки
end;
end;
exit;
end;
if count = 2 then
begin
// открыты 2 клетки с разными картинками
// закроем их и откроем новую, в которой
// сделан щелчок
// закрыть открытые клетки
Pole[openl.col,openl.row] := Pole[openl.col,openl.row] — 100;
Pole[open2.col,open2.row] := Pole[open2.col,open2.row] —
100;
Kletka(openl.col,openl.row);
Kletka(open2.col,open2.row);
// запись в openl номера текущей клетки
openl.col := col_;
openl.row := row_;
count := 1; // счетчик открытых клеток
// открыть текущую клетку
Pole[openl.col,openl.row] := Pole[openl.col,openl.row] + 100;
Kletka(openl.col,openl.row) ;
end;
end;
// обработка события таймера
procedure TForml.TimerlTimer(Sender: TObject);
begin
// в массиве Pole клетки помечаются как совпавшие
Pole[openl.col,openl.row] := Pole[openl.col,openl.row] + 100;
Pole[open2.col,open2.row] := Pole[open2.col,open2.row] + 100;
count := 0;
// отрисовать клетки
Kletka(open2.col,open2.row) ;
Kletka(openl.col,openl.row);
// остановка таймера
Forml.Timerl.Enabled := False;
if n = Trunc(W*H/2)
then // открыты все пары
begin
Forml.Canvas.Font.Name := 'Times New Roman';
Forml.Canvas.Font.Size := 36;
Forml.Canvas.Font.Color := clBlack;
Forml.Canvas.TextOut(70,160,'Game Over!') ;
Forml.Canvas.Font.Size := 10;
Forml.Canvas.TextOut(120,210,'(с) КультинП.Н., 2003');
end;
end;
// выбор в меню команды Новая игра
procedure TForml.NIClick(Sender: TObject);
begin
Canvas.Rectangle(0,O,ClientWidth,ClientHeight);
NewGame;
end;
end.

59. Хорошо знакомая всем пользователям Windows игра "Сапер" развивает логическое мышление. Вот правила игры. Игровое поле состоит из клеток, в каждой из которых может быть мина. Задача игрока — найти все мины и пометить их флажками. Ис пользуя кнопки мыши, игрок может открыть клетку или поста вить в нее флажок, указав тем самым, что в клетке находится мина. Клетка открывается щелчком левой кнопки мыши, фла жок ставится щелчком правой. Если в клетке, которую открыл игрок, есть мина, то происходит взрыв (сапер ошибся, а он, как известно, ошибается только один раз) и игра заканчивается (рис' 1.64). Если в клетке мины нет, то в этой клетке появляется число, соответствующее количеству мин, находящихся в сосед них клетках. Анализируя информацию о количестве мин в клет ках, соседних с уже открытыми, игрок может обнаружить и по метить флажками все мины. Ограничений на количество клеток, помеченных флажками, нет. Однако для завершения игры (вы игрыша) флажки должны быть установлены только в тех клет ках, в которых есть мины. Ошибочно установленный флажок можно убрать, щелкнув правой кнопкой мыши в клетке, в кото рой он находится.

Рис. 1.64. Вид окна во время (в конце) игры

Разработайте программу, реализующую игру "Сапер". Вид глав ной формы приведен на рис. 1.65.

Рис. 1.65. Главная форма программы Сапер

// модуль главной формы
unit saper_l;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls,
Forms, Dialogs, Menus, StdCtrls, OleCtrls;
type
TForml = class(TForm)
MainMenul: TMainMenu;
N1: TMenuItem;
N2: TMenuItem;
N3: TMenuItem;
N4: TMenuItem;
procedure FormlCreate(Sender: TObject);
procedure FormlPaint(Sender: TObject);
procedure FormlMouseDown(Sender: TObject; Button:
TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure NIClick(Sender: TObject);
procedure N4Click(Sender: TObject);
procedure N3Click(Sender: TObject);
private
( Private declarations }
public
[ Public declarations )
end;
var
Forml: TForml;
implementation
uses saper_2;
{$R *.DFM}
const
MR = 10; // кол-во клеток по вертикали
МС = 10; // кол-во клеток по горизонтали
NM = 10; // кол-во мин
W =40; // ширина клетки поля
Н =40; // высота клетки поля
var
Pole: array[0..MR+l, 0.. MC+l] of integer; //минное поле
// значение элемента массива:
// 0,.8 — количество мин в соседних клетках
// 9 — в клетке мина
// 100..109 — клетка открыта
// 200..209 — в клетку поставлен флаг
nMin : integer; // кол-во найденных мин
nFlag : integer; // кол-во поставленных флагов
status : integer; // 0 — начало игры; 1 — игра; 2 — результат
// генерирует новое поле
Procedure NewGame(); forward;
// показывает поле
Procedure ShowPole(Canvas : TCanvas; status:integer); forward;
// выводит содержимое клетки
Procedure Kletka(Canvas: TCanvas; row,col,status :integer);
forward;
// открывает текущую и все соседние клетки, в которых нет мин
Procedure Open( row, col : integer); forward;
// рисует мину
Procedure Mina(Canvas : TCanvas; x, у : integer); forward;
// рисует флаг
Procedure Flag( Canvas : TCanvas; x, у : integer); forward;
// выводит на экран содержимое клетки
Procedure Kletka(Canvas : TCanvas; row,col,status : integer);
var
x,y : integer; // координаты области вывода
begin
x := (col-1)* W + 1;
у := (row-1)* H + 1;
if status = 0 then
begin
Canvas.Brush.Color := clLtGray;
Canvas.Rectangle(x-1,y-l,x+W,y+H);
exit;
end;
if Pole[row,col] < 100 then
begin
// не открытые клетки — серые
Canvas.Brush.Color : = clLtGray;
Canvas.Rectangle(x-1,y-1,x+W,y+H);
// если игра завершена (status = 2),
// то показать мины
if (status = 2) and (Pole[row,col] = 9)
then Mina(Canvas, x, y);
exit;
end;
// открываем клетку
Canvas.Brush.Color := clWhite; // открытые белые
Canvas.Rectangle(x-1,y-1,x+W,y+H);
if ( Pole[row,col] = 100)
then exit; // клетка открыта, но она пустая
if (Pole[row,col] >= 101) and (Pole[row,col] <= 108) then
begin
Canvas.Font.Size := 14;
Canvas.Font.Color := clBlue;
Canvas .TextOut (x+3, y+2,.
IntToStr(Pole[row,col] - 100));
exit;
end;
if ( Pole[row,col] >= 200) then
Flag(Canvas, x, y);
if (Pole[row,col] = 109) then
// на этой мине подорвались!
begin
Canvas.Brush.Color := clRed;
Canvas.Rectangle(x-1,y-l,x+W,y+H) ;
end;
if ( (Pole[row,col] mod 10) = 9) and (status = 2) then
Mina(Canvas, x, y);
end;
// показывает поле
Procedure ShowPole(Canvas : TCanvas; status : integer);
var
row,col : integer;
begin
for row := 1 to MR do
for col := 1 to MC do
Kletka(Canvas, row, col, status);
end;
m
// рекурсивная функция открывает текущую и все соседние
// клетки, в которых нет мин
Procedure Open( row, col : integer);
begin
if Pole[row,col] = 0 then
begin
Pole[row,col] := 100;
Kletka(Forml.Canvas, row,col, 1);
Open(row,col-1);
Open(row-1,col);
Open(row,col+1);
Open(row+1,col);
//примыкающие диагонально
Open(row-1,col-1);
Open(row-1,col+1) ;
Open(row+1,col-1);
Open(row+1,col+1) ;
end
else
if (Pole[row,col]<100)and(Pole[row,col]<>-3) then
begin
Pole[row,col] := Pole[row,col] + 100;
Kletka(Forml.Canvas, row, col, 1) ;
end;
end;
// новая игра — генерирует новое поле
procedure NewGame();
var
row,col : integer; // координаты клетки
n : integer; // кол-во поставленных мин
к : integer; // кол-во мин в соседних клетках
begin
// Очистим эл-ты массива, соответствующие клеткам
// игрового поля.
for row :=1 to MR do
for col :=1 to MC do
Pole[row,col] := 0;
// расставим мины
Randomized; // инициализация ГСЧ
n := 0; // кол-во мин
repeat
row := Random(MR) + 1;
col := Random(MC) + 1;
if ( Pole[row,col] <> 9) then
begin
Pole[row,col] := 9;
n := n+1;
end;
until ( n = NM);
// для каждой клетки вычислим
// кол-во мин в соседних клетках
for row := 1 to MR do
for col := 1 to MC do
if ( Pole[row,col] <> 9) then
begin
к :=0;
if Pole[row-l,col-l] = 9 then к := к + 1;
if Pole[row-1,col] = 9 then к := к + 1;
if Pole[row-l,col+l] = 9 then к := к + 1;
if Pole[row,col-1] = 9 then к := к + 1;
if Pole[row,col+1] = 9 then к := к + 1;

if Pole[row+l,col-l] = 9 then к := к + 1;
if Pole[row+1,col] = 9 then к := к + 1;
if Pole[row+1,col+1] - 9 then к := к + 1;
Pole[row,col] := k;
end;
status := 0; // начало игры
nMin := 0; // нет обнаруженных мин
nFlag := 0; // нет флагов
end;
// рисует мину
Procedure Mina(Canvas : TCanvas; x, у : integer);
begin
with Canvas do
begin
Brush.Color := clGreen;
Pen.Color := clBlack;
Rectangle(x+16,y+26,x+24,y+30);
Rectangle(x+8,y+30,x+l6,y+34);
Rectangle (x+24, y+30, x+*32, y+34 ) ;
Pie(x+6,y+28,x+34,y+44,x+34,y+36,x+6,y+36) ;
MoveTo(x+12,y+32); LineTo(x+2 6,y+32);
MoveTo(x+8,y+36); LineTo(x+32,y+36);
MoveTo(x+20,y+22); LineTo(x+20,y+26);
MoveTo(x+8, y+30); LineTo(x+6,y+28);
MoveTo(x+32,y+30); LineTo(x+34,y+28);
end;
end;
// рисует флаг
Procedure Flag( Canvas : TCanvas; x, у : integer);
var
p : array [0..3] of TPoint; // координаты флажка и
// нижней точки древка
m : array [0..4] of TPoint; // буква М
begin
// зададим координаты точек флажка
р[0].х:=х+4; р[0].у:=у+4;
р[1].х:=х+30; р[1].у:=у+12;
р[2].х:=х+4; р[2].у:=у+20;
р[3].х:=х+4; р[3].у:=у+36; // нижняя точка древка
m[0].x:=x+8; m[0].у:=y+14;
m[1].x:=x+8; m[1].у:=y+8;
m[2].x:=x+10; m[2].y:=y+10;
m[3].x:=x+12; ra[3].y:=y+8;
m[4].x:=x+12; m[4].y:=y+14;
with Canvas do
begin
// установим цвет кисти и карандаша
Brush.Color := clRed;
Pen.Color := clRed;
Polygon(p); // флажок
// древко
Pen.Color := clBlack;
MoveTo(p[0] .x, p[0] .y) ;
LineTo(p[3] .x, p[3] .y) ;
// буква М
Pen.Color := clWhite;
Polyline(m);
Pen.Color := clBlack;
end;
end;
// выбор из меню ? команды О программе
procedure TForml.N4Click(Sender: TObject);
begin
AboutForm.Top := Trunc(Forml.Top + Forml.Height/2 -
AboutForm.Height/2);
AboutForm.Left := Trunc(Forml.Left +Forml.Width/2 -
AboutForm.Width/2);
About Form.ShowModal;
end;
procedure TForml.FormlCreate(Sender: TObject);
var
row,col : integer;
begin
// В неотображаемые ал-ты массива, которые соответствуют
// клеткам по границе игрового поля, запишем число -3.
// Это значение используется функцией Open для завершения
// рекурсивного процесса открытия соседних пустых клеток.
for row :=0 to MR+1 do
for col :=0 to MC+1 do
Pole[row,col] := -3;
NewGaineO; /'/' "разбросать" мины
Forml.ClientHeight := H*MR + 1;
Forml.ClientWidth := W*MC + 1;
end;
// нажатие кнопки мыши на игровом поле
procedure TForml.FormlMouseDown(Sender: TObject;
Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
var
row, col : integer;
begin
if status = 2 // игра завершена
then exit;
if status ¦ 0 then // первый щелчок
status := 1;
// преобразуем координаты мыши в индексы
// клетки поля
row := Trunc(y/H) + 1;
col := Trunc(x/W) + 1; .
if Button = rabLeft then
begin
if Pole[row,col] = 9 then
begin // открыта клетка, в которой есть мина
Pole[row,col] := Pole[row,col] + 100;
status := 2; // игра закончена
ShowPole(Forml.Canvas, status);
end
else if Pole[row,col] < 9 then
Open(row,col);
end
else
if Button = mbRight then
if Pole[row,col] > 200 then
begin
// уберем флаг и закроем клетку
nFlag := nFlag — 1;
Pole[row,col] := Pole[row,col] — 200;
к := (col-1)* W + 1;
у := (row-1)* H + 1;
Canvas.Brush.Color := clLtGray;
Canvas.Rectangle(x-1,y-l,x+W,y+H);
end
else
begin // поставить в клетку флаг
nFlag := nFlag + 1;
if Pole[row,col] = 9
then nMin := nMin + 1;
Pole[row,col] : = Pole[row,col]+ 200;
if (nMin = MM) and (nFlag = bJM) then
begin
status := 2; // игра закончена
ShowPole(Forml.Canvas, status);
end
else Kletka(Forml.Canvas, row, col,
status);
end;
end;
// выбор меню Новая игра
procedure TForml.NIClick(Sender: TObject);
begin
NewGame();
ShowPole(Forml.Canvas,status) ;
end;
/ выбор из меню ? команды Справка
procedure TForml.N3Click(Sender: TObject);
begin
/'/ вывести справочную информацию
Winhelp(Forml.Handle,'saper.hlp',HELP_CONTEXT,1);
end;
//' обработка события OnPaint
procedure TForml.FormlPaint(Sender: TObject);
begin
// отобразить игровое поле
ShowPole(Forml.Canvas, status);
end;
end.
// модуль формы О программе
unit saper 2;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls,
Forms, Dialogs, StdCtrls, saper_l;
type
TAboutForm = class(TForm)
Buttonl: TButton;
Label1: TLabel;
Label2: TLabel;
procedure ButtonlClick(Sender: TObject);
private
{ Private declarations }
public
I Public declarations }
end;
var
AboutForm: TAboutForm;
implementation
{$R *.DFM}
procedure TAboutForm.ButtonlClick(Sender: TObject);
begin
ModalResult := mrOk;
end;
end.

60. Напишите программу "Будильник". Форма программы при ведена на рис. 1.66. После того как пользователь установит вре мя сигнала, задаст текст напоминания и щелкнет на кнопке ОК, окно программы должно исчезнуть с экрана. В установленное время на экране должно появиться окно с напоминанием. По явление окна должно сопровождаться звуковым сигналом.

Рис. 1.66. Форма программы Будильник

{ Будильник. Модуль главной формы. )
unit Alarm2_l_;
interface
uses
Windows, Messages, SysUtils, Variants, Classes,
Graphics, Controls, Forms, Dialogs, StdCtrls,
ExtCtrls, ComCtrls, DateUtils;
type
TForml = class(TForm)
Timer1: TTimer;
Labell: TLabel;
Label2: TLabel;
Label3: TLabel;
Label4: TLabel;
UpDown1: TUpDown;
Label5: TLabel;
UpDown2: TUpDown;
Shape1: TShape;
Label7: TLabel;
Buttonl: TButton;
Shape2: TShape;
Label8: TLabel;
Editl: TEdit;
Label6: TLabel;
Label9: TLabel;
procedure FormCreate(Sender: TObject);
procedure TimerlTimer(Sender: TObject);
procedure UpDownlClick(Sender: TObject;
Button: TUDBtnType);
procedure UpDown2Click(Sender: TObject;
Button: TUDBtnType);
procedure ButtonlClick(Sender: TObject);
private
{ Private declarations }
public
I Public declarations }
end;
var
Forml: TForml;
implementation
uses Alarm2_2_;
{$R *.dfm)
var
Hour,Min: word; // время на индикаторе
AlHour, AlMin: word; // будильник установлен на AlHour.-AlMin
// начало работы программы
procedure TForml.FormCreate(Sender: TObject);
begin
Hour := HourOf(Now);
Min := MinuteOf(Now);
Label1.Caption := IntToStr(Hour);
if Min < 10
then Label2.Caption := 'O'+IntToStr(Min)
else Label2.Caption := IntToStr(Min);
end;
// сигнал от таймера
procedure TForml.TimerlTiraer(Sender: TObject);
var
cHour,cMin: word;
begin
// получить текущее время
cHour := HourOf(Now);
cMin := MinuteOf(Now);
if Timerl.Tag = 0 // окно программы на экране
then begin
/ проверим, совпадает ли текущее время
с отображаемым на индикаторе }
if cHour о Hour then
begin
Hour := cHour;
Labe11.Caption := IntToStr(Hour) ;
end;
if cMin <> Min then
begin
Min := cMin;
if min <10
then Label2.Caption := '0' + IntToStr(Min)
else Label2.Caption := IntToStr(Min);
end;
// обеспечим мигание двоеточия
if Label3.Visible
then Label3.Visible := False
else Iabel3.Visible := True;
end
else // окно программы скрыто, контролируем
// наступление момента подачи сигнала
if (cHour = AlHour) and (cMin = AlMin)
// сигнал !
then begin
Form2.Show;
Timerl.Tag := 0;
Timerl.Interval := 1000;
end;
end;
// щелчок на UpDownl изменяет
// время сигнала будильника — часы
procedure TForml.UpDownlClick(Sender: TObject; Button: TUDBtnType);
begin
if UpDownl.Position < 10
then Label4.Caption := '0' +
IntToStr(UpDownl.Position)
else Label4.Caption := IntToStr(UpDownl.Position);
end;
// щелчок на UpDown2 изменяет
// время сигнала будильника - ъмнуты
procedure TForml.UpDown2Click(Sender: TObject;
Button: TUDBtnType);
begin
if UpDown2.Position < 10
then Label5.Caption := '0' +
IntToStr(UpDown2.Position)
else Label5.Caption := IntToStr(UpDown2.Position);
end;
// щелчок на кнопке OK
procedure TForml.ButtonlClick(Sender: TObject);
begin
// установить будильник
AlHour := UpDownl.Position;
AlMin := UpDown2.Position;
Timer1.Tag := 1; ,
Forml.Hide; //
Timerl.Interval := 3000; // проверять каждые З секунды
end;
end.
{ Будильник. Модуль окна сообщения. )
unit Alarm2_2_;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics,
Controls, Forms, Dialogs, StdCtrls,
MMSYSTEM, // для доступа к PlaySound
Alarm2_l_; // для доступа к стартовой форме программы
type
TForm2 = class(TForm)
Buttonl: TButton;
Labell: TLabel;
procedure ButtonlClick(Sender: TObject);
procedure FormActivate(Sender: TObject);
private
{ Private declarations j
public
( Public declarations )
end;
var
Form2: TForm2;
implementation
{$R *.dfra}
procedure TForm2.ButtonlClick(Sender: TObject);
begin
Form2.Hide; // скрыть окно с сообщением
Forml.Show; // сделать доступным главное окно
end;
procedure TForm2.FormActivate(Sender: TObject);
begin
Labell.Caption := Forml .Edit 1 .Text; //' текст сообщения
PlaySound('tada.wav',0,SND_ASYNC); // звуковой сигнал
end;
end.

61. Напишите программу "Будильник". Форма программы при ведена на рис. 1.67. После того как пользователь установит вре мя сигнала и щелкнет на кнопке ОК, окно программы должно исчезнуть с экрана, а значок программы — появиться на сис темной панели (рис. 1.68). Окно программы должно появиться на экране в установленное время. Появление окна должно со провождаться звуковым сигналом.

unit Alarm_;
interface
uses
Windows, Messages, SysUtils, Variants, Classes,
Graphics, Controls, Forms, Dialogs, StdCtrls,
ExtCtrls, ComCtrls,
ShellAPI, // для доступа к Shell_NotifyIcon
DateUtils, MPlayer;
Будильник
Рис. 1.68. Значок программы
Будильник во время ее работы
Рис. 1.67. Форма программы должен находиться
Будильник на системной панели
type
TForml = class(TForm)
Timerl: TTimer;
Labell: TLabel;
Label2: TLabel;
Label3: TLabel;
Labels.- TLabel;
UpDownl: TUpDown;
Label5: TLabel;
UpDown2: TUpDown;
Label6: TLabel;
Shapel: TShape;
Label7: TLabel;
Buttonl: TButton;
Shape2: TShape;
Label8: TLabel;
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure FormCreate(Sender: TObject);
procedure TimerITimer(Sender: TObject);
procedure UpDownlClick(Sender: TObject;
Button: TUDBtnType);
procedure UpDown2Click(Sender: TObject;
Button: TUDBtnType);
procedure ButtonlClick(Sender: TObject);
// **** эти объявления вставлены сюда вручную
procedure CreateTraylcon(n: integer; Tip: String);
procedure DeleteTraylcon(n: integer);
procedure SetSound;
// ******************************************
private
I Private declarations }
public
(' Public declarations }
end;
var
Forrnl: TForml;
implementation
/ Имя WAV-файла, который должен находиться
в системном каталоге Media, программа
берет из командной строки. Если параметр
не указан, будильник воспроизводит звук,
который располагается в файле sound.wav,
который должен находиться в том же
каталоге, что и выполняемый файл программы.
I
{$R *.dfm]
var
Hour,Min: word; // время на индикаторе
AlHour, AlMin: word; // будильник установлен на AlHour:AXMin
MediaPlayer : TMediaPlayer;
// компонент MediaPlayer обеспечивает воспроизведение
// звукового сигнала
// начало работы программы
procedure TForml.FormCreate(Sender: TObject);
begin
Hour := HourOf(Now);
Min := MinuteOf(Now) ;
Labell.Caption := IntToStr(Hour) ;
if Min < 10
then Label2.Caption := '0'+IntToStr(Min)
else Label2.Caption := IntToStr(Min!;
7 Зак. 939
// CreateTraylcon (1) ; // поместить картинку на System Tray
SetSound; // загрузить WAV-файл
end;
// завершение работы программы
procedure TForml.FormClose(Sender: TObject; var Action:
TCloseAction);
begin
// удалить картинку с System Tray
DeleteTraylcon(1);
end;
const
WM_MYTRAYNOTIFY = WM_USER + 123;
// помещает картинку на System Tray
procedure TForml.CreateTraylcon(n: integer; Tip: string);
var
nidata: TNotifylconData;
begin
// заполним структуру nidata,
// поля которой определяют значок
// на System Tray
with nidata do
begin
cbSize : = SizeOf(TNotifylconData);
Wnd := Self.Handle; // окно (приложение), которое
// представляет значок
uld := n; // номер значка (одно приложение может
// разместить несколько значков)
uFlags := NIF_ICON or NIF_MESSAGE or NIFJHP; // что
// надо сделать
uCallBackMessage := WM_MYTRAYNOTIFY;
hlcon := Application.Icon.Handle;
//szTip := 'Будильник';
StrPCopy(szTip,Tip); // копируем Ansi-строку
// в nul-terminated-строку
end;
Shell_NotifyIcon(NIM_ADD, Snidata);
end;
// удаляет картинку с System Tray
procedure TForml.DeleteTraylcon(n: integer);
nidata: TNotifylconData;
begin
// заполним структуру nidata,
// поля которой определяют значок
// на System Tray
with nidata do
begin
cbsize := SizeOf(TNotifylconData);
Wnd := Self.Handle; // окно (приложение), которое
// представляет значок
uld := n; // номер значка (одно приложение может
// разместить несколько значков)
end;
Shell_NotifyIcon(NIM_DELETE, @nidata);
end;
// сигнал от таймера
procedure TForml.TimerlTimer(Sender: TObject);
var
cHour,cMin: word;
begin
// получить текущее время
cHour := HourOf(Now);
cMin := MinuteOf(Now) ;
if Timerl.Tag = 0 // окно программы на экране
then begin
I проверим, совпадает ли текущее время
с отображаемым на индикаторе }
if cHour О Hour then
begin
Hour := cHour;
Labell.Caption := IntToStr(Hour) ;
end;
if cMin <> Min then
begin
Min := cMin;
if min <10
then Label2.Caption := '0' + IntToStr(Min)
else Label2.Caption := IntToStr(Min);
end;
// обеспечим мигание двоеточия
if Label3.Visible
then Label3.Visible := False
else Iabel3.Visible := True;
end
else // окно программы скрыто, контролируем
// наступление момента подачи сигнала
if (cHour = AlHour) and (cMin = AlMin)
// сигнал !
then begin
Forral.Show;
Timer1.Tag := 0;
Timerl.Interval := 1000;
try
MediaPlayer.Play; // воспроизвести
// звуковой фрагмент
except
on EMCIDeviceError do;
end;
end; .
end;
// щелчок на UpDovml изменяет
// время сигнала будильника — часы
procedure TForml.UpDownlClick(Sender: TObject;
Button: TUDBtnType);
begin
if UpDownl.Position < 10
then Label4.Caption := '0' +
IntToStr(UpDownl.Position)
else Label4.Caption := IntToStr(UpDownl.Position);
end;
// щелчок на UpDown2 изменяет
// время сигнала будильника — минуты
procedure TForml.UpDown2Click(Sender: TObject;
Button: TUDBtnType);
begin
if UpDown2.Position < 10
then Label5.Caption := '0' + IntToStr(UpDown2.Position)
else Label5.Caption := IntToStr(UpDown2.Position);
end;
// щелчок на кнопке ОК
procedure TForml.ButtonlClick(Sender: TObject);
begin
// установить будильник
AlHour := UpDownl.Position;
AlMin := UpDown2.Position;
Timer1.Tag := 1;
// поместить картинку на System Tray
CreateTraylconU, 'Будильник ' +
Label4.Caption+':'+Label5.Caption);
Forml.Hide;
Timerl.Interval := 3000; // проверять каждые З секунды
end;
// определяет звук будильника
procedure TForml.SetSound;
var
pWinDir: PChar; // указатель на nul-terminated-строку
sWinDir: String[80];
begin
// создадим компонент MediaPlayer
MediaPlayer := TMediaPlayer.Create(Forml) ;
MediaPlayer.ParentWindow := Forml.Handle;
MediaPlayer.Visible := False;
// Стандартные WAV-файлы находятся в каталоге Media,
// но где находится и как называется каталог, в который
// установлен Windows? Выясним это.
// Чтобы получить имя каталога Windows,
// воспользуемся API-функцией GetWindowsDirectory.
// Строка, которая передается в API-функцию,
// должна быть nul-terminated-строкой.
// Получить имя каталога Windows
GetMem(pWinDir,80); // выделить память для строки
GetWindowsDirectory(pWinDir,80); // получить каталог
// Windows
sWinDir := pWindir;
// открыть WAV-файл
if ParamStr(1) = ''
then MediaPlayer.FileName := 'Sound.wav'
else MediaPlayer.FileName := sWinDir + '\media\' +
ParamStr(1);
try
. MediaPlayer.Open;
except
on EMCIDeviceError do;
end;
end;

end.

62. Напишите программу тестирования, в которой выбор пра вильного ответа осуществляется при помощи переключателя (рис. 1.69).

Рис. 1.69. Окно программы

Тест — последовательность вопросов и альтернативных ответов, должен находиться в файле. Количество вопросов теста не огра ничено. Программа тестирования должна получать имя файла теста из командной строки.
Ниже приведен пример файла теста. Первая строка — это заго ловок теста. Потом следует описание 4-х уровней оценок. Для каждого уровня задается сообщение и количество правильных ответов, необходимых для достижения уровня. Далее следуют вопросы и варианты ответов. После каждого альтернативного ответа стоит 1 или 0. Единица показывает, что данный вариант ответа — правильный. Следует обратить внимание, что каждое сообщение, каждый вопрос и ответ в файле теста представлены одной строкой.

Экономика
Вы прекрасно справились с вопросами. Оценка — ОТЛИЧНО!
6
На один или несколько вопросов Вы ответили неправильно. Оценка — ХОРОШО.
5
На некоторые вопросы Вы ответили неправильно. Оценка —
УДОВЛЕТВОРИТЕЛЬНО.
4
Вы плохо подготовились к испытанию. Оценка — ПЛОХО!
3
Карл Маркс написал книгу:
"Материализм и эмпириокритицизм"
О
"Как нам бороться с инфляцией"
О
"Капитал"
1
Что означает выражение "Делать бизнес"?
обманывать и хитрить
О
учиться в школе бизнесменов
О
заниматься конкретным делом, приносящим доход
1
Когда впервые появились бартерные сделки?
при первобытнообщинном строе
1
в период общественного разделения труда
О
в наше время
О
Слово "бухгалтер" переводится с немецкого как:
человек, держащий книгу
1
человек, считающий на счетах
О
человек, работающий с большой кипой бумаг
О
Как переводится с английского "ноу-хау" и что оно обозначает?
секрет
О
новое предприятие
О
новая идея (знаю, как)
1
Конкуренция в переводе с латинского:
столкновение
1
соревнование
О
конкурс
О

implementation
($R *.dfm}
var
f: TextFile; // файл теста (вопросы и варианты ответов)
nq: integer; // количество вопросов в тесте
right: integer; // количество правильны;< ответов
level: array[1..4] of integer; // критерии оценок
mes: array[1..4] of string; // комментарии
buf: string;
// читает вопрос из файла и выводит его
// в поля формы
function NextQw : boolean;
begin
if not EOF(f) then
begin
// прочитать и вывести вопрос
Readln(f,buf);
Forml.Labell.Caption := buf;
// прочитать и вывести варианты ответов
// 1-й вариант
Readln(f,buf) ; // прочитать 1-й вариант ответа
Forml.Label2.Caption : = buf;
Readlnff,buf); // оценка за выбор этого ответа:
// 1 — правильно, 0 — нет
Forml.RadioButtonl.Tag := StrToInt(buf);
// 2-й вариант
Readln(f,buf);
Forml.Label3.Caption := buf;
Readln(f,buf) ;
Forml.RadioButton2.Tag := StrToInt(buf);
// 3-й вариант
Readln(f,buf) ;
Forml.Label4.Caption := buf;
Readln(f,buf) ;
Forml.RadioButton3.Tag := StrToInt(buf);
// счетчик общего количества вопросов
nq: = nq + 1;
// кнопка Дальше недоступна,
// пока не выбран один из вариантов ответа
Forml.Buttonl.Enabled := False;
// ни один из переключателей не выбран
Forml.RadioButtonl.Checked := False;
Forml.RadioButton2.Checked := False;
Forml.RadioButton3.Checked := False;
NextQw := TRUE;
end
else NextQw := FALSE;
end;
// событие FormCreate возникает в момент
// создания формы
procedure TForml.FormCreate(Sender: TObject);
var
i: integer;
fname : string;
begin
( Если программа запускается из Delphi,
то шля файла теста надо ввести в
поле Parameters диалогового окна
Run Parameters, которое становится
доступным в результате выбора в меню
Run команды Parameters. )
fname := ParamStr(l); // взять имя файла теста
// из командной строки
if fname = '' then
begin
ShowMessage('В командной строке запуска программы' +#13+
'надо указать имя файла теста.');
Application.Terminate; //' завершить программу
end;
AssignFile(f,fname);
// а процессе открытия файла возможны
// ошибки, поэтому ...
try
Reset(f); // эта инструкция может вызвать ошибку
except
on EInOutError do
begin
ShowMessage('Ошибка обращения к файлу теста: ' +
fname);
Application.Terminate; // завершить программу
end;
end;
// здесь файл теста успешно открыт
// прочитать название теста — первая строка файла
Readln(f,buf) ;
Forml.Caption := buf;
// прочитать оценки и комментарии
for i: =1 to 4 do
begin
Readln(f,buf);
mes [i] := buf;
Readln(f,buf) ;
level[i] := StrToInt(buf);
end;
right := 0; // правильных ответов
nq := 0; // всего вопросов
NextQW; // прочитать и вывести первый вопрос
end;
// щелчок на кнопке Дальше
procedure TForml.ButtonlClick(Sender: TObject);
var
buf: string;
i: integer;
begin
if Buttonl.Caption = 'Завершить' then Close;
// добавим оценку за выбранный вариант ответа
// оценка находится в свойстве Button.Tag
// Button.Tag = 1 — ответ правильный, 0 — нет
if RadioButtonl.Checked then
right := right + RadioButtonl.Tag;
if RadioButton2.Checked then
right := right + RadioButton2.Tag;
if RadioButton3.Checked then
right := right + RadioButton3.Tag;
// вывести следующий вопрос
// NextQW читает и выводит вопрос
// NextQW = FALSE, если в файле теста
// вопросов больше нет
if not NextQW then
begin
// здесь значение NextQW = FALSE
Buttonl.Caption := 'Завершить1;
// скрыть переключатели и поля меток
RadioButtonl.Visible := False;
RadioButton2.Visible := False;
RadioButton3.Visible := False;
Label2.Visible := False;
Label3.Visible := False;
Label4.Visible := False;
buf := 'Тестирование завершено.1 + #13 +
'Правильных ответов: ' + IntToStr(right) +
' из ' + IntToStr(nq) + '.' + #13;
// выставить оценку
// right — кол-во правильных ответов
i:=1; // номер уровня
while (right < level[i]) and (i < 4) do
inc(i);
buf := buf + mes[i];
Labell.AutoSize := TRUE;
Labell.Caption := buf;
end;
end;
// щелчок на переключателе выбора первого варианта ответа
procedure TForml.RadioButtonlClick(Sender: TObject);
begin
Buttonl.Enabled := True; // кнопка Дальше теперь доступна
end;
procedure TForml.RadioButton2Click(Sender: TObject);
begin
Buttonl.Enabled := True;
end;
procedure TForml.RadioButton3Click(Sender: TObject);
begin
Buttonl.Enabled := True;
end;
end.

63. Напишите программу тестирования, в которой вопрос может сопровождаться иллюстрацией, а количество вариантов ответа к каждому вопросу может быть от двух до 4. Пример окна про граммы приведен на рис. 1.70.

Рис. 1.70. Окно программы

Вопросы теста должны находиться в текстовом файле, имя кото рого должно передаваться программе тестирования как параметр командной строки.
Предлагается следующая структура файла теста. Первая строка файла теста — название теста, за которым следу ют разделы:

• заголовка;
• оценок;
• вопросов.

Название выводится в заголовке стартового окна программы тестирования.
Раздел заголовка содержит общую информацию о тесте, напри мер, о его назначении. Заголовок может состоять из нескольких строк. Признаком конца раздела заголовка является точка, стоящая в начале строки.
Вот пример заголовка файла теста:

Сейчас Вам будут предложены вопросы о знаменитых памятниках
и архитектурных сооружениях Санкт-Петербурга. Вы должны
из предложенных нескольких вариантов ответа выбрать правильный.

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

Отлично
100
Хорошо
85
Удовлетворительно
60
Плохо
50

За разделом оценок следует раздел вопросов теста. Каждый вопрос начинается текстом вопроса, за которым может следовать имя файла иллюстрации, размещаемое на отдельной строке и начинающееся символом \. Имя файла иллюстрации является признаком конца текста вопроса. Если к вопросу нет иллюстрации, то вместо имени файла ставится точка. После, вопроса следуют альтернативные ответы. Текст альтерна тивного ответа может занимать несколько строк. В строке, сле дующей за текстом ответа, располагается оценка (количество баллов) за выбор этого ответа. Если альтернативный ответ не является последним для текущего ответа, то перед оценкой ста вится запятая, если последний — то точка.
Вот пример вопроса:

Архитектор Исаакиевского' собора:
\isaak.bmp
Домеиико Трезини
,0
Огюст Монферран
,1
Карл Росси
.0

В приведенном вопросе первый и третий варианты ответа поме чены как не правильные (оценка за их выбор равна нулю).
Вид формы программы тестирования приведен на рис. 1.71.

I Универсальная программа тестирования.
(с) Культин Н.Б., 2003 )
unit tester_;
interface
uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics,
Controls, Forms, Dialogs, StdCtrls, ExtCtrls,
jpeg;
type
TForml = class(TForm)
// вопрос
Label5: TLabel;
// альтернативные ответы
Label1: TLabel;
Рис. 1.71. Форма программы тестирования
Label2: TLabel;
Label3: TLabel;
Label4: TLabel;
// переключатели выбора ответа
RadioButtonl: TRadioButton;
RadioButton2: TRadioButton;
RadioButton3: TRadioButton;
RadioButton4: TRadioButton;
Imagel: TImage; // область вывода иллюстрации
Buttonl: TButton;
Panell: TPanel;
RadioButton5: TRadioButton;
procedure FormActivate(Sender: TObject);
procedure ButtonlClick(Sender: TObject);
procedure RadioButtonClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
// Эти объявления вставлены сюда вручную
procedure Info;
procedure VoprosToScr;
procedure ShowPicture; // выводит иллюстрацию
procedure ResetForm; // "очистка" формы перед выводом
// очередного вопроса
procedure Itog; // результат тестирования
private
/' Private declarations }
public
I Public declarations j
end;
var
Forrnl: TForml; // форма
implementation
{$R *.DFM}
const
N_LEV=4; // четыре уровня оценки
N_ANS=4; // четыре варианта ответов
var >
f:TextFile;:
fn:string; // имя файла вопросов
// сумма, соответствующая уровню
level:array[l..N_LEV] of integer;
// сообщение, соответствующее уровню
mes:array[1..N_LEV] of string;
score: array[ 1. .N_ANS] of integer; //' оценка за выбор ответа
suirnia: integer; // набрано очков
vopros:integer; // номер текущего вопроса
otv:integer; // номер выбранного ответа
// вывод информации о тесте
procedure Tforml.Info;
var
s,buf:string;
begin
readln(f,s);
Forml.Caption := s;
buf:='';
repeat
readln(f,s);
if s[l] <>
then buf := buf +s + #13;
until s[1] ='.' ;
Label5.caption:=buf;
end;
// прочитать информацию об оценках за тест
Procedure GetLevel;
var
i:integer;
buf:string;
begin
i:=l;
repeat
readln(f,buf) ;
if buf[1] <> '.' then begin
mes[i]:=buf; // сообщение
readln(f,level[i]); // оценка
i:=i+l;
end;
until buf[1]='.';
end;
// масштабирование иллюстрации
Procedure TForml.ShowPicture;
var
w,h: integer; // максимально возможные размеры картинки
begin
// вычислить допустимые размеры картинки
w:=C.lientWidth-10;
h:=ClientHeight
- Panell.Height -10
- Label5.Top
- Label5.Height - 10;
// вопросы
if Label1.Caption О "
then h:=h-Labell.Height-10;
if Label2.Caption <> "
then h:=h-Label2.Height-10;
if Label3.Caption <> ''
then h:=h-Label3.Height-10;
if Label4.Caption <> ''
then h:=h-Label4.Height-10;
// если размер картинки меньше w на h,
// то она не масштабируется
ImageI.Top:=Forml.Label5.Top+Label5.Height+10;
if Image1.Picture.Bitmap.Height > h
then Imagel.Height:=h
else Imagel.Height:= Imagel.Picture.Height;
if Imagel.Picture.Bitmap.Width > w
then Imagel.Width:=w
else Imagel.Width:=Imagel.Picture.Width;
Imagel.Visible := True;
end;
// вывести вопрос
Procedure TForml.VoprosToScr;
var
i:integer;
s,buf:string;
ifn:string; // файл иллюстрации
begin
vopros:=vopros+l;
caption:='Вопрос ' + IntToStr(vopros);
// прочитать вопрос
buf:='';
repeat
readln(f,s);
if (s[l] о '.') and (s[l] <> 'V)
then buf:=buf+s+' ';
until (s[l] ='.') or (s[l] ='\');
Label5.caption:=buf; // вывести вопрос
I Иллюстрацию прочитаем, но выведем только после
того, как прочитаем альтернативные ответы
и определим максимально возможный размер
области формы, который можно использовать
для ее вывода.}
if s[l] <> 'V
then Imagel.Tag:=0 // к вопросу нет иллюстрации
else // к вопросу есть иллюстрация
begin
Imagel.Tag:=l;
ifn:=copy(s,2,length(s)) ;
try
Imagel.Picture.LoadFromFile(ifn) ;
except
on E:EFOpenError do
Imagel. Tag:=0;
end;
end;
// читаем варианты ответов
i:=l;
repeat
buf:='';
repeat // читаем текст варианта ответа
readln(f,s);
if (s[l]<>' . ' ) and (s[l] <> ', ' )
then buf:=buf+s+' ';
until (s[l] = r, ' )or(s[l] = ' . ') ;
// прочитан альтернативный ответ
scored] := StrToInt (s [2] ) ;
case i of
1: Labell.caption:=buf;
2: Label2.caption:=buf;
3: Label3.caption:=buf;
4: Label4.caption:=buf;
end;
i:=i+l;
until s[l] = ' . ' ;
// здесь прочитана иллюстрация и альтернативные ответы
// текст вопроса уже выведен
if Imagel.Tag =1 // есть иллюстрация к вопросу
then ShowPicture;
// вывод альтернативных ответов
if Forml.Labell.Caption О ''
then begin
if Forml.Imagel.Tag =1
then Labell.Top:=Imagel.Top+Imagel.Height+10
else Labell.Top:=Label5.Top+Label5.Height+10;
RadioButtonl.Top:=Labell.Top;
Labell.visible:=TRUE;
RadioButtonl.visible:=TRUE;
end;
if Forml.Label2.Caption <> "
then begin
Label2.top:=Labell.top+ Labell.height+10;
RadioButton2.top:=Label2.top;
Label2 . visible: =TRUE;
RadioButton2.visible:=TRUE;
end;
if Forml.Label3.Caption о "
then begin
Label3.top:=Label2.top+ Label2.height+10;
RadioButton3.top:=Label3.top;
Label3.visible:=TRUE;
RadioButton3.visible:=TRUE;
end;
if Forml.Label4.Caption О '{•
then begin
Label4.top:=Label3.top+ Label3.height+10;
RadioButton4.top:=Label4.top;
Label4.visible:=TRUE;
RadioButton4.visible:=TRUE;
end;
end;
Procedure TForml.ResetForm;
begin // сделать невидимыми все метки и переключатели
Labell.Visible:=FALSE;
Labell.Caption:='';
Labell.Width:=ClientWidth-Labell.left-5;
RadioButtonl.Visible:=FALSE;
Label2.Visible:=FALSE;
Label2.Caption:='';
Label2.Width:=ClientWidth-Label2.left-5;
RadioButton2.Vis ible:=FALSE;
Label3.Visible:=FALSE;
Label3.Caption:='';
Label3.Width:=ClientWidth-Label3.1eft-S;
RadioButton3.Visible:=FALSE;
Label4.Visible:=FALSE;
Label4.Caption:='';
Labe14.Width:=C1ientWidth-Label4.lett-5;
RadioButton4.Visible:=FALSE;
Label5.Width:=ClientWidth-Label5.left-5;
Imagel.Visible:=FALSE;
end;
// определение достигнутого уровня
procedure TForml.Itog;
var
i:integer;
buf:string;
begin
buf:='';
buf:='Результаты тестирования'+ #13
+'Всего баллов: '+ IntToStr(summa);
i:=l;
while (summa < level[i]) and (i<N_LEV) do
i:=i+l;
buf:=buf+ #13+mes(i];
Label5.Top:=20;
Label5.Caption:=buf;
end;
procedure TForml.FormActivate(Sender: TObject);
begin
ResetForm;
if ParamCount = 0
then begin
Label5.Caption:= 'He задан файл вопросов теста.';
Buttonl.Caption:='Ok';
Buttonl.Tag:=2;
Buttonl.Enabled:=TRUE
end
else begin
fn := ParamStr(l);
assignfile(f,fn);
try
reset(f);
except
on EFOpenError do
begin
ShowMessage{'Файл теста '+fn+' не найден.');
Buttonl.Caption: = 'Ok' ;
Buttonl.Tag:=2;
Buttonl.Enabled:=TRUE;
exit;
end;
end;
Info; // прочитать и вывести информацию о тесте
GetLevel; // прочитать информацию об уровнях оценок
end;
end;
// щелчок на кнопке Buttonl
procedure TForml.ButtonlClick(Sender: TObject);
begin
case Buttonl.tag of
0: begin
Buttonl.caption:='Дальше';
Buttonl.tag:=1;
RadioButton5.Checked:=TRUE;
// вывод первого вопроса
Butt onl.Enabled:=Fa1s e;
ResetForm;
VoprosToScr;
end;
1: begin // вывод остальных вопросов
summa:=surama+score[otv];
RadioButton5.Checked:=TRUE;
Buttonl.Enabled:=False;
ResetForm;
if not eof(f)
then VoprosToScr
else
begin
summa:=summa+score[otv];
closefile(f);
Buttonl.caption:='Ok';
Forml.caption:='Результат1;
Buttonl.tag:=2;
Buttonl.Enabled:=TRUE;
Itog; // вывести результат
end;
end;
2: begin // завершение работы
Forml.Close;
end;
end;
end;
/./ Процедура обработки события Onclick
// для компонентов RadioButtonl-RadioButton4
procedure TForml.RadioButtonClick(Sender: TObject);
begin
if sender = RadioButtonl
then otv:=1
else if sender = RadioButton2
then otv:=2
else if sender = RadioButton3
then otv:=3
else otv:=4;
Buttonl.enabled:=TRUE;
end;
// обеспечивает настройку компонентов
procedure TForml.FormCreate(Sender: TObject);
begin
Imagel.AutoSize := False;
Imagel.Proportional := True;
RadioButtonl.Visible := False;
end;
end.