📄 linegame.pas
字号:
{*******************************************************************************
Copyright (C), 2004, 风月工作室.
作者: 追风逐月
版本: 1.0
日期: 2005年12月28日
描述: QQ连连看游戏控制类
修改历史:
徐明 2005/12/28 1.0 创建该文件
...
********************************************************************************}
unit LineGame;
interface
uses
Windows,
Messages,
ShellAPI,
Classes;
const
MAP_HLENGTH = 19;
MAP_VLENGTH = 11;
MAPCOUNT = 100;
gLeft = 16;
gTop = 184;
hwidth = 31;
vWidth = 35;
type
TLineGame = class
private
Maps: array[0..MAP_VLENGTH - 1, 0..MAP_HLENGTH - 1] of integer;
gh: THandle;
RectA: TRect;
LineMap: TStringList;
ptLines: array[1..MAPCOUNT] of Tlist;
FGameThreadID:integer;
procedure SetPtLines;
function CanConnect(P1, P2: TPoint): boolean;
function CanLine(P1, P2: TPoint): Boolean;
function isEmptyPt(pt: TPoint): boolean;
function GetMapIndex(Color: integer): integer;
function LeftMapCount: integer;
procedure GetColor(x, y: Integer; var col: Cardinal);
function GetColorMx(i, j: integer): Cardinal;
function isBackGround(Color: Integer): boolean;
procedure SendMouse(x1, y1, x2, y2: Integer);
function GetMapPos(i, j: integer): Tpoint;
function Search(var P1, P2: TPoint): boolean;
function isSameMap(Color1, Color2: integer): boolean;
procedure GetBox;
procedure SetMemData(hnd:THandle);
public
constructor Create;
destructor Destroy; override;
procedure AutoStart;
procedure RunStep;
procedure KillAll;
end;
function SetKbHook(threadid:DWORD):bool;stdcall; external 'kbhook.dll' ;
implementation
function StrToInt(const S: string): Integer;
var
E: Integer;
begin
Val(S, Result, E);
//if E <> 0 then ConvertErrorFmt(@SInvalidInteger, [S]);
end;
{ TLineGame }
{*************************************************
函数名: TLineGame.GetColor
描 述: 获取指定位置（屏幕坐标）的颜色值
参 数: x, y: Integer; var col: Cardinal
返回值: None
*************************************************}
procedure TLineGame.GetColor(x, y: Integer; var col: Cardinal);
var
WindowDC: THandle;
begin
WindowDC := GetWindowDC(gh);
col := GetPixel(WindowDC, x, y);
ReleaseDC(gh, WindowDC);
end;
{*************************************************
函数名: TLineGame.GetColorMx
描 述: 获取指定位置（对子矩阵坐标）的评估值
参 数: i, j: integer
返回值: Cardinal - 评估值
*************************************************}
function TLineGame.GetColorMx(i, j: integer): Cardinal;
var
x, y: integer;
col1, col2: Cardinal;
begin
x := gLeft + 14 + hwidth * i;
y := gTop + 18 + vwidth * j;
GetColor(x, y, col1);
x := x - 6;
GetColor(x, y, col2);
result := col1 + col2;
end;
{*************************************************
函数名: TLineGame.Search
描 述: 搜索可以消除的对子的位置
参 数: var P1, P2: TPoint 可以消除的对子坐标
返回值: boolean
*************************************************}
function TLineGame.Search(var P1, P2: TPoint): boolean;
var
i, j, k: integer;
LineList: TList;
begin
result := false;
for i := Low(ptlines) to High(ptlines) do
begin
LineList := ptLines[i];
for j := 0 to LineList.Count - 1 do
for k := j + 1 to LineList.Count - 1 do
begin
p1 := pPoint(LineList.Items[j])^;
p2 := pPoint(LineList.Items[k])^;
if CanConnect(p1, p2) then
begin
result := true;
Dispose(LineList.Items[k]);
LineList.Delete(k);
Maps[p1.X, p1.Y] := -2;
Dispose(LineList.Items[j]);
LineList.Delete(j);
Maps[p2.X, p2.Y] := -2;
exit;
end;
end;
end;
end;
{*************************************************
函数名: TLineGame.CanConnect
描 述: 判断两点是否连通
参 数: P1, P2: TPoint
返回值: boolean
*************************************************}
function TLineGame.CanConnect(P1, P2: TPoint): boolean;
var
mpt1, mpt2: TPoint;
begin
result := false;
if (p1.x = p2.X) and (p1.y = p2.Y) then
exit;
//可以直线相连
Result := Canline(P1, p2);
if result then
exit;
//一个拐点
mpt1.X := p1.X;
mpt1.Y := p2.Y;
Result := (isEmptyPt(mpt1)) and Canline(P1, mpt1) and Canline(mpt1, P2);
if result then
exit;
mpt1.X := p2.X;
mpt1.Y := p1.Y;
Result := (isEmptyPt(mpt1)) and Canline(P1, mpt1) and Canline(mpt1, P2);
if result then
exit;
//两个拐点
//以p1为基准
//获取y坐标方向的空点
mpt1.y := p1.Y;
mpt2.Y := p2.Y;
mpt1.X := p1.X - 1;
while (mpt1.x > -1) and (isEmptyPt(mpt1)) do
begin
mpt2.X := mpt1.X;
if isEmptyPt(mpt2) then
result := CanLine(mpt1, mpt2) and CanLine(mpt2, p2);
if result then
exit;
dec(mpt1.X);
end;
mpt1.X := p1.X + 1;
while (mpt1.x < MAP_VLENGTH) and (isEmptyPt(mpt1)) do
begin
mpt2.X := mpt1.X;
if isEmptyPt(mpt2) then
result := CanLine(mpt1, mpt2) and CanLine(mpt2, p2);
if result then
exit;
inc(mpt1.X);
end;
//获取x坐标方向的空点
mpt1.x := p1.x;
mpt2.x := p2.x;
mpt1.y := p1.y - 1;
while (mpt1.y > -1) and (isEmptyPt(mpt1)) do
begin
mpt2.y := mpt1.y;
if isEmptyPt(mpt2) then
result := CanLine(mpt1, mpt2) and CanLine(mpt2, p2);
if result then
exit;
dec(mpt1.y);
end;
mpt1.y := p1.y + 1;
while (mpt1.y < MAP_HLENGTH) and (isEmptyPt(mpt1)) do
begin
mpt2.y := mpt1.y;
if isEmptyPt(mpt2) then
result := CanLine(mpt1, mpt2) and CanLine(mpt2, p2);
if result then
exit;
inc(mpt1.y);
end;
end;
{*************************************************
函数名: TLineGame.CanLine
描 述: 判断两点是否可以直线相连
参 数: P1, P2: TPoint
返回值: Boolean
*************************************************}
function TLineGame.CanLine(P1, P2: TPoint): Boolean;
var
i: integer;
begin
result := false;
// 横1....1
if (p1.y = p2.Y) then
begin
if p1.x > p2.X then
begin
result := CanLine(P2, P1);
end
else
begin
result := true;
for i := p1.X + 1 to p2.X - 1 do
begin
result := Maps[i, p1.Y] = -2;
if not result then
exit;
end;
end;
end
else if (p1.x = p2.x) then // 竖
begin
if p1.y > p2.y then
begin
result := CanLine(P2, P1);
end
else
begin
result := true;
for i := p1.y + 1 to p2.y - 1 do
begin
result := Maps[p1.x, i] = -2;
if not result then
exit;
end;
end;
end;
end;
{*************************************************
函数名: TLineGame.isEmptyPt
描 述: 是否空白点
参 数: pt: TPoint
返回值: boolean
*************************************************}
function TLineGame.isEmptyPt(pt: TPoint): boolean;
begin
result := Maps[pt.X, pt.Y] = -2;
end;
{*************************************************
函数名: TLineGame.Create
描 述: 创建TlineGame类
参 数: None
返回值: None
*************************************************}
constructor TLineGame.Create;
var
i: integer;
Res: TResourceStream;
begin
LineMap := TStringList.Create;
Res := TResourceStream.Create(HInstance,'SRC1', PChar('FILE1'));
LineMap.LoadFromStream(res);
Res.Free;
for i := 1 to MAPCOUNT do
begin
ptLines[i] := TList.Create;
end;
end;
{*************************************************
函数名: TLineGame.Destroy
描 述: 消耗TLineGame类
参 数: None
返回值: None
*************************************************}
destructor TLineGame.Destroy;
var
i: integer;
begin
LineMap.Free;
for i := MAPCOUNT downto 1 do
begin
ptLines[i].Free;
end;
SetKbHook(0);
end;
{*************************************************
函数名: TLineGame.SetPtLines
描 述: 根据矩阵设置对子队列
参 数: None
返回值: None
*************************************************}
procedure TLineGame.SetPtLines;
var
i, j: integer;
pt: pPoint;
mapValue: integer;
begin
try
for i := 1 to MAPCOUNT do
for j := ptLines[i].Count - 1 downto 0 do
begin
Dispose(ptLines[i].Items[j]);
ptLines[i].Delete(j);
end;
for i := 0 to MAP_VLENGTH - 1 do
for j := 0 to MAP_HLENGTH - 1 do
begin
new(pt);
pt.X := i;
pt.Y := j;
mapValue := Maps[i, j];
if mapValue <> -2 then
begin
ptLines[mapValue].Add(pt);
end;
end;
except
end;
end;
{*************************************************
函数名: TLineGame.isSameMap
描 述: 判断两点是否相似，如相似则认为是同一类型的点
参 数: Color1, Color2: integer
返回值: boolean
*************************************************}
function TLineGame.isSameMap(Color1, Color2: integer): boolean;
var
r1, g1, b1: Integer;
r2, g2, b2: Integer;
begin
r1 := GetRValue(Color1);
g1 := GetGValue(Color1);
b1 := GetBValue(Color1);
r2 := GetRValue(Color2);
g2 := GetGValue(Color2);
b2 := GetBValue(Color2);
Result := (abs(r1 - r2) < 5) and (abs(g1 - g2) < 5) and (abs(b1 - b2) < 5)
end;
{*************************************************
函数名: TLineGame.GetMapIndex
描 述: 根据颜色值，判断其所属的类型队列的位置
参 数: Color: integer
返回值: integer
*************************************************}
function TLineGame.GetMapIndex(Color: integer): integer;
var
i: integer;
Color1: integer;
begin
result := -2;
for i := 0 to LineMap.Count - 1 do
begin
Color1 := StrToInt(LineMap.Names[i]);
if isSameMap(Color, Color1) then
begin
result := strtoint(LineMap.ValueFromIndex[i]);
exit;
end;
end;
end;
{*************************************************
函数名: TLineGame.LeftMapCount
描 述: 计算ptLine中剩余的点数
参 数: None
返回值: integer
*************************************************}
function TLineGame.LeftMapCount: integer;
var
i: integer;
begin
Result := 0;
for i := 1 to MAPCOUNT do
begin
inc(Result, ptLines[i].Count);
end;
end;
{*************************************************
函数名: TLineGame.GetBox
描 述: 获取游戏界面布局数据
参 数: None
返回值: None
*************************************************}
procedure TLineGame.GetBox;
var
i, j: Integer;
color1: Cardinal;
begin
gh := FindWindow(nil, PChar('QQ连连看'));
//生成数组
GetWindowRect(gh, Recta);
for i := 0 to MAP_VLENGTH - 1 do
for j := 0 to MAP_HLENGTH - 1 do
begin
color1 := GetColorMx(j, i);
if isBackGround(color1) then
maps[i, j] := -2
else
maps[i, j] := GetMapIndex(color1);
end;
end;
{*************************************************
函数名: TLineGame.isBackGround
描 述: 判断是否游戏中的背景
参 数: Color: Integer
返回值: boolean
*************************************************}
function TLineGame.isBackGround(Color: Integer): boolean;
var
r, g, b: Integer;
begin
r := GetRValue(Color);
g := GetGValue(Color);
b := GetBValue(Color);
Result := (Abs(110 - r) < 20) and (abs(154 - g) < 20) and (abs(236 - b) < 20);
end;
{*************************************************
函数名: TLineGame.GetMapPos
描 述: 获取对子矩阵中点在游戏中的位置
参 数: i, j: integer
返回值: Tpoint
*************************************************}
function TLineGame.GetMapPos(i, j: integer): Tpoint;
begin
result.x := Recta.Left + gLeft + 16 + hwidth * j;
result.y := recta.Top + gTop + 18 + vwidth * i;
end;
{*************************************************
函数名: TLineGame.SendMouse
描 述: 模拟发送消除对子的消息
参 数: x1, y1, x2, y2: Integer
返回值: None
*************************************************}
procedure TLineGame.SendMouse(x1, y1, x2, y2: Integer);
var
pos1, pos2: TPoint;
Recta: TRect;
begin
GetWindowRect(gh, Recta);
pos1 := GetMapPos(x1, y1);
PostMessage(gh, WM_LBUTTONDOWN, 0, MakeLong(pos1.X - Recta.Left, pos1.y -
Recta.Top));
Pos2 := GetMapPos(x2, y2);
PostMessage(gh, WM_LBUTTONDOWN, 0, MakeLong(pos2.X - Recta.Left, pos2.y -
Recta.Top));
end;
{*************************************************
函数名: TLineGame.RunStep
描 述: 消除一组对子
参 数:
返回值: None
*************************************************}
procedure TLineGame.RunStep();
var
p1, p2: TPoint;
begin
gh := FindWindow(nil, PChar('QQ连连看'));
SetMemData(gh);
GetBox;
SetPtLines;
if Search(p1, p2) then
begin
SendMouse(p1.X, p1.Y, p2.X, p2.Y);
end;
end;
{*************************************************
函数名: TLineGame.KillAll
描 述: 消除所有对子
参 数:
返回值: None
*************************************************}
procedure TLineGame.KillAll();
var
p1, p2: TPoint;
SearchFail: Boolean;
begin
gh := FindWindow(nil, PChar('QQ连连看'));
SetMemData(gh);
GetBox;
SetPtLines;
repeat
SearchFail := true;
while Search(p1, p2) do
begin
SearchFail := False;
SendMouse(p1.X, p1.Y, p2.X, p2.Y);
end;
until (LeftMapCount = 0) or SearchFail;
end;
{*************************************************
函数名: TLineGame.AutoStart
描 述: 自动开始游戏
参 数: None
返回值: None
*************************************************}
procedure TLineGame.AutoStart;
begin
gh := FindWindow(nil, PChar('QQ连连看'));
PostMessage(gh, WM_LBUTTONDOWN, 0, MakeLong(684, 532));
PostMessage(gh, WM_LBUTTONUP, 0, MakeLong(684, 532));
end;
procedure TLineGame.SetMemData(hnd: THandle);
var ThreadProcessID:integer;
begin
ThreadProcessID:=GetWindowThreadProcessId(hnd,nil);
if ThreadProcessID=FGameThreadID then exit;
FGameThreadID:=ThreadProcessID ;
SetKbHook(FGameThreadID);
end;
end.
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -