unit WeaselCode;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, Math, SessionManagement;

type

  { TWeaselAlgorithm }

  TWeaselAlgorithm = class
  private
    FAllowDeletes: boolean;
    FAllowInserts: boolean;
    FCharacters:   string;
    FCurrentTextWithNS: string;
    FCurrentTextWithoutNS: string;
    FGeneration:   integer;
    FMutationRate: currency;
    FOffspring:    integer;
    FTargetText:   string;
    function GetCurrentDistanceWithNS: integer;
    function GetCurrentDistanceWithoutNS: integer;

    function DecideMutate: boolean;
    function GenerateRandomLetter: char;
    function CalcDistance(const AText1, AText2: string): integer;
    function Breed(const AMother: string): string;
    function BreedWithNS(const AMother: string): string;
  public
    constructor Create;

    procedure Start(const AStartText: string);
    procedure Reset;
    procedure RunGeneration;

    property Generation: integer Read FGeneration;
    property MutationRate: currency Read FMutationRate Write FMutationRate;
    property Offspring: integer Read FOffspring Write FOffspring;
    property Characters: string Read FCharacters Write FCharacters;
    property AllowInserts: boolean Read FAllowInserts Write FAllowInserts;
    property AllowDeletes: boolean Read FAllowDeletes Write FAllowDeletes;

    property TargetText: string Read FTargetText Write FTargetText;

    property CurrentTextWithNS: string Read FCurrentTextWithNS;
    property CurrentTextWithoutNS: string Read FCurrentTextWithoutNS;
    property CurrentDistanceWithNS: integer Read GetCurrentDistanceWithNS;
    property CurrentDistanceWithoutNS: integer Read GetCurrentDistanceWithoutNS;
  end;



implementation


{ TWeaselAlgorithm }


function TWeaselAlgorithm.GetCurrentDistanceWithNS: integer;
begin
  Result := CalcDistance(FTargetText, FCurrentTextWithNS);
end;

function TWeaselAlgorithm.GetCurrentDistanceWithoutNS: integer;
begin
  Result := CalcDistance(FTargetText, FCurrentTextWithoutNS);
end;

// Decide if a mutation should occure based on property MutationRate
function TWeaselAlgorithm.DecideMutate: boolean;
var
  Limit:   extended;
  Fortune: extended;
begin
  // Calculate limit from percent value
  Limit := FMutationRate / 100;

  // Draw a random number from [0..[1
  Fortune := Random;

  // A mutation occurs if Fortune < Limit
  Result := Fortune < Limit;
end;

// Generate a random character
function TWeaselAlgorithm.GenerateRandomLetter: char;
var
  CharacterCount: integer;
  Pos: integer;
begin
  // If we have no characters to choose from,
  // we always return a space character
  if FCharacters = '' then
  begin
    Result := ' ';
    Exit;
  end;

  // Count how many characters we can choose from
  CharacterCount := Length(FCharacters);

  // Randomly choose one of those
  Pos    := Random(CharacterCount) + 1;
  Result := FCharacters[Pos];
end;

// Calculate distance between two strings
function TWeaselAlgorithm.CalcDistance(const AText1, AText2: string): integer;
var
  I: integer;
  Ch1, Ch2: char;
begin
  Result := 0;

  // For each character position (up to longest of the two strings)
  for I := 1 to Max(Length(AText1), Length(AText2)) do
  begin
    // Get respective character in first string
    // If string too short, we use character #0
    if I > Length(AText1) then
    begin
      Ch1 := #0;
    end
    else
    begin
      Ch1 := AText1[I];
    end;

    // Get respective character in second string
    // If string too short, we use character #0
    if I > Length(AText2) then
    begin
      Ch2 := #0;
    end
    else
    begin
      Ch2 := AText2[I];
    end;

    // If the two letters are not the same,
    // increase distance by one
    if Ch1 <> Ch2 then
      Result := Result + 1;
  end;
end;

 // Breed a new daughter string from string AMother by
 // randomly mutating characters
function TWeaselAlgorithm.Breed(const AMother: string): string;
var
  I: integer;
begin
  // Start with mother
  Result := AMother;

  // For every character in Result, mutate it if chance says so
  // Go from back to fron to deal with insertions and deletions
  for I := Length(Result) downto 1 do
  begin
    if DecideMutate then
    begin
      Result[I] := GenerateRandomLetter;
    end;
  end;

  // Mutations can also add a character at the end
  if FAllowInserts and DecideMutate then
  begin
    Result := Result + GenerateRandomLetter;
  end;

  // Mutations can also remove a character from the end
  if FAllowDeletes and DecideMutate then
  begin
    Delete(Result, Length(Result), 1);
  end;

end;

 // Breed n daughter strings from AMother and choose the one
 // nearest to the target text to live
function TWeaselAlgorithm.BreedWithNS(const AMother: string): string;
var
  BestDistanceSoFar: integer;
  I: integer;
  Daughter: string;
  DaughterDistance: integer;
begin
  // Start with mother in case Offspring is 0
  Result := AMother;

  // Start of with worst (highest) distance possible
  BestDistanceSoFar := High(BestDistanceSoFar);

  // Consecutively breed n Offspring
  for I := 1 to FOffspring do
  begin
    // Breed a daughter
    Daughter := Breed(AMother);

    // Calculate distance for daugher
    DaughterDistance := CalcDistance(Daughter, FTargetText);

    // If distance is better (smaller) than best distance so far
    // let this daughter live
    if DaughterDistance < BestDistanceSoFar then
    begin
      Result := Daughter;
      BestDistanceSoFar := DaughterDistance;
    end;
  end;
end;

constructor TWeaselAlgorithm.Create;
begin
  inherited Create;

  // Init object
  Reset;
end;

procedure TWeaselAlgorithm.Start(const AStartText: string);
begin
  // (Re-)Start algorithm
  FGeneration := 0;
  FCurrentTextWithNS := AStartText;
  FCurrentTextWithoutNS := AStartText;
end;

// reset
procedure TWeaselAlgorithm.Reset;
begin
  FAllowDeletes := False;
  FAllowInserts := False;
  FCharacters   := '';
  FCurrentTextWithNS := '';
  FCurrentTextWithoutNS := '';
  FGeneration   := 0;
  FMutationRate := 0;
  FOffspring    := 0;
  FTargetText   := '';
end;

procedure TWeaselAlgorithm.RunGeneration;
begin
  // Next generation
  FGeneration := FGeneration + 1;

  // Run next generation without natural selection
  // We only produce one offspring and take that
  // We could produce n offspring and randomly select one of those
  // but this doesn't change the outcome, since selection is random
  // and we want to save time and memory
  FCurrentTextWithoutNS := Breed(FCurrentTextWithoutNS);

  // Run next generation with natural selection
  FCurrentTextWithNS := BreedWithNS(FCurrentTextWithNS);
end;

initialization
  // Init random number generation with current time
  Randomize
end.