Brute Force Algorithm to solve the TSP in Delphi [closed] - algorithm

Closed. This question needs to be more focused. It is not currently accepting answers.
Want to improve this question? Update the question so it focuses on one problem only by editing this post.
Closed 9 years ago.
Improve this question
I'm writing a program for an extended project to simulate the travelling salesman problem. So far I have written it to allow the user to enter a route, as well as 'solving' a route using a nearest neighbour algorithm. I am now trying to write a brute force algorithm to solve for a selection of cities, from 3 cities up to about 13/14. The program is for the purpose of showing how the increase in number of cities leads to an exponential/factorial increase in the time taken to calculate the shortest route. I have tried to write a recursive function but cannot get my head around how it would work. I am in desperate need of some guidance as to how to do this. Any help would be appreciated.

Since there is no tag with Delphi version, then any version suits the TopicStarter just fine. I would base thus draft on XE2 version then. I also would assume that each town is only visited once. I would assume that there is a road network rather than a private airplane, that is between any chosen cities A and B there may be direct path or may not (connection only through other cities).
type TCity = class
public
Name : string;
Routes : TList<TCity>; // available roads to/from this place
LeftFor : integer; // where did the merchant went next; -1 if did not arrived or left, used to iterate all the paths
CameFrom: TCity; // nil initially
.....
End; // writing this draft from phone ( testing official StackOverflow Android app) would not write boilerplate with creating/free in internal objects - do it yourself
Type TPath = TArray<TCity>; // for your app you would add segments and total cost and whatever
Var World: TArray<TCity >; // fill cities and links yourself
AllPaths: TList<TPath>; // create yourself
Current: TList<TCity >; // create yourself
Procedure SaveResult;
Begin AllPaths.Add( Current.ToArray) end;
Function TryNextCity: boolean;
Var c1,c2: TCity; I : integer;
Begin
c1 := Current.Last; // where we are
While true do begin
Inc( c1.LeftFor) ;
If c1.LeftFor >= c1.Routes.Count // tried all ways?
Then Exit( false );
c2 := c1.Routes (. c1.LeftFor .);
if c2 = c1.CameFrom then continue;
if c2.LeftFor >= 0 then continue; // already were there
AddCity(c2);
Exit( True) ;
End;
End;
Procedure AddCity( const City: TCity) ;
Begin
Assert ( not Current.Contains( City) ) ;
If Current.Count = 0
then City.CameFrom := nil //starting point
else City.CameFrom := Current.Last;
City.LeftFor := -1;
Current.Add(City) ;
End;
Procedure Withdraw;
Begin
Assert ( Current.Count > 0);
With Current.Last do begin
CameFrom := nil;
LeftFor := -1;
End;
Current.Delete( Current.Count - 1) ;
End;
Procedure Recurs;
Var DeadEnd : boolean;
Begin
DeadEnd := true;
while TryNextCity() do begin
DeadEnd := false;
Recurs();
end;
if DeadEnd then SaveResult();
Withdraw ();
End;
Procedure RunBruteForce;
Var c: TCity ;
Begin
AllPaths.Clear;
For c in world do begin
Current.Clear;
AddCity( c );
Recurs();
End;
End;
PS. #MartynA looks like I cannot comment my answer now in Android. So my reply is: this questions as is now falls into a triangle between "do my homework", "write a textbook or at least an essay" and "throw a bunch of vague nice ideas, correct per se, but none of which would be detailed and complete enough to be called an answer".
I only started the answer to try new SO app, and only go on for it does not have options to delete the answer.

Related

Wrong use of 'file of char'

Im having problems with this code, I have two file of char, one is filed with information about books, and the other is empty, i have to write in SAL some information from S and then show the total of how many books match the first 2 digits of the code and how many are R and how many are T. The code, does write the information form S to Sal, but when its supposed to show the totals it appears ERORR 100 on screen. I read about it and it says that it is a problem with 'Disk read error' and that *This error typically occurs, if you "seed" a non-existent record of a typed file and try to read/write it. *, i really dont undertand.
I've benn trying to figure it out, but I haven't been able to. I notice that if I dont put 'WHILE NOT EOF(S) DO' the error does not appear, but of course i need the while, if someone is able to point out my mistakes i would really apreciate it.
This is the code:
uses crt;
var
i : byte;
s,sal: file of char;
v,l1,l2: char;
cs,cn,cl: integer;
pn,ps,tot: integer;
BEGIN
cs:=0; cn:=0; i:=0; cl:=0;
Assign (s, 'C:\Users\te\Documents\s.txt');
{$I-}
Reset (s);
{$I+}
if IOResult <> 0 then
begin
writeln('Error');
halt(2);
end;
Assign (sal, 'C:\Users\te\Documents\sal.txt');
{$I-}
Rewrite (sal);
IOResult;
{$I+}
if IOResult <> 0 then
halt(2);
writeln('Please write the code of the book, only 2 digits');
read(L1);read(L2);
read(s,v);
while (not eof(s)) do
begin
for i:=1 to 2 do
read(s,v);
if (v = '0') then
begin
read(s,v);
if (v = '1') or (v = '2') then
begin
for i:=1 to 5 do
read(s,v);
if (v = 'R') then
begin
read(s,v);
cs:= cs + 1;
end
else
begin
if (v = 'T') then
begin
cn:= cn + 1;
read(s,v);
end;
end;
while (v <> '-') do
read(s,v);
while (v = '-') do
read(s,v);
if (v = L1) then
begin
write(sal, v);
read(s,v);
if (v = L2) then
begin
write(sal,v);
read(s,v);
cl:= cl + 1;
end;
end;
while ( v <> '/') do
begin
write(sal,v);
read(s,v);
end;
write(sal, '-');
end
else
begin
for i:= 1 to 5 do
read(s,v);
if (v = 'R') then
cs:= cs + 1
else
cn:= cn + 1;
if (v = L1) then
read(s,v);
if (v = L2) then
begin
cl:= cl + 1;
read(s,v);
end;
end;
end
else
begin
for i:= 1 to 5 do
read(s,v);
if (v = 'R') then
cs:= cs + 1
else
cn:= cn + 1;
if (v = L1) then
read(s,v);
if (v = L2) then
begin
cl:= cl + 1;
read(s,v);
end;
end;
end;
tot:= cs + cn;
ps:= (cs * 100) div tot;
pn:= (cn * 100) div tot;
writeln('TOTAL ',cl);
writeln();
writeln(ps,'% and',pn,'%');
The file S content:
02022013Rto kill a mockingbird-1301/02012014Tpeter pan-1001/02032013Thowto-2301/02012012Tmaze runner-1001/02012012Tmaze runner-1001/02012012Tmaze runner-1001/$
I really just need someone else's point of view on this code, I think maybe the algorithm is flawed.
Thanks
(After your edit, i see that your code now compiles w/o error in FPC, so I'm glad you've managed to fix the error yourself)
As this is obviously coursework, I'm not going to fix your code for you and in any case the wayEven so, I'm afraid you are going about this is completely wrong.
Basically, the main thing wrong with your code is that you are trying to control what happens as your read the source file character by character. Quite frankly, that's a hopeless way of trying to do it, because it makes the execution flow unnecessarily complicated and littered with ifs, buts and loops. It also requires you to keep mental track of what you are trying to do at any given step, and the resulting code is inherently not self-documenting - imagine if you came back to your code in six months, could you tell at a glance how it works and what it does? I certsinly couldn't personally.
You need to break the task down in a different way. Instead of analysing the problem from the bottom up ("If I read this character next, then what I need to do next is ...') do it from the top down: Although your input file is a file of char, it contains a series of strings, separated by a / character and finally terminated by a $ (but this terminator does not really matter). So what you need to do is to read these strings one-by-one; once you've got one, check whether it's the one you're looking for: if it is. process it however you need to, otherwise read the next one until you reach the end of the file.
Once you have successfully read one of the book strings, you can then split it up into the various fields it's composed of. The most useful function for doing this splitting is probably Copy, which lets you extract substrings from a string - look it up in the FPC help. I've included functions ExtractTitle and ExtractPreamble which show you what you need to do to write similar functions to extract the T/R code and the numeric code which follows the hyphen. Btw, if you need to ask a similar q in the future, it would be very helpful if you include a description of the layout and meaning of the various fields in the file.
So, what I'm going to show you is how to read the series of strings in your S.Txt by building them character-by-character. In the code below, I do this using a function GetNextBook which I hope is reasonable self-explanatory. The code uses this function in a while loop to fill the BookRecord string variable. Then, it simply writes the BookRecord to the console. What your code should do, of course, is to process the BookRecord contents to see if it is the one you are looking for and then do whether the remainder of your task is.
I hope you will agree that the code below is a lot clearer, a lot shorter and will be a lot easier to extend in future than the code in your q. They key to structuring a program this way is to break the program's task into a series of functions and procedures which each perform a single sub-task. Writing the program that way makes it easier to "re-wire" the program to change what it does, without having to rewrite the innards of the functions/procedures.
program fileofcharproject;
uses crt;
const
sContents = '02022013Rto kill a mockingbird-1301/02012014Tpeter pan-1001/02032013Thowto-2301/02012012Tmaze runner-1001/02012012Tmaze runner-1001/02012012Tmaze runner-1001/$';
InputFileName = 'C:\Users\MA\Documents\S.Txt';
OutputFileName = 'C:\Users\MA\Documents\Sal.Txt';
type
CharFile = File of Char; // this is to permit a file of char to be used
// as a parameter to a function/procedure
function GetNextBook(var S : CharFile) : String;
var
InputChar : Char;
begin
Result := '';
InputChar := Chr(0);
while not Eof(S) do begin
Read(S, InputChar);
// next, check that the char we've read is not a '/'
// if it is a '/' then exit this while loop
if (InputChar <> '/') then
Result := Result + InputChar
else
Break;
end;
end;
function ExtractBookTitle(BookRecord : String) : String;
var
p : Integer;
begin
Result := Copy(BookRecord, 10, Length(BookRecord));
p := Pos('-', Result);
if p > 0 then
Result := Copy(Result, 1, p - 1);
end;
procedure AddToOutputFile(var OutputFile : CharFile; BookRecord : String);
var
i : Integer;
begin
for i := 1 to Length(BookRecord) do
write(OutputFile, BookRecord[i]);
write(OutputFile, '/');
end;
function ExtractPreamble(BookRecord : String) : String;
begin
Result := Copy(BookRecord, 1, 8);
end;
function TitleMatches(PartialTitle, BookRecord : String) : Boolean;
begin
Result := Pos(PartialTitle, ExtractBookTitle(BookRecord)) > 0;
end;
var
i : Integer; //byte;
s,sal: file of char;
l1,l2: char;
InputChar : Char;
BookFound : Boolean;
cs,cn,cl: integer;
pn,ps,tot: integer;
Contents : String;
BookRecord : String;
PartialTitle : String;
begin
// First, create S.Txt so we don't have to make any assumptions about
// its contents
Contents := sContents;
Assign(s, InputFileName);
Rewrite(s);
for i := 1 to Length(Contents) do begin
write(s, Contents[i]); // writes the i'th character of Contents to the file
end;
Close(s);
cs:=0; cn:=0; i:=0; cl:=0;
// Open the input file
Assign (s, InputFileName);
{$I-}
Reset (s);
{$I+}
if IOResult <> 0 then
begin
writeln('Error');
halt(2);
end;
// Open the output file
Assign (sal, OutputFileName);
{$I-}
Rewrite (sal);
IOResult;
{$I+}
if IOResult <> 0 then
halt(2);
// the following reads the BookRecords one-by-one and copies
// any of them which match the partial title to sal.txt
writeln('Enter part of a book title, followed by [Enter]');
readln(PartialTitle);
while not Eof(s) do begin
BookRecord := GetNextBook(S);
writeln(BookRecord);
writeln('Preamble : ', ExtractPreamble(BookRecord));
writeln('Title : ', ExtractBookTitle(BookRecord));
if TitleMatches(PartialTitle, BookRecord) then
AddToOutputFile(sal, BookRecord);
end;
// add file '$' to sal.txt
write(sal, '$');
Close(sal);
Close(s);
writeln('Done, press any key');
readln;
end.

How to forbid equal numbers

I started learning Pascal :) and I was interested on making a kind of Euromillion... However, I don't know how to forbid the same numbers or stars...
I thought this (below) would solve it... But it didn't... Help?
Program euromillion;
var num: array [1..5] of integer;
Procedure numbers;
var i, j: integer;
Begin
write ('Digite o número 1: ');
readln (num[1]);
for i:=2 to 5 do
for j:=1 to (i-1) do
Begin
repeat
write ('Digite o número ', i, ': ');
readln (num[i]);
until (num[i]>=1) and (num[i]<=50) and ((num[i]=num[j])=false);
End;
End;
Begin
numbers;
readln();
End.
Thanks guys :)
Although it is tempting to try and write a single block of code, as you have, it is better not to. Instead, a better way to write a program like this
is to think about splitting the task up into a number of procedures or functions
each of which only does a single part of the task.
One way to look at your task is to split it up into sub-tasks, as follows:
You prompt the user to enter a series of numbers
Once each number is entered, you check whether it is already in the array
If it isn't, you enter it in the array, otherwise prompt the user for another number
Once the array is filled, you output the numbers in the array
So, a key thing is that it would be helpful to have a function that checks whether
a new number is already in the array and returns True if it is and False otherwise. How to do that is the answer to your question.
You need to be careful about this because if you use the array a second time in the
program, you need to avoid comparing the new number with the array contents from
the previous time. I deliberately have not solved that problem in the example code below, to leave it as an exercise for the reader. Hint: One way would be to write a procedure which "clears" the array before each use of it, e.g. by filling it with numbers which are not valid lottery numbers, like negative numbers or zero. Another way would be to define a record which includes the NumberArray and a Count field which records how many numbers have been entered so far: this would avoid comparing the new number to all the elements in the
array and allow you to re-use the array by resetting the Count field to zero before calling ReadNumbers.
program LotteryNumbers;
uses crt;
type
TNumberArray = array[1..5] of Integer;
var
Numbers : TNumberArray;
Number : Integer;
function IsInArray(Number : Integer; Numbers : TNumberArray) : Boolean;
var
i : Integer;
begin
Result := False;
for i:= Low(Numbers) to High(Numbers) do begin
if Numbers[i] = Number then begin
Result := True;
break;
end;
end
end;
procedure ReadNumbers(var Numbers : TNumberArray);
var
i : Integer;
NewNumber : Integer;
OK : Boolean;
begin
// Note: This function needs to have a check added to it that the number
// the user enters is a valid lottery number, in other words that the
// number is between 1 and the highest ball number in the lottery
for i := Low(Numbers) to High(Numbers) do begin
repeat
OK := False;
writeln('enter a number');
ReadLn(NewNumber);
OK := not IsInArray(NewNumber, Numbers);
if not OK then
writeln('Sorry, you''ve already chosen ', NewNumber);
until OK;
Numbers[i] := NewNumber;
end;
end;
procedure ListNumbers(Numbers : TNumberArray);
var
i : Integer;
begin
for i := Low(Numbers) to High(Numbers) do
writeln(Numbers[i]);
end;
begin
ReadNumbers(Numbers);
ListNumbers(Numbers);
writeln('press any key');
readkey;
end.

