Реферат (стр. 8 )

SNeuronCount = 'Неправильно указано количество нейронов';

SOutFieldCount = 'Неправильно установлено количество выходных полей';

SOutNeuronCount = 'Неправильно установлено количество выходных нейронов';

SOutVectorCount = 'Неправильно установлена размерность выходного вектора';

SPatternRangeIndex = 'Выход за границы массива примеров %d';

SStreamCannotRead = 'Ошибка чтения из потока';

SWeightRangeIndex = 'Неправильно указан номер веса %d';

SWrongFileName = 'Неправильно указано имя файла %s';

SCannotBeNumber = 'Ошибка, выражение %s невозможно привести к числовому типу';

SBPStopCondition = 'Не задано условие останова процесса обучения';

type

TVectorInt = array of integer;

TVectorFloat = array of double;

TVectorString = array of string;

TMatrixInt = array of array of integer;

TMatrixFloat = array of array of double;

TNormalize = (nrmLinear, nrmSigmoid, nrmAuto, nrmNone,

nrmLinearOut, nrmAutoOut);

TNeuroFieldType = (fdInput, fdOutput, fdNone);

implementation

end.

Листинг 4 Основной файл проекта NeroSys

unit NeroSys;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls,

Forms, Dialogs, PumpData, NeuralBaseTypes, IniFiles, Math;

type

// Классы исключений

EInOutDimensionError = class(Exception);

ENeuronCountError = class(Exception);

ENeuronNotEqualFieldError = class(Exception);

EBPStopCondition = class(Exception);

// Процедурные типы

TActivation = function (Value: double): double of object;

// Упреждающее объявление классов

TNeuron = class;

TLayer = class;

// Базовый класс нейрона

TNeuron = class(TObject)

private

FOutput: double;

// Вектор весов

FWeights: TVectorFloat;

// Указатель на слой в котором находится нейрон just in case

Layer: TLayer;

function GetWeights(Index: integer): double;

procedure SetWeights(Index: integer; Value: double);

procedure SetWeightCount(const Value: integer);

public

constructor Create(ALayer: TLayer); virtual;

destructor Destroy; override;

// Инициализация весов

procedure InitWeights; virtual;

// Взвешенная сумма

procedure ComputeOut(const AInputs: TVectorFloat); virtual;

property Output: double read FOutput write FOutput;

property WeightCount: integer write SetWeightCount;

property Weights[Index: integer]: double read GetWeights write SetWeights;

end;

// Класс нейрона для сети back-propagation

TNeuronBP = class(TNeuron)

private

// Локальная ошибка

FDelta: double;

// Значение скорости обучения на предыдущей эпохе

FLearningRate: TVectorFloat;

// Значение частной производной на предыдущей эпохе

FPrevDerivative: TVectorFloat;

// Значение коррекции веса на предыдущей эпохе

FPrevUpdate: TVectorFloat;

// Функция активации

FOnActivationF: TActivation;

// Производная функции активации

FOnActivationD: TActivation;

function GetPrevUpdate(Index: integer): double;

function GetPrevDerivative(Index: integer): double;

function GetLearningRate(Index: integer): double;

function GetPrevUpdateCount: integer;

procedure SetPrevDerivative(Index: integer; const Value: double);

procedure SetPrevDerivativeCount(const Value: integer);

procedure SetDelta(Value: double);

procedure SetPrevUpdate(Index: integer; Value: double);

procedure SetPrevUpdateCount(const Value: integer);

procedure SetLearningRate(Index: integer; const Value: double);

procedure SetLearningRateCount(const Value: integer);

public

destructor Destroy; override;

procedure ComputeOut(const AInputs: TVectorFloat); override;

property Delta: double read FDelta write SetDelta;

property LearningRate[Index: integer]: double read GetLearningRate write SetLearningRate; // Delta-Bar-Delta, SuperSAB

property LearningRateCount: integer write SetLearningRateCount;

property PrevDerivativeCount: integer write SetPrevDerivativeCount;

property PrevDerivative[Index: integer]: double read GetPrevDerivative write SetPrevDerivative; // QuickProp, Delta-Bar-Delta, SuperSAB

property PrevUpdateCount: integer read GetPrevUpdateCount write SetPrevUpdateCount;

property PrevUpdate[Index: integer]: double read GetPrevUpdate write SetPrevUpdate;

property OnActivationF: TActivation read FOnActivationF write FOnActivationF;

property OnActivationD: TActivation read FOnActivationD write FOnActivationD;

end;

// Базовый класс слоя

TLayer = class(TPersistent)

private

FNumber: integer;

// Размерность NeuronCount

FNeurons: array of TNeuron;

function GetNeurons(Index: integer): TNeuron;

function GetNeuronCount: integer;

procedure SetNeurons(Index: integer; Value: TNeuron);

procedure SetNeuronCount(Value: integer);

public

constructor Create(ALayerNumber: integer; ANeuronCount: integer); virtual;

destructor Destroy; override;

procedure Assign(Source: TPersistent); override;

property Neurons[Index: integer]: TNeuron read GetNeurons write SetNeurons;

property NeuronCount: integer read GetNeuronCount write SetNeuronCount;

end;

// Класс слоя для сети back-propagation

TLayerBP = class(TLayer)

private

function GetNeuronsBP(Index: integer): TNeuronBP;

procedure SetNeuronsBP(Index: integer; Value: TNeuronBP);

public

constructor Create(ALayerNumber: integer; ANeuronCount: integer); override;

destructor Destroy; override;

procedure Assign(Source: TPersistent); override;

property NeuronsBP[Index: integer]: TNeuronBP read GetNeuronsBP write SetNeuronsBP;

end;

// Базовый класс сети

TNeuralNet = class(TComponent)

