RedGuy/OldPascalProjects
Archived
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

init

Browse Source
This commit is contained in:
RedGuy 2023-06-20 21:49:58 +03:00
commit 17e7a7bf2c
22 changed files with 30571 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

179
15.pas Normal file
View File

@ -0,0 +1,179 @@
// Игра в 15
uses GraphABC,ABCObjects,ABCButtons;
const
/// размер поля
n = 4;
/// размер фишки
sz = 100;
/// зазор между фишками
zz = 10;
/// отступ от левого и правого краев
x0 = 20;
/// отступ от верхнего и нижнего краев
y0 = 20;
var
p: array [1..n,1..n] of SquareABC;
digits: array [1..n*n-1] of integer;
MeshButton: ButtonABC;
StatusRect: RectangleABC;
EmptyCellX,EmptyCellY: integer;
MovesCount: integer;
EndOfGame: boolean; // True если все фишки стоят на своих местах
// Поменять местами две фишки
procedure Swap(var p,p1: SquareABC);
begin
PABCSystem.Swap(p,p1);
var i := p.Left;
p.Left := p1.Left;
p1.Left := i;
i := p.Top;
p.Top := p1.Top;
p1.Top := i;
end;
// Определить, являются ли клетки соседями
function Sosedi(x1,y1,x2,y2: integer): boolean;
begin
Result := (abs(x1-x2)=1) and (y1=y2) or (abs(y1-y2)=1) and (x1=x2)
end;
// Заполнить вспомогательный массив цифр
procedure FillDigitsArr;
begin
for var i:=1 to n*n-1 do
digits[i] := i;
end;
// Перемешать вспомогательный массив цифр. Количество обменов должно быть четным
procedure MeshDigitsArr;
var x: integer;
begin
for var i:=1 to n*n-1 do
begin
repeat
x := Random(15)+1;
until x<>i;
Swap(digits[i],digits[x]);
end;
if n mod 2=0 then
Swap(digits[1],digits[2]); // количество обменов должно быть четным
end;
// Заполнить двумерный массив фишек. Вместо пустой ячейки - белая фишка с числом 0
procedure Fill15ByDigitsArr;
begin
Swap(p[EmptyCellY,EmptyCellX],p[n,n]); // Переместить пустую фишку в правый нижний угол
EmptyCellX := n;
EmptyCellY := n;
var i := 1;
for var y:=1 to n do
for var x:=1 to n do
begin
if x*y=n*n then exit;
p[y,x].Number := digits[i];
i += 1;
end;
end;
// Перемешать массив фишек
procedure Mesh15;
begin
MeshDigitsArr;
Fill15ByDigitsArr;
MovesCount := 0;
EndOfGame := False;
StatusRect.Text := 'Количество ходов: '+IntToStr(MovesCount);
StatusRect.Color := RGB(200,200,255);
end;
// Создать массив фишек
procedure Create15;
begin
EmptyCellX := n;
EmptyCellY := n;
for var x:=1 to n do
for var y:=1 to n do
begin
p[y,x] := new SquareABC(x0+(x-1)*(sz+zz),y0+(y-1)*(sz+zz),sz,clMoneyGreen);
p[y,x].BorderColor := clGreen;
p[y,x].BorderWidth := 2;
p[y,x].TextScale := 0.7;
end;
p[EmptyCellY,EmptyCellX].Color := clWhite;
p[EmptyCellY,EmptyCellX].BorderColor := clWhite;
FillDigitsArr;
MeshDigitsArr;
Fill15ByDigitsArr;
end;
// Проверить, все ли фишки стоят на своих местах
function IsSolution: boolean;
var x,y,i: integer;
begin
Result:=True;
i:=1;
for y:=1 to n do
for x:=1 to n do
begin
if p[y,x].Number<>i then
begin
Result:=False;
break;
end;
Inc(i);
if i=n*n then i:=0;
end;
end;
procedure MouseDown(x,y,mb: integer);
begin
if EndOfGame then // Если все фишки на своих местах, то не реагировать на мышь и ждать нажатия кнопки "Перемешать"
exit;
if ObjectUnderPoint(x,y)=nil then // Eсли мы щелкнули не на объекте, то не реагировать на мышь
exit;
var fx := (x-x0) div (sz+zz) + 1; // Вычислить координаты на доске для ячейки, на которой мы щелкнули мышью
var fy := (y-y0) div (sz+zz) + 1;
if (fx>n) or (fy>n) then
exit;
if Sosedi(fx,fy,EmptyCellX,EmptyCellY) then // Если ячейка соседствует с пустой, то поменять их местами
begin
Swap(p[EmptyCellY,EmptyCellX],p[fy,fx]);
EmptyCellX := fx;
EmptyCellY := fy;
Inc(MovesCount);
StatusRect.Text := 'Количество ходов: ' + IntToStr(MovesCount);
if IsSolution then
begin
StatusRect.Text := 'Победа! Сделано ходов: ' + IntToStr(MovesCount);
StatusRect.Color := RGB(255,200,200);
EndOfGame := True;
end
end;
end;
begin
SetSmoothingOff;
Window.Title := 'Игра в 15';
Window.IsFixedSize := True;
SetWindowSize(2*x0+(sz+zz)*n-zz,2*y0+(sz+zz)*n-zz+90);
EndOfGame := False;
Create15;
MeshButton := ButtonABC.Create((WindowWidth-200) div 2,2*y0+(sz+zz)*n-zz,200,'Перемешать',clLightGray);
MeshButton.OnClick := Mesh15;
StatusRect := new RectangleABC(0,WindowHeight-40,WindowWidth,40,RGB(200,200,255));
StatusRect.TextVisible := True;
StatusRect.Text := 'Количество ходов: '+IntToStr(MovesCount);
StatusRect.BorderWidth := 2;
StatusRect.BorderColor := RGB(80,80,255);
MovesCount := 0;
OnMouseDown := MouseDown;
end.

96
Animals/Animals.pas Normal file
View File

@ -0,0 +1,96 @@
// Самообучающаяся игра "Угадай животное".
// Старайтесь на вопрос "Чем отличается" вводить самый общий ответ
// Например: "Чем отличается чиж от ежа" - "Умеет летать"
type
TNode = class
s: string;
left,right: TNode;
constructor(s: string);
begin
Self.s := s;
left := nil;
right := nil;
end;
end;
var f: text;
/// Сохранить дерево в файл
procedure SaveToFile(p: TNode);
begin
if p=nil then
begin
writeln(f,'');
exit
end;
writeln(f,p.s);
SaveToFile(p.left);
SaveToFile(p.right);
end;
/// Загрузить дерево из файла
function LoadFromFile: TNode;
var
s: string;
p: TNode;
begin
readln(f,s);
if s='' then
begin
Result := nil;
exit
end;
p := new TNode(s);
p.left := LoadFromFile;
p.right := LoadFromFile;
Result := p;
end;
var
p,p1,p2,root: TNode;
x: integer;
s,q: string;
begin
writeln('Загадайте животное');
assign(f, 'animals_data.txt');
if not FileExists('animals_data.txt') then
root := new TNode('Собака')
else
begin
reset(f);
root := loadfromfile;
close(f);
end;
p := root;
while p.left<>nil do
begin
write(p.s+'? (0 - Нет, 1 - Да): ');
readln(x);
if x=1 then
p := p.left
else
p := p.right
end;
write('Это '+p.s+'? (0 - Нет, 1 - Да): ');
readln(x);
if x=1 then
writeln('Я угадала!')
else
begin
write('Я проиграла. Что это за животное? ');
readln(s);
write('Введите вопрос, отличающий это животное от '+p.s+': ');
readln(q);
p1 := new TNode(s);
p2 := new TNode(p.s);
p.s := q;
p.left := p1;
p.right := p2;
end;
Rewrite(f);
SaveToFile(root);
Close(f);
end.

175
Animals/animals_data.txt Normal file
View File

@ -0,0 +1,175 @@
Это птица
Не летает
Домашняя птица
Курица
Не имеет перьев
Пингвин
Страус
Очень маленькая птица
Живет в клетке
Попугай
Как яйцо
Пингвин
Колибри
Каркает
Ворона
Поет
Соловей
Дятел
Она мяукает
ест людей
Пантера
Кошка
Это большое животное
Это рыба
Не хищное
Имеет усы
Сом
Дельфин
Акула
Она хрюкает
Оно дикое
Кабан
Свинья
Это человекообразное
Оно разумное
Смотрит Аниме
Анимешник
человек
Горилла
Ест людей
Царь зверей
Лев
Имеет шерсть
Имеет пятнистую шкуру
Пантера
Тигр
Крокодил
Имеет большую пасть
Имеет рог на носу
Носорог
Длинный нос
Слон
Бегемот
Имеет длинную шею
Жираф
Дает молоко
В китае?
Панда
корова
Спит зимой
Медведь
Слон
Имеет длинные уши
Заяц
Ползает по кухне
Ткет паутину
Паук
Боится кошки
Мышь
Гавкает
Собака
Таракан
Живет в лесу
Нападает на людей
Волк
Лиса
Квакает
Лягушка
За ней охотится кошка
Мышь
Блеет
Козел
Имеет рога
Баран
Грызёт всё
Хомяк
Собака

