Forum > Other
[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 [+][-]window.onload = function(){var x1 = document.getElementById("main_content_section"); if (x1) { var x = document.getElementsByClassName("geshi");for (var i = 0; i < x.length; i++) { x[i].style.maxHeight='none'; x[i].style.height = Math.min(x[i].clientHeight+15,306)+'px'; x[i].style.resize = "vertical";}};} ---program dining_philosophers; {$mode objfpc}{$modeswitch advancedrecords} uses {$IFDEF UNIX} cthreads, {$ENDIF} Classes, SysUtils, DateUtils; const PHIL_COUNT = 5; PHIL_NAMES: array[1..PHIL_COUNT] of string = ('Aristotle', 'Kant', 'Spinoza', 'Marx', 'Russell'); DELAY_RANGE = 10; DELAY_SCALE = 100;var StillDining: Integer = PHIL_COUNT; type TFork = record strict private FState: DWord; public procedure Take; inline; procedure PutDown; inline; end; PFork = ^TFork; TForks = array[1..PHIL_COUNT] of TFork; TPhilosopher = class(TThread) private FName: string; FLeftFork, FRightFork: PFork; FLifeSpan: Integer; FAwait: PRtlEvent; protected procedure Execute; override; procedure Delay(aInterval: DWord); public constructor Create(const aName: string; aLeftFork, aRightFork: PFork; aLifeSpan: Integer); destructor Destroy; override; end; procedure TFork.Take;begin while Boolean(InterlockedExchange(FState, 1)) do ThreadSwitch;end; procedure TFork.PutDown;begin InterlockedExchange(FState, 0);end; function RandomInterval: Integer; forward; procedure TPhilosopher.Execute;var StartTime: TTime;begin WriteLn(FName, ' sits down at the table'); while FLifeSpan > 0 do begin WriteLn(FName, ' thinking about the eternal'); StartTime := Time; Delay(RandomInterval); WriteLn(FName, ' thought for ', MillisecondsBetween(Time, StartTime), ' ms'); WriteLn(FName, ' is hungry'); FLeftFork^.Take; FRightFork^.Take; WriteLn(FName, ' eating'); StartTime := Time; Delay(RandomInterval); WriteLn(FName, ' ate for ', MillisecondsBetween(Time, StartTime), ' ms'); WriteLn(FName, ' is full'); FRightFork^.PutDown; FLeftFork^.PutDown; Dec(FLifeSpan); end; WriteLn(FName, ' leaves the table'); InterlockedDecrement(StillDining); Terminate;end; procedure TPhilosopher.Delay(aInterval: DWord);begin RTLEventWaitFor(FAwait, aInterval); RTLEventResetEvent(FAwait);end; constructor TPhilosopher.Create(const aName: string; aLeftFork, aRightFork: PFork; aLifeSpan: Integer);begin inherited Create(True); FName := aName; FLeftFork := aLeftFork; FRightFork := aRightFork; FLifeSpan := aLifeSpan; FreeOnTerminate := True; FAwait := RtlEventCreate;end; destructor TPhilosopher.Destroy;begin RTLEventDestroy(FAwait); inherited;end; var Philosophers: array[1..PHIL_COUNT] of TPhilosopher; Forks: TForks; LifeSpan: Integer = 3; RandLock: DWord = 0; function RandomInterval: Integer;begin while Boolean(InterlockedExchange(RandLock, 1)) do; try Result := Succ(Random(DELAY_RANGE)) * DELAY_SCALE; finally InterlockedExchange(RandLock, 0); end;end; procedure AskLifeSpan;var s: string; tmp: Integer;begin Write('You may set life span[default 3]: '); ReadLn(s); tmp := StrToIntDef(s, 0); if (Tmp > 0) and (Tmp <> LifeSpan) then begin LifeSpan := Tmp; WriteLn('Ok, life span is ', LifeSpan); end else WriteLn('Life span remains ', LifeSpan); WriteLn('Now let''s begin');end; procedure StartDinner;var I: Integer = 1;begin Randomize; Forks := Default(TForks); WriteLn(LineEnding, 'table is empty', LineEnding); repeat Philosophers[I] := TPhilosopher.Create(PHIL_NAMES[I], @Forks[I], @Forks[Succ(I)], LifeSpan); Inc(I); until I = PHIL_COUNT; Philosophers[I] := TPhilosopher.Create(PHIL_NAMES[I], @Forks[1], @Forks[I], LifeSpan); for I := 1 to PHIL_COUNT do Philosophers[I].Start;end; procedure WaitForEnd;begin while StillDining > 0 do ThreadSwitch; WriteLn(LineEnding, 'table is empty', LineEnding);end; begin AskLifeSpan; StartDinner; WaitForEnd; Write('Done, press any key to exit...'); ReadLn;end. 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:
--- Quote from: Thaddy on March 03, 2019, 04:10:37 pm ---I actually attended some classes from Edsger Dijkstra
--- End quote ---
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 [+][-]window.onload = function(){var x1 = document.getElementById("main_content_section"); if (x1) { var x = document.getElementsByClassName("geshi");for (var i = 0; i < x.length; i++) { x[i].style.maxHeight='none'; x[i].style.height = Math.min(x[i].clientHeight+15,306)+'px'; x[i].style.resize = "vertical";}};} ---program dining_philosophers;{$mode objfpc}uses {$IFDEF UNIX} cthreads, {$ENDIF} Classes, SysUtils, SyncObjs;const PHIL_COUNT = 5; DEFAULT_SPAN = 3; DELAY_RANGE = 950; DELAY_LOW = 50; PHIL_NAMES: array[1..PHIL_COUNT] of string = ('Aristotle', 'Kant', 'Spinoza', 'Marx', 'Russell');var LifeSpan: Integer = DEFAULT_SPAN; RandLock: DWord = 0; StillDining: Integer = PHIL_COUNT; DinnerOver: PRtlEvent = nil;type TFork = TCriticalSection; TPhilosopher = class(TThread) private FName: string; FLeftFork, FRightFork: TFork; FLifeSpan: Integer; FAwait: PRtlEvent; protected procedure Execute; override; procedure Delay(aInterval: DWord); public constructor Create(const aName: string; aLeftFork, aRightFork: TFork; aLifeSpan: Integer); destructor Destroy; override; end; function RandomInterval: Integer;begin while Boolean(InterlockedExchange(RandLock, 1)) do; try Result := Random(DELAY_RANGE) + DELAY_LOW; finally InterlockedExchange(RandLock, 0) end;end; procedure TPhilosopher.Execute;begin WriteLn(FName, ' sits down at the table'); while FLifeSpan > 0 do begin WriteLn(FName, ' thinking about the eternal'); Delay(RandomInterval); WriteLn(FName, ' is hungry'); FLeftFork.Acquire; FRightFork.Acquire; WriteLn(FName, ' eating'); Delay(RandomInterval); FRightFork.Release; FLeftFork.Release; Dec(FLifeSpan); end; WriteLn(FName, ' leaves the table'); if InterlockedDecrement(StillDining) = 0 then RtlEventSetEvent(DinnerOver); Terminate;end; procedure TPhilosopher.Delay(aInterval: DWord);begin RTLEventWaitFor(FAwait, aInterval); RTLEventResetEvent(FAwait);end; constructor TPhilosopher.Create(const aName: string; aLeftFork, aRightFork: TFork; aLifeSpan: Integer);begin inherited Create(True); FName := aName; FLeftFork := aLeftFork; FRightFork := aRightFork; FLifeSpan := aLifeSpan; FreeOnTerminate := True; FAwait := RtlEventCreate;end; destructor TPhilosopher.Destroy;begin RTLEventDestroy(FAwait); inherited;end; procedure AskLifeSpan;var s: string; tmp: Integer;begin Write('You can set the lifespan[default 3]: '); ReadLn(s); tmp := StrToIntDef(s, 0); if (Tmp > 0) and (Tmp <> LifeSpan) then begin LifeSpan := Tmp; WriteLn('Ok, lifespan is ', LifeSpan); end else WriteLn('Lifespan remains ', LifeSpan); WriteLn('Now let''s begin');end; var Philosophers: array[1..PHIL_COUNT] of TPhilosopher; Forks: array[1..PHIL_COUNT] of TFork; procedure StartDinner;var I: Integer; Phil: TPhilosopher;begin WriteLn(LineEnding, 'table is empty', LineEnding); Randomize; DinnerOver := RTlEventCreate; for I := 1 to PHIL_COUNT do Forks[I] := TFork.Create; for I := 1 to Pred(PHIL_COUNT) do Philosophers[I] := TPhilosopher.Create(PHIL_NAMES[I], Forks[I], Forks[Succ(I)], LifeSpan); Philosophers[PHIL_COUNT] := TPhilosopher.Create(PHIL_NAMES[PHIL_COUNT], Forks[1], Forks[PHIL_COUNT], LifeSpan); for Phil in Philosophers do Phil.Start;end; procedure WaitForDinnerOver;var Fork: TFork;begin RtlEventWaitFor(DinnerOver); RtlEventDestroy(DinnerOver); for Fork in Forks do Fork.Free; WriteLn(LineEnding, 'table is empty', LineEnding);end; begin AskLifeSpan; StartDinner; WaitForDinnerOver; Write('Done, press any key to exit...'); ReadLn;end.
Thaddy:
--- Quote from: avk on March 04, 2019, 08:13:52 am ---
--- Quote from: Thaddy on March 03, 2019, 04:10:37 pm ---I actually attended some classes from Edsger Dijkstra
--- End quote ---
Really? It's great, you are lucky!
--- End quote ---
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.... 8-)
avk:
... elegance and "simplicity" ... Hmm ... :-[
Well, in the third submission there seems nothing more to simplify:
--- Code: Pascal [+][-]window.onload = function(){var x1 = document.getElementById("main_content_section"); if (x1) { var x = document.getElementsByClassName("geshi");for (var i = 0; i < x.length; i++) { x[i].style.maxHeight='none'; x[i].style.height = Math.min(x[i].clientHeight+15,306)+'px'; x[i].style.resize = "vertical";}};} ---program dining_philosophers;{$mode objfpc}uses {$IFDEF UNIX} cthreads, {$ENDIF} Classes, SysUtils, SyncObjs;const PHIL_COUNT = 5; DELAY_RANGE = 950; DELAY_LOW = 50; PHIL_NAMES: array[1..PHIL_COUNT] of string = ('Aristotle', 'Kant', 'Spinoza', 'Marx', 'Russell');type TFork = TCriticalSection; TPhilosopher = class(TThread) private FName: string; FLeftFork, FRightFork: TFork; FLifeSpan: Integer; protected procedure Execute; override; public constructor Create(const aName: string; aLeftFork, aRightFork: TFork; aLifeSpan: Integer); end; procedure Delay(aInterval: DWord); forward; procedure TPhilosopher.Execute;begin WriteLn(FName, ' sits down at the table'); while FLifeSpan > 0 do begin WriteLn(FName, ' thinking'); Delay(Random(DELAY_RANGE) + DELAY_LOW); WriteLn(FName, ' is hungry'); FLeftFork.Acquire; FRightFork.Acquire; WriteLn(FName, ' eating'); Delay(Random(DELAY_RANGE) + DELAY_LOW); FRightFork.Release; FLeftFork.Release; WriteLn(FName, ' is full'); Dec(FLifeSpan); end; WriteLn(FName, ' leaves the table');end; constructor TPhilosopher.Create(const aName: string; aLeftFork, aRightFork: TFork; aLifeSpan: Integer);begin inherited Create(True); FName := aName; FLeftFork := aLeftFork; FRightFork := aRightFork; FLifeSpan := aLifeSpan;end; var Philosophers: array[1..PHIL_COUNT] of TPhilosopher; Forks: array[1..PHIL_COUNT] of TFork; LifeSpan: Integer = 5; DelayAwait: PRtlEvent; procedure DinnerBegin;var I: Integer; Phil: TPhilosopher;begin DelayAwait := RtlEventCreate; for I := 1 to PHIL_COUNT do Forks[I] := TFork.Create; for I := 1 to Pred(PHIL_COUNT) do Philosophers[I] := TPhilosopher.Create(PHIL_NAMES[I], Forks[I], Forks[Succ(I)], LifeSpan); Philosophers[PHIL_COUNT] := TPhilosopher.Create(PHIL_NAMES[PHIL_COUNT], Forks[1], Forks[PHIL_COUNT], LifeSpan); for Phil in Philosophers do Phil.Start;end; procedure WaitForDinnerOver;var Phil: TPhilosopher; Fork: TFork;begin for Phil in Philosophers do begin Phil.WaitFor; Phil.Free; end; for Fork in Forks do Fork.Free; RtlEventDestroy(DelayAwait);end; procedure Delay(aInterval: DWord);begin RTLEventWaitFor(DelayAwait, aInterval);end; begin Randomize; WriteLn(LineEnding, 'table is empty', LineEnding); DinnerBegin; WaitForDinnerOver; WriteLn(LineEnding, 'table is empty', LineEnding);end.
Navigation
[0] Message Index
[#] Next page