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.
Related
Something strange happens when I try to pass strings from the Lines of a TMemo control to an array of PChar. At the end of the routine, the last string in the array is duplicated. I was able to replicate this in this simple code:
procedure Test;
var
i: smallint;
arr: array of PAnsiChar;
strarr: array[0..1] of string;
begin
SetLength(arr, 2);
strarr[0] := 'abbb';
strarr[1] := 'baaa';
for i := 0 to Length(strarr) do
arr[i] := PAnsiChar(AnsiString(strarr[i]));
end;
If I run this procedure step by step, I can see arr[0] = 'abbb' however, at the end of the rutine, both values, arr[0] and arr[1] equal to baaa. I guess it has something to do with the typecast.
Can anyone see what is wrong ?
There are two problems with your code:
Your loop is exceeding the upper bound of the array. It needs to use for i := 0 to Length(strarr)-1 do or for i := 0 to High(strarr) do instead.
More importantly, when you type-cast an AnsiString to a PAnsiChar, it returns a pointer to the AnsiString's internal data if the AnsiString is not empty. You are type-casting a UnicodeString to an AnsiString and grabbing a pointer into it, so the compiler has to use a compiler-generated local variable for the AnsiString data. In other words, your code is effectively doing the same thing as the following:
procedure Test;
var
i: smallint;
arr: array of PAnsiChar;
strarr: array[0..1] of string;
compiler_temp: AnsiString;
begin
SetLength(arr, 2);
strarr[0] := 'abbb';
strarr[1] := 'baaa';
for i := 0 to Length(strarr) do
begin
compiler_temp := AnsiString(strarr[i]);
arr[i] := PAnsiChar(compiler_temp);
end;
end;
Depending on how the memory for compiler_temp gets managed by the RTL memory manager at run-time, it is certainly possible for arr[0] and arr[1] to end up pointing at the same physical memory block in this situation.
If you want an array of PAnsiChar values then you need to start with an array of Ansi data for them to point at:
procedure Test;
var
i: Integer;
arr: array of PAnsiChar;
strarr: array[0..1] of AnsiString;
begin
SetLength(arr, 2);
strarr[0] := 'abbb';
strarr[1] := 'baaa';
for i := 0 to Length(strarr)-1 do
arr[i] := PAnsiChar(strarr[i]);
end;
I have a unit something like this
type
TMyClass = Class(TObject)
private
AnInteger : Integer;
MyThreadHandle : DWORD;
procedure MyPrivateProcedure;
public
procedure MyPublicProcedure;
end;
procedure TMyClass.MyPrivateProcedure;
procedure MyThread; stdcall;
begin
if AnInteger <> 0 then MyPublicProcedure;
end;
var
DummyID: DWORD;
begin
MyThreadHandle := CreateThread(NIL,0,#MyThread,NIL,0, DummyID);
end;
procedure TMyClass.MyPublicProcedure;
begin
AnInteger := 0;
end;
My goal is to have a Thread (no TTthread please.) that can "access" the vars/functions/procedures just like it's part of the class. This Example fails because it doesn't have access to the vars nor to the procedure. This is just an example, I am aware that the Integer can't change just like that. To me it's just important to have a thread that is part of the class. I also tried to pass the integer as a pointer (which worked) to the thread but I still can't access a procedure/function of the class. any ideas?
You can use TThread and keep filesize small. I think you are going into a difficult path: reinvent the wheel is time consuming, I can tell you that! :)
Here is some working code to initialize the thread:
function ThreadProc(Thread: TThread): Integer;
var FreeThread: Boolean;
begin
if not Thread.FTerminated then
try
result := 0; // default ExitCode
try
Thread.Execute;
except
on Exception do
result := -1;
end;
finally
FreeThread := Thread.FFreeOnTerminate;
Thread.FFinished := True;
if Assigned(Thread.OnTerminate) then
Thread.OnTerminate(Thread);
if FreeThread then
Thread.Free;
EndThread(result);
end;
end;
constructor TThread.Create(CreateSuspended: Boolean);
begin
IsMultiThread := true; // for FastMM4 locking, e.g.
inherited Create;
FSuspended := CreateSuspended;
FCreateSuspended := CreateSuspended;
FHandle := BeginThread(nil, 0, #ThreadProc, Pointer(Self), CREATE_SUSPENDED, FThreadID);
if FHandle = 0 then
raise Exception.Create(SysErrorMessage(GetLastError));
SetThreadPriority(FHandle, THREAD_PRIORITY_NORMAL);
end;
That is, you pass the object as pointer() to the thread creation API, which will be passed as the unique parameter of the ThreadProc.
The ThreadProc should NOT be part of any method, but global to the unit.
Here is another piece of code directly calling the APIs to handle multi-thread compression, with no overhead, and synchronization:
type
TThreadParams = record
bIn, bOut: pAESBlock;
BlockCount: integer;
Encrypt: boolean;
ID: DWORD;
AES: TAES;
end;
{ we use direct Windows threads, since we don't need any exception handling
nor memory usage inside the Thread handler
-> avoid classes.TThread and system.BeginThread() use
-> application is still "officialy" mono-threaded (i.e. IsMultiThread=false),
for faster System.pas and FastMM4 (no locking)
-> code is even shorter then original one using TThread }
function ThreadWrapper(var P: TThreadParams): Integer; stdcall;
begin
with P do
AES.DoBlocks(bIn,bOut,bIn,bOut,BlockCount,Encrypt);
ExitThread(0);
result := 0; // make the compiler happy, but won't never be called
end;
procedure TAES.DoBlocksThread(var bIn, bOut: PAESBlock; Count: integer; doEncrypt: boolean);
var Thread: array[0..3] of TThreadParams; // faster than dynamic array
Handle: array[0..3] of THandle; // high(Thread) is not compiled by XE2
nThread, i, nOne: integer;
pIn, pOut: PAESBlock;
begin
if Count=0 then exit;
if {$ifdef USEPADLOCK} padlock_available or {$endif}
(SystemInfo.dwNumberOfProcessors<=1) or // (DebugHook<>0) or
(Count<((512*1024) div AESBlockSize)) then begin // not needed below 512 KB
DoBlocks(bIn,bOut,bIn,bOut,Count,doEncrypt);
exit;
end;
nThread := SystemInfo.dwNumberOfProcessors;
if nThread>length(Thread) then // a quad-core is enough ;)
nThread := length(Thread);
nOne := Count div nThread;
pIn := bIn;
pOut := bOut;
for i := 0 to nThread-1 do
with Thread[i] do begin // create threads parameters
bIn := pIn;
bOut := pOut;
BlockCount := nOne;
Encrypt := doEncrypt;
AES := self; // local copy of the AES context for every thread
Handle[i] := CreateThread(nil,0,#ThreadWrapper,#Thread[i],0,ID);
inc(pIn,nOne);
inc(pOut,nOne);
dec(Count,nOne);
end;
if Count>0 then
DoBlocks(pIn,pOut,pIn,pOut,Count,doEncrypt); // remaining blocks
inc(Count,nOne*nThread);
assert(integer(pIn)-integer(bIn)=Count*AESBlockSize);
assert(integer(pOut)-integer(bOut)=Count*AESBlockSize);
bIn := pIn;
bOut := pOut;
WaitForMultipleObjects(nThread,#Handle[0],True,INFINITE);
for i := 0 to nThread-1 do
CloseHandle(Handle[i]);
end;
A thread has its own stack pointer, so you can't access local variables or parameters (like the hidden Self parameter) in you MyThread local procedure (which BTW is declared wrong). Furthermore you can't use local procedures for threads if they access variables (including Self) from the outer function. And if you want to use the 64bit compiler in the future, you can't use local procedures for any callback.
In your case you just have to fix the declaration of your procedure and move it into the unit scope (make it a "stand alone" procedure. This allows you to use the thread-callback parameter for "Self".
function MyThread(MyObj: TMyClass): DWORD; stdcall;
begin
if MyObj.AnInteger <> 0 then
MyObj.MyPublicProcedure;
Result := 0;
end;
procedure TMyClass.MyPrivateProcedure;
var
DummyID: DWORD;
begin
MyThreadHandle := CreateThread(nil, 0, #MyThread, Self, 0, DummyID);
end;
I have a string comprising numerous words. How do I find and count the total amount of times that a particular word appears?
E.g "hello-apple-banana-hello-pear"
How would I go about finding all the "hello's" in the example above?
Thanks.
In Delphi XE you can use StrUtils.SplitString.
Something like this
var
Words: TstringDynArray;
Word: string;
WordCount: Integer;
begin
WordCount := 0;
Words := SplitString('hello-apple-banana-hello-pear', '-');
for Word in Words do
begin
if Word = 'hello' then
inc(WordCount);
end;
This would depend entirely on how you define a word and the text from which you wish to pull the words. If a "word" is everything between spaces, or "-" in your example, then it becomes a fairly simple task. If, however, you want to deal with hyphenated words, abbreviations, contractions, etc. then it becomes a lot more difficult.
More information please.
EDIT: After rereading your post, and if the example you give is the only one you want, then I'd suggest this:
function CountStr(const ASearchFor, ASearchIn : string) : Integer;
var
Start : Integer;
begin
Result := 0;
Start := Pos(ASearchFor, ASearchIn);
while Start > 0 do
begin
Inc(Result);
Start := PosEx(ASearchFor, ASearchIn, Start + 1);
end;
end;
This will catch ALL instances of a sequence of characters.
I'm sure there is plenty of code around to do this sort of thing, but it's easy enough to do it yourself with the help of Generics.Collections.TDictionary<K,V>.
program WordCount;
{$APPTYPE CONSOLE}
uses
SysUtils, Character, Generics.Collections;
function IsSeparator(const c: char): Boolean;
begin
Result := TCharacter.IsWhiteSpace(c);//replace this with whatever you want
end;
procedure PopulateWordDictionary(const s: string; dict: TDictionary<string, Integer>);
procedure AddItem(Item: string);
var
Count: Integer;
begin
if Item='' then
exit;
Item := LowerCase(Item);
if dict.TryGetValue(Item, Count) then
dict[Item] := Count+1
else
dict.Add(Item, 1);
end;
var
i, len, Start: Integer;
Item: string;
begin
len := Length(s);
Start := 1;
for i := 1 to len do begin
if IsSeparator(s[i]) then begin
AddItem(Copy(s, Start, i-Start));
Start := i+1;
end;
end;
AddItem(Copy(s, Start, len-Start+1));
end;
procedure Main;
var
dict: TDictionary<string, Integer>;
pair: TPair<string, Integer>;
begin
dict := TDictionary<string, Integer>.Create;
try
PopulateWordDictionary('hello apple banana Hello pear', dict);
for pair in dict do
Writeln(pair.Key, ': ', pair.Value);
finally
dict.Free;
end;
end;
begin
try
Main;
except
on E: Exception do
Writeln(E.ClassName, ': ', E.Message);
end;
end.
Output:
hello: 2
banana: 1
apple: 1
pear: 1
Note: I'm working with Delphi 2010 and don't have SplitString() available.
A very clever implementation I saw somewhere on the web:
{ Returns a count of the number of occurences of SubText in Text }
function CountOccurences( const SubText: string;
const Text: string): Integer;
begin
if (SubText = '') OR (Text = '') OR (Pos(SubText, Text) = 0) then
Result := 0
else
Result := (Length(Text) - Length(StringReplace(Text, SubText, '', [rfReplaceAll]))) div Length(subtext);
end; { CountOccurences }
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.