318
Battle.pas Normal file
View File

@ -0,0 +1,318 @@
uses GraphABC;
const types = 3; //число типов рыб минус 1
rmax = 4; //радиус всех рыб
CanEat = rmax; //максимальное расстояние при поедании
eps = 0.00001; //необходимо при операциях с данными real
epsustupi = 0.1; //насколько значима иерархия среди хищников
strahkraj = 3; //во сколько раз жертвы боятся края меньше, чем хищников
ustupi = CanEat*10; //насколько значима иерархия среди хищников
BkColor = clBlack; //Фон
Height = 600; //Высота графического окна
Width = 780; //Ширина графического окна
xmin = 10; //
ymin = 10; //Минимальные и максимальные значения координат,
xmax = Width - 100; //которые могут принимать рыбы
ymax = Height - 140; //
Type
fishtype = class //Описание одной стаи
c : color;
public
CanRazm, MaxKol, Kol, MaxLife, MinFood: integer;
//цвет, размножение, макс. кол-во, текущее кол-во, макс. жизнь,
//сколько хищнику нужно есть для размножения
Speed, See: real; //Нормальная скорость и зрение в пикселях
constructor create(ac:color; aCanRazm, aMaxKol, aMaxLife, aMinFood:integer; aSpeed, aSee: real);
begin
c:= ac; CanRazm:= aCanRazm; MaxKol:= aMaxKol; Kol:= 1;
MaxLife:= aMaxLife; MinFood:= aMinFood; Speed:= aSpeed; See:= aSee
end;
procedure ShowKol(y: integer); //отобразить текущее кол-во
var s: string;
begin
SetFontColor(c);
TextOut(xmax + 20, y, ' ');
s := IntToStr(kol);
TextOut(xmax + 20, y, s);
end;
end;
var opisanie: array[0..types] of fishtype; //данные для всех стай
Type
fish = class
x, y, r, dx0, dy0: real; //текущие координаты, радиус и предыдущий шаг
tip, life, razm, status, food: integer;
//razm - время с момента последнего размножения,
//status - состояние - спокойное или возбуждённое
next, prev: fish; //двусвязный циклический список
constructor Create(ax, ay, ar: real; atip: integer; aprev, anext: fish);
begin
x:= ax; y:= ay; r:= ar; tip:= atip; prev:= aprev; next:= anext;
life:= 0; razm:= 0; dx0:= random; dy0:= random; status:= 1; food:= 0;
end;
procedure show;
begin
SetPenColor(opisanie[tip].c);
circle(round(x), round(y), round(r))
end;
procedure hide;
begin
SetPenColor(BkColor);
circle(round(x), round(y), round(r))
end;
procedure Destroy;
begin
hide;
opisanie[tip].kol:= opisanie[tip].kol - 1;
opisanie[tip].ShowKol(tip*40 + 20);
end;
procedure moveto(dx, dy: real);
begin
hide;
x:= x + dx; y:= y + dy;
if x > xmax then x:= xmax;
if x < xmin then x:= xmin;
if y > ymax then y:= ymax;
if y < ymin then y:= ymin;
show
end;
procedure MakeDeti(var mama, StartAkula, KonAkula, StartKilka, KonKilka : fish);
//произвести потомство
var d: fish;
begin
razm:= 0;
food:= 0;
d:= fish.create(x, y, r, tip, mama, next);
next.prev:= d;
next:= d;
if mama = KonAkula then KonAkula:= d;
if mama = KonKilka then KonKilka:= d;
opisanie[tip].kol:= opisanie[tip].kol + 1;
opisanie[tip].ShowKol(tip*40 + 20);
end;
procedure step(var ribka, StartAkula, KonAkula, StartKilka, KonKilka : fish);
//Здесь алгоритмы для рыб
var
dx, dy, d, dx2, dy2, dmin: real;
t, trup, found: fish;
FoundOhot: boolean;
begin
status:= 1; //Нормальное состояние
dx:= 0; dy:= 0;
if tip > 0 then
begin //Начало алгоритма для жертв
t:= StartAkula;
if t<>nil then
repeat //Ищем всех хищников в поле видимости
d:= sqrt((x - t.x)*(x - t.x) + (y - t.y)*(y - t.y));
if d < opisanie[tip].See then
begin
if d < eps then d:= eps;
dx2:= (x - t.x)/(d*d);
dy2:= (y - t.y)/(d*d);
dx:= dx + dx2;
dy:= dy + dy2;
status:= 2; //Возбуждённое состояние
end;
t:= t.next
until t = KonAkula.next;
//И обратим внимание на края:
if x - xmin < opisanie[tip].See then dx:= dx + 1/((x - xmin + eps)*strahkraj);
if xmax - x < opisanie[tip].See then dx:= dx + 1/((x - xmax - eps)*strahkraj);
if y - ymin < opisanie[tip].See then dy:= dy + 1/((y - ymin + eps)*strahkraj);
if ymax - y < opisanie[tip].See then dy:= dy + 1/((y - ymax - eps)*strahkraj);
d:= sqrt(dx*dx + dy*dy);
if d < eps then
begin
dx:= 2*status*random()*opisanie[tip].Speed - status*opisanie[tip].Speed;
dy:= 2*status*random()*opisanie[tip].Speed - status*opisanie[tip].Speed
end
else
begin
dx:= status*opisanie[tip].Speed*dx/d;
dy:= status*opisanie[tip].Speed*dy/d
end
end
else {tip = 0}
begin //Начало алгоритма для хищников
dmin:= 11000;
t:= StartAkula;
while t<>ribka do //Проверяем всех выше по иерархии
begin
d:= sqrt((x - t.x)*(x - t.x) + (y - t.y)*(y - t.y));
if (d < dmin) and (abs(dx0 - t.dx0) < epsustupi) and
(abs(dy0 - t.dy0) < epsustupi) then dmin:= d;
t:= t.next
end;
FoundOhot:= dmin < ustupi;
dmin:= 11000;
found:= nil;
t:= StartKilka;
if (t<>nil) and (life > 100) and not FoundOhot then
repeat
d:= sqrt((x - t.x)*(x - t.x) + (y - t.y)*(y - t.y));
if d < dmin then
begin
dmin:= d;
found:= t //found - ближайшая жертва
end;
t:= t.next
until t = KonKilka.next;
if (found <> nil) and (dmin < opisanie[tip].See) then
begin
status:= 2; //Возбуждённое состояние
dx:= found.x - x;
dy:= found.y - y;
if dmin < CanEat + status*opisanie[tip].Speed then
begin //Поедание
found.next.prev:= found.prev;
found.prev.next:= found.next;
if (found = StartKilka) and (found = KonKilka) then
begin
//StartKilka:= nil;
//KonKilka:= nil
end;
if found = StartKilka then
StartKilka:= StartKilka.next;
if found = KonKilka then
KonKilka:= KonKilka.prev;
found.destroy;
found := nil;
food:= food + 1
end
end
else
if (x <= xmin) or (x >= xmax) or (y <= ymin) or (y >= ymax) then
begin
dx:= 2*status*random()*opisanie[tip].Speed - status*opisanie[tip].Speed;
dy:= 2*status*random()*opisanie[tip].Speed - status*opisanie[tip].Speed
end
else
begin
dx:= dx0; dy:= dy0 //Повтор предыдущего шага - патрулирование
end;
d:= sqrt(dx*dx + dy*dy);
if d > eps then
begin
dx:= status*opisanie[tip].Speed*dx/d;
dy:= status*opisanie[tip].Speed*dy/d;
end
end;
//Начало алгоритма для всех рыб
moveto(dx, dy);
dx0:= dx; dy0:= dy;
life:= life + 1; razm:= razm + 1;
if opisanie[tip].Kol >= opisanie[tip].MaxKol then Razm:= 0;
if (razm > opisanie[tip].CanRazm) and (food >= opisanie[tip].minfood) then
MakeDeti(ribka, StartAkula, KonAkula, StartKilka, KonKilka);
if life > opisanie[tip].MaxLife then //Смерть от старости
begin
trup:= ribka; ribka:= ribka.prev;
trup.next.prev:= trup.prev;
trup.prev.next:= trup.next;
if trup = StartKilka then
StartKilka:= StartKilka.next;
if trup = KonKilka then
KonKilka:= KonKilka.prev;
if trup = StartAkula then
StartAkula:= StartAkula.next;
if trup = KonAkula then
KonAkula:= KonAkula.prev;
if trup = trup.next then ribka:= nil;
if trup <> nil then
trup.destroy;
trup := nil;
end
end;
end;
function getAllCount:integer;
var i,c:integer;
begin
c:=0;
for i:=0 to types do
c:=c+opisanie[i].Kol;
getAllCount:=c;
end;
var i: integer;
p, q, StartAkula, StartKilka, KonAkula, KonKilka, tek: fish;
begin
SetSmoothing(False);
SetWindowSize(Width, Height);
SetWindowLeft(200);
SetWindowTop(50);
SetWindowCaption('Битва за жизнь');
SetFontSize(7);
SetFontName('Arial');
SetBrushColor(BkColor);
FillRectangle(0, 0, Width, Height);
SetFontColor(clWhite);
TextOut(10, ymax + 20, 'Автор программы - Иванов С.О. e-mail: ssyy@yandex.ru');
TextOut(10, ymax + 20+1*18, 'Программа моделирует поведение нескольких стай рыб. Справа - количества рыб в текущий');
TextOut(10, ymax + 20+2*18, 'момент времени. Изменяя параметры в коде программы, можно влиять на ход битвы.');
TextOut(10, ymax + 20+3*18, 'По умолчанию: красные - хищники, поедают любых рыб из других стай, не плодятся,');
TextOut(10, ymax + 20+4*18, 'пока не поели; синие - жертвы, самые медленные, но быстрее всех плодятся; зелёные - жертвы,');
TextOut(10, ymax + 20+5*18, 'быстрее синих, но плодятся медленнее; желтые - самые быстрые среди жертв, но желтых мало.');
SetFontSize(12);
StartAkula:= nil;
StartKilka:= nil;
KonAkula:= nil;
KonKilka:= nil;
//c - цвет.
//CanRazm - минимальное количество ходов отдельно взятой рыбы между двумя
// её последовательными размножениями.
//MaxKol - максимально допустимое количество рыб данного вида.
//Kol - количество рыб данного вида в текущий момент времени.
//MaxLife - максимальная продолжительность жизни.
// После того, как рыба сделает больше шагов, чем это число, она умирает.
//MinFood - минимальное количество съеденных жертв, необходимое для размножения
// (только для хищников; для жертв это количество принято за -1).
//Speed - нормальная скорость. Максимальная скорость рыбы в 2 раза больше этого числа.
//See - радиус обзора - как далеко видит рыба.
//c, CanRazm, MaxKol, MaxLife, MinFood, Speed, See
opisanie[3]:= fishtype.create(clYellow, 300, 15, 1500, -1, 0.99, 50);
opisanie[2]:= fishtype.create(clGreen, 150, 50, 1500, -1, 0.9, 50);
opisanie[1]:= fishtype.create(clBlue, 30, 50, 500, -1, 0.7, 35);
opisanie[0]:= fishtype.create(clRed, 1000, 40, 5000, 1, 1, 500);
SetPenColor(clWhite);
rectangle(round(xmin - rmax - 1), round(ymin - rmax - 1),
round(xmax + rmax + 1), round(ymax + rmax + 1));
//Теперь нужно построить первоначальный список
q:= fish.create(xmin + 10, ymax - 10, rmax, 0, nil, nil);
p:= fish.create(xmin + 10, ymin + 10, rmax, 1, q, q);
q.next:= p; q.prev:= p;
StartAkula:= q; KonAkula:= q;
StartKilka:= p; KonKilka:= p;
p:= fish.create(xmax - 10, ymin + 10, rmax, 2, KonKilka, StartAkula);
StartAkula.prev:= p;
KonKilka.next:= p; KonKilka:= p;
p:= fish.create(xmax - 10, ymax - 10, rmax, 3, KonKilka, StartAkula);
StartAkula.prev:= p;
KonKilka.next:= p; KonKilka:= p;
for i:= 0 to types do opisanie[i].ShowKol(i*40 + 20);
//И все ходят по очереди, пока хоть кто-то жив.
tek:= StartKilka;
//i:=0;c:=getallcount;LockDrawing;
repeat
tek:= tek.next;
tek.step(tek, StartAkula, KonAkula, StartKilka, KonKilka);
{i:=i+1;
if i>=c then begin
i:=0;c:=getallcount;
Redraw;
end;}
until (tek = nil);
end.

228
BookWorm/BookWormABCNET.pas Normal file
View File

@ -0,0 +1,228 @@
uses GraphABC,ABCObjects,ABCButtons,Events;
const
/// Примерная частота повторяемости букв
freqcharstr='аааааааааааааааааааааааааабббббввввввввггггдддддддееееееееееееееееееееежжззззииииииииииииииииииийккккккккккккккклллллллллллммммммнннннннннннннннннооооооооооооооооооооооооппппппппрррррррррррррррррссссссссссссстттттттттттттттууууууффххцццчччшшщыыьььььэюяяяя';
const
MaxWordLen = 12;
scorehits: array [1..MaxWordLen] of integer = (0,1,2,4,7,11,16,22,29,37,46,56);
type
MySquareABC = class(SquareABC) end;
var
/// Доска с буквами
MainBoard: ObjectBoardABC;
/// Доска высоты 1 для размещения слова
WordBoard: ObjectBoardABC;
/// Номер первого незанятого символа на доске WordBoard
cur: integer;
/// Количество ходов
moves: integer;
/// Очки
score: integer;
/// Прямоугольник для отображения информации
Status: RectangleABC;
/// Существует ли такое слово (все слова хранятся в файле words.txt)
function WordExists(s: string): boolean;
var
f: text;
str: string;
begin
s := LowerCase(s);
Result := False;
assign(f,'words.txt');
reset(f);
while not eof(f) do
begin
readln(f,str);
if s=str then
begin
Result := True;
break;
end;
end;
close(f);
end;
procedure MyMouseDown(x,y,mb: integer);
begin
// Нажата левая мышь
if mb=1 then
begin
if cur>WordBoard.DimX then
exit;
var ob := ObjectUnderPoint(x,y);
if (ob is MySquareABC) and ob.Visible then
begin
var ob1 := WordBoard[cur,1];
ob1.Visible := True;
ob1.Text := ob.Text;
Inc(cur);
ob.Visible := False;
var s := '';
for var i:=1 to cur-1 do
s := s + WordBoard[i,1].Text;
if WordExists(s) then
WordBoard.Color := clYellow
else WordBoard.Color := clSkyBlue
end;
end
else
// Нажата правая мышь
begin
for var xx:=1 to cur-1 do
WordBoard[xx,1].Visible := False;
for var xx:=1 to MainBoard.DimX do
for var yy:=1 to MainBoard.DimY do
MainBoard[xx,yy].Visible:=True;
cur := 1;
WordBoard.Color := clSkyBlue
end;
end;
/// Обработчик кнопки "Новая игра"
procedure BtNewClick;
begin
score := 0;
moves := 0;
Status.Text := 'Ходов: '+IntToStr(moves)+' Очков: '+IntToStr(score);
MyMouseDown(1,1,2);
for var xx:=1 to MainBoard.DimX do
for var yy:=1 to MainBoard.DimY do
MainBoard[xx,yy].Text := UpCase(freqcharstr[Random(255)+1]);
end;
/// Обработчик кнопки "Сказать слово"
procedure BtWordClick;
begin
if WordBoard.Color<>clYellow then
exit;
Inc(score,scorehits[cur-1]);
Inc(moves);
for var xx:=1 to cur-1 do
WordBoard[xx,1].Visible:=False;
for var xx:=1 to MainBoard.DimX do
for var yy:=1 to MainBoard.DimY do
if not MainBoard[xx,yy].Visible then
begin
MainBoard[xx,yy].Visible:=True;
MainBoard[xx,yy].Text:=UpCase(freqcharstr[Random(255)+1]);
end;
cur := 1;
WordBoard.Color := clSkyBlue;
Status.Text := 'Ходов: '+IntToStr(moves)+' Очков: '+IntToStr(score);
end;
/// Обработчик кнопки "Подсказка"
procedure BtPleaseClick;
var
f: text;
str,maxstr: string;
arr,work: array ['а'..'я'] of integer;
maxlen: integer;
function CanConstructWord(s: string): boolean;
begin
work := arr;
Result := True;
for var i:=1 to Length(s) do
begin
Dec(work[s[i]]);
if work[s[i]]<0 then
begin
Result := False;
break;
end;
end;
end;
begin // BtPleaseClick
maxlen := 0;
maxstr := '';
for var c:='а' to 'я' do
arr[c]:=0;
for var xx:=1 to MainBoard.DimX do
for var yy:=1 to MainBoard.DimY do
Inc(arr[LowCase(MainBoard[xx,yy].Text[1])]);
assign(f,'words.txt');
reset(f);
while not eof(f) do
begin
readln(f,str);
if CanConstructWord(str) and (Length(str)>maxlen) and (Length(str)<=MaxWordLen) then
begin
maxlen := Length(str);
maxstr := str;
end;
end;
close(f);
writeln(maxstr);
end;
procedure InitWindow;
begin
SetWindowSize(640,480);
Window.IsFixedSize := True;
Window.Title := 'Знай русские слова!';
Brush.Color := clMoneyGreen;
FillRect(0,0,WindowWidth,WindowHeight);
end;
procedure InitGameVars;
begin
cur := 1;
moves := 0;
score := 0;
end;
procedure InitButtons;
begin
var btword := new ButtonABC(70,410,180,30,'Сказать слово',clGray);
var btnew := new ButtonABC(280,410,100,30,'Заново',clLightGray);
var btplease := new ButtonABC(410,410,160,30,'Подсказка',clGray);
// Привязка обработчиков к кнопкам
btword.OnClick := BtWordClick;
btnew.OnClick := BtNewClick;
btplease.OnClick := BtPleaseClick;
end;
procedure InitInterface;
begin
Status := new RectangleABC(70,350,500,30,clSkyBlue);
Status.Text := 'Ходов: 0 Очков: 0';
WordBoard := new ObjectBoardABC(20,40,MaxWordLen,1,50,50,clSkyBlue);
MainBoard := new ObjectBoardABC(220,120,4,4,50,50,clMoneyGreen);
MainBoard.BorderColor := clGreen;
//MainBoard.Bordered := False;
for var x:=1 to WordBoard.DimX do
begin
WordBoard[x,1] := new SquareABC(0,0,WordBoard.CellSizeX-6,clWhite);
WordBoard[x,1].Visible := False;
end;
for var x:=1 to MainBoard.DimX do
for var y:=1 to MainBoard.DimY do
begin
MainBoard[x,y] := new MySquareABC(0,0,MainBoard.CellSizeX-6,clWhite);
MainBoard[x,y].Text := UpCase(freqcharstr[Random(freqcharstr.Length)+1]);
end;
end;
begin
SetConsoleIO;
InitWindow;
InitGameVars;
InitInterface;
InitButtons;
OnMouseDown := MyMouseDown;
end.