private

// Массив слоев

FLayers: array of TLayer;

// Число выборок

FPatternCount: integer;

// Размерность FPatternCount, InputNeuronCount

FPatternsInput: TMatrixFloat;

// Размерность FPatternCount, OutputNeuronCount

FPatternsOutput: TMatrixFloat;

function GetLayers(Index: integer): TLayer;

function GetOutputNeuronCount: integer;

function GetPatternsOutput(PatternIndex: integer; OutputIndex: integer): double;

function GetPatternsInput(PatternIndex: integer; InputIndex: integer): double;

procedure SetLayers(Index: integer; Value: TLayer);

procedure SetPatternsInput(PatternIndex: integer; InputIndex: integer; Value: double);

procedure SetPatternsOutput(PatternIndex: integer; InputIndex: integer; Value: double);

protected

function GetLayerCount: integer; virtual;

function GetInputNeuronCount: integer; virtual;

procedure Clear; virtual;

procedure ResizeInputDim; virtual;

procedure ResizeOutputDim; virtual;

procedure SetPatternCount(const Value: integer); virtual;

procedure SetLayerCount(Value: integer); virtual;

property PatternCount: integer read FPatternCount write SetPatternCount;

public

destructor Destroy; override;

procedure AddLayer(ANeurons: integer); virtual; abstract;

procedure AddPattern(const AInputs: TVectorFloat; const AOutputs: TVectorFloat); overload; virtual;

procedure DeleteLayer(Index: integer); virtual; abstract;

procedure DeletePattern(Index: integer); virtual;

procedure Init(const ANeuronsInLayer: TVectorInt); overload; virtual;

property InputNeuronCount: integer read GetInputNeuronCount;

property LayerCount: integer read GetLayerCount write SetLayerCount;

property Layers[Index: integer]: TLayer read GetLayers write SetLayers;

property OutputNeuronCount: integer read GetOutputNeuronCount;

property PatternsInput[PatternIndex: integer; InputIndex: integer]: double read GetPatternsInput write SetPatternsInput;

property PatternsOutput[PatternIndex: integer; InputIndex: integer]: double read GetPatternsOutput write SetPatternsOutput;

procedure ResetPatterns; virtual;

end;

// Класс сети back-propagation

TNeuralNetBP = class(TNeuralNet)

private

// Коэффициент крутизны пороговой сигмоидальной функции

FAlpha: double;

// Флаг автоинициализации топологии сети

FAutoInit: boolean;

// Флаг продолжения обучения

FContinueTeach: boolean;

// Желаемый выход нейросети размерность OutputNeuronCount

FDesiredOut: TVectorFloat;

// Флаг остановки при достижении FEpochCount

FEpoch: boolean;

// Счетчик эпох (предъявление сети всех примеров из обучающей выборки)

FEpochCount: integer;

// Номер текущей эпохи

FEpochCurrent: integer;

// Значение ошибки, при которой пример считается распознанным

FIdentError: double;

// Значение максимальной ошибки на обучающем множестве

FMaxTeachResidual: double;

// Значение максимальной ошибки на тестовом множестве

FMaxTestResidual: double;

// Значение средней ошибки на обучающем множестве

FMidTeachResidual: double;

// Значение средней ошибки на тестовом множестве

FMidTestResidual: double;

// Ошибка на обучающем множестве

FTeachError: double;

// Коэффициент инерционности

FMomentum: double;

// Количество нейронов в слоях

FNeuronsInLayer: TStrings;

// Событие после инициализации

FOnAfterInit: TNotifyEvent;

FOnAfterNeuronCreated: TNotifyEvent;

// Событие после обучения

FOnAfterTeach: TNotifyEvent;

// Событие до инициализации

FOnBeforeInit: TNotifyEvent;

// Событие до начала обучения

FOnBeforeTeach: TNotifyEvent;

// Событие после прохождения одной эпохи

FOnEpochPassed: TNotifyEvent;

// Число примеров в обучающем множестве

FPatternCount: integer;

// Массив содержащий псевдослучайную последовательсность

FRandomOrder: TVectorInt;

// Счетчик распознанных примеров на обучающем множестве

FRecognizedTeachCount: integer;

// Счетчик распознанных примеров на обучающем множестве

FRecognizedTestCount: integer;

// Флаг остановки обучения

FStopTeach: boolean;

FTeachStopped: boolean;

// Коэффициент скорости обучения - величина градиентного шага

FTeachRate: double;

// Число примеров в тестовом множестве

FTestSetPatternCount: integer;

// Размерность FTestSetPatternCount, InputNeuronCount

FTestSetPatterns: TMatrixFloat;

// Размерность FTestSetPatternCount, InputNeuronCount

FTestSetPatternsOut: TMatrixFloat;

function GetDesiredOut(Index: integer): double;

function GetLayersBP(Index: integer): TLayerBP;

function GetTestSetPatterns(InputIndex, PatternIndex: integer): double;

function GetTestSetPatternsOut(InputIndex, PatternIndex: integer): double;

procedure NeuronCountError;

procedure NeuronsInLayerChange(Sender: TObject);

procedure SetAlpha(Value: double);

procedure SetDesiredOut(Index: integer; Value: double);

procedure SetEpochCount(Value: integer);

procedure SetLayersBP(Index: integer; Value: TLayerBP);

procedure SetMomentum(Value: double);

procedure SetTeachRate(Value: double);

procedure SetTestSetPatternCount(const Value: integer);

procedure SetTestSetPatterns(InputIndex, PatternIndex: integer; const Value: double);

procedure SetTestSetPatternsOut(InputIndex, PatternIndex: integer; const Value: double);

// Перетасовка набора данных

procedure Shuffle;

protected

function GetLayerCount: integer; override;

