IP Address String Routines in Delphi? - string

I'm looking for a way in Delphi to validate and manipulate IP Addresses. Some of the things it should be able to do is...
Verify that a string is a valid IP address
Verify that a string is a valid subnet mask
Verify that an IP address is within a given Subnet
Some type (record or string or whatever) which is meant for storing an IP address
Basic conversion of an IP address types, such as String or Array[0..3] of Byte
Any other IP address routines that can make IP manipulation easier
The basic reason is that I want to see if these things are already out there before I go ahead and reinvent them.

I also once wrote a IPv4 and IPv6 conversion unit including a custom variant type for both types of IP addresses. This answer shows a few examples of its capabilities. Originally, it was designed to visualize values of various types in scale on some slider control 1). The requirements then were such that default existing libraries weren't sufficient, but I agree with the comments here that you probably will be helped with just Indy (10!) or alike.
Answering your list of questions with a few code snippets from that unit:
Q4: Storage type for IP types:
const
IPv4BitSize = SizeOf(Byte) * 4 * 8;
IPv6BitSize = SizeOf(Word) * 8 * 8;
type
T4 = 0..3;
T8 = 0..7;
TIPv4ByteArray = array[T4] of Byte;
TIPv6WordArray = array[T8] of Word;
TIPv4 = packed record
case Integer of
0: (D, C, B, A: Byte);
1: (Groups: TIPv4ByteArray);
2: (Value: Cardinal);
end;
TIPv6 = packed record
case Integer of
0: (H, G, F, E, D, C, B, A: Word);
1: (Groups: TIPv6WordArray);
end;
Q5: Conversion of IP address strings to these record or array types:
function StrToIPv4(const S: String): TIPv4;
var
SIP: String;
Start: Integer;
I: T4;
Index: Integer;
Count: Integer;
SGroup: String;
G: Integer;
begin
SIP := S + '.';
Start := 1;
for I := High(T4) downto Low(T4) do
begin
Index := PosEx('.', SIP, Start);
if Index = 0 then
IPv4ErrorFmt(SInvalidIPv4Value, S);
Count := Index - Start + 1;
SGroup := Copy(SIP, Start, Count - 1);
if TryStrToInt(SGroup, G) and (G >= Low(Word)) and (G <= High(Word)) then
Result.Groups[I] := G
else
Result.Groups[I] := 0;
Inc(Start, Count);
end;
end;
function StrToIPv6(const S: String): TIPv6;
{ Valid examples for S:
2001:0db8:85a3:0000:0000:8a2e:0370:7334
2001:db8:85a3:0:0:8a2e:370:7334
2001:db8:85a3::8a2e:370:7334
::8a2e:370:7334
2001:db8:85a3::
::1
::
::ffff:c000:280
::ffff:192.0.2.128 }
var
ZeroPos: Integer;
DotPos: Integer;
SIP: String;
Start: Integer;
Index: Integer;
Count: Integer;
SGroup: String;
G: Integer;
procedure NormalNotation;
var
I: T8;
begin
SIP := S + ':';
Start := 1;
for I := High(T8) downto Low(T8) do
begin
Index := PosEx(':', SIP, Start);
if Index = 0 then
IPv6ErrorFmt(SInvalidIPv6Value, S);
Count := Index - Start + 1;
SGroup := '$' + Copy(SIP, Start, Count - 1);
if not TryStrToInt(SGroup, G) or (G > High(Word)) or (G < 0) then
IPv6ErrorFmt(SInvalidIPv6Value, S);
Result.Groups[I] := G;
Inc(Start, Count);
end;
end;
procedure CompressedNotation;
var
I: T8;
A: array of Word;
begin
SIP := S + ':';
Start := 1;
I := High(T8);
while Start < ZeroPos do
begin
Index := PosEx(':', SIP, Start);
if Index = 0 then
IPv6ErrorFmt(SInvalidIPv6Value, S);
Count := Index - Start + 1;
SGroup := '$' + Copy(SIP, Start, Count - 1);
if not TryStrToInt(SGroup, G) or (G > High(Word)) or (G < 0) then
IPv6ErrorFmt(SInvalidIPv6Value, S);
Result.Groups[I] := G;
Inc(Start, Count);
Dec(I);
end;
FillChar(Result.H, (I + 1) * SizeOf(Word), 0);
if ZeroPos < (Length(S) - 1) then
begin
SetLength(A, I + 1);
Start := ZeroPos + 2;
repeat
Index := PosEx(':', SIP, Start);
if Index > 0 then
begin
Count := Index - Start + 1;
SGroup := '$' + Copy(SIP, Start, Count - 1);
if not TryStrToInt(SGroup, G) or (G > High(Word)) or (G < 0) then
IPv6ErrorFmt(SInvalidIPv6Value, S);
A[I] := G;
Inc(Start, Count);
Dec(I);
end;
until Index = 0;
Inc(I);
Count := Length(A) - I;
Move(A[I], Result.H, Count * SizeOf(Word));
end;
end;
procedure DottedQuadNotation;
var
I: T4;
begin
if UpperCase(Copy(S, ZeroPos + 2, 4)) <> 'FFFF' then
IPv6ErrorFmt(SInvalidIPv6Value, S);
FillChar(Result.E, 5 * SizeOf(Word), 0);
Result.F := $FFFF;
SIP := S + '.';
Start := ZeroPos + 7;
for I := Low(T4) to High(T4) do
begin
Index := PosEx('.', SIP, Start);
if Index = 0 then
IPv6ErrorFmt(SInvalidIPv6Value, S);
Count := Index - Start + 1;
SGroup := Copy(SIP, Start, Count - 1);
if not TryStrToInt(SGroup, G) or (G > High(Byte)) or (G < 0) then
IPv6ErrorFmt(SInvalidIPv6Value, S);
case I of
0: Result.G := G shl 8;
1: Inc(Result.G, G);
2: Result.H := G shl 8;
3: Inc(Result.H, G);
end;
Inc(Start, Count);
end;
end;
begin
ZeroPos := Pos('::', S);
if ZeroPos = 0 then
NormalNotation
else
begin
DotPos := Pos('.', S);
if DotPos = 0 then
CompressedNotation
else
DottedQuadNotation;
end;
end;
For Q1 to Q3 you have to derive some routines yourself, but that should not be any problem.
1) For those interested, it's this slider control and this topic served as initiation of this unit.

