[SOLVED]Dining philosophers

[avk]

Greetings to all.
I recently discovered that there is no implementation in Pascal on the appropriate Rosettacode page.
(see https://rosettacode.org/wiki/Dining_philosophers)
I decided to improve the situation, but the code is quite long:

Code: Pascal  [Select][+][-]

1. program dining_philosophers;
2.  
3. {$mode objfpc}{$modeswitch advancedrecords}
4.  
5. uses
6.   {$IFDEF UNIX}
7.   cthreads,
8.   {$ENDIF}
9.   Classes, SysUtils, DateUtils;
10.  
11. const
12.   PHIL_COUNT = 5;
13.   PHIL_NAMES: array[1..PHIL_COUNT] of string = ('Aristotle', 'Kant', 'Spinoza', 'Marx', 'Russell');
14.   DELAY_RANGE = 10;
15.   DELAY_SCALE = 100;
16. var
17.   StillDining: Integer = PHIL_COUNT;
18.  
19. type
20.   TFork = record
21.   strict private
22.     FState: DWord;
23.   public
24.     procedure Take; inline;
25.     procedure PutDown; inline;
26.   end;
27.   PFork = ^TFork;
28.   TForks = array[1..PHIL_COUNT] of TFork;
29.  
30.   TPhilosopher = class(TThread)
31.   private
32.     FName: string;
33.     FLeftFork,
34.     FRightFork: PFork;
35.     FLifeSpan: Integer;
36.     FAwait: PRtlEvent;
37.   protected
38.     procedure Execute; override;
39.     procedure Delay(aInterval: DWord);
40.   public
41.     constructor Create(const aName: string; aLeftFork, aRightFork: PFork; aLifeSpan: Integer);
42.     destructor Destroy; override;
43.   end;
44.  
45. procedure TFork.Take;
46. begin
47.   while Boolean(InterlockedExchange(FState, 1)) do
48.     ThreadSwitch;
49. end;
50.  
51. procedure TFork.PutDown;
52. begin
53.   InterlockedExchange(FState, 0);
54. end;
55.  
56. function RandomInterval: Integer; forward;
57.  
58. procedure TPhilosopher.Execute;
59. var
60.   StartTime: TTime;
61. begin
62.   WriteLn(FName, ' sits down at the table');
63.   while FLifeSpan > 0 do
64.     begin
65.       WriteLn(FName, ' thinking about the eternal');
66.       StartTime := Time;
67.       Delay(RandomInterval);
68.       WriteLn(FName, ' thought for ', MillisecondsBetween(Time, StartTime), ' ms');
69.       WriteLn(FName, ' is hungry');
70.       FLeftFork^.Take;
71.       FRightFork^.Take;
72.       WriteLn(FName, ' eating');
73.       StartTime := Time;
74.       Delay(RandomInterval);
75.       WriteLn(FName, ' ate for ', MillisecondsBetween(Time, StartTime), ' ms');
76.       WriteLn(FName, ' is full');
77.       FRightFork^.PutDown;
78.       FLeftFork^.PutDown;
79.       Dec(FLifeSpan);
80.     end;
81.   WriteLn(FName, ' leaves the table');
82.   InterlockedDecrement(StillDining);
83.   Terminate;
84. end;
85.  
86. procedure TPhilosopher.Delay(aInterval: DWord);
87. begin
88.   RTLEventWaitFor(FAwait, aInterval);
89.   RTLEventResetEvent(FAwait);
90. end;
91.  
92. constructor TPhilosopher.Create(const aName: string; aLeftFork, aRightFork: PFork; aLifeSpan: Integer);
93. begin
94.   inherited Create(True);
95.   FName := aName;
96.   FLeftFork := aLeftFork;
97.   FRightFork := aRightFork;
98.   FLifeSpan := aLifeSpan;
99.   FreeOnTerminate := True;
100.   FAwait := RtlEventCreate;
101. end;
102.  
103. destructor TPhilosopher.Destroy;
104. begin
105.   RTLEventDestroy(FAwait);
106.   inherited;
107. end;
108.  
109. var
110.   Philosophers: array[1..PHIL_COUNT] of TPhilosopher;
111.   Forks: TForks;
112.   LifeSpan: Integer = 3;
113.   RandLock: DWord = 0;
114.  
115. function RandomInterval: Integer;
116. begin
117.   while Boolean(InterlockedExchange(RandLock, 1)) do;
118.   try
119.     Result := Succ(Random(DELAY_RANGE)) * DELAY_SCALE;
120.   finally
121.     InterlockedExchange(RandLock, 0);
122.   end;
123. end;
124.  
125. procedure AskLifeSpan;
126. var
127.   s: string;
128.   tmp: Integer;
129. begin
130.   Write('You may set life span[default 3]: ');
131.   ReadLn(s);
132.   tmp := StrToIntDef(s, 0);
133.   if (Tmp > 0) and (Tmp <> LifeSpan) then
134.     begin
135.       LifeSpan := Tmp;
136.       WriteLn('Ok, life span is ', LifeSpan);
137.     end
138.   else
139.     WriteLn('Life span remains ', LifeSpan);
140.   WriteLn('Now let''s begin');
141. end;
142.  
143. procedure StartDinner;
144. var
145.   I: Integer = 1;
146. begin
147.   Randomize;
148.   Forks := Default(TForks);
149.   WriteLn(LineEnding, 'table is empty', LineEnding);
150.   repeat
151.     Philosophers[I] := TPhilosopher.Create(PHIL_NAMES[I], @Forks[I], @Forks[Succ(I)], LifeSpan);
152.     Inc(I);
153.   until I = PHIL_COUNT;
154.   Philosophers[I] := TPhilosopher.Create(PHIL_NAMES[I], @Forks[1], @Forks[I], LifeSpan);
155.   for I := 1 to PHIL_COUNT do
156.     Philosophers[I].Start;
157. end;
158.  
159. procedure WaitForEnd;
160. begin
161.   while StillDining > 0 do
162.     ThreadSwitch;
163.   WriteLn(LineEnding, 'table is empty', LineEnding);
164. end;
165.  
166. begin
167.   AskLifeSpan;
168.   StartDinner;
169.   WaitForEnd;
170.   Write('Done, press any key to exit...');
171.   ReadLn;
172. end.
173.  

And what do you think about it?

[Thaddy]

I should still have some TP code for that.... If it is not lost on a really floppy floppy... I will have a look. I actually attended some classes from Edsger Dijkstra and.. of course my major is in Political science, actually political philosophy, hence I like that particular problem very much (I have a B.Sc in computer science too, but no M.Sc). Will have a look..

[avk]

I actually attended some classes from Edsger Dijkstra

Really? It's great, you are lucky!

Since the random delays are quite large, it turns out that homemade spinlocks heavily load the processor. Replaced them with normal critical sections.

Code: Pascal  [Select][+][-]

1. program dining_philosophers;
2. {$mode objfpc}
3. uses
4.   {$IFDEF UNIX}
5.   cthreads,
6.   {$ENDIF}
7.   Classes, SysUtils, SyncObjs;
8. const
9.   PHIL_COUNT   = 5;
10.   DEFAULT_SPAN = 3;
11.   DELAY_RANGE  = 950;
12.   DELAY_LOW    = 50;
13.   PHIL_NAMES: array[1..PHIL_COUNT] of string = ('Aristotle', 'Kant', 'Spinoza', 'Marx', 'Russell');
14. var
15.   LifeSpan: Integer = DEFAULT_SPAN;
16.   RandLock: DWord = 0;
17.   StillDining: Integer = PHIL_COUNT;
18.   DinnerOver: PRtlEvent = nil;
19. type
20.   TFork = TCriticalSection;
21.   TPhilosopher = class(TThread)
22.   private
23.     FName: string;
24.     FLeftFork, FRightFork: TFork;
25.     FLifeSpan: Integer;
26.     FAwait: PRtlEvent;
27.   protected
28.     procedure Execute; override;
29.     procedure Delay(aInterval: DWord);
30.   public
31.     constructor Create(const aName: string; aLeftFork, aRightFork: TFork; aLifeSpan: Integer);
32.     destructor Destroy; override;
33.   end;
34.  
35. function RandomInterval: Integer;
36. begin
37.   while Boolean(InterlockedExchange(RandLock, 1)) do;
38.   try
39.     Result := Random(DELAY_RANGE) + DELAY_LOW;
40.   finally InterlockedExchange(RandLock, 0) end;
41. end;
42.  
43. procedure TPhilosopher.Execute;
44. begin
45.   WriteLn(FName, ' sits down at the table');
46.   while FLifeSpan > 0 do
47.     begin
48.       WriteLn(FName, ' thinking about the eternal');
49.       Delay(RandomInterval);
50.       WriteLn(FName, ' is hungry');
51.       FLeftFork.Acquire;
52.       FRightFork.Acquire;
53.       WriteLn(FName, ' eating');
54.       Delay(RandomInterval);
55.       FRightFork.Release;
56.       FLeftFork.Release;
57.       Dec(FLifeSpan);
58.     end;
59.   WriteLn(FName, ' leaves the table');
60.   if InterlockedDecrement(StillDining) = 0 then
61.     RtlEventSetEvent(DinnerOver);
62.   Terminate;
63. end;
64.  
65. procedure TPhilosopher.Delay(aInterval: DWord);
66. begin
67.   RTLEventWaitFor(FAwait, aInterval);
68.   RTLEventResetEvent(FAwait);
69. end;
70.  
71. constructor TPhilosopher.Create(const aName: string; aLeftFork, aRightFork: TFork; aLifeSpan: Integer);
72. begin
73.   inherited Create(True);
74.   FName := aName;
75.   FLeftFork := aLeftFork;
76.   FRightFork := aRightFork;
77.   FLifeSpan := aLifeSpan;
78.   FreeOnTerminate := True;
79.   FAwait := RtlEventCreate;
80. end;
81.  
82. destructor TPhilosopher.Destroy;
83. begin
84.   RTLEventDestroy(FAwait);
85.   inherited;
86. end;
87.  
88. procedure AskLifeSpan;
89. var
90.   s: string;
91.   tmp: Integer;
92. begin
93.   Write('You can set the lifespan[default 3]: ');
94.   ReadLn(s);
95.   tmp := StrToIntDef(s, 0);
96.   if (Tmp > 0) and (Tmp <> LifeSpan) then
97.     begin
98.       LifeSpan := Tmp;
99.       WriteLn('Ok, lifespan is ', LifeSpan);
100.     end
101.   else
102.     WriteLn('Lifespan remains ', LifeSpan);
103.   WriteLn('Now let''s begin');
104. end;
105.  
106. var
107.   Philosophers: array[1..PHIL_COUNT] of TPhilosopher;
108.   Forks: array[1..PHIL_COUNT] of TFork;
109.  
110. procedure StartDinner;
111. var
112.   I: Integer;
113.   Phil: TPhilosopher;
114. begin
115.   WriteLn(LineEnding, 'table is empty', LineEnding);
116.   Randomize;
117.   DinnerOver := RTlEventCreate;
118.   for I := 1 to PHIL_COUNT do
119.     Forks[I] := TFork.Create;
120.   for I := 1 to Pred(PHIL_COUNT) do
121.     Philosophers[I] := TPhilosopher.Create(PHIL_NAMES[I], Forks[I], Forks[Succ(I)], LifeSpan);
122.   Philosophers[PHIL_COUNT] := TPhilosopher.Create(PHIL_NAMES[PHIL_COUNT], Forks[1], Forks[PHIL_COUNT], LifeSpan);
123.   for Phil in Philosophers do
124.     Phil.Start;
125. end;
126.  
127. procedure WaitForDinnerOver;
128. var
129.   Fork: TFork;
130. begin
131.   RtlEventWaitFor(DinnerOver);
132.   RtlEventDestroy(DinnerOver);
133.   for Fork in Forks do
134.     Fork.Free;
135.   WriteLn(LineEnding, 'table is empty', LineEnding);
136. end;
137.  
138. begin
139.   AskLifeSpan;
140.   StartDinner;
141.   WaitForDinnerOver;
142.   Write('Done, press any key to exit...');
143.   ReadLn;
144. end.
145.  

[Thaddy]

I actually attended some classes from Edsger Dijkstra

Really? It's great, you are lucky!

Depends: he had the pen and paper (or blackboard) approach to computing and is famous for rarely touching one... Better payed attention... Difficult and funny at the same time.
I felt that he expected all of his audience to have compute powers like he had in their brains. In my case: not! not at that point in time (90's).

I hope that what I picked up about elegance and "simplicity" ,<yeah, right...> still shows in my little examples on this forum: that definitely had an impact.
Note I did not study at Austin, but he gave lectures and was a visiting professor to the Netherlands all of his life.
There must be more - either Dutch or American - forum members here that attended some of his lectures. I wonder what their opinion is. Must be close....

Now playing "one of these days...."  I invent a Semaphore....

[avk]

... elegance and "simplicity" ... Hmm ...

Well, in the third submission there seems nothing more to simplify:

Code: Pascal  [Select][+][-]

1. program dining_philosophers;
2. {$mode objfpc}
3. uses
4.   {$IFDEF UNIX}
5.   cthreads,
6.   {$ENDIF}
7.   Classes, SysUtils, SyncObjs;
8. const
9.   PHIL_COUNT   = 5;
10.   DELAY_RANGE  = 950;
11.   DELAY_LOW    = 50;
12.   PHIL_NAMES: array[1..PHIL_COUNT] of string = ('Aristotle', 'Kant', 'Spinoza', 'Marx', 'Russell');
13. type
14.   TFork        = TCriticalSection;
15.   TPhilosopher = class(TThread)
16.   private
17.     FName: string;
18.     FLeftFork, FRightFork: TFork;
19.     FLifeSpan: Integer;
20.   protected
21.     procedure Execute; override;
22.   public
23.     constructor Create(const aName: string; aLeftFork, aRightFork: TFork; aLifeSpan: Integer);
24.   end;
25.  
26. procedure Delay(aInterval: DWord); forward;
27.  
28. procedure TPhilosopher.Execute;
29. begin
30.   WriteLn(FName, ' sits down at the table');
31.   while FLifeSpan > 0 do
32.     begin
33.       WriteLn(FName, ' thinking');
34.       Delay(Random(DELAY_RANGE) + DELAY_LOW);
35.       WriteLn(FName, ' is hungry');
36.       FLeftFork.Acquire;
37.       FRightFork.Acquire;
38.       WriteLn(FName, ' eating');
39.       Delay(Random(DELAY_RANGE) + DELAY_LOW);
40.       FRightFork.Release;
41.       FLeftFork.Release;
42.       WriteLn(FName, ' is full');
43.       Dec(FLifeSpan);
44.     end;
45.   WriteLn(FName, ' leaves the table');
46. end;
47.  
48. constructor TPhilosopher.Create(const aName: string; aLeftFork, aRightFork: TFork; aLifeSpan: Integer);
49. begin
50.   inherited Create(True);
51.   FName := aName;
52.   FLeftFork := aLeftFork;
53.   FRightFork := aRightFork;
54.   FLifeSpan := aLifeSpan;
55. end;
56.  
57. var
58.   Philosophers: array[1..PHIL_COUNT] of TPhilosopher;
59.   Forks: array[1..PHIL_COUNT] of TFork;
60.   LifeSpan: Integer = 5;
61.   DelayAwait: PRtlEvent;
62.  
63. procedure DinnerBegin;
64. var
65.   I: Integer;
66.   Phil: TPhilosopher;
67. begin
68.   DelayAwait := RtlEventCreate;
69.   for I := 1 to PHIL_COUNT do
70.     Forks[I] := TFork.Create;
71.   for I := 1 to Pred(PHIL_COUNT) do
72.     Philosophers[I] := TPhilosopher.Create(PHIL_NAMES[I], Forks[I], Forks[Succ(I)], LifeSpan);
73.   Philosophers[PHIL_COUNT] := TPhilosopher.Create(PHIL_NAMES[PHIL_COUNT], Forks[1], Forks[PHIL_COUNT], LifeSpan);
74.   for Phil in Philosophers do
75.     Phil.Start;
76. end;
77.  
78. procedure WaitForDinnerOver;
79. var
80.   Phil: TPhilosopher;
81.   Fork: TFork;
82. begin
83.   for Phil in Philosophers do
84.     begin
85.       Phil.WaitFor;
86.       Phil.Free;
87.     end;
88.   for Fork in Forks do
89.     Fork.Free;
90.   RtlEventDestroy(DelayAwait);
91. end;
92.  
93. procedure Delay(aInterval: DWord);
94. begin
95.   RTLEventWaitFor(DelayAwait, aInterval);
96. end;
97.  
98. begin
99.   Randomize;
100.   WriteLn(LineEnding, 'table is empty', LineEnding);
101.   DinnerBegin;
102.   WaitForDinnerOver;
103.   WriteLn(LineEnding, 'table is empty', LineEnding);
104. end.  
105.  

[Ñuño_Martínez]

I would add some comments, including some to separate CLASS implementation from procedures and such.

[engkin]

... elegance and "simplicity" ... Hmm ...

Well, in the third submission there seems nothing more to simplify:

Code: Pascal  [Select][+][-]

1.   TPhilosopher.Create(PHIL_NAMES[PHIL_COUNT], Forks[1], Forks[PHIL_COUNT], LifeSpan);

Don't these forks need to be swapped?


Deleted!


Instead of:

Code: Pascal  [Select][+][-]

1.   Forks: array[1..PHIL_COUNT] of TFork;
2.  
3. procedure DinnerBegin;
4. var
5.   I: Integer;
6.   Phil: TPhilosopher;
7. begin
8.   DelayAwait := RtlEventCreate;
9.   for I := 1 to PHIL_COUNT do
10.     Forks[I] := TFork.Create;
11.   for I := 1 to Pred(PHIL_COUNT) do
12.     Philosophers[I] := TPhilosopher.Create(PHIL_NAMES[I], Forks[I], Forks[Succ(I)], LifeSpan);
13.   Philosophers[PHIL_COUNT] := TPhilosopher.Create(PHIL_NAMES[PHIL_COUNT], Forks[1], Forks[PHIL_COUNT], LifeSpan);
14.   for Phil in Philosophers do
15.     Phil.Start;
16. end;

I somehow prefer to have an additional fork instead of creating the last TPhilosopher outside the loop:

Code: Pascal  [Select][+][-]

1.   Forks: array[1..PHIL_COUNT+1] of TFork;
2.  
3. procedure DinnerBegin;
4. var
5.   I: Integer;
6.   Phil: TPhilosopher;
7. begin
8.   DelayAwait := RtlEventCreate;
9.   for I := 1 to PHIL_COUNT do
10.     Forks[I] := TFork.Create;
11.   Forks[PHIL_COUNT+1] := Forks[1];
12.   for I := 1 to PHIL_COUNT do
13.     Philosophers[I] := TPhilosopher.Create(PHIL_NAMES[I], Forks[I], Forks[Succ(I)], LifeSpan);
14.   for Phil in Philosophers do
15.     Phil.Start;
16. end;

[avk]

Unfortunately, by the condition of the problem there are only five forks.

For the aforementioned line, I have a rather long comment:
 "In fact, to the left of Russell is the fork number 5.
  But we, taking advantage of the fact that philosophers are usually absent-minded people,
  are trying to convince him that to the left lies the fork number 1.
  If he does not believe us, then a deadlock may occur." 
   
And yes, the code can be even simpler:

Code: Pascal  [Select][+][-]

1. program dining_philosophers;
2. {$mode objfpc}{$H+}
3. uses
4.   {$IFDEF UNIX}
5.   cthreads,
6.   {$ENDIF}
7.   Classes, SysUtils, SyncObjs;
8. const
9.   PHIL_COUNT   = 5;
10.   LIFESPAN     = 7;
11.   DELAY_RANGE  = 950;
12.   DELAY_LOW    = 50;
13.   TABLE_EMPTY  = LineEnding + 'table is empty' + LineEnding;
14.   PHIL_NAMES: array[1..PHIL_COUNT] of string = ('Aristotle', 'Kant', 'Spinoza', 'Marx', 'Russell');
15. type
16.   TFork        = TCriticalSection;
17.   TPhilosopher = class(TThread)
18.   private
19.     FName: string;
20.     FLeftFork, FRightFork: TFork;
21.   protected
22.     procedure Execute; override;
23.   public
24.     constructor Create(const aName: string; aLeftFork, aRightFork: TFork);
25.   end;
26.  
27. procedure TPhilosopher.Execute;
28. var
29.   LfSpan: Integer = LIFESPAN;
30. begin
31.   WriteLn(FName, ' sits down at the table');
32.   while LfSpan > 0 do
33.     begin
34.       WriteLn(FName, ' thinking');
35.       Sleep(Random(DELAY_RANGE) + DELAY_LOW);
36.       WriteLn(FName, ' is hungry');
37.       FLeftFork.Acquire;
38.       FRightFork.Acquire;
39.       WriteLn(FName, ' eating');
40.       Sleep(Random(DELAY_RANGE) + DELAY_LOW);
41.       FRightFork.Release;
42.       FLeftFork.Release;
43.       WriteLn(FName, ' is full');
44.       Dec(LfSpan);
45.     end;
46.   WriteLn(FName, ' leaves the table');
47. end;
48.  
49. constructor TPhilosopher.Create(const aName: string; aLeftFork, aRightFork: TFork);
50. begin
51.   inherited Create(False);
52.   FName := aName;
53.   FLeftFork := aLeftFork;
54.   FRightFork := aRightFork;
55. end;
56.  
57. var
58.   Forks: array[1..PHIL_COUNT] of TFork;
59.   Philosophers: array[1..PHIL_COUNT] of TPhilosopher;
60.  
61. procedure DinnerBegin;
62. var
63.   I: Integer;
64. begin
65.   for I := 1 to PHIL_COUNT do
66.     Forks[I] := TFork.Create;
67.   for I := 1 to Pred(PHIL_COUNT) do
68.     Philosophers[I] := TPhilosopher.Create(PHIL_NAMES[I], Forks[I], Forks[Succ(I)]);
69.   Philosophers[PHIL_COUNT] := TPhilosopher.Create(PHIL_NAMES[PHIL_COUNT], Forks[1], Forks[PHIL_COUNT]);
70. end;
71.  
72. procedure WaitForDinnerOver;
73. var
74.   Phil: TPhilosopher;
75.   Fork: TFork;
76. begin
77.   for Phil in Philosophers do
78.     begin
79.       Phil.WaitFor;
80.       Phil.Free;
81.     end;
82.   for Fork in Forks do
83.     Fork.Free;
84. end;
85.  
86. begin
87.   Randomize;
88.   WriteLn(TABLE_EMPTY);
89.   DinnerBegin;
90.   WaitForDinnerOver;
91.   WriteLn(TABLE_EMPTY);
92. end.
93.  

[engkin]

Unfortunately, by the condition of the problem there are only five forks.

Five forks, Fork[6] := Fork[1]

Code: Text  [Select][+][-]

1. Fork[1] Aristotle Fork[2]
2. Fork[2] Kant     Fork[3]
3. Fork[3] Spinoza  Fork[4]
4. Fork[4] Marx     Fork[5]
5. Fork[5] Russell  Fork[6] same as Fork[1]

Your arrangement makes Russell giving his back to the table, and he would not be able to eat.

[avk]

 Ah, you mean that Russell has seeing double?
 But fork number 1 is indeed to the right of Russell(round table), and that’s the problem.
 That is, you could write:

Code: Pascal  [Select][+][-]

1.   for I := 1 to PHIL_COUNT do
2.     Philosophers[I] := TPhilosopher.Create(PHIL_NAMES[I], Forks[I], Forks[Succ(I mod PHIL_COUNT)], LifeSpan);
3.  

But what happens if they all get hungry at the same time? 

[avk]

Thanks for the tips, the page is updated.

[Thaddy]

Remember the above problem can be also solved by making one of them left-handed!

[avk]

Yes, of course, done.

[lainz]

Thanks for sharing.

I guess this can be used to make a single connection to local SQLite database and use different threads to access and write data into it with no major problems?

Edit: found this https://forum.lazarus.freepascal.org/index.php/topic,42212.0.html