function GetOutput(Index: integer): double; virtual;

// Активационная функция

function ActivationF(Value: double): double; virtual;

// Производная активационной функции

function ActivationD(Value: double): double; virtual;

// Средняя квадратичная ошибка

function QuadError: double; virtual;

// Подстройка весов

procedure AdjustWeights; virtual;

// Рассчитывает локальную ошибку - дельту

procedure CalcLocalError; virtual;

// Проверка сети на тестовом множестве

procedure CheckTestSet; virtual;

procedure DoOnAfterInit; virtual;

procedure DoOnAfterNeuronCreated(ALayerIndex, ANeuronIndex: integer); virtual;

procedure DoOnAfterTeach; virtual;

procedure DoOnBeforeInit; virtual;

procedure DoOnBeforeTeach; virtual;

procedure DoOnEpochPassed; virtual;

// Инициализация весов сети псевдослучайными значениями

procedure InitWeights; virtual;

// Предъявление сети входных значений примера

procedure LoadPatternsInput(APatternIndex :integer); virtual;

// Предъявление сети входных значений примера

procedure LoadPatternsOutput(APatternIndex :integer); virtual;

// Распространяет сигнал в прямом направлении

procedure Propagate; virtual;

// Установка значений по умолчанию

procedure SetDefaultProperties; virtual;

procedure SetPatternCount(const Value: integer); override;

// Встряска сети

procedure ShakeUp; virtual;

property TeachStopped: boolean read FTeachStopped write FTeachStopped;

public

constructor Create(AOwner: TComponent); override;

destructor Destroy; override;

procedure AddLayer(ANeurons: integer); override;

procedure Compute(AVector: TVectorFloat); virtual;

procedure DeleteLayer(Index: integer); override;

procedure Init; reintroduce; overload;

procedure ResetLayers; virtual;

procedure TeachOffLine; virtual;

property DesiredOut[Index: integer]: double read GetDesiredOut write SetDesiredOut;

property EpochCurrent: integer read FEpochCurrent;

property IdentError: double read FIdentError write FIdentError;

property LayersBP[Index: integer]: TLayerBP read GetLayersBP write SetLayersBP;

property LayerCount: integer read GetLayerCount write SetLayerCount;

property Output[Index: integer]: double read GetOutput;

property StopTeach: boolean read FStopTeach write FStopTeach;

property TeachError: double read FTeachError;

property MaxTeachResidual: double read FMaxTeachResidual;

property MaxTestResidual: double read FMaxTestResidual;

property MidTeachResidual: double read FMidTeachResidual;

property MidTestResidual: double read FMidTestResidual;

property RecognizedTeachCount: integer read FRecognizedTeachCount;

property RecognizedTestCount: integer read FRecognizedTestCount;

property TestSetPatternCount: integer read FTestSetPatternCount write SetTestSetPatternCount;

property TestSetPatterns[InputIndex: integer; PatternIndex: integer]: double read GetTestSetPatterns write SetTestSetPatterns;

property TestSetPatternsOut[InputIndex: integer; PatternIndex: integer]: double read GetTestSetPatternsOut write SetTestSetPatternsOut;

published

property Alpha: double read FAlpha write SetAlpha;

property AutoInit: boolean read FAutoInit write FAutoInit;

property ContinueTeach: boolean read FContinueTeach write FContinueTeach;

property Epoch: boolean read FEpoch write FEpoch;

property EpochCount: integer read FEpochCount write SetEpochCount;

property Momentum: double read FMomentum write SetMomentum;

property NeuronsInLayer: TStrings read FNeuronsInLayer write FNeuronsInLayer;

property OnAfterInit: TNotifyEvent read FOnAfterInit write FOnAfterInit;

property OnAfterNeuronCreated: TNotifyEvent read FOnAfterNeuronCreated write FOnAfterNeuronCreated;

property OnAfterTeach: TNotifyEvent read FOnAfterTeach write FOnAfterTeach;

property OnBeforeInit: TNotifyEvent read FOnBeforeInit write FOnBeforeInit;

property OnBeforeTeach: TNotifyEvent read FOnBeforeTeach write FOnBeforeTeach;

property OnEpochPassed: TNotifyEvent read FOnEpochPassed write FOnEpochPassed;

property PatternCount: integer read FPatternCount write SetPatternCount;

property TeachRate: double read FTeachRate write SetTeachRate;

end;

// Класс сети back-propagation TNeuralNetExtended }

TNeuralNetExtended = class(TNeuralNetBP)

private

// Файл данных

FNeuroDataSource: TNeuroDataSource;

// Имя файла данных *.txt

FSourceFileName: TFileName;

// Имя конфигурационного файла *.nnw

FFileName: TFileName;

// Конфигурационный файл

FNnwFile: TIniFile;

// Поля

FFields: TNeuroFields;

// Количество доступных полей

FAvailableFieldsCount: integer;

FMaxTeachError: boolean;

FMaxTeachErrorValue: double;

FMaxTestError: boolean;

FMaxTestErrorValue: double;

FMidTeachError: boolean;

FMidTeachErrorValue: double;

FMidTestError: boolean;

FMidTestErrorValue: double;

FOptions: string;

FSettingsLoaded: boolean;

FTestAsValid: boolean;

FTeachIdent: boolean;

FTeachIdentCount: integer;

FTestIdent: boolean;

FTestIdentCount: integer;

FUseForTeach: integer;

FIdentError: double;

FRealOutputIndex: TVectorInt;

FRealInputIndex: TVectorInt;

function GetFields(Index: integer): TNeuroField;

function GetInputFieldCount: integer;

function GetOutputFieldCount: integer;

function GetRealInputIndex(Index: integer): integer;

function GetRealOutputIndex(Index: integer): integer;

procedure SetFields(Index: integer; Value: TNeuroField);

procedure SetFileName(Value: TFilename);

procedure SetAvailableFieldsCount(Value: integer);

procedure SetUseForTeach(const Value: integer);

procedure SetTeachIdentCount(const Value: integer);

procedure SetRealOutputIndex(Index: integer; const Value: integer);

procedure SetRealOutputIndexCount(const Value: integer);

procedure SetRealInputIndex(Index: integer; const Value: integer);

procedure SetRealInputIndexCount(const Value: integer);

protected

function GetOutput(Index: integer): double; override;

procedure DoOnBeforeTeach; override;

procedure DoOnEpochPassed; override;

procedure SetDefaultProperties; override;

public

constructor Create(AOwner: TComponent); override;

destructor Destroy; override;

procedure ComputeUnPrepData(AVector: TVectorFloat);

// Загружает данные из текстового файла

procedure LoadDataFrom;

// Загружает настройки сети

procedure LoadNetwork;

// Загружает настройки сети

procedure LoadPhase1;

// Загружает настройки сети

procedure LoadPhase2;

// Загружает настройки сети

procedure LoadPhase4;

// Нормализует набор данных

procedure NormalizeData;

// Сохраняет настройки сети

procedure SaveNetwork;

// Сохраняет настройки сети

procedure SavePhase1;

// Сохраняет настройки сети

procedure SavePhase2;

// Сохраняет настройки сети

procedure SavePhase4;

// Обучение нейронной сети

procedure Train;

property AvailableFieldsCount: integer read FAvailableFieldsCount write SetAvailableFieldsCount;

property Fields[Index: integer]: TNeuroField read GetFields write SetFields;

property InputFieldCount: integer read GetInputFieldCount;

property OutputFieldCount: integer read GetOutputFieldCount;

property SettingsLoaded: boolean read FSettingsLoaded write FSettingsLoaded;

property RealOutputIndex[Index: integer]: integer read GetRealOutputIndex write SetRealOutputIndex;

property RealOutputIndexCount: integer write SetRealOutputIndexCount;

property RealInputIndex[Index: integer]: integer read GetRealInputIndex write SetRealInputIndex;

property RealInputIndexCount: integer write SetRealInputIndexCount;

property NnwFile: TIniFile read FNnwFile write FNnwFile;

published

property FileName: TFileName read FFileName write SetFileName;

property IdentError: double read FIdentError write FIdentError;

property MaxTeachError: boolean read FMaxTeachError write FMaxTeachError;

property MaxTeachErrorValue: double read FMaxTeachErrorValue write FMaxTeachErrorValue;

property MaxTestError: boolean read FMaxTestError write FMaxTestError;

property MaxTestErrorValue: double read FMaxTestErrorValue write FMaxTestErrorValue;

property MidTeachError: boolean read FMidTeachError write FMidTeachError;

property MidTeachErrorValue: double read FMidTeachErrorValue write FMidTeachErrorValue;

property MidTestError: boolean read FMidTestError write FMidTestError;

property MidTestErrorValue: double read FMidTestErrorValue write FMidTestErrorValue;

property Options: string read FOptions write FOptions;

property SourceFileName: TFileName read FSourceFileName write FSourceFileName;

property TestAsValid: boolean read FTestAsValid write FTestAsValid;

property TeachIdent: boolean read FTeachIdent write FTeachIdent;

property TeachIdentCount: integer read FTeachIdentCount write SetTeachIdentCount;

property TestIdent: boolean read FTestIdent write FTestIdent;

property TestIdentCount: integer read FTestIdentCount write FTestIdentCount;

property UseForTeach: integer read FUseForTeach write SetUseForTeach;

end;

implementation

{$R *.RES}

{ TNeuron }

constructor TNeuron. Create(ALayer: TLayer);

begin

inherited Create;

// указатель на слой в котором находится нейрон

Layer := ALayer;

end;

destructor TNeuron. Destroy;

begin

WeightCount := 0;

FWeights := nil;

Layer := nil;

inherited;

end;

procedure puteOut(const AInputs: TVectorFloat);

var

i: integer;

begin

FOutput := 0;

// Подсчитывается взвешенная сумма нейрона

for i := Low(AInputs) to High(AInputs) do

FOutput := FOutput + FWeights[i] * AInputs[i];

end;

function TNeuron. GetWeights(Index: integer): double;

begin

try

Result := FWeights[Index];

except

on E: ERangeError do

raise E. CreateFmt(SWeightRangeIndex, [Index])

end;

procedure TNeuron. InitWeights;

var

i: integer;

begin

// Инициализация весов нейрона

for i := Low(FWeights) to High(FWeights) do

FWeights[i] := Random

end;

procedure TNeuron. SetWeightCount(const Value: integer);

begin

SetLength(FWeights, Value);

end;

procedure TNeuron. SetWeights(Index: integer; Value: double);

begin

try

FWeights[Index] := Value;

except

on E: ERangeError do

raise E. CreateFmt(SWeightRangeIndex, [Index])

end;

{ Конец описания TNeuron }

{ TNeuronBP }

destructor TNeuronBP. Destroy;

begin

FOnActivationF := nil;

FOnActivationD := nil;

PrevUpdateCount := 0;

FPrevUpdate := nil;

inherited;

end;

function TNeuronBP. GetLearningRate(Index: integer): double;

begin

Result := FLearningRate[Index];

end;

function TNeuronBP. GetPrevDerivative(Index: integer): double;

begin

Result := FPrevDerivative[Index];

end;

function TNeuronBP. GetPrevUpdateCount: integer;

begin

Result := High(FPrevUpdate) + 1;

end;

function TNeuronBP. GetPrevUpdate(Index: integer): double;

begin

