📄 edmain.pas
字号:
y := y div 2 * 2;
if (ssLeft in Shift) and not (ssAlt in Shift) then begin
PutTileXY (x, y, ImageIndex * UNITBLOCK + Random(5) + 1);
DrawCellBk (x, y, 1, 1);
end;
if ssAlt in Shift then begin
PutTileXY (x, y, 0);
DrawCellBk (x, y, 1, 1);
end;
end;
procedure TFrmMain.DrawAutoTile (x, y: integer; Shift: TShiftState);
procedure DrawSide (x, y: integer);
var
idx, myunit: integer;
begin
//idx := GetBkImg (x, y);
myunit := ImageIndex; //idx div UNITBLOCK;
DrawOne (x-2, y, myunit, 10);
DrawOne (x, y-2, myunit, 10);
DrawOne (x+2, y-2, myunit, 11);
DrawOne (x+4, y, myunit, 11);
DrawOne (x-2, y+2, myunit, 12);
DrawOne (x, y+4, myunit, 12);
DrawOne (x+4, y+2, myunit, 13);
DrawOne (x+2, y+4, myunit, 13);
end;
procedure DrawWing (x, y: integer);
var
i, j, xx, yy, idx, myunit: integer;
begin
for i:=0 to 3 do begin
for j:=0 to 3 do begin
xx := x - 2 + i*2;
yy := y - 2 + j*2;
idx := GetBkImg (xx, yy);
myunit := ImageIndex; //idx div UNITBLOCK;
idx := idx mod UNITBLOCK;
case idx of
10: //up '/'
begin
DrawOne (xx, yy - 2, myunit, 5);
DrawOne (xx-2, yy, myunit, 5);
end;
11: //up '\'
begin
DrawOne (xx, yy - 2, myunit, 6);
DrawOne (xx+2, yy, myunit, 6);
end;
12: //dn '\'
begin
DrawOne (xx, yy + 2, myunit, 7);
DrawOne (xx-2, yy, myunit, 7);
end;
13: //dn '/'
begin
DrawOne (xx, yy + 2, myunit, 8);
DrawOne (xx+2, yy, myunit, 8);
end;
end;
end;
end;
end;
procedure SolidBlock (xx, yy, myunit, idx: integer);
var
p, p1, p2, p3, p4, p12, p23, p34, p14: integer;
begin
p := GetPoint (idx);
if GetBkUnit(xx-2, yy) = myunit then p1 := GetPoint (GetBkImgUnit (xx-2, yy))
else p1 := 0;
if GetBkUnit(xx, yy-2) = myunit then p2 := GetPoint (GetBkImgUnit (xx, yy-2))
else p2 := 0;
if GetBkUnit(xx+2, yy) = myunit then p3 := GetPoint (GetBkImgUnit (xx+2, yy))
else p3 := 0;
if GetBkUnit(xx, yy+2) = myunit then p4 := GetPoint (GetBkImgUnit (xx, yy+2))
else p4 := 0;
{p12 := GetPoint (GetBkImgUnit (xx-2, yy-2));
p23 := GetPoint (GetBkImgUnit (xx+2, yy-2));
p34 := GetPoint (GetBkImgUnit (xx+2, yy+2));
p14 := GetPoint (GetBkImgUnit (xx-2, yy+2));}
if (p1 >= 4) and (p2 >= 4) and (p3 >= 4) and (p4 >= 4) then begin
DrawOneDr (xx, yy, myunit, Random(5));
end;
end;
procedure AssemblePuzzle (xx, yy, myunit, idx: integer);
var
d1, d2, d3, d4: integer;
begin
if (idx = 10) then begin
d1 := GetBkImgUnit (xx, yy+2);
if (d1 = 12) or (d1 = 22) then DrawOneDr (xx, yy, myunit, 20);
d2 := GetBkImgUnit (xx+2, yy);
if (d2 = 11) or (d2 = 16) then DrawOneDr (xx, yy, myunit, 15);
end;
if (idx = 12) then begin
d1 := GetBkImgUnit (xx, yy-2);
if (d1 = 10) or (d1 = 20) then DrawOneDr (xx, yy, myunit, 22);
d2 := GetBkImgUnit (xx+2, yy);
if (d2 = 13) or (d2 = 18) then DrawOneDr (xx, yy, myunit, 17);
end;
if (idx = 11) then begin
d1 := GetBkImgUnit (xx, yy+2);
if (d1 = 13) or (d1 = 23) then DrawOneDr (xx, yy, myunit, 21);
d2 := GetBkImgUnit (xx-2, yy);
if (d2 = 10) or (d2 = 15) then DrawOneDr (xx, yy, myunit, 16);
end;
if (idx = 13) then begin
d1 := GetBkImgUnit (xx, yy-2);
if (d1 = 11) or (d1 = 21) then DrawOneDr (xx, yy, myunit, 23);
d2 := GetBkImgUnit (xx-2, yy);
if (d2 = 12) or (d2 = 17) then DrawOneDr (xx, yy, myunit, 18);
end;
if (idx = 15) then begin
d1 := GetBkImgUnit (xx+2, yy);
if (d1 <> 16) and (d1 <> 11) then DrawOneDr (xx, yy, myunit, 10);
end;
if (idx = 16) then begin
d1 := GetBkImgUnit (xx-2, yy);
if (d1 <> 15) and (d1 <> 10) then DrawOneDr (xx, yy, myunit, 11);
end;
if (idx = 17) then begin
d1 := GetBkImgUnit (xx+2, yy);
if (d1 <> 18) and (d1 <> 13) then DrawOneDr (xx, yy, myunit, 12);
end;
if (idx = 18) then begin
d1 := GetBkImgUnit (xx-2, yy);
if (d1 <> 17) and (d1 <> 12) then DrawOneDr (xx, yy, myunit, 13);
end;
if (idx = 20) then begin
d1 := GetBkImgUnit (xx, yy+2);
if (d1 <> 22) and (d1 <> 12) then DrawOneDr (xx, yy, myunit, 10);
end;
if (idx = 21) then begin
d1 := GetBkImgUnit (xx, yy+2);
if (d1 <> 23) and (d1 <> 13) then DrawOneDr (xx, yy, myunit, 11);
end;
if (idx = 22) then begin
d1 := GetBkImgUnit (xx, yy-2);
if (d1 <> 20) and (d1 <> 10) then DrawOneDr (xx, yy, myunit, 12);
end;
if (idx = 23) then begin
d1 := GetBkImgUnit (xx, yy-2);
if (d1 <> 21) and (d1 <> 11) then DrawOneDr (xx, yy, myunit, 13);
end;
if (idx >= 0) and (idx <= 4) then begin
d1 := GetBkImgUnit (xx-2, yy);
d2 := GetBkImgUnit (xx, yy-2);
d3 := GetBkImgUnit (xx+2, yy);
d4 := GetBkImgUnit (xx, yy+2);
if ((d1 = 11) or (d1 = 16)) and ((d2 = 12) or (d2 = 22)) then
DrawOneDr (xx, yy, myunit, 10);
if ((d2 = 13) or (d2 = 23)) and ((d3 = 10) or (d3 = 15)) then
DrawOneDr (xx, yy, myunit, 11);
if ((d3 = 12) or (d3 = 17)) and ((d4 = 11) or (d4 = 21)) then
DrawOneDr (xx, yy, myunit, 13);
if ((d1 = 13) or (d1 = 18)) and ((d4 = 10) or (d4 = 20)) then
DrawOneDr (xx, yy, myunit, 12);
end;
if (GetBkUnit(xx,yy) <> myunit) or (idx = -1) or (idx = 99) then begin
d1 := GetBkImgUnit (xx-2, yy);
d2 := GetBkImgUnit (xx, yy-2);
d3 := GetBkImgUnit (xx+2, yy);
d4 := GetBkImgUnit (xx, yy+2);
if (d4 = 20) and (d3 = 15) then DrawOneDr (xx, yy, myunit, 5);
if (d1 = 16) and (d4 = 21) then DrawOneDr (xx, yy, myunit, 6);
if (d2 = 23) and (d1 = 18) then DrawOneDr (xx, yy, myunit, 8);
if (d3 = 17) and (d2 = 22) then DrawOneDr (xx, yy, myunit, 7);
end;
end;
procedure DrawRemainBlock (x, y: integer);
var
i, j, xx, yy, idx, myunit: integer;
begin
for i:=0 to 6 do begin
for j:=0 to 6 do begin
xx := x - 3*2 + i*2;
yy := y - 3*2 + j*2;
idx := GetBkImg (xx, yy);
myunit := ImageIndex; //idx div UNITBLOCK;
idx := idx mod UNITBLOCK;
SolidBlock (xx, yy, myunit, idx);
end;
end;
for i:=0 to 6 do begin
for j:=0 to 6 do begin
xx := x - 3*2 + i*2;
yy := y - 3*2 + j*2;
idx := GetBkImg (xx, yy);
myunit := ImageIndex; //idx div UNITBLOCK;
idx := idx mod UNITBLOCK;
AssemblePuzzle (xx, yy, myunit, idx);
end;
end;
end;
var
i, j: integer;
begin
x := x div 2 * 2;
y := y div 2 * 2;
for i:=0 to 1 do
for j:=0 to 1 do begin
PutBigTileXY (x+i*2, y+j*2, ImageIndex * UNITBLOCK + Random(5) + 1);
DrawCellBk (x+i*2, y+j*2, 1, 1);
end;
DrawSide (x, y);
DrawRemainBlock (x, y);
DrawRemainBlock (x, y);
DrawWing (x, y);
end;
procedure TFrmMain.DrawAutoMiddleTile (x, y: integer; Shift: TShiftState);
var
diu, di, changecount, WW, HH: integer;
rlist: TList;
function IMG (idx: integer): integer;
begin
if idx >= 1 then
Result := MiddleIndex*MIDDLEBLOCK + idx*4 + Random(4) + 4 + 1
else Result := MiddleIndex*MIDDLEBLOCK + Random(8) + 1;
end;
procedure PutTile (x, y, idx: integer);
var
i: integer;
p: pointer;
begin
Inc (changecount);
PutMiddleXY (x, y, idx);
p := pointer (MakeLong(word(x), word(y)));
for i:=0 to rlist.Count-1 do
if rlist[i] = p then
exit;
rlist.Add (p);
end;
function UN (x, y: integer): integer;
var
idx: integer;
begin
idx := GetMidImg (x, y);
if (idx >= MiddleIndex*MIDDLEBLOCK) and (idx < (MiddleIndex+1)*MIDDLEBLOCK) then begin
idx := idx - MiddleIndex*MIDDLEBLOCK;
if idx < 8 then Result := 0
else Result := (idx - 8) div 4 + 1;
end else
Result := -1;
end;
procedure DrawSide (x, y: integer);
var
idx: integer;
begin
if UN (x, y-1) < 0 then PutTile (x, y-1, IMG(1));
if UN (x+1, y-1) < 0 then PutTile (x+1, y-1, IMG(2));
if UN (x+1, y) < 0 then PutTile (x+1, y, IMG(3));
if UN (x+1, y+1) < 0 then PutTile (x+1, y+1, IMG(4));
if UN (x, y+1) < 0 then PutTile (x, y+1, IMG(5));
if UN (x-1, y+1) < 0 then PutTile (x-1, y+1, IMG(6));
if UN (x-1, y) < 0 then PutTile (x-1, y, IMG(7));
if UN (x-1, y-1) < 0 then PutTile (x-1, y-1, IMG(8));
end;
procedure DrawAutoPattern (x, y: integer);
var
i, j, c, n1, n2: integer;
begin
for i:=x-WW to x+WW do
for j:=y-HH to y+HH do begin
if (i > 0) and (j > 0) then begin
if UN(i,j) > 0 then begin
// (ぁ)
n1 := UN (i, j-1);
n2 := UN (i+1, j);
if UN(i,j) <> 11 then
if ((n1=2) or (n1=3) or (n1=12)) and ((n2=2) or (n2=1) or (n2=10)) then begin
PutTile (i, j, IMG(11));
end;
n1 := UN (i+1, j);
n2 := UN (i, j+1);
if UN(i,j) <> 12 then
if ((n1=4) or (n1=5) or (n1=9)) and ((n2=4) or (n2=3) or (n2=11)) then begin
PutTile (i, j, IMG(12));
end;
n1 := UN (i-1, j);
n2 := UN (i, j+1);
if UN(i,j) <> 9 then
if ((n1=6) or (n1=5) or (n1=12)) and ((n2=6) or (n2=7) or (n2=10)) then begin
PutTile (i, j, IMG(9));
end;
n1 := UN (i, j-1);
n2 := UN (i-1, j);
if UN(i,j) <> 10 then
if ((n1=8) or (n1=7) or (n1=9)) and ((n2=8) or (n2=1) or (n2=11)) then begin
PutTile (i, j, IMG(10));
end;
// (い)
n1 := UN(i-1, j);
n2 := UN(i+1, j);
if UN(i,j) <> 1 then
if ((n1=1) or (n1=8) or (n1=11)) and ((n2=2) or (n2=1) or (n2=10)) and (UN(i,j-1)<0) then begin
PutTile (i, j, IMG(1));
end;
n1 := UN(i, j-1);
n2 := UN(i, j+1);
if UN(i,j) <> 3 then
if ((n1=3) or (n1=2) or (n1=12)) and ((n2=3) or (n2=4) or (n2=11)) and (UN(i+1,j)<0) then begin
PutTile (i, j, IMG(3));
end;
n1 := UN(i-1, j);
n2 := UN(i+1, j);
if UN(i,j) <> 5 then
if ((n1=6) or (n1=5) or (n1=12)) and ((n2=5) or (n2=4) or (n2=9)) and (UN(i,j+1)<0) then begin
PutTile (i, j, IMG(5));
end;
n1 := UN(i, j-1);
n2 := UN(i, j+1);
if UN(i,j) <> 7 then
if ((n1=7) or (n1=8) or (n1=9)) and ((n2=7) or (n2=6) or (n2=10)) and (UN(i-1,j)<0) then begin
PutTile (i, j, IMG(7));
end;
// (ぇ)
if UN(i,j) <> 1 then
if {(UN(i,j-1)=-1) and (UN(i+1,j-1)=-1) and} (UN(i,j+1)=0) and (UN(i+1,j+1)=0) then
if (UN(i,j)=2) and ((UN(i+1,j)=8) or (UN(i+1,j)=7)) then
PutTile (i,j, IMG(1));
if UN(i,j) <> 3 then
if {(UN(i+1,j)=-1) and (UN(i+1,j+1)=-1) and} (UN(i-1,j)=0) and (UN(i-1,j+1)=0) then
if (UN(i,j)=4) and ((UN(i,j+1)=2) or (UN(i,j+1)=1)) then
PutTile (i,j, IMG(3));
if UN(i,j) <> 5 then
if {(UN(i,j+1)=-1) and (UN(i+1,j+1)=-1) and} (UN(i,j-1)=0) and (UN(i+1,j-1)=0) then
if (UN(i,j)=4) and ((UN(i+1,j)=6) or (UN(i+1,j)=7)) then
PutTile (i,j, IMG(5));
if UN(i,j) <> 7 then
if {(UN(i-1,j)=-1) and (UN(i-1,j+1)=-1) and} (UN(i+1,j)=0) and (UN(i+1,j+1)=0) then
if (UN(i,j)=6) and ((UN(i,j+1)=8) or (UN(i,j+1)=7)) then
PutTile (i,j, IMG(7));
// (ぉ)
if (UN(i-1,j)=5) and (UN(i,j-1)=3) and (UN(i+1,j)=1) and (UN(i,j+1)=7) or
(UN(i-1,j)=1) and (UN(i,j+1)=3) and (UN(i,j-1)=7) and (UN(i+1,j)=5) then begin
PutTile (i, j, IMG(0));
DrawSide (i, j);
end;
// (け)
if UN(i,j) = 2 then begin
if (UN(i+1,j) > -1) and (UN(i,j+1)=0) and (UN(i+1,j+1)>=0) then
PutTile(i,j, IMG(1));
if (UN(i,j-1) > -1) and (UN(i-1,j)=0) and (UN(i-1,j-1)>=0) then
PutTile(i,j, IMG(3));
end;
if UN(i,j) = 4 then begin
if (UN(i+1,j) > -1) and (UN(i,j-1)=0) and (UN(i+1,j-1)>=0) then
PutTile(i,j, IMG(5));
if (UN(i,j+1) > -1) and (UN(i-1,j)=0) and (UN(i-1,j+1)>=0) then
PutTile(i,j, IMG(3));
end;
if UN(i,j) = 6 then begin
if (UN(i,j+1) > -1) and (UN(i+1,j)=0) and (UN(i+1,j+1)>=0) then
PutTile(i,j, IMG(7));
if (UN(i-1,j) > -1) and (UN(i-1,j-1)=0) and (UN(i,j-1)>=0) then
PutTile(i,j, IMG(5));
end;
if UN(i,j) = 8 then begin
if (UN(i,j-1) > -1) and (UN(i+1,j)=0) and (UN(i+1,j-1)>=0) then
PutTile(i,j, IMG(7));
if (UN(i-1,j) > -1) and (UN(i,j+1)=0) and (UN(i-1,j+1)>=0) then
PutTile(i,j, IMG(1));
end;
// else
c := 0;
if UN(i,j-1)>=0 then Inc (c);
if UN(i+1,j-1)>=0 then Inc (c);
if UN(i+1,j)>=0 then Inc (c);
if UN(i+1,j+1)>=0 then Inc (c);
if UN(i,j+1)>=0 then Inc (c);
if UN(i-1,j+1)>=0 then Inc (c);
if UN(i-1,j)>=0 then Inc (c);
if UN(i-1,j-1)>=0 then Inc (c);
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -