Related
To take an example, lets say I would like to write a simple procedure that deletes the 'X' characters from a string.
How can I design my procedure so that it works for both string and PCHAR parameters.
If I define it as:
procedure RemoveX( source : PCHAR);
than calls to RemoveX(PCHAR(mystring)) where myString is a string will remove the 'X' but will not take care of updating the string length ... Hence a subsequent myString := myString + 'done' will leave myString unchanged. And I don't want to change the length after the call to RemoveX, I expect the RemoveX procedure to deal with everything.
If on the other hand I define it as:
procedure RemoveX( var source : string);
I don't know how to pass it a PCHAR ...
I would not suggest implementing the string version in terms of the PChar version, or vice versa. I would keep them separate so that you can tailor them independently, eg:
procedure RemoveX(source : PChar); overload;
procedure RemoveX(var source : string); overload;
procedure RemoveX(source : PChar);
var
P: PChar;
Len: Integer;
begin
if source = nil then Exit;
Len := StrLen(source);
repeat
P := StrScan(source, 'X');
if P = nil then Exit;
StrMove(P, P+1, Len - Integer(P-source));
Dec(Len);
source := P;
until False;
end;
procedure RemoveX(var source : string);
begin
source := StringReplace(source, 'X', '', [rfReplaceAll]);
end;
Update: If you really want to use a single implementation for both PChar and String inputs then you can do something like this:
function RemoveX(source : PChar; sourceLen: Integer): Integer; overload;
procedure RemoveX(source : PChar); overload;
procedure RemoveX(var source : string); overload;
function RemoveX(source : PChar; sourceLen: Integer): Integer;
var
P: PChar;
begin
Result := 0;
if (source = nil) or (sourceLen = 0) then Exit;
repeat
P := StrScan(source, 'X');
if P = nil then Exit;
StrMove(P, P+1, sourceLen - Integer(P-source));
Dec(sourceLen);
source := P;
until False;
Result := sourceLen;
end;
procedure RemoveX(source : PChar);
begin
RemoveX(source, StrLen(source));
end;
procedure RemoveX(var source : string);
begin
UniqueString(source);
SetLength(source, RemoveX(PChar(source), Length(source)));
end;
You cannot implement this using a single parameter. You have two different types.
You could build the string version on top of a PChar version.
procedure RemoveX(var str: string);
var
P: PChar;
begin
UniqueString(str);
P := PChar(str);
RemoveX(P);
str := P;
end;
An alternative for final line could be:
SetLength(str, StrLen(P));
Either way, this obviously assumes that you already have a functioning overload that operates on PChar. And that the function removes characters. Clearly it cannot extend the PChar buffer.
The call to UniqueString is needed in case the string is shared (ref count greater than one) or constant. After this call the string buffer is editable and not shared.
Whether or not avoiding duplication of implementation in this way is the best approach I cannot say. It depends on your design drivers. If simplicity and clarity of code is key, then avoiding duplication makes sense. If performance is key then it may be desirable to provide two bespoke implementations.
This question is unlikely to help any future visitors; it is only relevant to a small geographic area, a specific moment in time, or an extraordinarily narrow situation that is not generally applicable to the worldwide audience of the internet. For help making this question more broadly applicable, visit the help center.
Closed 10 years ago.
I programmed a Turing machine in Pascal using the Free Pascal compiler version 2.6.0 on a Windows Vista laptop. After compiling and testing the results, I used the 'heaptrc' unit to detect some memory leaks. Unfortunately, the program found several ones, which I was not able to fix.
I already looked for solutions via Google and Stack Overflow. There I found constructs like 'try finally' which I used in the program. I reset all dynamic arrays to size of zero to be sure, they are cleaned up. These measures solved some memory leaks, but eight unfreed memory blocks remained.
Then I asked for help in a German Delphi forum, where I got some help, which sadly did not help. For those of you, who understand German, it is in Free Pascal 2.6.0. Memory Leak in Turingmaschine.
The basic way the program works, is, that the instruction table is created and filled by reading a .txt file. Then the user is asked for the initial data of the tape. In the following loop, the data is changed according to the instruction table until the machine is halted.
Then everything should be cleaned up, but this does not seem to work correctly. If I run the program in a debugger, the program ends with the exitcode '01', which, according to documentation, means 'Invalid function number An invalid operating system call was attempted.'. But that did not help very much either.
If I understand the 'try finally' structure correctly, 'Machine.Free' should be called and executed no matter what happens, so everything should be cleaned up correctly. I learned programming pretty much by trial and error, so I would really like to know, why things do not work correctly, and not just a solution.
Of course I am willing to change my code, if there is some serious design flaw. These are the source code files. The output of 'heaptrc' is in 'memory.txt':
turing.pas
{turing.pas}
{Program to imitate a Turing machine, based on the principles by Alan Turing.}
program Turing;
{$mode objfpc}{$H+}
uses
sysutils, {Used for the conversion from Integer to String.}
TuringHead, {Unit for the head instructions.}
TuringTable; {Unit for the instruction table.}
type
{Declarations of self made types}
TField = Array of Char;
{Class declarations}
TMachine = class(TObject)
private
Tape: TField; {The tape, from which data is read or on which data is written.}
TapeSize: Integer; {The length of the tape at the start of the machine.}
Head: THead; {The head, which reads, writes and moves. Look in "turinghead.pas" to see, how it works.}
InstructionTable: TInstructionTable; {The table, which contains the instructions for the machine. Look in "turingtable.pas" to see, how it works.}
ConstantOutput: Boolean; {If its value is "True", there will be constant output.
It is adjustable for performance, because the machine is much slower when it has to output data all the time.}
procedure GetSettings(); {Ask the user for different settings.}
procedure GetInput(); {Read the input from the user.}
procedure TapeResize(OldSize: Integer; Direction: Char); {Expand the tape and initialize a new element.}
procedure TapeCopy(); {Copies the elements of the array to the right.}
procedure Display(State: Char; ReadData: Char; WriteData: Char; MoveInstruction: Char; HeadPosition: Integer); {Display the machines current status.}
public
constructor Create(); {Prepare the machine.}
procedure Run(); {Run the machine.}
destructor Destroy(); Override;{Free all objects, the machine uses.}
protected
published
end;
var
Machine: TMachine;
procedure TMachine.GetSettings();
var
OutputType: Char;
begin
WriteLn('If you want constant output, please type "y", if not, please type "n"!');
ReadLn(OutputType);
case OutputType of
'n': ConstantOutput := False;
'y': ConstantOutput := True
end;
WriteLn('Please input the start tape length! It will expand automatically, if it overflows.');
ReadLn(TapeSize);
if TapeSize > 0 then {Test, if the input makes sense, to prevent errors.}
SetLength(Tape, TapeSize)
else
begin
WriteLn('Please input a length greater than zero!');
GetSettings()
end
end;
procedure TMachine.GetInput();
var
UserInput: String;
Data: Char;
HeadPosition: Integer;
begin
WriteLn('Please input the data for the tape!');
SetLength(UserInput, TapeSize);
ReadLn(UserInput);
if UserInput[TapeSize] <> '' then
begin
HeadPosition := 0;
while HeadPosition < TapeSize do
begin
Data := UserInput[HeadPosition + 1]; {The data is stored one place ahead of the current head position.}
Head.WriteData(Tape, HeadPosition, Data);
HeadPosition := Head.Move(HeadPosition, 'R')
end;
WriteLn('Thank you, these are the steps of the machine:')
end
else
begin
WriteLn('Please fill the whole tape with data!');
GetInput()
end
end;
procedure TMachine.TapeResize(OldSize: Integer; Direction: Char);
var
NewSize: Integer;
begin
case Direction of
'L': begin
NewSize := OldSize + 1;
SetLength(Tape, NewSize);
TapeCopy(); {Copy the elements of the array, to make space for the new element.}
Head.WriteData(Tape, Low(Tape), '0') {Initialize the new tape element with the empty data.}
end;
'R': begin
NewSize := OldSize + 1;
SetLength(Tape, NewSize);
Head.WriteData(Tape, High(Tape), '0') {Initialize the new tape element with the empty data.}
end
end
end;
procedure TMachine.TapeCopy();
var
Counter: Integer;
begin
Counter := High(Tape);
while Counter > 0 do
begin
Tape[Counter] := Tape[Counter - 1];
Dec(Counter, 1)
end
end;
procedure TMachine.Display(State: Char; ReadData: Char; WriteData: Char; MoveInstruction: Char; HeadPosition: Integer);
var
DispHead: Integer;
begin
DispHead := 0;
while DispHead < Length(Tape) do {Write the data on the tape to the output.}
begin
Write(Tape[DispHead]);
DispHead := Head.Move(DispHead, 'R');
end;
Write(' State: ' + State + ' Read: ' + ReadData + ' Write: ' + WriteData +
' Move: ' + MoveInstruction + ' Head: ' + IntToStr(HeadPosition + 1)); {Constructed string to write information about the machine.}
WriteLn('')
end;
constructor TMachine.Create();
begin
inherited;
Head := THead.Create();
InstructionTable := TInstructionTable.Create();
GetSettings();
GetInput()
end; {TMachine.Initialize}
procedure TMachine.Run();
var
TapeData: Char;
WriteData: Char;
StateRegister: Char;
MoveInstruction: Char;
HeadPosition: Integer;
Running: Boolean;
begin
if TapeSize > 1 then
HeadPosition := (Length(Tape) div 2) - 1 {The head starts in the middle of the tape.}
else
HeadPosition := 0;
StateRegister := 'A'; {This is the start register.}
Running := True;
while Running do
begin
{Get instructions for the machine.}
TapeData := Head.ReadData(Tape, HeadPosition);
WriteData := InstructionTable.GetData(StateRegister, TapeData, 'W');
MoveInstruction := InstructionTable.GetData(StateRegister, TapeData, 'M');
if ConstantOutput then
Display(StateRegister, TapeData, WriteData, MoveInstruction, HeadPosition);
Head.WriteData(Tape, HeadPosition, WriteData);
case MoveInstruction of {Depending on the instructions, move the head.}
'S': HeadPosition := Head.Move(HeadPosition, 'S');
'L': HeadPosition := Head.Move(HeadPosition, 'L');
'R': HeadPosition := Head.Move(HeadPosition, 'R')
end;
if HeadPosition > High(Tape) then
TapeResize(Length(Tape), 'R');
if HeadPosition < Low(Tape) then {If the head is farther to the left, than the tape is long, create a new field on the tape.}
begin
TapeResize(Length(Tape), 'L');
HeadPosition := 0
end;
{Get the next state of the machine.}
StateRegister := InstructionTable.GetData(StateRegister, TapeData, 'N');
if StateRegister = 'H' then {This is the halting register.}
begin
Display(StateRegister, TapeData, WriteData, MoveInstruction, HeadPosition);
Running := Head.Halt()
end
end
end; {TMachine.Run}
destructor TMachine.Destroy();
begin
Head.Free;
InstructionTable.Free;
SetLength(Tape, 0);
WriteLn('The turing machine stopped. You can end the program by pressing enter.');
inherited
end; {TMachine.Stop}
{Implementation of the main program.}
begin
Machine := TMachine.Create();
try
Machine.Run()
finally
Machine.Free
end;
ReadLn()
end. {Turing}
turinghead.pas
{turinghead.pas}
{Unit for the head of the turing machine.}
unit TuringHead;
{$mode objfpc}{$H+}
interface
type
THead = class(TObject)
private
function Stay(HeadPos: Integer): Integer; {Head does not move.}
function MoveLeft(HeadPos: Integer): Integer; {Head moves leftwards.}
function MoveRight(HeadPos: Integer): Integer; {Head moves rightwards.}
public
function Move(HeadPos: Integer; Direction: Char): Integer; {Public function, which calls 'Stay' or 'MoveLeft/Right'.}
function ReadData(Tape: Array of Char; HeadPos: Integer): Char; {Reads data from the tape.}
procedure WriteData(var Tape: Array of Char; HeadPos: Integer; Data: Char); {Writes data onto the tape.}
function Halt(): Boolean; {Commands the head to stop moving.}
protected
published
end;
implementation
function THead.Move(HeadPos: Integer; Direction: Char): Integer;
var
NextPos: Integer;
begin
case Direction of {Used this way, so only one function has to be public, not three.}
'S': NextPos := Stay(HeadPos);
'L': NextPos := MoveLeft(HeadPos);
'R': NextPos := MoveRight(HeadPos)
end;
Move := NextPos
end; {THead.Move}
function THead.ReadData(Tape: Array of Char; HeadPos: Integer): Char;
var
Data: Char;
begin
Data := Tape[HeadPos];
ReadData := Data
end; {THead.ReadData}
procedure THead.WriteData(var Tape: Array of Char; HeadPos: Integer; Data: Char);
begin
Tape[HeadPos] := Data
end; {THead.WriteData}
function THead.Stay(HeadPos: Integer): Integer;
var
NextPosition: Integer;
begin
NextPosition := HeadPos;
Stay := NextPosition
end; {THead.Stay}
function THead.MoveLeft(HeadPos: Integer): Integer;
var
NextPosition: Integer;
begin
NextPosition := HeadPos - 1;
MoveLeft := NextPosition
end; {THead.MovetLeft}
function THead.MoveRight(HeadPos: Integer): Integer;
var
NextPosition: Integer;
begin
NextPosition := HeadPos + 1;
MoveRight := NextPosition
end; {THead.MoveRight}
function THead.Halt(): Boolean;
begin
Halt := False
end; {THead.Halt}
begin
end.
turingtable.pas
{turingtable.pas}
{Unit for creating and accessing the instruction table.}
unit TuringTable;
{$mode objfpc}{$H+}
interface
const
TupelLength = 5; {The amount of characters, each tupel has.}
type
{Declarations of self made types}
TTextFile = TextFile;
TDataString = Array of String[TupelLength]; {Every tupel has its own data string.}
TDataTable = record {The type of the record, which is used to look up the instructions for the machine.}
State: Array of Char; {The current state of the machine.}
Read: Array of Char; {The read data.}
Write: Array of Char; {The data, which has to be written onto the tape.}
Move: Array of Char; {The movement instruction for the head.}
Next: Array of Char {The next state of the machine.}
end;
{Class declarations}
TInstructionTable = class(TObject)
private
TupelNumber: Word; {The number of seperate tupels, which are defined in the text file.}
DataString: TDataString; {The strings, that have all the tupels.}
DataTable: TDataTable;
procedure FileRead();
procedure ArrayResize(Size: Word); {Resizes all arrays, so they are only as big, as they have to be.}
procedure TableFill(); {Fills the data table with data from the data string.}
function GetWrite(CurrentState: Char; ReadData: Char): Char; {Functions, which return the wanted instruction from the table.}
function GetMove(CurrentState: Char; ReadData: Char): Char;
function GetNext(CurrentState: Char; ReadData: Char): Char;
public
constructor Create(); {Creates the data table, so it can be used.}
function GetData(CurrentState: Char; ReadData: Char; DataType: Char): Char; {Public function to get instructions.}
destructor Destroy(); Override;
protected
published
end;
implementation
procedure TInstructionTable.FileRead();
const
FileName = 'turingtable.txt'; {The text file, that contains the instructions.}
var
Text: String[TupelLength]; {The read text, which is just one unorganised string.}
CurrentTupel: Word; {Keeps track of the tupels.}
DataFile: TTextFile;
begin
SetLength(DataString, 256); {Make the array pretty big, so it gives enough space.}
CurrentTupel := 0;
Assign(DataFile, FileName); {Open the file.}
Reset(DataFile);
while not eof(DataFile) do {As long, as the procedure did not reach the end of the text file, it shall proceed.}
begin
ReadLn(DataFile, Text);
if Text[1] <> '/' then {If the line starts with an '/', it is a comment and thus not necessary for the program.}
begin
DataString[CurrentTupel] := Text; {Fill the data string.}
inc(CurrentTupel, 1)
end
end;
ArrayResize(CurrentTupel);
TupelNumber := CurrentTupel; {This is the maximum amount of tupels.}
Close(DataFile)
end; {TinstructionTable.FileRead}
procedure TInstructionTable.ArrayResize(Size: Word);
begin
SetLength(DataString, Size);
SetLength(DataTable.State, Size);
SetLength(DataTable.Read, Size);
SetLength(DataTable.Write, Size);
SetLength(DataTable.Move, Size);
SetLength(DataTable.Next, Size)
end; {TInstructionTable.ArrayResize}
procedure TInstructionTable.TableFill();
var
Position: Word;
CurrentTupel: Word;
begin
Position := 1;
CurrentTupel := 0;
while CurrentTupel <= TupelNumber do {Fill the record for each tupel.}
begin
while Position <= TupelLength do {Each tupel has a certain instruction at the same place, so the record is filled in a certain way.}
begin
case Position of
1: DataTable.State[CurrentTupel] := DataString[CurrentTupel][Position];
2: DataTable.Read[CurrentTupel] := DataString[CurrentTupel][Position];
3: DataTable.Write[CurrentTupel] := DataString[CurrentTupel][Position];
4: DataTable.Move[CurrentTupel] := DataString[CurrentTupel][Position];
5: DataTable.Next[CurrentTupel] := DataString[CurrentTupel][Position]
end;
inc(Position, 1)
end;
Position := 1;
inc(CurrentTupel, 1)
end
end; {TInstructionTable.TableFill}
function TInstructionTable.GetWrite(CurrentState: Char; ReadData: Char): Char;
var
Write: Char;
EntryFound: Boolean;
CurrentTupel: Integer;
begin
EntryFound := false;
CurrentTupel := 0;
while not EntryFound do
if (DataTable.State[CurrentTupel] = CurrentState) and (DataTable.Read[CurrentTupel] = ReadData) then {Tests, if the data pair exists in the record.}
EntryFound := True
else
inc(CurrentTupel, 1);
Write := DataTable.Write[CurrentTupel];
GetWrite := Write
end; {TInstructionTable.GetWrite}
function TInstructionTable.GetMove(CurrentState: Char; ReadData: Char): Char;
var
Move: Char;
EntryFound: Boolean;
CurrentTupel: Integer;
begin
EntryFound := false;
CurrentTupel := 0;
while not EntryFound do
if (DataTable.State[CurrentTupel] = CurrentState) and (DataTable.Read[CurrentTupel] = ReadData) then {Tests, if the data pair exists in the record.}
EntryFound := True
else
inc(CurrentTupel, 1);
Move := DataTable.Move[CurrentTupel];
GetMove := Move
end; {TInstructionTable.GetMove}
function TInstructionTable.GetNext(CurrentState: Char; ReadData: Char): Char;
var
Next: Char;
EntryFound: Boolean;
CurrentTupel: Integer;
begin
EntryFound := false;
CurrentTupel := 0;
while not EntryFound do
if (DataTable.State[CurrentTupel] = CurrentState) and (DataTable.Read[CurrentTupel] = ReadData) then {Tests, if the data pair exists in the record.}
EntryFound := True
else
inc(CurrentTupel, 1);
Next := DataTable.Next[CurrentTupel];
GetNext := Next
end; {TInstructionTable.GetNext}
constructor TInstructionTable.Create();
begin
inherited;
FileRead();
TableFill()
end; {TInstructionTable.Initialize}
function TInstructionTable.GetData(CurrentState: Char; ReadData: Char; DataType: Char): Char;
var
Data: Char;
begin
case DataType of {Used this way, so only one public function exists, instead of three.}
'W': Data := GetWrite(CurrentState, ReadData);
'M': Data := GetMove(CurrentState, ReadData);
'N': Data := GetNext(CurrentState, ReadData)
end;
GetData := Data
end; {TInstructionTable.GetData}
destructor TInstructionTable.Destroy();
begin
ArrayResize(0);
inherited
end;
begin
end. {TuringTable}
turingtable.txt
/This is the table for the turing machine.
/Here you can define the instructions for the machine.
/Please use the given format.
/The start state is 'A'.
/Use 'S' for staying, 'L' for moving the head leftwards and 'R' for moving the head rightwards.
/'H' is used to stop the machine.
/The head starts in the middle of the tape.
/If the array is expanded, it is filled with '0'.
/Lines are commented out when they begin with '/'.
/State Read Write Move Next
/Busy beavers taken from en.wikipedia.org
/2-state, 2-symbol busy beaver
/A01LB
/A11RB
/B01RA
/B11LH
/3-state, 2-symbol busy beaver
/A01LB
/A11RC
/B01RA
/B11LB
/C01RB
/C11SH
/4-state, 2-symbol busy beaver
A01LB
A11RB
B01RA
B10RC
C01LH
C11RD
D01LD
D10LA
/5-state, 2-symbol best contender busy beaver
/A01LB
/A11RC
/B01LC
/B11LB
/C01LD
/C10RE
/D01RA
/D11RD
/E01LH
/E10RA
/6-state, 2-symbol best contender busy beaver
/A01LB
/A11RE
/B01LC
/B11LF
/C01RD
/C10LB
/D01LE
/D10RC
/E01RA
/E10LD
/F01RH
/F11LC
memory.txt
C:\Programming_Software\FreePascal\2.6.0\projects\Turing_Machine\memory\turing.exe
Marked memory at $000A5200 invalid
Wrong signature $D4DF2FA1 instead of A76E4766
$0040F85B
$0040F917
$0041550D TINSTRUCTIONTABLE__ARRAYRESIZE, line 76 of turingtable.pas
$004159FD TINSTRUCTIONTABLE__DESTROY, line 180 of turingtable.pas
$00407162
$00407162
$0040C7B1
Heap dump by heaptrc unit
714 memory blocks allocated : 14207/18256
706 memory blocks freed : 14061/18080
8 unfreed memory blocks : 146
True heap size : 458752 (144 used in System startup)
True free heap : 457824
Should be : 457920
Call trace for block $000A53E0 size 22
$004018CF TMACHINE__TAPERESIZE, line 104 of turing.pas
$00401E81 TMACHINE__RUN, line 181 of turing.pas
$0040201D main, line 216 of turing.pas
$0040C7B1
Marked memory at $000A5380 invalid
Wrong signature $B3102445 instead of 3D0C752B
$004106C7
$0040F85B
$0040F917
$0041550D TINSTRUCTIONTABLE__ARRAYRESIZE, line 76 of turingtable.pas
$004159FD TINSTRUCTIONTABLE__DESTROY, line 180 of turingtable.pas
$00407162
$00407162
$0040C7B1
Marked memory at $000A5320 invalid
Wrong signature $FECB68AA instead of D626F67E
$004106C7
$0040F85B
$0040F917
$0041550D TINSTRUCTIONTABLE__ARRAYRESIZE, line 76 of turingtable.pas
$004159FD TINSTRUCTIONTABLE__DESTROY, line 180 of turingtable.pas
$00407162
$00407162
$0040C7B1
Marked memory at $000A52C0 invalid
Wrong signature $E738AA53 instead of AFAF3597
$004106C7
$0040F85B
$0040F917
$0041550D TINSTRUCTIONTABLE__ARRAYRESIZE, line 76 of turingtable.pas
$004159FD TINSTRUCTIONTABLE__DESTROY, line 180 of turingtable.pas
$00407162
$00407162
$0040C7B1
Marked memory at $000A5260 invalid
Wrong signature $CD2CED58 instead of FC317DEE
$004106C7
$0040F85B
$0040F917
$0041550D TINSTRUCTIONTABLE__ARRAYRESIZE, line 76 of turingtable.pas
$004159FD TINSTRUCTIONTABLE__DESTROY, line 180 of turingtable.pas
$00407162
$00407162
$0040C7B1
Marked memory at $000A5200 invalid
Wrong signature $D4DF2FA1 instead of A76E4766
$004106C7
$0040F85B
$0040F917
$0041550D TINSTRUCTIONTABLE__ARRAYRESIZE, line 76 of turingtable.pas
$004159FD TINSTRUCTIONTABLE__DESTROY, line 180 of turingtable.pas
$00407162
$00407162
$0040C7B1
Call trace for block $000AC3C8 size 32
$00401C59 TMACHINE__CREATE, line 141 of turing.pas
$00401FF4 main, line 214 of turing.pas
$0040C7B1
$00610068
$00650072
$005C0064
$00690057
$0064006E
Call trace for block $000A51A0 size 24
$00401FF4
$0040C7B1
$0040C7B1
As said in the comment, your first problem is the "invalid memory". Memory safety only comes when the program is working correctly. Look into the various kinds of checking (range/overflow).
I quickly compiled with range checks (-Cr) and I get this output:
An unhandled exception occurred at $00418609:
ERangeError: Range check error
$00418609 TINSTRUCTIONTABLE__TABLEFILL, line 95 of turingtable.pas
$00418B56 TINSTRUCTIONTABLE__CREATE, line 163 of turingtable.pas
$00401CFA TMACHINE__CREATE, line 140 of turing.pas
$004020AD main, line 211 of turing.pas
My guess is that while fileread initializes the datastring, you don't initialize the datatable, which also holds several dynamic arrays.
If everything fails, you can use Valgrind, but for programs of this size and complexity that is probably overkill.
The lesson to be learned from this question: If an error/exception happens, the normal flow of code is interrupted, and code (including freeing of memory) might not be done and turn up in memory debugging tools. One of the Pascal virtues are the (optional) runtime checks. Use them.
I have a string of delimited text ie:
Value1:Value2:Value3:Value4:Value5:Value6
How would I extract, for example, a specific value Ie:
Label.caption := GetValuefromDelimitedText(2); to get Value2
Thanks in advance
Paul
Something like that - if you like compact code (but not as performant as Davids):
function GetValueFromDelimitedText(const s: string; Separator: char; Index: Integer): string;
var sl : TStringList;
begin
Result := '';
sl := TStringList.Create;
try
sl.Delimiter := Separator;
sl.DelimitedText := s;
if sl.Count > index then
Result := sl[index];
finally
sl.Free;
end;
end;
Hope that helps
This should do it:
function GetValueFromDelimitedText(
const s: string;
const Separator: char;
const Index: Integer
): string;
var
i, ItemIndex, Start: Integer;
begin
ItemIndex := 1;
Start := 1;
for i := 1 to Length(s) do begin
if s[i]=Separator then begin
if ItemIndex=Index then begin
Result := Copy(s, Start, i-Start);
exit;
end;
inc(ItemIndex);
Start := i+1;
end;
end;
if ItemIndex=Index then begin
Result := Copy(s, Start, Length(s)-Start+1);
end else begin
Result := '';
end;
end;
This version allows you to specify the separator, you would obviously pass ':'. If you ask for an item beyond the end then the function will return the empty string. You could change that to an exception if you preferred. Finally, I have arranged that this uses 1-based indexing as per your example, but I personally would choose 0-based indexing.
If using Delphi XE or higher you can also use StrUtils.SplitString like this:
function GetValueFromDelimitedText (const Str: string; Separator: Char; Index: Integer) : string;
begin
Result := SplitString (Str, Separator) [Index];
end;
In production code, you should check that Index is indeed a valid index.
This method returns a TStringDynArray (a dynamic array of strings) so you can also use it like this (using enumerators):
for Str in SplitString (Str, Separator) do
Writeln (Str);
which can be very useful IMHO.
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;
Saving, editing and loading information. The information that I want to load is something I will add myself. Each line of information will contain 4 pieces, (string, integer, string, integer). Via 4 seperate edit boxes and a button I will add this information to a 'database' (not sure if I need a database or if it can be done via something like a Tstringlist). Everytime the button is clicked it will added the content that is typed at that moment in the 'database'.
The only demand of the saved data is when I type the first string from the list it could place the rest of the information that belongs to it in a memobox or edit boxes as well. So I suppose I have to be able to search. Just want to keep it as simple as possible. There will only be about 10 to 15 lines of information. and if possible it would be good if I can load them again a later time.
Here's some very basic code that should get you on your way. There's no error checking, and you'll no doubt want to develop it and modify it further. The point is that there should be some ideas to help you write code that works for you.
Now that I have comma-separated the fields, but made no attempt to handle the appearance of commas in any of the values. If this is a problem then choose a different delimiter, or escape the commas. I had toyed with writing each field on its own line (effectively using a newline as the separator), but this makes the reading code more tricky to write.
Again, the main point is that this is not final production code, but is intended to give you a starting point.
function Split(const s: string; Separator: char): TStringDynArray;
var
i, ItemIndex: Integer;
len: Integer;
SeparatorCount: Integer;
Start: Integer;
begin
len := Length(s);
if len=0 then begin
Result := nil;
exit;
end;
SeparatorCount := 0;
for i := 1 to len do begin
if s[i]=Separator then begin
inc(SeparatorCount);
end;
end;
SetLength(Result, SeparatorCount+1);
ItemIndex := 0;
Start := 1;
for i := 1 to len do begin
if s[i]=Separator then begin
Result[ItemIndex] := Copy(s, Start, i-Start);
inc(ItemIndex);
Start := i+1;
end;
end;
Result[ItemIndex] := Copy(s, Start, len-Start+1);
end;
type
TValue = record
i1, i2: Integer;
s: string;
end;
TMyDict = class(TDictionary<string,TValue>)
public
procedure SaveToFile(const FileName: string);
procedure LoadFromFile(const FileName: string);
end;
{ TMyDict }
procedure TMyDict.SaveToFile(const FileName: string);
var
Strings: TStringList;
Item: TPair<string,TValue>;
begin
Strings := TStringList.Create;
Try
for Item in Self do begin
Strings.Add(Format(
'%s,%s,%d,%d',
[Item.Key, Item.Value.s, Item.Value.i1, Item.Value.i2]
));
end;
Strings.SaveToFile(FileName);
Finally
FreeAndNil(Strings);
End;
end;
procedure TMyDict.LoadFromFile(const FileName: string);
var
Strings: TStringList;
Item: TPair<string,TValue>;
Line: string;
Fields: TStringDynArray;
begin
Strings := TStringList.Create;
Try
Strings.LoadFromFile(FileName);
for Line in Strings do begin
Fields := Split(Line, ',');
Assert(Length(Fields)=4);
Item.Key := Fields[0];
Item.Value.s := Fields[1];
Item.Value.i1 := StrToInt(Fields[2]);
Item.Value.i2 := StrToInt(Fields[3]);
Add(Item.Key, Item.Value);
end;
Finally
FreeAndNil(Strings);
End;
end;
Note that you don't attempt to search the file on disk. You simply load it into memory, into the dictionary and look things up from there.
A dictionary is great when you always use the same key. If you have multiple keys then a dictionary is less convenient, but who cares about the performance impact if you've only got 15 records?!
Disclaimer: I've not run the code, I've not tested it, etc. etc.