14842
BookWorm/words.txt Normal file
View File

File diff suppressed because it is too large Load Diff

3110
Chess3D/bishop.obj Normal file
View File

File diff suppressed because it is too large Load Diff

164
Chess3D/board.obj Normal file
View File

@ -0,0 +1,164 @@
# Blender3D v245 OBJ File: chess2.blend
# www.blender3d.org
v -6.000000 6.000000 0.000000
v -8.000000 6.000000 0.000000
v -8.000001 8.000000 0.000000
v -6.000000 7.999999 0.000000
v -6.000000 3.999999 0.000000
v -8.000000 3.999999 0.000000
v -8.000000 1.999999 0.000000
v -6.000000 2.000000 0.000000
v -6.000000 -2.000000 0.000000
v -8.000000 -2.000001 0.000000
v -8.000000 -0.000001 0.000000
v -6.000000 -0.000001 0.000000
v -5.999999 -4.000001 0.000000
v -8.000000 -4.000000 0.000000
v -8.000000 -6.000000 0.000000
v -6.000000 -6.000000 0.000000
v -3.999999 -8.000000 0.000000
v -6.000000 -8.000000 0.000000
v -6.000000 -6.000000 0.000000
v -3.999999 -6.000001 0.000000
v -3.999999 -2.000001 0.000000
v -6.000000 -2.000000 0.000000
v -6.000000 -4.000000 0.000000
v -4.000000 -4.000000 0.000000
v -4.000000 -0.000000 0.000000
v -6.000000 -0.000000 0.000000
v -6.000000 2.000000 0.000000
v -4.000000 1.999999 0.000000
v -4.000000 5.999999 0.000000
v -6.000000 6.000000 0.000000
v -6.000000 4.000000 0.000000
v -4.000000 4.000000 0.000000
v -0.000000 4.000000 0.000000
v -2.000000 4.000000 0.000000
v -2.000000 6.000000 0.000000
v 0.000000 6.000000 0.000000
v 0.000000 2.000000 0.000000
v -2.000000 2.000000 0.000000
v -2.000000 -0.000000 0.000000
v 0.000000 0.000000 0.000000
v 0.000000 -4.000000 0.000000
v -2.000000 -4.000000 0.000000
v -2.000000 -2.000000 0.000000
v 0.000001 -2.000000 0.000000
v 0.000001 -6.000000 0.000000
v -2.000000 -6.000000 0.000000
v -1.999999 -8.000000 0.000000
v 0.000001 -8.000000 0.000000
v -2.000000 -6.000000 0.000000
v -4.000000 -6.000000 0.000000
v -4.000000 -4.000000 0.000000
v -1.999999 -4.000000 0.000000
v -2.000000 -0.000001 0.000000
v -4.000000 -0.000000 0.000000
v -4.000000 -2.000000 0.000000
v -2.000000 -2.000000 0.000000
v -2.000000 2.000000 0.000000
v -4.000000 2.000000 0.000000
v -4.000000 4.000000 0.000000
v -2.000000 3.999999 0.000000
v -2.000000 8.000000 0.000000
v -4.000000 8.000000 0.000000
v -4.000000 6.000000 0.000000
v -2.000000 6.000000 0.000000
v 6.000000 6.000000 0.000000
v 4.000000 6.000000 0.000000
v 3.999999 8.000000 0.000000
v 6.000000 8.000000 0.000000
v 6.000000 4.000000 0.000000
v 4.000000 4.000000 0.000000
v 4.000000 2.000000 0.000000
v 6.000000 2.000000 0.000000
v 6.000000 -2.000000 0.000000
v 4.000000 -2.000000 0.000000
v 4.000000 0.000000 0.000000
v 6.000000 -0.000000 0.000000
v 6.000001 -4.000000 0.000000
v 4.000000 -4.000000 0.000000
v 4.000000 -6.000000 0.000000
v 6.000000 -6.000000 0.000000
v 8.000001 -8.000000 0.000000
v 6.000000 -8.000000 0.000000
v 6.000000 -6.000000 0.000000
v 8.000000 -6.000000 0.000000
v 8.000000 -2.000000 0.000000
v 6.000000 -2.000000 0.000000
v 6.000000 -4.000000 0.000000
v 8.000000 -3.999999 0.000000
v 8.000000 0.000001 0.000000
v 6.000000 0.000000 0.000000
v 6.000000 2.000000 0.000000
v 8.000000 2.000000 0.000000
v 8.000000 6.000000 0.000000
v 6.000000 6.000000 0.000000
v 6.000000 4.000000 0.000000
v 8.000000 4.000000 0.000000
v 4.000000 4.000000 0.000000
v 2.000000 4.000000 0.000000
v 2.000000 6.000000 0.000000
v 4.000000 6.000000 0.000000
v 4.000000 2.000000 0.000000
v 2.000000 2.000000 0.000000
v 2.000000 0.000000 0.000000
v 4.000000 0.000000 0.000000
v 4.000000 -4.000000 0.000000
v 2.000000 -4.000000 0.000000
v 2.000000 -2.000000 0.000000
v 4.000000 -2.000000 0.000000
v 4.000001 -6.000000 0.000000
v 2.000000 -6.000000 0.000000
v 2.000001 -8.000000 0.000000
v 4.000000 -8.000000 0.000000
v 2.000000 -6.000000 0.000000
v 0.000000 -6.000000 0.000000
v 0.000000 -4.000000 0.000000
v 2.000001 -4.000000 0.000000
v 2.000000 -0.000000 0.000000
v 0.000000 0.000000 0.000000
v 0.000000 -2.000000 0.000000
v 2.000000 -2.000000 0.000000
v 2.000000 2.000000 0.000000
v -0.000000 2.000000 0.000000
v -0.000000 4.000000 0.000000
v 2.000000 4.000000 0.000000
v 2.000000 8.000000 0.000000
v -0.000001 8.000000 0.000000
v -0.000000 6.000000 0.000000
v 2.000000 6.000000 0.000000
usemtl Material.001
s off
f 1 4 3 2
f 6 7 8 5
f 11 10 9 12
f 14 15 16 13
f 30 31 32 29
f 27 26 25 28
f 22 23 24 21
f 19 18 17 20
f 62 63 64 61
f 59 58 57 60
f 54 55 56 53
f 51 50 49 52
f 35 34 33 36
f 38 39 40 37
f 43 42 41 44
f 46 47 48 45
f 126 127 128 125
f 123 122 121 124
f 118 119 120 117
f 115 114 113 116
f 99 98 97 100
f 102 103 104 101
f 107 106 105 108
f 110 111 112 109
f 67 66 65 68
f 70 71 72 69
f 75 74 73 76
f 78 79 80 77
f 94 95 96 93
f 91 90 89 92
f 86 87 88 85
f 83 82 81 84

181
Chess3D/game2.pas Normal file
View File

