Simba Code:
program MainTab;
{$loadlib tabShareMem}
var bmp,w,h,w2,h2:integer;
var TPA,snake,tail :TPointArray;
var P:Pointer;
begin
ShareBool(false,'tab2start');
ShareBool(false,'tab3start');
while not (GetSharedBool('tab2start')and GetSharedBool('tab3start')) do
wait(100);
w := 300;
h := 200;
bmp := CreateBitmap(w,h);
RectangleBitmap(bmp,IntToBox(150,1,151,199),$FFFFFF);
RectangleBitmap(bmp,IntToBox(1,20,299,20),$FFFFFF);
TPAFromTextWrap('Time Running :','LoginChars',w2,h2,TPA);
OffsetTPA(TPA,Point(160,45));
DrawTPABitmap(bmp,TPA,$FF00FF);
TPAFromTextWrap('tab 3','LoginChars',w2,h2,TPA);
OffsetTPA(TPA,Point(50,2));
DrawTPABitmap(bmp,TPA,$00FF00);
TPAFromTextWrap('tab 2','LoginChars',w2,h2,TPA);
OffsetTPA(TPA,Point(200,2));
DrawTPABitmap(bmp,TPA,$00FF00);
wait(1000);
ShareBool(false,'CritSec1');
ShareBool(false,'CritSecSnake');
while(true) do
begin
wait(50);
RectangleBitmap(bmp,IntToBox(220,80,299,95),0);
if (GetSharedBool('CritSec1')) then
begin
TPA := TPointArray(GetSharedPointer('Tab2TPA'));
DrawTPABitmap(bmp,TPA,$FF00FF);
ShareBool(false,'CritSec1');
end;
if (GetSharedBool('CritSecSnake')) then
begin
snake := TPointArray(GetSharedPointer('snakeTPA'));
tail := TPointArray(GetSharedPointer('tailTPA'));
DrawTPABitmap(bmp,tail,0);
DrawTPABitmap(bmp,snake,$F0FF00);
ShareBool(false,'CritSecSnake');
end;
DisplayDebugImgWindow(w+1,h+1);
DrawBitmapDebugImg(bmp);
end;
end.
Simba Code:
program Tab2;
{$loadlib tabShareMem}
var TPA:TPointArray;
var w,h:integer;
begin
ShareBool(true,'tab2start');
while not( GetSharedBool('tab3start')) do
wait(100);
while(true) do
begin
if not(GetSharedBool('CritSec1')) then
begin
TPAFromTextWrap(tostr(GetTimeRunning),'LoginChars',w,h,TPA);
OffsetTPA(TPA,Point(220,80));
SharePointer(Pointer(TPA),'Tab2TPA');
ShareBool(true,'CritSec1');
end;
end;
end.
Simba Code:
program Tab3;
{$loadlib tabShareMem}
var Snake,toRemove :TPointArray;
sLen,w,h :integer;
dir :char;
procedure createSnake();
var i:integer;
begin
w := 150;
h := 199;
slen := 50;
SetLength(Snake,slen);
for i := 0 to slen-1 do
snake[i] := Point(round(w/2),round(h/2)+i);
dir := 'd';
end;
function WaitForKey(var dir :char;time:integer) : boolean;
var
t : LongWord;
dir2 : char;
begin
t := GetTimeRunning;
dir2 := dir;
repeat
if IsKeyDown(37)and(dir2<>'r') then dir := 'l' ;
if IsKeyDown(39)and(dir2<>'l') then dir := 'r' ;
if IsKeyDown(38)and(dir2<>'d') then dir := 'u' ;
if IsKeyDown(40)and(dir2<>'u') then dir := 'd' ;
until (GetTimeRunning - t) > time
end;
function NoClipControl(var nextPoint : TPoint) : boolean;
begin
if nextPoint.x > w then nextPoint.x := 0;
if nextPoint.x < 0 then nextPoint.x := w;
if nextPoint.y > h then nextPoint.y := 21;
if nextPoint.y < 21 then nextPoint.y := h;
end;
procedure DeleteValueInTPA(var Arr: TPointArray; ValuePosition: Integer); // by EvilChicken! & Coh3n
var
ArrLen, I: Integer;
begin
ArrLen := High(Arr);
for I := ValuePosition to ArrLen - 1 do
tSwap(Arr[I], Arr[I + 1]);
SetArrayLength(Arr, ArrLen);
end;
procedure MoveSnake(dir : char ); //input dir: 1 - left ,2 - rigth ,3 - up ,4 - down
var //output TRUE on crash
dx,dy,head : integer;
newHead,removeTail : TPoint;
t:integer;
begin
case dir of
'l': dx := -1;
'r': dx := 1;
'u': dy := -1;
'd': dy := 1;
end;
head := slen-1;
newHead := Point(snake[head].x + dx , snake[head].y + dy );
NoClipControl(newHead); // Noclip control
removeTail := Point(snake[0].x,snake[0].y);
toRemove:=[removeTail];
DeleteValueInTPA(snake,0);
setlength(snake,slen);
snake[head] := newHead;
end;
procedure SafeShare;
begin
while(GetSharedBool('CritSecSnake')) do
wait(5);
MoveSnake(dir);
SharePointer(Pointer(snake),'snakeTPA');
SharePointer(Pointer(toRemove),'tailTPA');
ShareBool(TRUE,'CritSecSnake');
end;
procedure MainLoop;
begin
while(true) do
begin
WaitForKey(dir,30);
SafeShare;
end;
end;
begin
ShareBool(true,'tab3start');
createSnake();
MainLoop;
end.
My ~~Multithreading thingy
assigned to buttons. But it doesn't depend on me...
Reply With Quote
Originally Posted by Kevin
