Sordie.co.uk

libsassy/libSassy.AI.pas

Raw

{(
 )) libSassy.AI
((    Artificial intelligence library
 ))
((  Copyright  Sordie Aranka Solomon-Smith 2015
 ))
((  This work is made available under the terms of the Creative Commons
 )) Attribution-NonCommercial-ShareAlike 3.0 Unported license
((  http://creativecommons.org/licenses/by-nc-sa/3.0/
 )}

unit libSassy.AI;

interface

uses
  libSassy.Arrays;

type
{$REGION 'TGene'}
  TGene = class abstract
  public
    constructor Create; virtual;

    function CreateCopy: TGene; virtual;

    procedure Mutate(Delta: Single = 1); virtual; abstract;
  end;
{$ENDREGION}

{$REGION 'TGeneType'}
  TGeneType<T> = class(TGene)
  private
    fValue: T;
  public
    function CreateCopy: TGene; override;

    property Value: T read fValue write fValue;
  end;
{$ENDREGION}

{$REGION 'TGenome'}
  TGenome = class(TGene)
  private
    fGenes:   TArray<TGene>;
    fFitness: Single;
  public
    constructor Create; override;
    destructor  Destroy; override;

    function CreateCopy: TGene; override;

    procedure Mutate(Delta: Single = 1); override;

    property Genes: TArray<TGene> read fGenes;

    property Fitness: Single read fFitness write fFitness;
  end;
{$ENDREGION}

{$REGION 'TNeuron'}
  TNeuronMode = (nmBland, nmHebbPostPre, nmHebbPost, nmHebbPre);

  TNeuron = class;

  TNeuronLink = record
    Weight: Single;
    Neuron: TNeuron;
  end;

  TNeuron = class(TGene)
  private
    fCharge:    Single;
    fThreshold: Single;
    fMode:      TNeuronMode;
    fStimulus:  Single;

    fLinks: array of TNeuronLink;
  public
    function CreateCopy: TGene; override;
    procedure Mutate(Delta: Single = 1); override;

    procedure Process; virtual;

    property Charge:    Single      read fCharge    write fCharge;
    property Threshold: Single      read fThreshold write fThreshold;
    property Mode:      TNeuronMode read fMode      write fMode;
    property Stimulus:  Single      read fStimulus  write fStimulus;
  end;
{$ENDREGION}

{$REGION 'TNeuralNetwork'}
  TNeurons = class
  private
    fSource:  TNeurons;
    fNeurons: array of TNeuron;

    function GetCount: Integer; inline;
    function GetNeuron(Index: Integer): TNeuron; inline;
  public
    constructor Create(const ANeurons: Integer; const ASource: TNeurons = nil; const ANeuronMode: TNeuronMode = nmBland; const AStimulus: Single = 0.1);
    destructor  Destroy; override;

    procedure Mutate(Delta: Single = 1);

    procedure Process;

    procedure SetNeuronMode(Mode: TNeuronMode);
    procedure SetStimulus(Stimulus: Single);

    property Source: TNeurons read fSource;

    property Count: Integer read GetCount;
    property Neurons[Index: Integer]: TNeuron read GetNeuron; default;
  end;

  TNeuralNetwork = class(TGene)
  private
    fInput:  TNeurons;
    fHidden: array of TNeurons;
    fOutput: TNeurons;

    function  GetInputs: Integer; inline;
    function  GetInput(Index: Integer): Single; inline;
    procedure SetInput(Index: Integer; Value: Single); inline;

    function GetOutputs: Integer; inline;
    function GetOutput(Index: Integer): Single; inline;
  public
    constructor Create(const AInputs, AOutputs: Integer; const AHidden: array of Integer); reintroduce;
    destructor  Destroy; override;

    function CreateCopy: TGene; override;
    procedure Mutate(Delta: Single = 1); override;

    procedure Process;

    procedure SetNeuronMode(Mode: TNeuronMode);
    procedure SetStimulus(Stimulus: Single);

    property Inputs: Integer read GetInputs;
    property Input[Index: Integer]: Single read GetInput write SetInput;

    property Outputs: Integer read GetOutputs;
    property Output[Index: Integer]: Single read GetOutput;
  end;
{$ENDREGION}