Result := FPrevUpdate[Index];

end;

procedure puteOut(const AInputs: TVectorFloat);

begin

inherited;

// Задает смещение нейрона

FOutput := FOutput + Weights[High(AInputs) + 1];

FOutput := OnActivationF(FOutput);

end;

procedure TNeuronBP. SetDelta(Value: double);

begin

FDelta := Value;

end;

procedure TNeuronBP. SetLearningRate(Index: integer; const Value: double);

begin

FLearningRate[Index] := Value;

end;

procedure TNeuronBP. SetLearningRateCount(const Value: integer);

begin

SetLength(FLearningRate, Value)

end;

procedure TNeuronBP. SetPrevUpdate(Index: integer; Value: double);

begin

FPrevUpdate[Index] := Value;

end;

procedure TNeuronBP. SetPrevUpdateCount(const Value: integer);

begin

SetLength(FPrevUpdate, Value)

end;

procedure TNeuronBP. SetPrevDerivative(Index: integer; const Value: double);

begin

FPrevDerivative[Index] := Value;

end;

procedure TNeuronBP. SetPrevDerivativeCount(const Value: integer);

begin

SetLength(FPrevDerivative, Value)

end;

{ Конец описания TNeuronBP }

{ TLayer }

procedure TLayer. Assign(Source: TPersistent);

var

i: integer;

begin

FNumber := (Source as TLayer).FNumber;

NeuronCount := (Source as TLayer).NeuronCount;

// Создаются нейроны

for i := 0 to NeuronCount - 1 do

FNeurons[i] := TNeuron. Create(Self);

end;

constructor TLayer. Create(ALayerNumber: integer; ANeuronCount: integer);

var

i: integer;

begin

inherited Create;

FNumber := ALayerNumber;

NeuronCount := ANeuronCount;

for i := 0 to ANeuronCount - 1 do

FNeurons[i] := TNeuron. Create(Self);

end;

destructor TLayer. Destroy;

var

i: integer;

begin

for i := 0 to NeuronCount - 1 do

FNeurons[i].Free;

NeuronCount := 0;

FNeurons := nil;

inherited;

end;

function TLayer. GetNeuronCount: integer;

begin

Result := High(FNeurons) + 1;

end;

function TLayer. GetNeurons(Index: integer): TNeuron;

begin

Result := FNeurons[Index];

end;

procedure TLayer. SetNeuronCount(Value: integer);

begin

if Value <> High(FNeurons) + 1 then

SetLength(FNeurons, Value);

end;

procedure TLayer. SetNeurons(Index: integer; Value: TNeuron);

begin

try

FNeurons[Index] := Value;

except

on E: ERangeError do

raise E. CreateFmt(SNeuronRangeIndex, [Index])

end;

{ TNeuralNetBP }

constructor TNeuralNetBP. Create(AOwner: TComponent);

var

i: integer;

begin

inherited;

FNeuronsInLayer := TStringList. Create;

for i := 0 to DefaultLayerCount do

AddLayer(DefaultNeuronCount);

TStringList(FNeuronsInLayer).OnChange := NeuronsInLayerChange;

AutoInit := True;

StopTeach := False;

TeachStopped := False;

NeuronsInLayerChange(Self);

SetDefaultProperties;

end;

destructor TNeuralNetBP. Destroy;

begin

FNeuronsInLayer. Free;

SetLength(FRandomOrder, 0);

FRandomOrder := nil;

SetLength(FDesiredOut, 0);

FDesiredOut := nil;

SetLength(FTestSetPatterns, 0, 0);

FTestSetPatterns := nil;

SetLength(FTestSetPatternsOut, 0, 0);

FTestSetPatternsOut := nil;

FOnAfterInit := nil;

FOnAfterTeach := nil;

FOnBeforeInit := nil;

FOnBeforeTeach := nil;

FOnEpochPassed := nil;

inherited;

end;

function TNeuralNetBP. GetLayersBP(Index: integer): TLayerBP;

begin

Result := FLayers[Index] as TLayerBP;

end;

function TNeuralNetBP. GetLayerCount: integer;

begin

Result := High(FLayers) + 1;

end;

function TNeuralNetBP. GetDesiredOut(Index: integer): double;

begin

Result := FDesiredOut[Index];

end;

function TNeuralNetBP. GetOutput(Index: integer): double;

begin

try

Result := LayersBP[LayerCount - 1].NeuronsBP[Index].Output;

except

on E: ERangeError do

raise E. CreateFmt(SNeuronRangeIndex, [Index])

end;

function TNeuralNet. GetPatternsOutput(PatternIndex: integer; OutputIndex: integer): double;

begin

Result := FPatternsOutput[PatternIndex, OutputIndex];

end;

function TNeuralNetBP. QuadError: double;

var

i: integer;

begin

// рассчитывает среднеквадратичную ошибку

Result := 0;

for i := 0 to OutputNeuronCount - 1 do

Result := Result + sqr(LayersBP[LayerCount - 1].NeuronsBP[i].Output - DesiredOut[i]);

Result := Result/2;

end;

function TNeuralNetBP. ActivationF(Value: double): double;

begin

// Активационная функция - сигмоид

Result := 1/( 1 + exp(-FAlpha * Value) )

end;

function TNeuralNetBP. ActivationD(Value: double): double;

begin

// Производная сигмоиды

Result := FAlpha * Value * (1 - Value)

end;

function TNeuralNetBP. GetTestSetPatterns(InputIndex, PatternIndex: integer): double;

begin

Result := FTestSetPatterns[InputIndex, PatternIndex];

end;

function TNeuralNetBP. GetTestSetPatternsOut(InputIndex, PatternIndex: integer): double;

begin

Result := FTestSetPatternsOut[InputIndex, PatternIndex];