Issue with calculation in function

I'm quite new to programming and I can't get a function to calculate properly. It is a compound interest calculator that uses this formula:
I = P ( 1 + i )n — P (p= principal i= interest n= years) Rate := to interest value.
On pascal my function looks like this,
function Compoundinterest(principal, years: integer; rate: double): double;
var
divrate: double;
interest: Double;
begin
divrate := rate/100;
interest := principal * power(1 + divrate, years) - Principal;
result := interest;
end;
It compiles fine but just wont return the right value.
for example 1000 principal, 15% interest over 3 years returns this : 1.52087500000000E+000.
I assume I'm doing something wrong in the formula?
Thanks for your help in advance.
In pascal, a function returns what it's name has been set to within the function. For example:
function set_one(): integer;
begin
set_one := 1
end;
In your function, you should replace
result := interest;
with
Compoundinterest := interest;
or to show in completion (with a few changes):
function compound_interest(principal, years: integer; rate: double): double;
var
divrate: double;
begin
divrate := rate / 100.0;
compound_interest := principal * power(1 + divrate, years) - principal;
end;
However, this assumes that you have access to the power function. In order to access the power function, the program must have: uses math written under the program header. This code was tested on compiles on Free Pascal Compiler version 2.6.4.
For more info on Pascal, see: https://www.tutorialspoint.com/pascal/pascal_functions.htm
For an online Pascal terminal, see:
https://www.tutorialspoint.com/compile_pascal_online.php
I tested here with Free Pascal 3.0.0 and it works (5.20875. I added
{$mode delphi}
uses math;
before your code and
begin
writeln(compoundinterest(1000,3,15));
end.
after. Verify that you do this too, or explain more about which pascal system you use.
If this is only a first step in some calculation you might also be interested in the math unit financial functions
You have to set the format of decimal using
:0:2
Try this
result := interest:0:2;
Counting the number of decimal places in pascal
var
divrate: double;
interest: Double;
begin
divrate := rate/100;
interest := principal * power(1 + divrate, years) - Principal;
result := interest:0:2;
end;

It's some kind of magic... or bug? [closed]

Closed. This question needs details or clarity. It is not currently accepting answers.
Want to improve this question? Add details and clarify the problem by editing this post.
Closed 7 years ago.
Improve this question
I added my program to the SendTo. I send two files to it.
They are:
C:\ThisIsMySuperTestHelloWorld\ThisBookIsRedMyPenIsWhite\test.jpg
C:\ThisIsMySuperTestHelloWorld\ThisBookIsRedMyPenIsWhite\hello.jpg
The code below shows C:\ThisIsMySuperTestHelloWorld\ThisBookIsRedMyPenIsWhite\test.jpg#C:\ThisIsMySuperTestHelloWorld\ThisBookIsRedMyPenIsWhite\test.jpg
procedure TForm1.FormCreate(Sender: TObject);
var Files: array of PAnsiChar;
i: Integer;
begin
SetLength(Files, 2);
for i:=0 to 1 do begin
Files[i] := PAnsiChar(ParamStr(2+i));
end;
ShowMessage( Files[0] +'#' + Files[1] );
end;
I use Delphi 6 on Windows7.
Under Delphi Xe3 (still Win7) I changed (both) PAnsiChar to PWideChar and I have the same effect.
My SendTo link links to:
"C:\<PATH_HERE>\Project1.exe" c
and is placed here:
C:\Users\<USER>\AppData\Roaming\Microsoft\Windows\SendTo
What about using strings? For example:
procedure HandleParams;
var Files: array of string;
i: Integer;
begin
SetLength(Files, ParamCount);
for i := 1 to ParamCount do
Files[i-1] := ParamStr(i);
if ParamCount >= 2 then
ShowMessage( Files[0] +'#' + Files[1] );
end;
Your code does not work, because PAnsiChar is only a Pointer and does not store the actual string data. When you assign the string returned from the ParamStr function only a pointer to the (temporary) function result is stored. The actual data is overwritten with the next function call. This can even crash your program when further used.
By the way, your ParamStr index iterates over 2 and 3, with references to the second and third parameter; maybe that's not intended as the arguments start at index 1 (index 0 being the program call itself)?
To solve the issue one has to store the string data, which makes the pointers kinda useless, but anyway, here's a fixed version of your example:
procedure HandleParamsPAnsi;
var Files: array of PAnsiChar;
FilesData: array of AnsiString;
i: Integer;
begin
SetLength(Files, 2);
SetLength(FilesData, 2);
for i:=0 to 1 do begin
FilesData[i] := AnsiString(ParamStr(1+i));
Files[i] := PAnsiChar(FilesData[i]);
end;
ShowMessage( Files[0] + '#' + Files[1] );
end;

Stack Overflow in binary tree insertion

PROCEDURE CreateNode (info: CHAR): BST;
VAR
bst : BST;
BEGIN
NEW(bst);
bst^.elem := info;
bst^.left := NIL;
bst^.right := NIL;
RETURN bst;
END CreateNode;
PROCEDURE Insert (info: CHAR; VAR t: BST);
BEGIN
IF t = NIL THEN
t := CreateNode(info);
ELSIF Compare(info, t^.elem) = greater THEN
Insert(info, t^.right);
ELSIF Compare(info, t^.elem) = less THEN
Insert(info, t^.left);
END;
END Insert;
This is causing a stack overflow when done with a FOR from 1 to a very high value (20k).
It only gets to a relatively low number (~900) before the overflow.
Have you searched on Stack Overflow? :p Just kidding.
The issue probably is the recursive call. A function call uses the stack to store register values, which are only removed from there if the called function ends and control is returned to the calling function. For recursive calls, all those nested calls remain on the stack until recursion is broken. Eventually the stack is not large enough and you will get this error.
You should be able to fix this by eliminating the recursion with a loop. That way, you just have iterations that jump to the next node, without all the overhead of function calls.
It can be hard to do that. Sometimes recursion seems to be the obvious way and you have to do some work to fix it in a loop.
Anyway, it should have the same logic as yours, which is, traverse the tree and look for the right spot. If the new value is smaller or larger than any leaf, it is inserted as a new node, as a leaf to the parent, and it is returned in 't'. If there is already a node with the same value, that node is returned.
To eliminate too much code duplication, the snippet below introduces a new function TryCreateNode. It tests if p (either the left or right leaf of the parent node) is nil, and if so, assigns a new node to it. It returns either p (the existing leaf) or the new node as an output parameter and returns true if a new node was created. That return value is used in the main function to break the loop.
I'm not sure which Pascal dialect you're using, so I just guessed a bit. Maybe you need to treat this as pseudo-code and fix the syntax first. ;)
FUNCTION TryCreateNode(Info: CHAR; VAR p: BST; VAR t: BST): Boolean;
BEGIN
TryCreateNode := False;
IF p = nil THEN
BEGIN
p := CreateNode(info);
TryCreateNode := True;
END;
t := p;
END;
PROCEDURE Insert (info: CHAR; VAR t: BST);
BEGIN
WHILE t <> nil DO
BEGIN
IF Compare(info, t^.elem) = greater THEN
IF TryCreateNode(info, t^.right, t) THEN
BREAK;
IF Compare(info, t^.elem) = less THEN
IF TryCreateNode(info, t^.left, t) THEN
BREAK;
END;
END Insert;
Seeing that this appears to be Pascal, the cause of your problem is most likely the recursion itself. It is quite likely that the version of Pascal that you are using cannot optimize this function (or won't) for tail recursion.

Resources