implementation

{$REGION 'TGene'}
constructor TGene.Create;
begin
  inherited;
end;

function TGene.CreateCopy;
begin
  Result := TGene(ClassType.NewInstance);
  Result.Create;
end;
{$ENDREGION}

{$REGION 'TGeneType'}
function TGeneType<T>.CreateCopy;
begin
  Result := inherited;
  TGeneType<T>(Result).fValue := fValue;
end;
{$ENDREGION}

{$REGION 'TGenome'}
constructor TGenome.Create;
begin
  inherited;

  fGenes   := TArray<TGene>.Create;
  fFitness := 0;
end;

destructor TGenome.Destroy;
var
  Gene: TGene;
begin
  for Gene in fGenes do
    Gene.Free;

  fGenes.Free;

  inherited;
end;

function TGenome.CreateCopy;
var
  Gene: TGene;
begin
  Result := inherited;

  for Gene in fGenes do
    TGenome(Result).fGenes.Add(Gene.CreateCopy);
end;

procedure TGenome.Mutate;
var
  Gene: TGene;
begin
  for Gene in fGenes do
    Gene.Mutate(Delta);
end;
{$ENDREGION}

{$REGION 'TNeuron'}
function TNeuron.CreateCopy;
var
  i: Integer;
begin
  Result := inherited;

  SetLength(TNeuron(Result).fLinks, Length(fLinks));

  for i := 0 to High(fLinks) do
    TNeuron(Result).fLinks[i] := fLinks[i];

  TNeuron(Result).fThreshold := fThreshold;
  TNeuron(Result).fMode      := fMode;
  TNeuron(Result).fStimulus  := fStimulus;
end;

procedure TNeuron.Mutate;
var
  i: Integer;
begin
  for i := 0 to High(fLinks) do
    fLinks[i].Weight := fLinks[i].Weight + ((-1 * Random) * Delta);

  fThreshold := fThreshold + ((-1 * Random) * Delta);
end;

procedure TNeuron.Process;
var
  i: Integer;
begin
  fCharge := 0;

  for i := 0 to High(fLinks) do
    if fLinks[i].Neuron <> nil then
      fCharge := fCharge + (fLinks[i].Neuron.Charge * fLinks[i].Weight);

  fCharge := (1 / (1 + exp(-1 / fCharge))) - fThreshold;

  for i := 0 to High(fLinks) do
    if fLinks[i].Neuron <> nil then
      case fMode of
        nmHebbPostPre: fLinks[i].Weight := fLinks[i].Weight + (fStimulus * fLinks[i].Neuron.Charge * Charge);
        nmHebbPost:    fLinks[i].Weight := fLinks[i].Weight + (fStimulus * (2 * fLinks[i].Neuron.Charge - 1) * Charge);
        nmHebbPre:     fLinks[i].Weight := fLinks[i].Weight + (fStimulus * fLinks[i].Neuron.Charge * (2 * Charge - 1));
      end;
end;
{$ENDREGION}

{$REGION 'TNeuralNetwork'}
function TNeurons.GetCount;
begin
  Result := Length(fNeurons);
end;

function TNeurons.GetNeuron;
begin
  Result := fNeurons[Index];
end;

constructor TNeurons.Create;
var
  i, j: Integer;
begin
  inherited Create;

  SetLength(fNeurons, ANeurons);
  fSource  := ASource;

  for i := 0 to High(fNeurons) do
  begin
    fNeurons[i] := TNeuron.Create;

    fNeurons[i].Threshold := Random;
    fNeurons[i].Mode      := ANeuronMode;
    fNeurons[i].Stimulus  := AStimulus;

    if fSource <> nil then
    begin
      SetLength(fNeurons[i].fLinks, fSource.Count);

      for j := 0 to fSource.Count - 1 do
      begin
        fNeurons[i].fLinks[j].Weight := -1 + (Random * 2);
        fNeurons[i].fLinks[j].Neuron := fSource.fNeurons[j];
      end;
    end;
  end;
end;

destructor TNeurons.Destroy;
var
  i: Integer;
begin
  for i := 0 to High(fNeurons) do
    fNeurons[i].Free;

  inherited;
end;

procedure TNeurons.Mutate;
var
  i: Integer;
begin
  for i := 0 to high(fNeurons) do
    fNeurons[i].Mutate(Delta);
end;

procedure TNeurons.Process;
var
  i: Integer;
begin
  for i := 0 to High(fNeurons) do
    fNeurons[i].Process;
end;

procedure TNeurons.SetNeuronMode;
var
  i: Integer;
begin
  for i := 0 to High(fNeurons) do
    fNeurons[i].Mode := Mode;
end;

procedure TNeurons.SetStimulus;
var
  i: Integer;
begin
  for i := 0 to High(fNeurons) do
    fNeurons[i].Stimulus := Stimulus;
end;

function TNeuralNetwork.GetInputs;
begin
  Result := Length(fInput.fNeurons);
end;

function TNeuralNetwork.GetInput;
begin
  Result := fInput.fNeurons[Index].fCharge;
end;

procedure TNeuralNetwork.SetInput;
begin
  fInput.fNeurons[Index].fCharge := Value;
end;

function TNeuralNetwork.GetOutputs;
begin
  Result := Length(fOutput.fNeurons);
end;

function TNeuralNetwork.GetOutput;
begin
  Result := fOutput.fNeurons[Index].fCharge;
end;

constructor TNeuralNetwork.Create;
var
  i: Integer;
  Source: TNeurons;
begin
  inherited Create;

  fInput := TNeurons.Create(AInputs);
  Source := fInput;

  SetLength(fHidden, Length(AHidden));

  for i := 0 to High(fHidden) do
  begin
    fHidden[i] := TNeurons.Create(AHidden[i], Source);
    Source := fHidden[i];
  end;

  fOutput := TNeurons.Create(AOutputs, Source);
end;

destructor TNeuralNetwork.Destroy;
var
  i: Integer;
begin
  fOutput.Free;

  for i := 0 to High(fHidden) do
    fHidden[i].Free;

  fInput.Free;

  inherited;
end;

function TNeuralNetwork.CreateCopy;
  procedure CopyLinks(Source, Dest: TNeurons);
  var
    i, j: Integer;
  begin
    for i := 0 to high(Source.fNeurons) do
    begin
      Dest.fNeurons[i].Threshold := Source.fNeurons[i].Threshold;

      for j := 0 to high(Source.fNeurons[i].fLinks) do
        Dest.fNeurons[i].fLinks[j].Weight := Source.fNeurons[i].fLinks[j].Weight;
    end;
  end;
var
  i:       Integer;
  AHidden: array of Integer;
  Child:   TNeuralNetwork;
begin
  SetLength(AHidden, Length(fHidden));

  for i := 0 to High(AHidden) do
    AHidden[i] := Length(fHidden[i].fNeurons);

  Child := TNeuralNetwork.Create(Length(fInput.fNeurons), Length(fOutput.fNeurons), AHidden);

  CopyLinks(fInput, Child.fInput);

  for i := 0 to high(fHidden) do
    CopyLinks(fHidden[i], Child.fHidden[i]);

  CopyLinks(fOutput, Child.fOutput);

  Result := Child;
end;

procedure TNeuralNetwork.Mutate;
var
  i: Integer;
begin
  fInput.Mutate(Delta);

  for i := 0 to high(fHidden) do
    fHidden[i].Mutate(Delta);

  fOutput.Mutate(Delta);
end;

procedure TNeuralNetwork.Process;
var
  i: Integer;
begin
  for i := 0 to High(fHidden) do
    fHidden[i].Process;

  fOutput.Process;
end;

procedure TNeuralNetwork.SetNeuronMode;
var
  i: Integer;
begin
  for i := 0 to High(fHidden) do
    fHidden[i].SetNeuronMode(Mode);

  fOutput.SetNeuronMode(Mode);
end;

procedure TNeuralNetwork.SetStimulus;
var
  i: Integer;
begin
  for i := 0 to High(fHidden) do
    fHidden[i].SetStimulus(Stimulus);

  fOutput.SetStimulus(Stimulus);
end;
{$ENDREGION}

end.