end;

procedure TNeuralNetBP. AddLayer(ANeurons: integer);

begin

if ANeurons < DefaultNeuronCount then

NeuronCountError

else

NeuronsInLayer. Add(IntToStr(ANeurons));

end;

procedure TNeuralNetBP. AdjustWeights;

var

i, j, k: integer;

xCurrentUpdate: double;

begin

// Подстройка весов начиная с первого слоя

for i := 1 to LayerCount - 1 do

for j := 0 to LayersBP[i].NeuronCount - 1 do

begin

for k := 0 to LayersBP[i-1].NeuronCount do

with LayersBP[i].NeuronsBP[j] do

begin

// корректирует вес соединяющий j-нейрон слоя i

// с k-нейроном слоя i-1: произведением дельта j-нейрона

// на выход k-нейрона слоя i-1

if k = LayersBP[i-1].NeuronCount then

// если это нейрон задающий смещение

xCurrentUpdate := - TeachRate * Delta + Momentum * PrevUpdate[k]

else

xCurrentUpdate := - TeachRate * Delta *

LayersBP[i-1].NeuronsBP[k].Output + Momentum * PrevUpdate[k];

Weights[k]:= Weights[k] + xCurrentUpdate;

PrevUpdate[k] := xCurrentUpdate;

end;

end

end;

procedure TNeuralNetBP. CalcLocalError;

var

i, j, k: integer;

begin

// Дельта-правило с последнего слоя до первого

for i := LayerCount - 1 downto 1 do

// для последнего слоя

if i = LayerCount - 1 then

for j := 0 to LayersBP[i].NeuronCount - 1 do

LayersBP[i].NeuronsBP[j].Delta := (LayersBP[i].NeuronsBP[j].Output-DesiredOut[j])

* ActivationD(LayersBP[i].NeuronsBP[j].Output)

else

for j := 0 to LayersBP[i].NeuronCount - 1 do

with LayersBP[i].NeuronsBP[j] do

begin

Delta := 0;

// Суммирует произведение локальной ошибки k-нейрона слоя i+1

// на вес соединяющий k-нейрон слоя i+1 с j-нейроном слоя i

for k := 0 to LayersBP[i+1].NeuronCount - 1 do

Delta := Delta + LayersBP[i+1].NeuronsBP[k].Delta *

LayersBP[i+1].NeuronsBP[k].Weights[j];

Delta := Delta * ActivationD(Output)

end;

procedure TNeuralNetBP. CheckTestSet;

var

i, j: integer;

xArray: TVectorFloat;

xFirstTestSample: boolean;

xQuadError: double;

// функция рассчитывает среднеквадратичную ошибку

function QuadError(APatternCount: integer): double;

var

i: integer;

begin

Result := 0;

for i := 0 to OutputNeuronCount - 1 do

Result := Result + sqr(LayersBP[LayerCount - 1].NeuronsBP[i].Output - TestSetPatternsOut[APatternCount, i]);

Result := Result/2;

end;

begin

SetLength(xArray, InputNeuronCount);

xFirstTestSample := True;

FRecognizedTestCount := 0;

FMidTestResidual := 0;

FMaxTestResidual := 0;

for i := 0 to TestSetPatternCount - 1 do

begin

for j := 0 to InputNeuronCount - 1 do

xArray[j] := TestSetPatterns[i, j];

Compute(xArray);

xQuadError := QuadError(i);

// проверка - распознан ли пример из тестового множества

if xQuadError < IdentError then

Inc(FRecognizedTestCount);

FMidTestResidual := FMidTestResidual + xQuadError;

// максимальная ошибка на тестовом множестве

if xFirstTestSample then

begin

FMaxTestResidual := xQuadError;

xFirstTestSample := False;

end

else

if FMaxTestResidual < xQuadError then

FMaxTestResidual := xQuadError;

end;

// средняя ошибка на тестовом множестве

FMidTestResidual := FMidTestResidual/TestSetPatternCount;

SetLength(xArray, 0);

xArray := nil;

end;

procedure pute(AVector: TVectorFloat);

var

i: integer;

begin

if InputNeuronCount <> High(AVector)+ 1 then

raise EInOutDimensionError. Create(SInNeuronCount);

for i := Low(AVector) to High(AVector) do

LayersBP[SensorLayer].NeuronsBP[i].Output := AVector[i];

Propagate;

end;

procedure TNeuralNetBP. DoOnAfterInit;

begin

if Assigned(FOnAfterInit) then

FOnAfterInit(Self);

end;

procedure TNeuralNetBP. DoOnAfterNeuronCreated(ALayerIndex, ANeuronIndex: integer);

var

i: integer;

begin

with LayersBP[ALayerIndex].NeuronsBP[ANeuronIndex] do

for i := 0 to PrevUpdateCount - 1 do

PrevUpdate[i] := 0;

if Assigned(FOnAfterNeuronCreated) then

FOnAfterNeuronCreated(Self);

end;

procedure TNeuralNetBP. DoOnAfterTeach;

begin

if Assigned(FOnAfterTeach) then

FOnAfterTeach(Self);

end;

procedure TNeuralNetBP. DoOnBeforeInit;

begin

if Assigned(FOnBeforeInit) then

FOnBeforeInit(Self);

end;

procedure TNeuralNetBP. DoOnBeforeTeach;

begin

if Assigned(FOnBeforeTeach) then

FOnBeforeTeach(Self);

end;

procedure TNeuralNetBP. DoOnEpochPassed;

begin

if Assigned(FOnEpochPassed) then

FOnEpochPassed(Self);

end;

procedure TNeuralNetBP. DeleteLayer(Index: integer);

var

i: integer;

begin

try

NeuronsInLayer. Delete(Index);

