{$mode objfpc}
{$h+}
uses
SysUtils, Classes;
type
{ TUniqueSequenceParser }
generic TUniqueSequenceParser<T, TAtom> = class
private
FSubLen: Integer;
FList: Array of T;
FTheThingToParse: T;
function IsInList(const Sub: T): Boolean;
procedure SetSubLen(AValue: Integer);
protected
function Equal(Item1, Item2: T): Boolean; virtual; abstract;
function GetAtom(Index: Integer): TAtom; virtual; abstract;
function Concat(Item1: T; Item2: TAtom): T; virtual; abstract;
function ItemLength(Item: T): Integer; virtual; abstract;
function GetParseCount: Integer;
function GetSub(StartIndex: Integer): T;
procedure InsertInList(Index: Integer; AItem: T); virtual;
procedure Parse;
procedure Report(Verbose: Boolean);
procedure Clear;
public
constructor Create; virtual;
property SubLen: Integer read FSubLen write SetSubLen default 3;
property TheThingToParse: T read FTheThingToParse write FTheThingToParse;
property ParseCount: Integer read GetParseCount;
end;
{ TUniqueSequenceParser }
function TUniqueSequenceParser.IsInList(const Sub: T): Boolean;
var
i: Integer;
begin
Result := False;
for i := Low(FList) to High(FList) do
if EQual(Sub, FList[i]) then Exit(True);
end;
procedure TUniqueSequenceParser.SetSubLen(AValue: Integer);
begin
if FSubLen = AValue then Exit;
if AValue < 1 then
AValue := 1;
FSubLen := AValue;
end;
function TUniqueSequenceParser.GetParseCount: Integer;
begin
Result := Length(FList);
end;
function TUniqueSequenceParser.GetSub(StartIndex: Integer): T;
var
LoopCount, i: Integer;
begin
Result := Default(T);
LoopCount := SubLen - 1;
if LoopCount < 0 then
Exit;
for i := StartIndex to StartIndex + LoopCount do
begin
Result := Concat(Result, GetAtom(i));
end;
end;
procedure TUniqueSequenceParser.InsertInList(Index: Integer; AItem: T);
begin
FList[Index] := AItem;
end;
procedure TUniqueSequenceParser.Parse;
var
Len, i, Idx: Integer;
Sub: T;
begin
Len := ItemLength(FTheThingToParse);
if Len < SubLen then
Exit;
SetLength(FList, Len-SubLen+1);
Idx := -1;
for i := 1 to Len - (FSubLen-1) do
begin
Sub := GetSub(i);
if not IsInList(Sub) then
begin
Inc(Idx);
InsertInList(Idx, Sub);
end;
end;
SetLength(FList, Succ(Idx));
end;
procedure TUniqueSequenceParser.Report(Verbose: Boolean);
var
i: Integer;
begin
if Verbose then
writeln(format('%d unique subitems of length %d found',[ParseCount, SubLen]));
for i := 0 to ParseCount - 1 do
begin
if verbose then write(Succ(i):2,': ');
writeln(FList[i]);
end;
end;
procedure TUniqueSequenceParser.Clear;
begin
FList := nil;
FTheThingToParse := default(T);
end;
constructor TUniqueSequenceParser.Create;
begin
inherited Create;
FList := nil;
FTheThingToParse := default(T);
FSubLen := 3;
end;
type
{ TStringParser }
TStringParser = class (specialize TUniqueSequenceParser<String, Char>)
private
FCaseSensitive: Boolean;
protected
function Equal(Item1, Item2: String): Boolean; override;
function GetAtom(Index: Integer): Char; override;
function Concat(Item1: String; Item2: Char): String; override;
function ItemLength(Item: String): Integer; override;
procedure InsertInList(Index: Integer; AItem: String); override;
public
constructor Create; override;
property CaseSensitive: Boolean read FCaseSensitive write FCaseSensitive default True;
end;
{ TStringParser }
function TStringParser.Equal(Item1, Item2: String): Boolean;
begin
if FCaseSensitive then
Result := (CompareStr(Item1, Item2) = 0)
else
Result := (CompareText(Item1, Item2) = 0);
end;
function TStringParser.GetAtom(Index: Integer): Char;
begin
Result := FTheThingToParse[Index];
end;
function TStringParser.Concat(Item1: String; Item2: Char): String;
begin
Result := Item1 + Item2;
end;
function TStringParser.ItemLength(Item: String): Integer;
begin
Result := Length(Item);
end;
procedure TStringParser.InsertInList(Index: Integer; AItem: String);
begin
if not FCaseSensitive then
AItem := LowerCase(AItem);
inherited InsertInList(Index, AItem);
end;
constructor TStringParser.Create;
begin
inherited Create;
FCaseSensitive := True;
end;
var
S: String;
Parser: TStringParser;
begin
repeat
Parser := TStringParser.Create;
try
Parser.SubLen := 3;
write('Enter string: ');
readln(S);
Parser.TheThingToParse := S;
write('Casesensitive [yes|no]: ');
readln(S);
Parser.CaseSensitive := (CompareText(S, 'YES') = 0);
Parser.Parse;
Parser.Report(True);
finally
Parser.Free;
end;
until (S='');
end.