@ -0,0 +1,181 @@
uses Graph3D;
type
FigureColor = (Black,White);
FigureKind = (BishopK, HorseK, KingK, PownK, QueenK, RockK);
var
BlackC := GrayColor(60);
WhiteC := Colors.White;
delay := 1000;
type ChessFigure = class
f: FileModelT;
public
color: FigureColor;
k: FigureKind;
x,y: integer;
constructor Create(kk: FigureKind; cc: FigureColor);
function MoveTo(xx,yy: integer): ChessFigure;
function AnimMoveTo(xx,yy: integer): ChessFigure;
procedure Destroy;
begin
f.Destroy;
end;
end;
var a := new ChessFigure[8,8];
constructor ChessFigure.Create(kk: FigureKind; cc: FigureColor);
begin
color := cc;
var c := cc=Black ? BlackC : WhiteC;
case kk of
bishopK: f := FileModel3D(4,14,0,'bishop.obj',c);
horseK : f := FileModel3D(2,14,0,'horse.obj',c);
kingK : f := FileModel3D(6,14,0,'king.obj',c);
pownK : f := FileModel3D(0,12,0,'pawn.obj',c);
queenK : f := FileModel3D(8,14,0,'queen.obj',c);
rockK : f := FileModel3D(0,14,0,'rook.obj',c);
end;
k := kk;
end;
function ChessFigure.MoveTo(xx,yy: integer): ChessFigure;
begin
a[y,x] := nil;
if a[yy,xx]<>nil then
a[yy,xx].Destroy;
a[yy,xx] := Self;
var dx := xx - x;
var dy := yy - y;
f.MoveOn(-dx*2,-dy*2,0);
(x,y) := (xx,yy);
Result := Self;
end;
function ChessFigure.AnimMoveTo(xx,yy: integer): ChessFigure;
begin
var dx := xx - x;
var dy := yy - y;
f.AnimMoveOn(-dx*2,-dy*2,0,delay/1000).WhenCompleted(procedure -> begin
a[y,x] := nil;
if a[yy,xx]<>nil then
a[yy,xx].Destroy;
a[yy,xx] := Self;
end
).Begin;
(x,y) := (xx,yy);
Result := Self;
end;
function Bishop(x,y: integer; c: FigureColor) := ChessFigure.Create(FigureKind.BishopK,c).MoveTo(x,y);
function Horse(x,y: integer; c: FigureColor) := ChessFigure.Create(FigureKind.HorseK,c).MoveTo(x,y);
function King(x,y: integer; c: FigureColor) := ChessFigure.Create(FigureKind.KingK,c).MoveTo(x,y);
function Queen(x,y: integer; c: FigureColor) := ChessFigure.Create(FigureKind.QueenK,c).MoveTo(x,y);
function Rock(x,y: integer; c: FigureColor) := ChessFigure.Create(FigureKind.RockK,c).MoveTo(x,y);
function Pown(x,y: integer; c: FigureColor) := ChessFigure.Create(FigureKind.PownK,c).MoveTo(x,y);
procedure InitScene;
begin
var d := 7;
for var c := 'A' to 'H' do
begin
var t := Text3D(d,8.5,0,c,0.5);
t.UpDirection := v3d(0,-1,0);
d -= 2;
end;
d := 7;
for var c := '1' to '8' do
begin
var t := Text3D(8.3,d,0,c,0.5);
t.UpDirection := v3d(0,-1,0);
d -= 2;
end;
View3D.ShowGridLines := False;
FileModel3D(0,0,0,'board.obj',GrayColor(100));
end;
procedure StartupPosition;
begin
Rock(0,0,White);
Horse(1,0,White);
Bishop(2,0,White);
King(3,0,White);
Queen(4,0,White);
Bishop(5,0,White);
Horse(6,0,White);
Rock(7,0,White);
for var i:=0 to 7 do
Pown(i,1,White);
Rock(0,7,Black);
Horse(1,7,Black);
Bishop(2,7,Black);
King(3,7,Black);
Queen(4,7,Black);
Bishop(5,7,Black);
Horse(6,7,Black);
Rock(7,7,Black);
for var i:=0 to 7 do
Pown(i,6,Black);
end;
procedure Turn(x,y,x1,y1: integer);
begin
if a[y,x]=nil then
begin
Println('>',y,x);
exit;
end;
//Print(a[y,x],a[y1,x1]);
a[y,x].AnimMoveTo(x1,y1);
//Println('->',a[y,x],a[y1,x1]);
Sleep(delay);
end;
procedure TurnB(s1,s2: string);
begin
//Println(s1,s2);
Turn(Ord(s1[1])-Ord('a'),s1[2].ToDigit-1,Ord(s2[1])-Ord('a'),s2[2].ToDigit-1);
end;
procedure Turns(s: string);
begin
var ss := s.ToWords.Batch(3).SelectMany(d->d.ToArray[1:]);
var i := 0;
foreach var d in ss do
begin
var p := Pos('-',d);
var p1 := d[:p];
if Length(p1)=3 then
p1 := p1[2:];
var p2 := d[p+1:];
if Length(p2)=3 then
p2 := p2[2:];
if (p1 = '0') and (p2 = '0') then
begin
if i mod 2 = 0 then
begin
TurnB('e1','g1');
TurnB('h1','f1');
end
else
begin
TurnB('e8','g8');
TurnB('h8','f8');
end
end
else TurnB(p1,p2);
i += 1;
end;
end;
begin
InitScene;
StartupPosition;
//Turns('1. c2-c4 g7-g6 2. e2-e4 Cf8-g7 3. d2-d4 d7-d6 4. Kb1-c3 Kg8-f6 5. Kg1-f3 0-0 6. Cf1-e2 e7-e5 7. Cc1-e3 Kf6-g4 8. Ce3-g5 f7-f6 9. Cg5-h4 g6-g5 10. Ch4-g3 Kg4-h6');
Turns('1. e2-e4 e7-e5 2. f1-c4 g8-f6 3. d2-d4 e5-d4 4. g1-f3 d7-d5 5. e4-d5 f8-b4 6. c2-c3 d8-e7');
end.

2557
Chess3D/horse.obj Normal file
View File

File diff suppressed because it is too large Load Diff

1463
Chess3D/king.obj Normal file
View File

File diff suppressed because it is too large Load Diff

2406
Chess3D/pawn.obj Normal file
View File

File diff suppressed because it is too large Load Diff

2214
Chess3D/queen.obj Normal file
View File

File diff suppressed because it is too large Load Diff

1542
Chess3D/rook.obj Normal file
View File

File diff suppressed because it is too large Load Diff

56
DeleteByMouse.pas Normal file
View File

@ -0,0 +1,56 @@
uses ABCObjects,GraphABC;
const CountSquares = 20;
var
/// Текущая цифра
CurrentDigit: integer;
/// Количество ошибок
Mistakes: integer;
/// Строка информации
StatusRect: RectangleABC;
/// Вывод информационной строки
procedure DrawStatusText;
begin
if CurrentDigit<=CountSquares then
StatusRect.Text := 'Удалено квадратов: ' + IntToStr(CurrentDigit-1) + ' Ошибок: ' + IntToStr(Mistakes)
else StatusRect.Text := 'Игра окончена. Время: ' + IntToStr(Milliseconds div 1000) + ' с. Ошибок: ' + IntToStr(Mistakes);
end;
/// Обработчик события мыши
procedure MyMouseDown(x,y,mb: integer);
begin
var ob := ObjectUnderPoint(x,y);
if (ob<>nil) and (ob is RectangleABC) then
if ob.Number=CurrentDigit then
begin
ob.Destroy;
Inc(CurrentDigit);
DrawStatusText;
end
else
begin
ob.Color := clRed;
Inc(Mistakes);
DrawStatusText;
end;
end;
begin
Window.Title := 'Игра: удали все квадраты по порядку';
Window.IsFixedSize := True;
for var i:=1 to CountSquares do
begin
var x := Random(WindowWidth-50);
var y := Random(WindowHeight-100);
var ob := RectangleABC.Create(x,y,50,50,clMoneyGreen);
ob.Number := i;
end;
StatusRect := RectangleABC.Create(0,Window.Height-40,Window.Width,40,Color.LightSteelBlue);
CurrentDigit := 1;
Mistakes := 0;
DrawStatusText;
// Установка обработчиков
OnMouseDown := MyMouseDown;
end.

238
KillThem.pas Normal file
View File