I have already written all the functions you require but I'm afraid I'm not in a position to share the code.
However, the Synapse library contains quite a few functions in the synaip unit. e.g.
function IsIP(const Value: string): Boolean;
function IsIP6(const Value: string): Boolean;
function IPToID(Host: string): Ansistring;
function StrToIp6(value: string): TIp6Bytes;
function Ip6ToStr(value: TIp6Bytes): string;
function StrToIp(value: string): integer;
function IpToStr(value: integer): string;
function ReverseIP(Value: AnsiString): AnsiString;
function ReverseIP6(Value: AnsiString): AnsiString;
When I tried the functions a few years ago, the IPv6 functions were a bit buggy, especially when dealing with compressed IPv6 addresses.
If you want to roll your own, here a few pointers:
Manipulating IPv4 addresses is fairly simple as they only consist of
32 bits which can be stored in a standard integer type. IPv6
addresses are harder as they need 128 bits and no native type has
that many bits.
Before trying to manipulate an IP address, first convert it into an
integer (IPv4 only of course, IPv6 will require a different storage
method). To do this, split the IP address using '.' as a delimiter.
Check each individual value only contains numbers and falls between 0
and 255 then use these values to generate the final integer.
Once the IP address has been converted into an integer, you can
manipulate it however you like. For example, given an IP address and
a subnet mask you can find the subnet that the IP address belongs to
e.g. IPtoInt(IPAddress) AND NOT(IPToInt(SubnetMask)) = The integer of
the subnet. Now, you can comaare an integer IP address to the integer
subnet to see if the IP falls within the subnet.
Finally, convert the integer IP address back into a string.
If you have any specific questions I can try to answer them too.

