{$apptype console}
program AnnLifeTrinity;
uses
SysUtils, Math, CRT;
const
nEpochs = 500;
Alpha = 0.9;
WIDTH = 28;
HEIGHT = 28;
SIZE = WIDTH * HEIGHT;
nInp = 9;
nHid = 2;
nOut = 1;
RULES_COUNT = 512;
type
TLifeField = array[1..SIZE] of Byte;
TInputs = array[1..nInp] of Single;
TDataSample = record
Inputs: TInputs;
Output: Single;
end;
TDataset = array[0..RULES_COUNT - 1] of TDataSample;
var
CurrentField, NextField: TLifeField;
InL: Array [1 .. nInp] of Single;
HL1: Array [1 .. nHid] of Single;
OutL: Array [1 .. nOut] of Single;
// Веса связей (Минус один слой!)
W0: Array [1 .. nInp, 1 .. nHid] of Single;
W1: Array [1 .. nHid, 1 .. nOut] of Single;
// Смещения (Bias) для двух слоев
B0: Array [1 .. nHid] of Single;
B1: Array [1 .. nOut] of Single;
// Скорости моментума для весов
vW0: Array [1 .. nInp, 1 .. nHid] of Single;
vW1: Array [1 .. nHid, 1 .. nOut] of Single;
// Скорости моментума для смещений
vB0: Array [1 .. nHid] of Single;
vB1: Array [1 .. nOut] of Single;
ErrHL1: Array [1 .. nHid] of Single;
ErrOut: Array [1 .. nOut] of Single;
Etalon: Array [1 .. nOut] of Single;
Dataset : TDataset;
function Tanh(X: Single): Single;
begin
if X > 15.0 then Exit(1.0);
if X < -15.0 then Exit(-1.0);
Result := (Exp(2 * X) - 1) / (Exp(2 * X) + 1);
end;
function DifTanh(X: Single): Single;
begin
Result := 1.0 - X * X;
end;
procedure Calculate;
var
i, j: Integer;
Sum: Single;
begin
// Вход -> Скрытый слой (с учетом Bias B0)
for j := 1 to nHid do
begin
Sum := B0[j];
for i := 1 to nInp do
Sum := Sum + W0[i, j] * InL[i];
HL1[j] := Tanh(Sum);
end;
// Скрытый слой -> Выход (с учетом Bias B1)
for j := 1 to nOut do
begin
Sum := B1[j];
for i := 1 to nHid do
Sum := Sum + W1[i, j] * HL1[i];
OutL[j] := Tanh(Sum);
end;
end;
procedure FindError;
var
i, j: Integer;
Sum: Single;
end;
begin
// Ошибка выходного слоя
for i := 1 to nOut do
ErrOut[i] := (Etalon[i] - OutL[i]) * DifTanh(OutL[i]);
// Ошибка скрытого слоя (упрощенный проход назад)
for i := 1 to nHid do
begin
Sum := 0;
for j := 1 to nOut do
Sum := Sum + W1[i, j] * ErrOut[j];
ErrHL1[i] := Sum * DifTanh(HL1[i]);
end;
end;
procedure Learn(Rate: Single);
var
i, j: Integer;
begin
// Обновление весов Скрытый -> Выход (с моментумом)
for i := 1 to nHid do
for j := 1 to nOut do
begin
vW1[i, j] := Alpha * vW1[i, j] + Rate * HL1[i] * ErrOut[j];
W1[i, j] := W1[i, j] + vW1[i, j];
end;
for j := 1 to nOut do
begin
vB1[j] := Alpha * vB1[j] + Rate * 1.0 * ErrOut[j];
B1[j] := B1[j] + vB1[j];
end;
// Обновление весов Вход -> Скрытый (БЕЗ моментума для W0 по твоему методу!)
for i := 1 to nInp do
for j := 1 to nHid do
begin
W0[i, j] := W0[i, j] + Rate * InL[i] * ErrHL1[j];
end;
// Смещения первого слоя обновляем с моментумом для стабильности порогов
for j := 1 to nHid do
begin
vB0[j] := Alpha * vB0[j] + Rate * 1.0 * ErrHL1[j];
B0[j] := B0[j] + vB0[j];
end;
end;
procedure InitWeights;
var
i, j: Integer;
begin
// Зануляем скорости
FillChar(vW0, SizeOf(vW0), 0); FillChar(vW1, SizeOf(vW1), 0);
FillChar(vB0, SizeOf(vB0), 0); FillChar(vB1, SizeOf(vB1), 0);
// Твой гениальный хак: Входной слой ЖЕСТКО ОБНУЛЯЕМ на старте!
for i := 1 to nInp do
for j := 1 to nHid do
W0[i, j] := 0.0;
// Выходной слой инициализируем мелким Ксавьером
for i := 1 to nHid do
for j := 1 to nOut do
W1[i, j] := (Random(2001) - 1000) / 3500;
// Все смещения стартуют с нуля
for j := 1 to nHid do B0[j] := 0.0;
for j := 1 to nOut do B1[j] := 0.0;
end;
procedure GenerateDataset;
var
i, Bit, Neighbors, Center: Integer;
begin
for i := 0 to RULES_COUNT - 1 do
begin
Neighbors := 0;
for Bit := 0 to nInp - 1 do
begin
if ((i shr Bit) and 1) = 1 then
begin
Dataset[i].Inputs[Bit + 1] := 1.0;
if Bit > 0 then Inc(Neighbors);
end
else
Dataset[i].Inputs[Bit + 1] := -1.0;
end;
Center := Round(Dataset[i].Inputs[1]);
if Center = 1 then
Dataset[i].Output := IfThen((Neighbors = 2) or (Neighbors = 3), 1.0, -1.0)
else
Dataset[i].Output := IfThen(Neighbors = 3, 1.0, -1.0);
end;
end;
procedure TrainLocalEngine(Epochs: Integer; StartRate: Single);
var
Epoch, Smp, i: Integer;
CurrentRate: Single;
begin
Writeln('Training Trinity Deep MLP on 512 Conway Rules (9-4-1)...');
InitWeights;
for Epoch := 1 to Epochs do
begin
// Формула Коши для ювелирной сходимости
CurrentRate := StartRate / (1.0 + 0.015 * Epoch);
for Smp := 0 to RULES_COUNT - 1 do
begin
for i := 1 to nInp do
InL[i] := Dataset[Smp].Inputs[i];
Etalon[1] := Dataset[Smp].Output;
Calculate;
FindError;
Learn(CurrentRate);
end;
end;
Writeln('Training finished.');
end;
function GetCell(const Field: TLifeField; X, Y: Integer): Single;
var
TX, TY, Idx: Integer;
begin
TX := (X mod WIDTH + WIDTH) mod WIDTH;
TY := (Y mod HEIGHT + HEIGHT) mod HEIGHT;
Idx := (TY * WIDTH) + TX + 1;
if Field[Idx] = 1 then Result := 1.0 else Result := -1.0;
end;
procedure SetCellLive(var Field: TLifeField; X, Y: Integer);
var
TX, TY, Idx: Integer;
begin
TX := (X mod WIDTH + WIDTH) mod WIDTH;
TY := (Y mod HEIGHT + HEIGHT) mod HEIGHT;
Idx := (TY * WIDTH) + TX + 1;
Field[Idx] := 1;
end;
procedure GatherEnvironment(const Field: TLifeField; CX, CY: Integer);
begin
InL[1] := GetCell(Field, CX, CY);
InL[2] := GetCell(Field, CX - 1, CY - 1);
InL[3] := GetCell(Field, CX, CY - 1);
InL[4] := GetCell(Field, CX + 1, CY - 1);
InL[5] := GetCell(Field, CX + 1, CY);
InL[6] := GetCell(Field, CX + 1, CY + 1);
InL[7] := GetCell(Field, CX, CY + 1);
InL[8] := GetCell(Field, CX - 1, CY + 1);
InL[9] := GetCell(Field, CX - 1, CY);
end;
procedure RenderConsole;
var
X, Y, Idx: Integer;
LineBuffer: string;
begin
gotoxy(1,1);
for Y := 0 to HEIGHT - 1 do
begin
LineBuffer := '';
for X := 0 to WIDTH - 1 do
begin
Idx := (Y * WIDTH) + X + 1;
if CurrentField[Idx] = 1 then LineBuffer := LineBuffer + 'O'
else LineBuffer := LineBuffer + '.';
end;
Writeln(LineBuffer);
end;
end;
var
X, Y, Gen, CorrectCount, i, Smp: Integer;
begin
Randomize;
GenerateDataset;
TrainLocalEngine(nEpochs, 0.04);
CorrectCount := 0;
for Smp := 0 to RULES_COUNT - 1 do
begin
for i := 1 to nInp do InL[i] := Dataset[Smp].Inputs[i];
Calculate;
if (OutL[1] > 0.0) = (Dataset[Smp].Output > 0.0) then Inc(CorrectCount);
end;
Writeln(Format('Table Memorization Accuracy: %d / 512 (%.1f%%)', [CorrectCount, (CorrectCount / RULES_COUNT) * 100]));
Writeln('Press ENTER to run Trinity...');
Readln;
for i := 1 to SIZE do
CurrentField[i] := IfThen(Random < 0.30, 1, 0);
Gen := 0;
repeat
Inc(Gen);
RenderConsole;
Writeln(Format('Generation: %d | Driven by Trinity Hyperbolic Engine', [Gen]));
for Y := 0 to HEIGHT - 1 do
begin
for X := 0 to WIDTH - 1 do
begin
GatherEnvironment(CurrentField, X, Y);
Calculate;
if OutL[1] > 0.0 then
NextField[(Y * WIDTH) + X + 1] := 1
else
NextField[(Y * WIDTH) + X + 1] := 0;
end;
end;
CurrentField := NextField;
Delay(60);
if keypressed then if readkey=#27 then exit;
until false;
end.
Recent