@ -0,0 +1,238 @@
uses ABCObjects,GraphABC,Timers;
const
clPlayer = Color.BurlyWood;
var
kLeftKey,kRightKey: boolean;
kSpaceKey: integer;
/// Игрок
Player: RectangleABC;
/// Таймер движения врагов
t: Timer;
/// Флаг конца игры
EndOfGame: boolean;
/// Количество неигровых объектов
StaticObjectsCount: integer;
/// Счетчик выигрышей
Wins: integer;
/// Счетчик проигрышей
Falls: integer;
/// Информационная строка
InfoString: RectangleABC;
/// Сообщение в начале игры
NewGame: RoundRectABC;
type
KeysType = (kLeft,kRight);
/// Класс пули
Pulya = class(CircleABC)
public
constructor Create(x,y: integer);
procedure Move; override;
end;
/// Класс врага
Enemy = class(RectangleABC)
public
constructor Create(x,y,w: integer);
procedure Move; override;
end;
constructor Pulya.Create(x,y: integer);
begin
inherited Create(x,y,5,clRed);
dx := 0;
dy := -5;
end;
procedure Pulya.Move;
begin
inherited Move;
if Top<0 then
Visible := False;
for var j:=StaticObjectsCount to Objects.Count-1 do
// При столкновении пуля и объект становятся невидимыми
if (Objects[j]<>Self) and Intersect(Objects[j]) then
begin
Objects[j].Visible := False;
Visible := False;
end;
end;
constructor Enemy.Create(x,y,w: integer);
begin
inherited Create(x,y,w,20,clRandom);
if Random(2)=0 then
dx := 5
else dx := -5;
dy := 0;
end;
procedure Enemy.Move;
begin
if Random(2)<>0 then
Exit;
if Random(10)=0 then
dy := 5;
if (Left<0) or (Left+Width>Window.Width) or (Random(30)=0) then
dx := -dx;
inherited Move;
if dy<>0 then
dy := 0;
if Top>Window.Height-50 then
EndOfGame := True;
end;
/// Количество врагов
function NumberOfEnemies: integer;
begin
Result := 0;
for var i:=0 to Objects.Count-1 do
if Objects[i] is Enemy then
Result += 1;
end;
/// Создание игрока и врагов
procedure CreateObjects;
begin
Player := new RectangleABC(280,WindowHeight-30,100,20,clPlayer);
for var i:=1 to 100 do
begin
var r1 := new Enemy(Random(WindowWidth-50),40+Random(10),50);
r1.TextVisible := True;
r1.Number := i;
end;
end;
/// Разрушение игрока и врагов
procedure DestroyObjects;
begin
for var i:=Objects.Count-1 downto StaticObjectsCount do
Objects[i].Destroy;
end;
/// Перемещение врагов
procedure MoveObjects;
begin
for var i:=StaticObjectsCount+1 to Objects.Count-1 do
Objects[i].Move;
end;
/// Удаление уничтоженных объектов
procedure DestroyKilledObjects;
begin
for var i:=ObjectsCount-1 downto StaticObjectsCount+1 do
if not Objects[i].Visible then
Objects[i].Destroy;
end;
/// Обработчик нажатия клавиши
procedure KeyDown(Key: integer);
begin
case Key of
vk_Left: kLeftKey := True;
vk_Right: kRightKey := True;
vk_Space: if kSpaceKey=2 then kSpaceKey := 1;
end;
end;
/// Обработчик отжатия клавиши
procedure KeyUp(Key: integer);
begin
case Key of
vk_Left: kLeftKey := False;
vk_Right: kRightKey := False;
vk_Space: kSpaceKey := 2;
end;
end;
/// Изменение информационной строки
procedure ChangeInfoString;
begin
InfoString.Text := 'Врагов: '+IntToStr(NumberOfEnemies)+' Побед: '+IntToStr(Wins)+' Поражений: '+IntToStr(Falls);
end;
/// Обработчик нажатия символьной клавиши
procedure KeyPress(Key: char);
begin
if (Key in ['G','П','g','п']) and EndOfGame then
begin
NewGame.Visible := False;
EndOfGame := False;
t.Start;
CreateObjects;
kSpaceKey := 2;
kLeftKey := False;
kRightKey := False;
end;
end;
/// Обработчик отжатия мыши
procedure MouseUp(x,y,mb: integer);
begin
if NewGame.PTInside(x,y) then
KeyPress('G');
end;
/// Обработчик таймера
procedure TimerProc;
begin
if kLeftKey and (Player.Left>0) then
Player.MoveOn(-10,0);
if kRightKey and (Player.Left+Player.Width<WindowWidth) then
Player.MoveOn(10,0);
if kSpaceKey=1 then
begin
new Pulya(Player.Left+Player.Width div 2,Player.Top-10);
kSpaceKey := 0;
end;
MoveObjects;
DestroyKilledObjects;
RedrawObjects;
ChangeInfoString;
var n := NumberOfEnemies;
// Страховка от случая, когда процедура таймера выполняется одновременно в нескольких потоках
if n=0 then
EndOfGame := True;
if EndOfGame then
begin
if t.Enabled=False then Exit;
t.Stop;
if n>0 then
Falls += 1
else Wins += 1;
NewGame.Visible := True;
DestroyObjects;
ChangeInfoString;
RedrawObjects;
end;
end;
begin
Window.Title := 'Стрелялка';
Window.IsFixedSize := True;
ClearWindow(clBlack);
LockDrawingObjects;
EndOfGame := True;
InfoString := new RectangleABC(0,0,Window.Width,38,Color.DarkBlue);
InfoString.Bordered := False;
InfoString.FontColor := clWhite;
InfoString.TextScale := 0.9;
var zz := 100;
NewGame := new RoundRectABC(zz,200,400,200,30,Color.Violet);
NewGame.Center := Window.Center;
NewGame.Text := 'G - Новая игра';
StaticObjectsCount := Objects.Count;
ChangeInfoString;
RedrawObjects;
OnKeyDown := KeyDown;
OnKeyPress := KeyPress;
OnKeyUp := KeyUp;
OnMouseUp := MouseUp;
t := new Timer(1,TimerProc);
end.

318
Life.pas Normal file
View File

@ -0,0 +1,318 @@
// Игра "Жизнь" на торе
// Оптимизация хешированием по равномерной сетке
uses GraphABC;
const
/// Ширина клетки
w = 4;
/// Количество клеток по ширине
m = 300;
/// Количество клеток по высоте
n = 220;
/// Отступ поля от левой границы окна
x0 = 1;
/// Отступ поля от верхней границы окна
y0 = 21;
mm = m + 1;
nn = n + 1;
/// Количество клеток сетки по горизонтали
mk = 15;
/// Количество клеток сетки по вертикали
nk = 10;
var
a,b,sosedia,sosedib: array [0..nn,0..mm] of byte;
obnovA,obnovB: array [1..nk,1..mk] of boolean;
CountCells: integer;
obn: boolean;
gen: integer;
hn,hm: integer;
/// Нарисовать ячейку
procedure DrawCell(i,j: integer);
begin
DrawInBuffer := False;
SetBrushColor(clBlack);
FillRectangle(x0+(j-1)*w,y0+(i-1)*w,x0+j*w-1,y0+i*w-1);
DrawInBuffer := True;
end;
/// Стереть ячейку
procedure ClearCell(i,j: integer);
begin
DrawInBuffer := False;
SetBrushColor(clWhite);
FillRectangle(x0+(j-1)*w,y0+(i-1)*w,x0+j*w-1,y0+i*w-1);
DrawInBuffer := True;
end;
/// Нарисовать все изменившиеся ячейки
procedure DrawConfiguration;
begin
for var i:=1 to n do
for var j:=1 to m do
begin
var bb := b[i,j];
if a[i,j]<>bb then
if bb=1 then DrawCell(i,j)
else ClearCell(i,j);
end;
end;
/// Нарисовать все ячейки
procedure DrawConfigurationFull;
begin
for var i:=1 to n do
for var j:=1 to m do
if b[i,j]=1 then DrawCell(i,j)
else ClearCell(i,j);
end;
/// Нарисовать поле
procedure DrawField;
begin
Pen.Color := clLightGray;
for var i:=0 to m do
begin
if i mod hm = 0 then
Pen.Color := clGray
else Pen.Color := clLightGray;
Line(x0+i*w-1,y0,x0+i*w-1,y0+n*w);
end;
for var i:=0 to n do
begin
if i mod hn = 0 then
Pen.Color := clGray
else Pen.Color := clLightGray;
Line(x0,y0+i*w-1,x0+m*w,y0+i*w-1);
end;
end;
/// Увеличить массив соседей для данной клетки
procedure IncSosedi(i,j: integer);
var i1,i2,j1,j2: integer;
begin
if i=1 then i1:=n else i1:=i-1;
if i=n then i2:=1 else i2:=i+1;
if j=1 then j1:=m else j1:=j-1;
if j=m then j2:=1 else j2:=j+1;
SosediB[i1,j1] += 1;
SosediB[i1,j] += 1;
SosediB[i1,j2] += 1;
SosediB[i,j1] += 1;
SosediB[i,j2] += 1;
SosediB[i2,j1] += 1;
SosediB[i2,j] += 1;
SosediB[i2,j2] += 1;
end;
/// Уменьшить массив соседей для данной клетки
procedure DecSosedi(i,j: integer);
var i1,i2,j1,j2: integer;
begin
if i=1 then i1:=n else i1:=i-1;
if i=n then i2:=1 else i2:=i+1;
if j=1 then j1:=m else j1:=j-1;
if j=m then j2:=1 else j2:=j+1;
SosediB[i1,j1] -= 1;
SosediB[i1,j] -= 1;
SosediB[i1,j2] -= 1;
SosediB[i,j1] -= 1;
SosediB[i,j2] -= 1;
SosediB[i2,j1] -= 1;
SosediB[i2,j] -= 1;
SosediB[i2,j2] -= 1;
end;
/// Поставить ячейку в клетку (i,j)
procedure SetCell(i,j: integer);
begin
if b[i,j]=0 then
begin
b[i,j] := 1;
obn := True;
IncSosedi(i,j);
end;
CountCells += 1;
end;
/// Убрать ячейку из клетки (i,j)
procedure UnSetCell(i,j: integer);
begin
if b[i,j]=1 then
begin
b[i,j] := 0;
obn := True;
DecSosedi(i,j);
end;
CountCells -= 1;
end;
/// Инициализировать массивы и конфигурацию поля
procedure Init;
var
xc := n div 2;
yc := m div 2;
begin
for var i:=0 to n+1 do
for var j:=0 to m+1 do
b[i,j] := 0;
a := b;
SosediB := b;
SosediA := SosediB;
for var ik:=1 to nk do
for var jk:=1 to mk do
obnovB[ik,jk] := True;
obnovA := obnovB;
CountCells := 0;
SetCell(xc,yc);
SetCell(xc,yc+1);
SetCell(xc,yc+2);
SetCell(xc-1,yc+2);
SetCell(xc+1,yc+1);
end;
/// Обработать ячейку
procedure ProcessCell(i,j: integer);
begin
case SosediA[i,j] of
0..1,4..9:
if b[i,j]=1 then
begin
b[i,j] := 0;
obn := True;
DecSosedi(i,j);
ClearCell(i,j);
Dec(CountCells);
end;
3: if b[i,j]=0 then
begin
b[i,j] := 1;
obn := True;
IncSosedi(i,j);
DrawCell(i,j);
Inc(CountCells);
end;
end; {case}
end;
/// Перейти к следующему поколению
procedure NextGen;
begin
for var ik:=1 to nk do
begin
for var jk:=1 to mk do
begin
obn := False;
var ifirst := (ik-1)*hn+1;
var ilast := (ik-1)*hn+hn;
var jfirst := (jk-1)*hm+1;
var jlast := (jk-1)*hm+hm;
if obnovA[ik,jk] then
begin
for var i:=ifirst to ilast do
for var j:=jfirst to jlast do
ProcessCell(i,j);
end
else
begin
var ik1,jk1,ik2,jk2: integer;
if ik=1 then ik1:=nk else ik1:=ik-1;
if ik=nk then ik2:=1 else ik2:=ik+1;
if jk=1 then jk1:=mk else jk1:=jk-1;
if jk=mk then jk2:=1 else jk2:=jk+1;
var l := obnovA[ik,jk1];
var r := obnovA[ik,jk2];
var u := obnovA[ik1,jk];
var d := obnovA[ik2,jk];
var lu := obnovA[ik1,jk1];
var ld := obnovA[ik2,jk1];
var ru := obnovA[ik1,jk2];
var rd := obnovA[ik2,jk2];
if u then
for var j:=jfirst+1 to jlast-1 do
ProcessCell(ifirst,j);
if d then
for var j:=jfirst+1 to jlast-1 do
ProcessCell(ilast,j);
if l then
for var i:=ifirst+1 to ilast-1 do
ProcessCell(i,jfirst);
if r then
for var i:=ifirst+1 to ilast-1 do
ProcessCell(i,jlast);
if u or l or lu then
ProcessCell(ifirst,jfirst);
if u or r or ru then
ProcessCell(ifirst,jlast);
if d or l or ld then
ProcessCell(ilast,jfirst);
if d or r or rd then
ProcessCell(ilast,jlast);
end;
obnovB[ik,jk] := obn;
end;
end;
end;
/// Перерисовка содержимого окна
procedure LifeRedrawProc;
begin
Redraw;
DrawConfigurationFull;
end;
/// Вывод номера поколения и количества ячеек
procedure DrawInfo;
begin
Brush.Color := clWhite;
TextOut(25,0,'Поколение '+IntToStr(gen));
TextOut(WindowWidth - 130,0,'Жителей: '+IntToStr(CountCells)+' ');
end;
begin
SetConsoleIO;
if (m mod mk<>0) or (n mod nk<>0) then
begin
writeln('Размер кластера не согласован с размером поля. Программа завершена');
exit
end;
hm := m div mk;
hn := n div nk;
SetWindowSize(x0+m*w,y0+n*w);
CenterWindow;
Window.Title := 'Игра "Жизнь"';
Window.IsFixedSize := True;
Font.Name := 'Arial';
Font.Size := 10;
Init;
LockDrawing;
DrawInfo;
DrawField;
DrawConfiguration;
UnLockDrawing;
var mil := Milliseconds;
gen := 0;
RedrawProc := LifeRedrawProc;
while True do
begin
gen += 1;
if gen mod 11 = 0 then
DrawInfo;
SosediA := SosediB;
obnovA := obnovB;
NextGen;
if gen mod 1000 = 0 then
begin
var mil1 := Milliseconds;
writeln(gen,' ',(mil1-mil)/1000);
mil := mil1;
end;
end;
end.

