Forum > Beginners
FreePascal: find all 3-symbol unique substring in string
Bart:
And for those who want a more Enterpise type of solution:
--- Code: Pascal [+][-]window.onload = function(){var x1 = document.getElementById("main_content_section"); if (x1) { var x = document.getElementsByClassName("geshi");for (var i = 0; i < x.length; i++) { x[i].style.maxHeight='none'; x[i].style.height = Math.min(x[i].clientHeight+15,306)+'px'; x[i].style.resize = "vertical";}};} ---{$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.
I dare you to submit that ...
Bart
BobDog:
A vert fast method, but a problem, the code block won't accept the characters ' which surround a string.
You should change ' to '
--- Code: Pascal [+][-]window.onload = function(){var x1 = document.getElementById("main_content_section"); if (x1) { var x = document.getElementsByClassName("geshi");for (var i = 0; i < x.length; i++) { x[i].style.maxHeight='none'; x[i].style.height = Math.min(x[i].clientHeight+15,306)+'px'; x[i].style.resize = "vertical";}};} ---usessysutils; Type intArray = Array of longword; function tally(somestring:ansistring;partstring:ansistring;var arr:intarray ):longword;vari,j,ln,lnp,count,num:longword;filler:boolean=false;labelskip,start,return;beginln:=length(somestring);lnp:=length(partstring);start:count:=0;i:=0;repeati:=i+1; if somestring[i] <> partstring[1] then goto skip ; if somestring[i] = partstring[1] then begin for j:=0 to lnp-1 do begin if somestring[j+i]<>partstring[j+1] then goto skip; end; count:=count+1; if filler = true then arr[count]:=i ; i:=i+lnp-1; end ; skip: until i>=ln-0 ; SetLength(arr,count); arr[0]:=count; num:=count; if filler=true then goto return;filler:=true; goto start; return: result:=num;end; {tally} vara:ansistring='abcabc6755abcabcyyabcabcabc';i:intarray;j:integer; beginwriteln('substring ',QuotedStr('abc'));writeln('main string ',QuotedStr(a),' length = ',length(a)); writeln('Number of occurrencies ',tally(a,'abc',i));writeln('Positions within string: ');for j:=1 to high(i)+1 do write(i[j],' ');writeln;writeln('Press enter to end . . .');readln;end.
Thaddy:
--- Quote from: BobDog on December 29, 2021, 03:33:50 pm ---A vert fast method, but a problem, the code block won't accept the characters ' which surround a string.
--- End quote ---
This is fixed.
engkin:
@BobDog,
Your solution does not count "unique" 3-char strings, it counts a specific substr.
BobDog:
I see what you mean now, engkin.
try this method maybe:
--- Code: Pascal [+][-]window.onload = function(){var x1 = document.getElementById("main_content_section"); if (x1) { var x = document.getElementsByClassName("geshi");for (var i = 0; i < x.length; i++) { x[i].style.maxHeight='none'; x[i].style.height = Math.min(x[i].clientHeight+15,306)+'px'; x[i].style.resize = "vertical";}};} --- {$R+} type aos=array of ansistring; procedure clean(a:aos;var b:aos);varflag:int32=0;count:int32=1;n1,n2:int32;beginsetlength(b,high(a)+1);b[0]:=a[0]; For n1 :=1 To high(a) do begin flag:=0; For n2 :=0 to n1-1 do begin If (a[n1]=a[n2]) Then begin flag:=1; break; end; end; If (flag=0) Then begin b[count]:=a[n1]; count:=count+1; End; end; setlength(b,count);end; procedure parse(s:ansistring;var b:aos);vari:int32;a:aos;beginif (length(s)=3) thenbeginsetlength(b,1);b[0]:=s;exit;end;for i:=1 to length(s)-2 do beginsetlength(a,i);a[i-1]:=s[i..i+2];end;clean(a,b);end; vars:ansistring;ans:aos;j:int32; beginwhile (s<>'q') dobeginwrite('Enter string at least 3 characters (or q to quit): '); read(s); if (s='q') then exit; parse(s,ans); for j:=0 to high(ans) do writeln(j+1,' ',ans[j]); readln; end;end. Tested 64 bits, windows.
Thanks Thaddy.
Navigation
[0] Message Index
[#] Next page
[*] Previous page