for i := Index to LayerCount - 2 do

LayersBP[i].Assign(LayersBP[i + 1]);

FLayers[LayerCount - 1].Free;

LayerCount := LayerCount - 1;

except

on E: ERangeError do

raise E. CreateFmt(SLayerRangeIndex, [Index])

end;

procedure TNeuralNetBP. Init;

var

i, j: integer;

begin

DoOnBeforeInit;

if NeuronsInLayer. Count > 0 then

begin

LayerCount := NeuronsInLayer. Count;

// FLayers[0] нулевой слой, используется только поле Output

FLayers[0] := TLayerBP. Create(0, StrToInt(NeuronsInLayer. Strings[0]));

// для нулевого слоя не нужны весовые коэффициенты

for i := 1 to LayerCount - 1 do

begin

FLayers[i] := TLayerBP. Create(i, StrToInt(NeuronsInLayer. Strings[i]));

for j := 0 to StrToInt(NeuronsInLayer. Strings[i]) - 1 do

with LayersBP[i].NeuronsBP[j] do

begin

// задает количество элементов в векторе весов + смещение

WeightCount := LayersBP[i-1].NeuronCount + BiasNeuron;

// задает количество в векторе содержащем предыдущую коррекцию

// элементов + смещение

PrevUpdateCount := LayersBP[i-1].NeuronCount + BiasNeuron;

PrevDerivativeCount := LayersBP[i-1].NeuronCount + BiasNeuron; // для быстрых алгоритмов

LearningRateCount := LayersBP[i-1].NeuronCount + BiasNeuron; // для быстрых алгоритмов

OnActivationF := ActivationF;

OnActivationD := ActivationD;

Randomize;

DoOnAfterNeuronCreated(i, j);

end

end;

// устанавливает размерность массива выходов

// число нейронов в последнем слое = числу выходов

SetLength(FDesiredOut, OutputNeuronCount);

end;

DoOnAfterInit;

end;

procedure TNeuralNetBP. InitWeights;

var

i, j: integer;

begin

Randomize;

// Инициализация весов

for i := 1 to LayerCount - 1 do

for j := 0 to LayersBP[i].NeuronCount - 1 do

LayersBP[i].NeuronsBP[j].InitWeights;

end;

procedure TNeuralNetBP. LoadPatternsInput(APatternIndex :integer);

var

i: integer;

begin

for i := 0 to InputNeuronCount - 1 do

LayersBP[SensorLayer].NeuronsBP[i].Output := PatternsInput[APatternIndex, i];

end;

procedure TNeuralNetBP. LoadPatternsOutput(APatternIndex :integer);

var

i: integer;

begin

for i := 0 to OutputNeuronCount - 1 do

DesiredOut[i] := PatternsOutput[APatternIndex, i];

end;

procedure TNeuralNetBP. NeuronsInLayerChange(Sender: TObject);

begin

if AutoInit then

Init;

end;

procedure TNeuralNetBP. NeuronCountError;

begin

raise ENeuronCountError. Create(SNeuronCount)

end;

procedure TNeuralNetBP. Propagate;

var

i, j, xIndex: integer;

xArray: TVectorFloat;

begin

// Распространение сигнала в прямом направлении с первого слоя

for i := 1 to LayerCount - 1 do

begin

// формирование массива входов из выходов предыдущего слоя

SetLength(xArray, LayersBP[i-1].NeuronCount);

for xIndex := 0 to LayersBP[i-1].NeuronCount - 1 do

xArray[xIndex] := LayersBP[i-1].NeuronsBP[xIndex].Output;

// вычисление выхода нейрона

for j := 0 to LayersBP[i].NeuronCount - 1 do

with LayersBP[i].NeuronsBP[j] do

ComputeOut(xArray);

for xIndex := 0 to LayersBP[i-1].NeuronCount - 1 do

xArray[xIndex] := 0;

end;

SetLength(xArray, 0);

xArray := nil;

end;

procedure TNeuralNetBP. ResetLayers;

begin

Clear;

FNeuronsInLayer. Clear;

end;

procedure TNeuralNetBP. SetDesiredOut(Index: integer; Value: double);

begin

FDesiredOut[Index] := Value;

end;

procedure TNeuralNetBP. SetLayersBP(Index: integer; Value: TLayerBP);

begin

FLayers[Index] := Value as TLayerBP;

end;

procedure TNeuralNetBP. SetAlpha(Value: double);

begin

if (Value > 10) or (Value < 0.01) then

FAlpha := DefaultAlpha

else

FAlpha := Value;

end;

procedure TNeuralNetBP. SetTeachRate(Value: double);

begin

if (Value > 1) or (Value <= 0) then

FTeachRate := DefaultTeachRate

else

FTeachRate := Value;

end;

procedure TNeuralNetBP. SetTestSetPatterns(InputIndex, PatternIndex: integer; const Value: double);

begin

FTestSetPatterns[InputIndex, PatternIndex] := Value;

end;

procedure TNeuralNetBP. SetTestSetPatternsOut(InputIndex, PatternIndex: integer; const Value: double);

begin

FTestSetPatternsOut[InputIndex, PatternIndex] := Value;

end;

procedure TNeuralNetBP. SetTestSetPatternCount(const Value: integer);

begin

FTestSetPatternCount := Value;

SetLength(FTestSetPatterns, FTestSetPatternCount, InputNeuronCount);

SetLength(FTestSetPatternsOut, FTestSetPatternCount, OutputNeuronCount);

end;

procedure TNeuralNetBP. SetMomentum(Value: double);

begin

if (Value > 1) or (Value < 0) then

FMomentum := DefaultMomentum

else

FMomentum := Value;

end;

procedure TNeuralNetBP. SetEpochCount(Value: integer);