45
Matches.pas Normal file
View File

@ -0,0 +1,45 @@
// Игра "Спички"
const InitialCount=15;
var
/// Текущее количество спичек
Count: integer;
/// Количество спичек, которое берет игрок
Num: integer;
/// Номер текущего игрока
Player: integer;
begin
Player := 1;
Count := InitialCount;
repeat
if Player=1 then
begin
var Correct: boolean;
repeat
write('Ваш ход. На столе ',Count,' спичек. ');
write('Сколько спичек Вы берете? ');
readln(Num);
Correct := (Num>=1) and (Num<=3) and (Num<=Count);
if not Correct then
writeln('Неверно! Повторите ввод!');
until Correct;
end
else
begin
Num := Random(1,3);
if Num>Count then
Num := Count;
writeln('Мой ход. Я взял ',Num,' спичек');
end;
Count -= Num;
if Player=1 then
Player := 2
else Player := 1;
until Count=0;
if Player=1 then
writeln('Вы победили!')
else writeln('Вы проиграли!');
end.

348
NewLife.pas Normal file
View File

@ -0,0 +1,348 @@
// Игра Жизнь на торе
// Оптимизация хешированием по равномерной сетке
uses Utils,GraphABC;
const
w =3;
w1=1;
k=20;
m=300;
n=220;
graphW=0;
mk=m div k;//15;
nk=n div k;//10;
mm=m+1;
nn=n+1;
x0=1;
y0=21;
ClearColor=clBlack;
FillColor=clLimeGreen;
FiledColor=RGB(0,40,0);
FiledColor2=RGB(0,70,0);{}
{ClearColor=clWhite;
FillColor=clBlack;
FiledColor=clLightGray;
FiledColor2=clGray;{}
var
//a,b,sosedia,sosedib: array [0..nn,0..mm] of byte;
a,b,sosedia,sosedib:array of array of byte;
//obnovA,obnovB: array [1..nk,1..mk] of boolean;
obnovA,obnovB: array of array of boolean;
count: integer;
obn: boolean;
mil,mil1: integer;
hn,hm: integer;
procedure AssignArray(var arr:array of array of boolean; n,m:integer);
begin
SetLength(arr,n);
for var i:=0 to n-1 do
SetLength(arr[i],m);
end;
procedure AssignArray(var arr:array of array of byte; n,m:integer);
begin
SetLength(arr,n);
for var i:=0 to n-1 do
SetLength(arr[i],m);
end;
procedure CopyArray(arr1,arr2:array of array of byte);
begin
for var i:=0 to arr1.Length-1 do
arr1[i].CopyTo(arr2[i],0);
end;
procedure CopyArray(arr1,arr2:array of array of boolean);
begin
for var i:=0 to arr1.Length-1 do
arr1[i].CopyTo(arr2[i],0);
end;
procedure DrawCell(i,j: integer);
begin
if BrushColor<>FillColor then begin
SetBrushColor(FillColor);
SetPenColor(FillColor);
end;
FillRect(x0+(j-1)*w,y0+(i-1)*w,x0+j*w-w1,y0+i*w-w1);
end;
procedure ClearCell(i,j: integer);
begin
if BrushColor<>clearColor then begin
SetBrushColor(clearColor);
SetPenColor(clearColor);
end;
FillRect(x0+(j-1)*w,y0+(i-1)*w,x0+j*w-w1,y0+i*w-w1);
end;
procedure DrawConfiguration;
begin
for var i:=1 to n do
for var j:=1 to m do
if a[i,j]=1 then
DrawCell(i,j)
end;
procedure DrawField;
begin
SetBrushColor(ClearColor);
FillRectangle(x0,y0,x0+m*w,y0+n*w);
SetPenColor(FiledColor);
for var i:=0 to m do
Line(x0+i*w-1,y0,x0+i*w-1,y0+n*w);
for var i:=0 to n do
Line(x0,y0+i*w-1,x0+m*w,y0+i*w-1);
SetPenColor(FiledColor2);
for var i:=0 to m div hm do
Line(x0+i*w*hm-1,y0,x0+i*w*hm-1,y0+n*w);
for var i:=0 to n div hn do
Line(x0,y0+i*w*hn-1,x0+m*w,y0+i*w*hn-1);
end;
procedure IncSosedi(i,j: integer);
begin
var i1 := i=1 ? n : i-1;
var i2 := i=n ? 1 : i+1;
var j1 := j=1 ? m : j-1;
var j2 := j=m ? 1 : j+1;
SosediB[i1,j1] += 1;
SosediB[i1,j] += 1;
SosediB[i1,j2] += 1;
SosediB[i,j1] += 1;
SosediB[i,j2] += 1;
SosediB[i2,j1] += 1;
SosediB[i2,j] += 1;
SosediB[i2,j2] += 1;
end;
procedure DecSosedi(i,j: integer);
begin
var i1 := i=1 ? n : i-1;
var i2 := i=n ? 1 : i+1;
var j1 := j=1 ? m : j-1;
var j2 := j=m ? 1 : j+1;
SosediB[i1,j1] -= 1;
SosediB[i1,j] -= 1;
SosediB[i1,j2] -= 1;
SosediB[i,j1] -= 1;
SosediB[i,j2] -= 1;
SosediB[i2,j1] -= 1;
SosediB[i2,j] -= 1;
SosediB[i2,j2] -= 1;
end;
procedure SetCell(i,j: integer);
begin
if b[i,j]=0 then
begin
b[i,j]:=1;
obn:=true;
IncSosedi(i,j);
end;
count += 1;
end;
procedure UnSetCell(i,j: integer);
begin
if b[i,j]=1 then
begin
b[i,j]:=0;
obn:=true;
DecSosedi(i,j);
end;
count -= 1;
end;
type
ColonyType = (Big, LD, RD, LU, RU);
procedure AddColonyType(xc,yc:integer; ctype:ColonyType);
begin
case ctype of
ColonyType.Big:begin
SetCell(xc,yc);
SetCell(xc,yc+1);
SetCell(xc,yc+2);
SetCell(xc-1,yc+2);
SetCell(xc+1,yc+1);
end;
ColonyType.LD:begin
SetCell(xc,yc-1);
SetCell(xc,yc);
SetCell(xc,yc+1);
SetCell(xc-1,yc-1);
SetCell(xc-2,yc);
end;
end;
//SosediA:=SosediB;
CopyArray(sosedib,sosedia);
for var ik:=1 to nk do
for var jk:=1 to mk do
obnovB[ik,jk]:=true;
//obnovA:=obnovB;
CopyArray(obnovB,obnovA);
end;
procedure Init;
begin
Count:=0;
AddColonyType(n div 2,m div 2, ColonyType.Big);
end;
procedure OnlyCase(i,j: integer);
begin
case SosediA[i,j] of
0..1,4..9:
if b[i,j]=1 then
begin
b[i,j]:=0;
obn:=true;
DecSosedi(i,j);
ClearCell(i,j);
count -= 1;
end;
3: if b[i,j]=0 then
begin
b[i,j]:=1;
obn:=true;
IncSosedi(i,j);
DrawCell(i,j);
count += 1;
end;
end;
end;
procedure NextGen;
var
i,j,ik1,jk1,ik2,jk2,ifirst,jfirst,ilast,jlast: integer;
l,r,u,d,lu,ld,ru,rd: boolean;
begin
for var ik:=1 to nk do
begin
for var jk:=1 to mk do
begin
obn := false;
ifirst := (ik-1)*hn+1;
ilast := ik*hn;
jfirst := (jk-1)*hm+1;
jlast := jk*hm;
if obnovA[ik,jk] then
begin
for i:=ifirst to ilast do
for j:=jfirst to jlast do
OnlyCase(i,j);
end
else
begin
ik1 := ik=1 ? nk : ik-1;
ik2 := ik=nk ? 1 : ik+1;
jk1 := jk=1 ? mk : jk-1;
jk2 := jk=mk ? 1 : jk+1;
l:=obnovA[ik,jk1];
r:=obnovA[ik,jk2];
u:=obnovA[ik1,jk];
d:=obnovA[ik2,jk];
lu:=obnovA[ik1,jk1];
ld:=obnovA[ik2,jk1];
ru:=obnovA[ik1,jk2];
rd:=obnovA[ik2,jk2];
if u then
begin
i:=ifirst;
for j:=jfirst+1 to jlast-1 do
OnlyCase(i,j);
end;
if d then
begin
i:=ilast;
for j:=jfirst+1 to jlast-1 do
OnlyCase(i,j);
end;
if l then
begin
j:=jfirst;
for i:=ifirst+1 to ilast-1 do
OnlyCase(i,j);
end;
if r then
begin
j:=jlast;
for i:=ifirst+1 to ilast-1 do
OnlyCase(i,j);
end;
if u or l or lu then
OnlyCase(ifirst,jfirst);
if u or r or ru then
OnlyCase(ifirst,jlast);
if d or l or ld then
OnlyCase(ilast,jfirst);
if d or r or rd then
OnlyCase(ilast,jlast);
end;
obnovB[ik,jk]:=obn;
end;
end;
end;
procedure MouseDown(x,y,b:integer);
begin
case b of
1:AddColonyType((y-y0)div w,(x-x0)div w, ColonyType.LD);
end;
end;
begin
SetConsoleIO;
AssignArray(obnovA,nk+1,mk+1);
AssignArray(obnovB,nk+1,mk+1);
AssignArray(a,nn+1,mm+1);
AssignArray(b,nn+1,mm+1);
AssignArray(sosedia,nn+1,mm+1);
AssignArray(sosedib,nn+1,mm+1);
SetWindowCaption('Игра "Жизнь"');
if (m mod mk<>0) or (n mod nk<>0) then
begin
writeln('Размер кластера не согласован с размером поля. Программа завершена');
exit
end;
hm:=m div mk;
hn:=n div nk;
SetBrushColor(ClearColor);
SetWindowSize(x0+m*w,y0+n*w+graphW);
CenterWindow;
ClearWindow(ClearColor);
SetFontName('Courier New');
SetFontSize(10);
Init;
DrawField;
DrawConfiguration;
OnMouseDown:=MouseDown;
mil:=Milliseconds;
var gen:=0;
DrawInBuffer := false;
while true do begin
gen+=1;
//SosediA:=SosediB;
//obnovA:=obnovB;
CopyArray(sosedib,sosedia);
CopyArray(obnovB,obnovA);
NextGen;
if gen mod 10 = 0 then begin
DrawInBuffer := True;
SetBrushColor(ClearColor);
SetFontColor(FillColor);
TextOut(25, 0,'Поколение: '+IntToStr(gen));
TextOut(765,0,'Жителей: '+IntToStr(count)+' ');
if gen mod 1000 = 0 then begin
mil1:=Milliseconds;
writeln(gen,' ',(mil1-mil)/1000);
mil:=mil1;
end;
DrawInBuffer := false;
end;
end;
end.

BIN
блокнот/Open.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 575 B

BIN
блокнот/Save.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 535 B

91
блокнот/TextEditor.pas Normal file
View File

@ -0,0 +1,91 @@
{$apptype windows}
{$reference 'System.Windows.Forms.dll'}
{$reference 'System.Drawing.dll'}
{$resource 'Open.png'}
{$resource 'Save.png'}
uses System.Windows.Forms;
const
TextFileExt = 'txt';
TextFileFilter = 'Текстовые файлы (*.'+TextFileExt+')|*.'+TextFileExt;
var
myForm: Form;
TextBox1: TextBox;
procedure SaveFile(FileName: string);
begin
//Создаем файловый поток с кодировкой Windows 1251, необходимо для корректного сохранения русских букв
var f := new System.IO.StreamWriter(FileName, false, System.Text.Encoding.Default);
f.Write(TextBox1.Text);
f.Close;
end;
procedure OpenFile(FileName: string);
begin
//Создаем файловый поток с кодировкой Windows 1251, необходимо для корректного чтения русских букв
var f := new System.IO.StreamReader(FileName, System.Text.Encoding.Default);
TextBox1.Text := f.ReadToEnd;
f.Close;
end;
procedure FormClose(sender: object; args: System.EventArgs);
begin
myForm.Close;
end;
procedure MenuSaveClick(sender:object; args:System.EventArgs);
begin
//Диалог для выбора файла
var sd := new SaveFileDialog;
//Расширение поумолчанию
sd.DefaultExt := TextFileExt;
//Фильтр для диалга
sd.Filter := TextFileFilter;
if sd.ShowDialog=DialogResult.OK then
//если результат выполнения sd.ShowDialog это нажатие кнопки подтверждения то
SaveFile(sd.FileName);
end;
procedure MenuOpenClick(sender:object; args:System.EventArgs);
begin
var sd := new OpenFileDialog;
sd.DefaultExt := TextFileExt;
sd.Filter := TextFileFilter;
if sd.ShowDialog = DialogResult.OK then
OpenFile(sd.FileName);
end;
begin
myForm := new Form;
myForm.Text := 'Простой текстовый редактор';
TextBox1 := new TextBox;
TextBox1.Multiline := True;
TextBox1.Height := 100;
TextBox1.Dock := DockStyle.Fill;
//Полосы прокрутки
TextBox1.ScrollBars := ScrollBars.Both;
//Устанавливаем шрифт
TextBox1.Font := new System.Drawing.Font('Courier New',10);
myForm.Controls.Add(TextBox1);
//Создаем меню
var toolStrip1 := new ToolStrip;
toolStrip1.GripStyle := System.Windows.Forms.ToolStripGripStyle.Hidden;
var miFile := new ToolStripMenuItem('Файл');
miFile.DropDownItems.Add(new ToolStripMenuItem('Открыть', new System.Drawing.Bitmap(GetResourceStream('Open.png')),MenuOpenClick));
miFile.DropDownItems.Add(new ToolStripMenuItem('Сохранить как...',new System.Drawing.Bitmap(GetResourceStream('Save.png')),MenuSaveClick));
miFile.DropDownItems.Add(new ToolStripMenuItem('Выход',nil,FormClose));
toolStrip1.Items.Add(miFile);
myForm.Controls.Add(toolStrip1);
//Посмотрим в аргументы командной строки
//Если их количество = 1, то открываем
if CommandLineArgs.Length = 1 then
OpenFile(CommandLineArgs[0]);
Application.Run(myForm);
end.