SCAR Code:
program Bejeweled;
type
ScoreNumber = record
x, y: Integer;
Number: Integer;
end;
ByteArray7 = array[0..7] of Integer;
{const
begx = 179;
begy = 36;
eindx = 432;
eindy = 288;
breed = 8;
hoog = 8;
rood = 1061359;
groen = 5426836;
blauw = 16772938;
geel = 3276799;
oranje = 2126847;
paars = 14972090;
wit = 13487565; }
const
begx = 50;
begy = 70;
eindx = 275;
eindy = 300;
breed = 8;
hoog = 8;
rood = 199;
groen = 65280;
blauw = 16765865;
geel = 3407871;
oranje = 39402;
paars = 16719066;
wit = 9211020;
var
bejs: array of array of Integer; //bej[x][y]
deled,bej: array of array of Integer; //bej[x][y]
a,i,b,x1,y1,x,y,hoogst,blokx,bloky,test: Integer;
xi,yi,xe,ye: integer;//muv cords
xii,yii,xee,yee:integer;// temp muv cors
lengthscores: array of integer;
Scores: array of ScoreNumber;
Score,mogs: Integer;
Procedure index;
begin
blokx := (eindx-begx)/(breed-1)
bloky := (eindy-begy)/(hoog-1)
for a:=0 to hoog-1 do
begin
writeln(a);
x1 := (a)*blokx+begx
for b:=0 to breed-1 do
begin
writeln(' ' + IntToStr(b));
y1 := (b)*bloky+begy
writeln(' ' +IntToStr(x1));
writeln(' ' +IntToStr(y1));
if (findColorTolerance(x,y,wit,x1-(blokx/2),y1-(bloky/2),x1+(blokx/2),y1+(blokx/2),20)) then
begin
// writeln(' ' +IntToStr(x));
//writeln(' ' +IntToStr(y));
bej[a][b] := 1;
writeln(' ' +IntToStr(a)+ '' +IntToStr(b)+'= wit' );
end;
if (findColorTolerance(x,y,rood,x1-(blokx/2),y1-(bloky/2),x1+(blokx/2),y1+(blokx/2),20)) then
begin
// writeln(' ' +IntToStr(x));
//writeln(' ' +IntToStr(y));
bej[a][b] := 2;
writeln(' ' +IntToStr(a)+ '' +IntToStr(b)+'= rood' );
end;
if (findColorTolerance(x,y,groen,x1-(blokx/2),y1-(bloky/2),x1+(blokx/2),y1+(blokx/2),60)) then
begin
// writeln(' ' +IntToStr(x));
//writeln(' ' +IntToStr(y));
bej[a][b] := 3;
writeln(' ' +IntToStr(a)+ '' +IntToStr(b)+'= groen' );
end;
if (findColorTolerance(x,y,blauw,x1-(blokx/2),y1-(bloky/2),x1+(blokx/2),y1+(blokx/2),20)) then
begin
// writeln(' ' +IntToStr(x));
//writeln(' ' +IntToStr(y));
bej[a][b] := 4;
writeln(' ' +IntToStr(a)+ '' +IntToStr(b)+'= blauw' );
end;
if (findColorTolerance(x,y,oranje,x1-(blokx/2),y1-(bloky/2),x1+(blokx/2),y1+(blokx/2),20)) then
begin
// writeln(' ' +IntToStr(x));
//writeln(' ' +IntToStr(y));
bej[a][b] := 5;
writeln(' ' +IntToStr(a)+ '' +IntToStr(b)+'= oranje' );
end;
if (findColorTolerance(x,y,geel,x1-(blokx/2),y1-(bloky/2),x1+(blokx/2),y1+(blokx/2),20)) then
begin
// writeln(' ' +IntToStr(x));
//writeln(' ' +IntToStr(y));
bej[a][b] := 6;
writeln(' ' +IntToStr(a)+ '' +IntToStr(b)+'= geel' );
end;
if (findColorTolerance(x,y,paars,x1-(blokx/2),y1-(bloky/2),x1+(blokx/2),y1+(blokx/2),20)) then
begin
// writeln(' ' +IntToStr(x));
//writeln(' ' +IntToStr(y));
bej[a][b] := 7;
writeln(' ' +IntToStr(a)+ '' +IntToStr(b)+'= paars' );
end;
end;
end;
end;
procedure muv(xi,yi,xe,ye:Integer);
begin
HoldMouse(begx+(xe*blokx),begy+(ye*bloky),True);
wait(200);
MoveMouse( begx+(xi*blokx),begy+(yi*bloky));
wait(200);
ReleaseMouse(begx+(xi*blokx),begy+(yi*bloky), True);
wait(1500);
end;
function findmoves(var arr: array of array of Integer; lvl:integer):Integer;
var
arrtemp: array of array of Integer;
w,i,q,ham, love: Integer; //loop array
move, hooger: Integer; //onthoud welke move
temp: String;
begin
SetLength(arrtemp, hoog);
for i := 0 to High(arrtemp) do
begin
lvl := lvl+1;
w:=0;
SetLength(arrtemp[i], breed);
end;
for ham := 0 to high(arr) do
for love := 0 to high(arr[ham]) do
begin
Writeln(arr[ham][love]);
if not(ham = hoog-1)Then
begin
//Writeln('verticaal');
if (arr[ham][love] = arr[ham+1][love]) Then // \/
Begin
if not(love = 0)AND not(ham = 0) Then
begin
if (arr[ham][love] = arr[ham-1][love-1]) Then // \/
Begin
//verander arr
if(lvl>1)Then
begin
if(findmoves(bej,lvl) > hooger)Then
end else
begin
xii := love;
yii := ham-1;
xee := love-1;
yee := ham-1;
end;
Writeln('links naar rechts');
//HoldMouse(begx+((love-1)*blokx),begy+((ham-1)*bloky),True);
//wait(200);
//MoveMouse( begx+(love*blokx),begy+((ham-1)*bloky));
//wait(200);
//ReleaseMouse(begx+((love-1)*blokx),begy+((ham-1)*bloky), True);
//wait(200);
//muv(love,ham-1,love-1,ham-1);
writeln('muv' + IntToStr(ham));
w:=w+1;
exit;
end;
end;
end;
end;
end;
writeln(hooger);
end;
function arrs(var arr: array of array of String; x1,y1,x2,y2:integer):array of array of String;
var
temp:string;
begin
temp := arr[x1][y1];
arr[x1][y1] := arr[x2][y2];
arr[x2][y2] := temp;
end;
function GetLauk(x, y: Integer): Integer;
begin
Result := -1;
if (x >= 1) and (x <= 8) and (y >= 1) and (y <= 8) then
Result := bej[x][y];
end;
function CheckLaukSq(c: Char; var last: Integer; x, y: Integer): Boolean;
begin
Result := True;
if (c = '1') then
begin
Result := ((last = -1) or (bej[x][y] = last));
last := bej[x][y];
end;
end;
function FindVShapeInLauk(s: string; x, y: Integer): Boolean;
var
last: Integer;
begin
Result := True;
last := -1;
Result := Result and CheckLaukSq(s[1], last, x, y);
Result := Result and CheckLaukSq(s[2], last, x + 1, y);
Result := Result and CheckLaukSq(s[3], last, x, y + 1);
Result := Result and CheckLaukSq(s[4], last, x + 1, y + 1);
Result := Result and CheckLaukSq(s[5], last, x, y + 2);
Result := Result and CheckLaukSq(s[6], last, x + 1, y + 2);
end;
function FindHShapeInLauk(s: string; x, y: Integer): Boolean;
var
last: Integer;
begin
Result := True;
last := -1;
Result := Result and CheckLaukSq(s[1], last, x, y);
Result := Result and CheckLaukSq(s[2], last, x + 1, y);
Result := Result and CheckLaukSq(s[3], last, x + 2, y);
Result := Result and CheckLaukSq(s[4], last, x, y + 1);
Result := Result and CheckLaukSq(s[5], last, x + 1, y + 1);
Result := Result and CheckLaukSq(s[6], last, x + 2, y + 1);
end;
function FindHHShapeInLauk(s: string; x, y: Integer): Boolean;
var
last: Integer;
begin
Result := True;
last := -1;
Result := Result and CheckLaukSq(s[1], last, x, y);
Result := Result and CheckLaukSq(s[2], last, x + 1, y);
Result := Result and CheckLaukSq(s[3], last, x + 2, y);
Result := Result and CheckLaukSq(s[4], last, x + 3, y);
end;
function FindVVShapeInLauk(s: string; x, y: Integer): Boolean;
var
last: Integer;
begin
Result := True;
last := -1;
Result := Result and CheckLaukSq(s[1], last, x, y);
Result := Result and CheckLaukSq(s[2], last, x, y + 1);
Result := Result and CheckLaukSq(s[3], last, x, y + 2);
Result := Result and CheckLaukSq(s[4], last, x, y + 3);
end;
function FullLines(temp: array of array of integer): array of array of integer;
var
n, last, x, y: Integer;
begin
for y := 1 to 8 do
begin
n := 0;
last := 0;
for x := 1 to 8 do
if (temp[x][y] = last) then
begin
n := n + 1;
if (n = 3) then
end else
begin
n := 1;
last := temp[x][y];
end;
end;
for x := 1 to 8 do
begin
last := 0;
n := 0;
for y := 1 to 8 do
if (temp[x][y] = last) then
begin
n := n + 1;
if (n = 3) then
end else
begin
n := 1;
last := temp[x][y];
end;
end;
Result := temp;
end;
function CanDropLines(temp:array of array of integer): Boolean;
var
x, y: Integer;
begin
Result := False;
for x := 1 to 8 do
for y := 1 to 8 do
Result := Result or (temp[x][y] <= 0);
end;
function DeleteLine(x, y, xv, yv, num: Integer): Integer;
begin
Result := LengthScores[num];
while (num > 0) do
begin
Deled[x][y] := 1;
x := x + xv;
y := y + yv;
num := num - 1;
end;
end;
procedure DelLine(x, y, xv, yv, n: Integer);
var
k: Integer;
begin
k := DeleteLine(x, y, xv, yv, n);
end;
function DeleteLines(temp: array of array of integer):array of array of integer;
var
n, last, x, y: Integer;
begin
writeln('deled:');
for x := 0 to 7 do
writeln('x:' + IntToStr(x));
for y := 0 to 7 do
begin
Deled[x][y] := 0;
end;
for y := 0 to 7 do
begin
n := 0;
last := 0;
for x := 0 to 7 do
if (temp[x][y] = last) then
n := n + 1
else begin
if (n >= 3) then
DelLine(x - 1, y, -1, 0, n);
n := 1;
last := temp[x][y];
end;
if (n >= 3) then
DelLine(8, y, -1, 0, n);
end;
for x := 0 to 7 do
begin
last := 0;
n := 0;
for y := 0 to 7 do
if (temp[x][y] = last) then
n := n + 1
else begin
if (n >= 3) then
DelLine(x, y - 1, 0, -1, n);
n := 1;
last := temp[x][y];
end;
if (n >= 3) then
DelLine(x, 8, 0, -1, n);
end;
for x := 0 to 7 do
for y := 0 to 7 do
if (Deled[x][y] = 1) then
temp[x][y] := 0;
Result := temp
end;
function DropLine(temp: array of array of integer):array of array of integer;
var
x, y, f: Integer;
FLauk: array[1..8] of array[0..8] of Byte;
begin
for x := 1 to 8 do
for y := 1 to 8 do
FLauk[x][y] := 0;
for y := 8 downto 1 do
for x := 1 to 8 do
if (temp[x][y] < 1) or (FLauk[x][y] = 1) then
FLauk[x][y - 1] := 1;
for y := 8 downto 2 do
for x := 1 to 8 do
if (temp[x][y] < 1) then
begin
temp[x][y] := temp[x][y - 1];
temp[x][y - 1] := 0;
end;
Result := temp;
end;
function gelijk(temp, temp2:array of array of integer):Boolean;
begin
Result := false
for x := 0 to 6 do
for y := 0 to 5 do
begin
if(temp[x][y] = temp2[x][y]) then Result := true
end;
end;
function HaveMoves(lvl:integer; bej:array of array of integer): Boolean;
var
x, y: Integer;
new: array of array of integer;
begin
lvl := lvl+1;
writeln('lvl:' + IntToStr(lvl));
if(lvl>hoogst) Then
begin
hoogst := lvl;
xi := xii;
yi := yii;
xe := xee;
ye := yee;
end;
Result := False;
for x := 0 to 6 do
for y := 0 to 5 do
begin
Result := Result or FindVShapeInLauk('011010', x, y);
if(Result = true)then
begin
if(lvl = 1)then
begin
xii := 0;
yii := 0;
xee := 0;
yee := 0;
end;
new:= bej;
repeat
DeleteLines(new);
while (CanDropLines(new)) do
new := DropLine(new);
until (gelijk(fulllines(new), new)); //FullLines(bej) = bej
havemoves(lvl, new);
//movemouse(begx+x*blokx,begy+y*bloky);
writeln('011010');
mogs := mogs +1;
//wait(400);
end;
Result := False;
Result := Result or FindVShapeInLauk('100101', x, y);
if(Result = true)then
begin
//movemouse(begx+x*blokx,begy+y*bloky);
mogs := mogs +1;
//wait(400);
end;
Result := False;
Result := Result or FindVShapeInLauk('011001', x, y);
if(Result = true)then
begin
//movemouse(begx+x*blokx,begy+y*bloky);
mogs := mogs +1;
//wait(400);
end;
Result := False;
Result := Result or FindVShapeInLauk('100110', x, y);
if(Result = true)then
begin
//movemouse(begx+x*blokx,begy+y*bloky);
mogs := mogs +1;
//wait(400);
end;
Result := False;
Result := Result or FindVShapeInLauk('010110', x, y);
if(Result = true)then
begin
//movemouse(begx+x*blokx,begy+y*bloky);
mogs := mogs +1;
//wait(400);
end;
Result := False;
Result := Result or FindVShapeInLauk('101001', x, y);
if(Result = true)then
begin
//movemouse(begx+x*blokx,begy+y*bloky);
mogs := mogs +1;
//wait(400);
end;
Result := False;
end;
for x := 0 to 5 do
for y := 0 to 6 do
begin
Result := Result or FindHShapeInLauk('011100', x, y);
if(Result = true)then
begin
//movemouse(begx+x*blokx,begy+y*bloky);
mogs := mogs +1;
//wait(400);
end;
Result := False;
Result := Result or FindHShapeInLauk('100011', x, y);
if(Result = true)then
begin
//movemouse(begx+x*blokx,begy+y*bloky);
mogs := mogs +1;
//wait(400);
end;
Result := False;
Result := Result or FindHShapeInLauk('110001', x, y);
if(Result = true)then
begin
//movemouse(begx+x*blokx,begy+y*bloky);
mogs := mogs +1;
//wait(400);
end;
Result := False;
Result := Result or FindHShapeInLauk('001110', x, y);
if(Result = true)then
begin
//movemouse(begx+x*blokx,begy+y*bloky);
mogs := mogs +1;
//wait(400);
end;
Result := False;
Result := Result or FindHShapeInLauk('101010', x, y);
if(Result = true)then
begin
//movemouse(begx+x*blokx,begy+y*bloky);
mogs := mogs +1;
//wait(400);
end;
Result := False;
Result := Result or FindHShapeInLauk('010101', x, y);
if(Result = true)then
begin
//movemouse(begx+x*blokx,begy+y*bloky);
mogs := mogs +1;
//wait(400);
end;
Result := False;
end;
for x := 0 to 4 do
for y := 0 to 7 do
begin
Result := Result or FindHHShapeInLauk('1011', x, y);
if(Result = true)then
begin
//movemouse(begx+x*blokx,begy+y*bloky);
mogs := mogs +1;
//wait(400);
end;
Result := False;
Result := Result or FindHHShapeInLauk('1101', x, y);
if(Result = true)then
begin
//movemouse(begx+x*blokx,begy+y*bloky);
mogs := mogs +1;
//wait(400);
end;
Result := False;
end;
for x := 0 to 7 do
for y := 0 to 4 do
begin
Result := Result or FindVVShapeInLauk('1011', x, y);
if(Result = true)then
begin
//movemouse(begx+x*blokx,begy+y*bloky);
mogs := mogs +1;
//wait(400);
end;
Result := False;
Result := Result or FindVVShapeInLauk('1101', x, y);
if(Result = true)then
begin
//movemouse(begx+x*blokx,begy+y*bloky);
mogs := mogs +1;
//wait(400);
end;
Result := False;
end;
end;
begin
hoogst := 0;
SetLength(bej, hoog);
for i := 0 to High(bej) do SetLength(bej[i], breed);
index;
//findmoves(bej,0);
//muv(xi,yi,xe,ye);;
writeln('test');
writeln(FindVShapeInLauk('011010', 1, 1));
FindVShapeInLauk('100101', 1, 1);
FindVShapeInLauk('011001', 1, 1);
FindVShapeInLauk('100110', 1, 1);
FindVShapeInLauk('010110', 1, 1);
FindVShapeInLauk('101001', 1, 1);
writeln('test2s');
writeln(havemoves(0,bej));
writeln('mogelijkheden:' + IntToStr(mogs));
writeln('hoogst:' + IntToStr(hoogst));
end.