begin

if Value < 1 then

FEpochCount := 1

else

FEpochCount := Value;

end;

procedure TNeuralNetBP. ShakeUp;

var

i, j, k: integer;

begin

Randomize;

for i := 1 to LayerCount - 1 do

for j := 0 to LayersBP[i].NeuronCount - 1 do

for k := 0 to LayersBP[i-1].NeuronCount do

with LayersBP[i].NeuronsBP[j] do

Weights[k]:= Weights[k] + Random*0.1-0.05;

end;

procedure TNeuralNetBP. Shuffle;

var

i, j, xNewInd, xLast: integer;

xIsUnique : boolean;

begin

xNewInd := 0;

FRandomOrder[0] := Round(Random(FPatternCount));

xLast := 0;

for i := 1 to PatternCount - 1 do

begin

xIsUnique := False;

while not xIsUnique do

begin

xNewInd := Round((Random(FPatternCount)));

xIsUnique := True;

for j := 0 to xLast do

if xNewInd = FRandomOrder[j] then

xIsUnique := False;

end;

FRandomOrder[i] := xNewInd;

xLast := xLast +1;

end;

procedure TNeuralNetBP. TeachOffLine;

var

j: integer;

xQuadError: double;

xNewEpoch: boolean;

begin

DoOnBeforeTeach;

if not ContinueTeach then

begin

// веса инициализируются, если сеть обучается с "нуля"

InitWeights;

FEpochCurrent := 1;

end;

Randomize;

SetLength(FRandomOrder, FPatternCount);

TeachStopped := False;

while (FEpochCurrent <= EpochCount) do

begin

FTeachError := 0;

FMaxTeachResidual := 0;

FRecognizedTeachCount := 0;

xNewEpoch := True;

Shuffle;

for j := 0 to PatternCount - 1 do

begin

LoadPatternsInput(FRandomOrder[j]);

LoadPatternsOutput(FRandomOrder[j]);

Propagate;

xQuadError := QuadError;

// проверка - распознан ли пример из обучающего множества

if xQuadError < IdentError then

Inc(FRecognizedTeachCount);

FTeachError := FTeachError + xQuadError;

// максимальная ошибка на обучающем множестве

if xNewEpoch then

begin

FMaxTeachResidual := xQuadError;

xNewEpoch := False;

end

else

if MaxTeachResidual < xQuadError then

FMaxTeachResidual := xQuadError;

CalcLocalError;

AdjustWeights;

end;

// средняя ошибка на обучающем множестве

FMidTeachResidual := TeachError/PatternCount;

// проверка сети на обобщение

if TestSetPatternCount > 0 then

CheckTestSet;

DoOnEpochPassed;

if StopTeach then

begin

TeachStopped := True;

Exit;

end;

Inc(FEpochCurrent);

end;

DoOnAfterTeach;

end;

procedure TNeuralNetBP. SetPatternCount(const Value: integer);

begin

FPatternCount := Value;

inherited;

end;

procedure TNeuralNetBP. SetDefaultProperties;

begin

// параметры устанавливаемые по умолчанию

Alpha := DefaultAlpha;

ContinueTeach := False;

Epoch := True;

EpochCount := DefaultEpochCount;

Momentum := DefaultMomentum;

TeachRate := DefaultTeachRate;

ResizeInputDim;

ResizeOutputDim;

end;

end.

Исходный код скрипта подключения библиотеки ActiveX к системе “1C:Предприятие”

//Нейросеть - начало

Если флNero=1 Тогда

Если ПустоеЗначение(Нейросеть)=1 Тогда

Если ЗагрузитьВнешнююКомпоненту("NeroNet. dll")=0 Тогда

Возврат;

КонецЕсли;

НейроСеть=СоздатьОбъект("AddIn. NeroNet");

КонецЕсли;

НейроСеть. НачатьОпределениеКолонок();

Для с=1 по СписокГруппировок. РазмерСписка() Цикл

Идент=СписокГруппировок. ПолучитьЗначение(с);

НейроСеть. НоваяКолонка(Идент);

КонецЦикла;

НейроСеть. НоваяКолонка("Количество","Количество","Число");

НейроСеть. НоваяКолонка("Стоимость","Стоимость","Число");

НейроСеть. НоваяКолонка("Наименование товара"," Наименование товара ","Число");

НейроСеть. НоваяКолонка("Дата"," Дата "," Дата ");

НейроСеть. ЗавершитьОпределениеКолонок();

Прогресс="=>";

Загрузить_Данные_В_НейроСеть(1);

НейроСеть. Показать("Прогноз продажи по товарам");

Возврат;

КонецЕсли;

//НейроСеть – конец

Основные элементы интерфейса пользователя системы

Рис. 1 Главное окно программы и экранная форма вызова внешнего отчета

Рис. 2 Основная экранная форма с элементами настройки

Рис. 3 Форма отчета прогноза

[1] Информационные технологии – совокупность методов, производственных процессов и программно-технических средств, объединенных в технологическую цепочку, обеспечивающую сбор, обработку, хранение, распространение (транспортировку) и отображение информации с целью снижения трудоемкости процессов использования информационного ресурса, а также повышения их надежности и оперативности.

[2] Data Mining – в переводе с английского означает "добыча данных". Альтернативное название – knowledge discovery in databases ("обнаружение знаний в базах данных" или "интеллектуальный анализ данных").

[3] Документ, позволяющий обосновать целесообразность разработки, производства, и сбыта продукции в условиях конкуренции.

Из за большого объема этот материал размещен на нескольких страницах:
1 2 3 4 5 6 7 8

Листинг 4 Основной файл проекта NeroSys

Домашний очаг

Справочная информация

Техника

Общество

Образование и наука

Мир

Бизнес и финансы