Related

Delphi (10.2): fast Integer conversion to string with separator

Let's say we have this Integer 1234567890, we want it converted to a string with a separator = 1.234.567.890, we could do Format('%n',[1234567890.0]); but it's very slow. I wrote a function to speed it up considerably (more than 2x faster). How could I improve it further, or can you come up with a faster routine?
function MyConvertDecToStrWithDot(Const n: UInt64): string;
Var a,b,x: Integer;
z,step: Integer;
l: SmallInt;
begin
Result := IntToStr(n);
if n < 1000 then Exit;
l := Length(Result);
a := l div 3;
b := l mod 3;
step := b+1;
z := 4;
if b <> 0 then begin
Insert('.',Result,step);
Inc(z,step);
end;
for x := 1 to (a-1) do begin
Insert('.',Result,z);
Inc(z,4);
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
Var a: Integer;
s: string;
begin
PerfTimerInit;
for a := 1 to 1000000 do
s := MyConvertDecToStrWithDot(1234567890);
Memo1.lines.Add(PerfTimerStopMS.ToString);
caption := s;
end;
32-bit
Format: ~230ms
My function: ~79ms
64-bit
Format: ~440ms
My function: ~103ms
In my tests, the following is ever so slightly faster:
function ThousandsSepStringOf(Num: UInt64): string;
const
MaxChar = 30; // Probably, 26 is enough: 19 digits + 7 separators
var
Count: Integer;
Rem: UInt64;
Res: array[0..MaxChar] of Char;
WritePtr: PChar;
begin
WritePtr := #Res[MaxChar];
WritePtr^ := #0;
Count := 0;
while Num > 0 do
begin
DivMod(Num, 10, Num, Rem);
Dec(WritePtr);
WritePtr^ := Char(Byte(Rem) + Ord('0'));
Inc(Count);
if Count = 3 then
begin
Dec(WritePtr);
WritePtr^ := '.';
Count := 0;
end;
end;
if WritePtr^ = '.' then
Inc(WritePtr);
Count := MaxChar - ((NativeInt(WritePtr) - NativeInt(#Res)) shr 1);
SetLength(Result, Count);
Move(WritePtr^, PByte(Result)^, Count * SizeOf(Char));
end;
Tested with:
procedure TestHisCode;
Var
a: Integer;
s: string;
SW: TStopwatch;
begin
Writeln('His code');
SW := TStopwatch.StartNew;
for a := 1 to KLoops do
s := MyConvertDecToStrWithDot(1234567890);
Writeln(SW.ElapsedMilliseconds);
Writeln(s);
Writeln;
end;
procedure TestMyCode;
Var
a: Integer;
s: string;
SW: TStopwatch;
begin
Writeln('My code');
SW := TStopwatch.StartNew;
for a := 1 to KLoops do
s := ThousandsSepStringOf(1234567890);
Writeln(SW.ElapsedMilliseconds);
Writeln(s);
Writeln;
end;
and:
TestHisCode;
TestMyCode;
TestMyCode;
TestHisCode;
TestMyCode;
TestHisCode;
TestHisCode;
TestMyCode;
Haven't properly tested the performance of this, however it should be cross-platform and locale independent:
function Thousands(const ASource: string): string;
var
I, LLast: Integer;
begin
Result := ASource;
LLast := Length(Result);
I := LLast;
while I > 0 do
begin
if (LLast - I + 1) mod 3 = 0 then
begin
Insert(FormatSettings.ThousandSeparator, Result, I);
Dec(I, 2);
end
else
Dec(I);
end;
end;
Note: It obviously just works on integers
It's better to insert the separators directly while constructing the string instead of inserting separators later into the converted string because each insertion involves a lot of data movements and performance degradation. Besides avoid the division by 3 may improve performance a bit
This is what I get from my rusty Pascal after decades not using it
uses strutils;
function FormatNumber(n: integer): string;
var digit: integer;
count: integer;
isNegative: boolean;
begin
isNegative := (n < 0);
if isNegative then n := -n;
Result := '';
count := 3;
while n <> 0 do begin
digit := n mod 10;
n := n div 10;
if count = 0 then begin
Result := Result + '.';
count := 3;
end;
Result := Result + chr(ord('0') + digit);
dec(count);
end;
if isNegative then Result := Result + '-';
Result := reversestring(Result);
end;
See it in action: http://ideone.com/6O3e8w
It's also faster to just assign the characters directly instead of using concatenation operator/function like Victoria suggested. This is the improved version with only unsigned types
type string28 = string[28];
function FormatNumber(n: UInt64): string28;
var digit: integer;
length: integer;
count: integer;
c: char;
begin
count := 3;
length := 0;
while n <> 0 do begin
digit := n mod 10;
n := n div 10;
if count = 0 then begin
inc(length);
Result[length] := '.';
count := 3;
end;
inc(length);
Result[length] := chr(ord('0') + digit);
dec(count);
end;
for count := 1 to (length + 1) div 2 do begin
c := Result[count];
Result[count] := Result[length - count + 1];
Result[length - count + 1] := c;
end;
setlength(Result, length);
FormatNumber := Result;
end;
If the operation is done millions of times and is really a bottleneck after profiling, it's better to do in multiple threads along with SIMD

How to remove repeated spaces from a string

I need to remove repeated spaces from a string.
The following code, grabbed from internet, works decently except that it duplicate the first char of the string.
Also maybe there is something faster that this.
function DeleteRepeatedSpaces(OldText: string): string;
var
i: integer;
s: string;
begin
if length(OldText) > 0 then
s := OldText[1]
else
s := '';
for i := 1 to length(OldText) do
begin
if OldText[i] = ' ' then
begin
if not (OldText[i - 1] = ' ') then
s := s + ' ';
end
else
begin
s := s + OldText[i];
end;
end;
DelDoubleSpaces := s;
end;
Function based on the simplest state machine (DFA). Minimum of memory reallocations.
State is number of continuous spaces.
J is count of deleted spaces.
function DeleteRepeatedSpaces(const s: string): string;
var
i, j, State: Integer;
begin
SetLength(Result, Length(s));
j := 0;
State := 0;
for i := 1 to Length(s) do begin
if s[i] = ' ' then
Inc(State)
else
State := 0;
if State < 2 then
Result[i - j] := s[i]
else
Inc(j);
end;
if j > 0 then
SetLength(Result, Length(s) - j);
end;
Iterate all members of the string, move the characters to the Result, but skip repeated spaces.
function DeleteRepeatedSpaces(const OldText: string): string;
var
i,j,hi: Integer;
begin
SetLength(Result,Length(OldText));
i := Low(OldText);
j := i;
hi := High(OldText);
while (i <= hi) do begin
Result[j] := OldText[i];
Inc(j);
if (OldText[i] = ' ') then begin
repeat //Skip additional spaces
Inc(i);
until (i > hi) or (OldText[i] <> ' ');
end
else
Inc(i);
end;
SetLength(Result,j-Low(Result)); // Set correct length
end;
The above code is rather fast (faster than any other contribution, so far).
Below is an even more optimized routine:
function DeleteRepeatedSpaces(const OldText: string): string;
var
pO,pR: PChar;
begin
SetLength(Result,Length(OldText));
pR := Pointer(Result);
pO := Pointer(OldText);
while (pO^ <> '') do begin
pR^ := pO^;
Inc(pR);
if (pO^ <> ' ') then begin
Inc(pO);
Continue;
end;
repeat // Skip additional spaces
Inc(pO);
until (pO^ = '') or (pO^ <> ' ');
end;
SetLength(Result,pR-Pointer(Result));
end;
The following isn't wildly efficient, but possibly more so that processiing the string character by character because it doesn't require a new string allocation for each character in the output:
function RemoveDupSpaces(const Input : String) : String;
var
P : Integer;
begin
Result := Input;
repeat
P := Pos(' ', Result); // that's two spaces
if P > 0 then
Delete(Result, P + 1, 1);
until P = 0;
end;
You can use something like this:
function DeleteRepeatedSpaces(const s: string):string;
var
i:integer;
begin
Result := '';
for i := 1 to Length(S) do begin
if not ((s[i]=' ') and (s[i-1]=' ')) then begin
Result := Result + s[i];
end;
end;
end;
Delete two o more spaces contiguous in a string.
This string (without spaces):
The string have groups of spaces inside
return this:
The string have groups of spaces inside
This string (with spaces groups inside):
The string have groups of spaces inside
Return this:
The string have groups of spaces inside

Delphi 2007 AsyncMultiSync Does not work

I have tried to write a parallel threading example using AsyncCalls and the following is to parallel compute the number of prime numbers
program Project3;
{$APPTYPE CONSOLE}
uses
SysUtils,
Math,
Windows,
AsyncCalls in 'AsyncCalls.pas';
const
N = 1000000;
MAXT = 100;
var
threads : array of IAsyncCall;
ans: array of integer;
cnt: DWORD;
i, v, j, k, portion: integer;
function IsPrime(x: integer): boolean;
var
i: integer;
begin
if (x <= 1) then
begin
Result := False;
Exit;
end;
if (x = 2) then
begin
Result := True;
Exit;
end;
for i:= 2 to Ceil(Sqrt(x))do
begin
if (x mod i = 0) then
begin
Result := False;
Exit;
end;
end;
Result := True;
end;
procedure DoWork(left, right: integer; value: PInteger); cdecl;
var
i, cnt: integer;
begin
cnt := 0;
for i := left to right do
begin
if (IsPrime(i)) then
begin
Inc(cnt);
end;
end;
value^ := cnt;
end;
begin
// Paralell
cnt := GetTickCount;
SetLength(ans, MAXT);
SetLength(threads, MAXT);
portion := N div MAXT;
for i := 0 to MAXT - 2 do
begin
// left index
j := i * portion;
// right index
k := (i + 1) * portion - 1;
threads[i] := AsyncCall(#DoWork, [j, k, #ans[i]]);
end;
// last thread
j := (MAXT - 1) * portion;
threads[MAXT - 1] := AsyncCall(#DoWork, [j, N - 1, #ans[MAXT - 1]]);
// Join, doesn't seem to wait all
AsyncMultiSync(threads, True, INFINITE);
// ****Adding a delay to wait for all threads*****
// Sleep(1000);
// Sum the answer
v := 0;
for i := 0 to MAXT - 1 do
begin
Inc(v, ans[i]);
end;
Writeln('Parallel = ', GetTickCount - cnt);
Writeln('Answer = ', v);
// Serial
cnt := GetTickCount;
DoWork(0, N - 1, #v);
Writeln('Serial = ', GetTickCount - cnt);
Writeln('Answer = ', v);
Readln;
end.
Strange behaviour. The AsyncMultiSync does not seem waiting at all. If I do not add Sleep(1000), the output is
Parallel = 172
Answer = 0
Serial = 453
Answer = 78498
If I add Sleep(1000), the output is correct:
Parallel = 1188
Answer = 78498
Serial = 265
Answer = 78498
I tried using threads[i].Sync, and it produces similar results.
Did I miss something here?
The environment is D2007, Windows 10 64-bit Home
Documentation says not to exceed the maximum number of wait objects, 61.
So you will have to reduce the MaxT constant.

Best way to replace every third character in a string in delphi

What's the most efficient way to replace every third character of the same type in a string?
I have a string like this:
str := 'c1'#9'c2'#9'c3'#9'c4'#9'c5'#9'c6'#9'
I want to replace every third #9 by #13#10, so that i get:
str1 := 'c1'#9'c2'#9'c3'#13#10'c4'#9'c5'#9'c6'#13#10'
I would do this in this way:
i:=0;
newStr:='';
lastPos := Pos(str,#9);
while lastPos > 0 do begin
if i mod 3 = 2 then begin
newStr := newStr + Copy(str,1,lastPos-1) + #13#10;
end else begin
newStr := newStr + Copy(str,1,lastPos);
end;
str := Copy(str,lastPos+1,MaxInt);
i := i + 1;
lastPos := Pos(str,#9);
end;
newStr := Copy(str,1,MaxInt);
But thats a lot of copying. Is there a string manipulation function to do this?
I think the problem as stated doesn't match the code you provided. Is every third character a #9? If so, do you want to change every third appearance of #9 for #13#10?
If so, I would do it this way:
function test(str: string): string;
var
i, c, l: integer;
begin
l := Length(str);
SetLength(Result, l + l div 9);
c := 1;
for i := 1 to l do
begin
if (i mod 9 = 0) and (i > 0) then
begin
Result[c] := #13;
Inc(c);
Result[c] := #10;
end
else
Result[c] := str[i];
Inc(c);
end;
end;
I actually have no idea if this function performs well. But given that the constraints aren't clear, I guess so.
If the position of the #9 character is unknown then this solution won't work at all.
Edit: as David points out, this is not nearly equivalent to the original code posted. This seems to work, but it requires two passes on the original string. The thing is, to know if its more efficient or not we need to know more about the input and context.
function OccurrencesOfChar(const S: string; const C: char): integer;
var
i: integer;
begin
result := 0;
for i := 1 to Length(S) do
if S[i] = C then
inc(result);
end;
function Test(str: string): string;
var
len, n, C, i: integer;
begin
C := 1;
len := Length(str);
n := OccurrencesOfChar(str, #9);
SetLength(result, len + n div 3);
n := 1;
for i := 1 to len do
begin
if str[i] = #9 then
begin
if n mod 3 = 0 then
begin
result[C] := #13;
inc(C);
result[C] := #10;
end
else
result[C] := #9;
Inc(n);
end
else
result[C] := str[i];
inc(C);
end;
end;
I expect this question will be closed, but just for fun, that would be my proposal.
Function Replace(const Instr:String;Re:Char;const ReWith:String):String;
var
i,o,cnt,l:Integer;
begin
cnt:=0;
o:=0;
SetLength(Result,Length(Instr)*Length(ReWith));// just for security
for I := 1 to Length(Instr) do
begin
if Instr[i]=Re then inc(cnt);
if cnt=3 then
begin
for l := 1 to Length(ReWith) do
begin
inc(o);
Result[o] := ReWith[l];
end;
cnt := 0;
end
else
begin
inc(o);
Result[o] := Instr[i];
end;
end;
SetLength(Result,o);
end;
procedure TForm3.Button1Click(Sender: TObject);
begin
Edit2.Text := Replace(Edit1.Text,'A','xxx')
end;
I would probably do something like this (coded in the browser). It only needs one string resize and should have less movement of data around. I exit when I have made the last replacement or if it didn't need any:
procedure ReplaceXChar(var aStringToReplace: string; const aIteration:
Integer; const aChar: Char; const aReplacement: string);
var
replaceCount: Integer;
cntr: Integer;
outputCntr: Integer;
lengthToReplace: Integer;
begin
// Find the number to replace
replaceCount := 0;
for cntr := 1 to Length(aStringToReplace) do
begin
if aStringToReplace[cntr] = aChar then
Inc(replaceCount);
end;
if replaceCount >= aIteration then
begin
// Now replace them
lengthToReplace := Length(aReplacement);
cntr := Length(aStringToReplace);
SetLength(aStringToReplace, cntr +
(replaceCount div aIteration) * (lengthToReplace - 1));
outputCntr := Length(aStringToReplace);
repeat
if aStringToReplace[cntr] = aChar then
begin
if (replaceCount mod aIteration) = 0 then
begin
Dec(outputCntr, lengthToReplace);
Move(aReplacement[1], aStringToReplace[outputCntr+1],
lengthToReplace * SizeOf(Char));
end
else
begin
aStringToReplace[outputCntr] := aStringToReplace[cntr];
Dec(outputCntr);
end;
Dec(replaceCount);
end
else
begin
aStringToReplace[outputCntr] := aStringToReplace[cntr];
Dec(outputCntr);
end;
Dec(cntr);
until replaceCount = 0;
end;
end;
Usage would be like this:
var
myString: String;
begin
myString := 'c1'#9'c2'#9'c3'#9'c4'#9'c5'#9'c6'#9;
ReplaceXChar(myString, 3, #9, #13#10);
ShowMessage(myString);
end;

How many different letters are in string

I have to write program that counts how many different letters are in string.
For example "abc" will give 3; and "abcabc" will give 3 too, because there are only 3 different letters.
I need to use pascal, but if you can help with code in different languages it would be very nice too.
Here is my code that does not work:
var s:string;
i,j,x,count:integer;
c:char;
begin
clrscr;
Readln(s);
c:=s[1];
x:=1;
Repeat
For i:=1 to (length(s)) do
begin
If (c=s[i]) then
begin
delete(s,i,1);
writeln(s);
end;
end;
c:=s[1];
x:=x+1;
Until length(s)=1;
Writeln(x);
x is the different letter counter;
Maybe my algorythm is very bad.. any ideas? Thank you.
You've got answers on how to do it, here's why your way doesn't work.
First of all intuitively you had a good idea: Start with the first char in the string, count it (you forgot to include the counting code), remove all occurrences of the same char in the string. The idea is inefficient, but it would work. You ran into trouble with this bit of code:
For i:=1 to (length(s)) do
begin
If (c=s[i]) then
begin
delete(s,i,1);
end;
end;
The trouble is, Pascal will take the Length(s) value when it sets up the loop, but your code changes the length of the string by removing chars (using delete(s,i,1)). You'll end up looking at bad memory. The secondary issue is that i is going to advance, it doesn't matter if it matched and removed an char or not. Here's why that's bad.
Index: 12345
String: aabbb
You're going to test for i=1,2,3,4,5, looking for a. When i is 1 you'll find a match, remove the first char, and your string is going to look like this:
Index: 1234
String: abbb
You're now testing with i=2, and it's not a match, because s[2] =b. You just skiped one a, and that given a is going to stay in the array an other round and cause your algorithm to count it twice. The "fixed" algorithm would look like this:
i := 1;
while i <= Length(s) do
if (c=s[i]) then
Delete(s,i,1)
else
Inc(i);
This is different: In the given example, if I found a match at 1, the cursor doesn't advance, so it sees the second a. Also because I'm using a while loop, not a for loop, I can't get in trouble with possible implementation details of the for loop.
Your algorithm has an other problem. After the loop that removes all occurrences of the first char in string you're preparing the next loop using this code:
c:=s[1];
The trouble is, if you feed this algorithm an string of the form aa (length=2, two identical chars), it's going to enter the loop, delete or occurrences of a (those turning s into an EMPTY string) and then attempt to read the first char of the EMPTY string.
One final word: Your algorithm should handle the empty string on input, returning an count=0. Here's the fixed algorithm:
var s:string;
i,count:integer;
c:char;
begin
Readln(s);
count:=0;
while Length(s) > 0 do
begin
Inc(Count);
c := s[1];
i := 1;
while i <= Length(s) do
begin
If (c=s[i]) then
delete(s,i,1)
else
Inc(i);
end;
end;
Writeln(Count);
Readln;
end.
I am a Delphi expert, so I don't quite know how restrictive plain Pascal is. Nevertheless, this is Delphi:
// Returns the number of *distinct* "ANSI" characters in Str
function NumChrs(const Str: AnsiString): integer;
var
counts: array[0..255] of boolean;
i: Integer;
begin
ZeroMemory(#counts[0], sizeof(boolean) * length(counts));
for i := 1 to length(Str) do
counts[ord(Str[i])] := true;
result := 0;
for i := 0 to high(counts) do
if counts[i] then
inc(result);
end;
The first line can be written
for i := 0 to high(counts) do
counts[i] := false;
if you cannot use the Windows API (or the Delphi FillChar function).
If you wish to have Unicode support (as in Delphi 2009+), you can do
// Returns the number of *distinct* Unicode characters in Str
function NumChrs(const Str: string): integer;
const
AllocBy = 1024;
var
FoundCodepoints: array of integer;
i: Integer;
procedure Push(Codepoint: integer);
var
i: Integer;
begin
for i := 0 to result - 1 do
if FoundCodepoints[i] = Codepoint then
Exit;
if length(FoundCodepoints) = result then
SetLength(FoundCodepoints, length(FoundCodepoints) + AllocBy);
FoundCodepoints[result] := Codepoint;
inc(result);
end;
begin
result := 0;
for i := 1 to length(Str) do
Push(ord(Str[i]));
end;
Here's my version. I'm not saying you'll get a great mark in your assignment if you hand this in.
function NumberOfUniqueChars(s: string): Integer;
var
i, j: Integer;
c: char;
begin
for i := 1 to Length(s) do
for j := i+1 to Length(s) do
if s[i]<s[j] then
begin
c := s[i];
s[i] := s[j];
s[j] := c;
end;
Result := 0;
for i := 1 to Length(s) do begin
if (i=1) or (s[i]<>c) then
inc(Result);
c := s[i];
end;
end;
And using a Delphi construct (not efficient, but clean)
function returncount(basestring: String): Integer;
var charstrings: TStringList;
I:Integer;
begin
Result := 0;
charstrings := TStringlist.create;
try
charstrings.CaseSensitive := False;
charstrings.Duplicates := DupIgnore;
for I := 1 to length(basestring) do
charstrings.Add(basestring[i]);
Result := charstrings.Count;
finally
charstrings.free;
end;
end;
Different languages are ok?
RUBY:
s = "abcabc"
=> "abcabc"
m = s.split(//)
=> ["a", "b", "c", "a", "b", "c"]
p = m & m
=> ["a", "b", "c"]
p.count
=> 3
A Delphi version. Same idea as #The Communist Duck Python version.
function GetNumChars(Str: string): Integer;
var
s: string;
c: Char;
begin
s := '';
for c in Str do
begin
if Pos(c, s) = 0 then
begin
s := s + c;
end;
end;
Result := Length(s);
end;
Just tossing in a set-alternative...
program CountUniqueChars;
{$APPTYPE CONSOLE}
uses
SysUtils;
var
InputStr: String;
CountedChr: Set of Char;
TotalCount: Integer;
I: Integer;
begin
Write('Text: ');
ReadLn(InputStr);
CountedChr := [];
TotalCount := 0;
for I := 1 to Length(InputStr) do
begin
Write('Checking: ' + InputStr[i]);
if (InputStr[i] in CountedChr)
then WriteLn(' --')
else begin
Include(CountedChr, InputStr[i]);
Inc(TotalCount);
WriteLn(' +1')
end;
end;
WriteLn('Unique chars: ' + IntToStr(TotalCount));
ReadLn;
end.
In Python, with explanation if you want it for any other language: (Since you wanted different languages)
s = 'aahdhdfrhr' #s is the string
l = [] #l is an empty list of some kind.
for i in s: #Iterate through the string
if i not in l: #If the list does not contain the character
l.append(i) #Add the character to the list
print len(l) #Print the number of characters in the list
function CountChars(const S:AnsiString):Integer;
var C:AnsiChar; CS:Set of AnsiChar;
begin
Result := 0;
CS := [];
for C in S do
if not (C in CS) then
begin
CS := CS + [C];
Inc(Result);
end;
end;

Resources