unit Unit1;
{
3D tic tac toe
events & control
}
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ExtCtrls, Buttons,shellapi;
type
TForm1 = class(TForm)
PaintBox1: TPaintBox;
msgtext: TStaticText;
backBtn: TImage;
Image2: TImage;
analyseBtn: TImage;
newBtn: TImage;
procedure FormCreate(Sender: TObject);
procedure PaintBox1Paint(Sender: TObject);
procedure PaintBox1MouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
procedure PaintBox1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure backBtnClick(Sender: TObject);
procedure newBtnClick(Sender: TObject);
procedure FormKeyPress(Sender: TObject; var Key: Char);
procedure analyse1BTnClick(Sender: TObject);
procedure Image2Click(Sender: TObject);
procedure Image4Click(Sender: TObject);
procedure Image1Click(Sender: TObject);
procedure analyseBtnClick(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
procedure AnalyseReport(p,score : byte);
var
Form1: TForm1;
implementation
{$R *.dfm}
uses unit2;
type TPlane = record
left : word;
top : word;
square : word;
end;
TPosTriple = record
column : byte;
row : byte;
plane : byte;
end;
TGameStatus = (gsInitializing,gsAnalysing,gsMoving,gsEnd);
TGameUpdate = (guMove,guWin,guAnalyseBtn,guNewBtn,guBackBtn);
const planes : array[0..2] of TPlane =
((left : 20; top : 450; square : 80),
(left : 280; top : 220; square : 70),
(left : 510; top : 20; square : 60));
fw = 9; //frame width
gameBGcolor = $feffff;
markcolor = $00b0ff;
chdef : array[1..2] of char = ('O','X');
playercolors : array[1..2] of dword = ($0000ff,$ff0000);
procedure GameControl(gum : TGameUpdate);forward;
procedure displaymover;forward;
var selectfield : byte;
gamestatus : TGamestatus;
wintriple : Twintriple;
Fwintriple : boolean;
Fscores : boolean;
scores : array[1..maxmove] of byte;
//-- helpers
procedure msgproc(s : string; colr : dword);
begin
with form1.msgtext do
begin
font.color := colr;
caption := s;
end;
end;
function playerColor(pl: byte) : dword;
//return color of player;
begin
result := playercolors[pl];
end;
procedure multiline(x1,y1,x2,y2: word; w : byte; colr : dword);
//paint 5 fold line (x1,y1) --> (x2,y2) in paintbox1
var i : byte;
begin
with form1.PaintBox1.Canvas do
begin
pen.Width := 1;
pen.Color := colr;
for i := 0 to w-1 do
begin
moveto(x1+i,y1-i);
lineto(x2+i,y2-i);
end;
end;
end;
procedure paintedges(im : Timage);
var i : byte;
begin
with im.Picture.bitmap do with canvas do
for i := 0 to 2 do
begin
pen.color := $606060;
moveto(width-1-i,i);
lineto(i,i);
lineto(i,height-1-i);
pen.color := $a0a0a0;
lineto(width-1-i,height-1-i);
lineto(width-1-i,i);
end;
end;
function pos2triple(p : byte) : TPosTriple;
//convert position p to column,row,plane
begin
with result do
begin
dec(p);
column := p mod 3;
p := p div 3;
row := p mod 3;
plane := p div 3;
end;
end;
function triple2Pos(tr : TPosTriple) : byte;
//convert column,row,plane to position
begin
with tr do result := column + 3*row + 9*plane + 1;
end;
function pos2Rect(p : byte) : Trect;
//calculate rectangle of a field [0..26]
var tr : Tpostriple;
begin
tr := pos2triple(p);
with tr do with planes[tr.plane] do
begin
result.left := left + square*column;
result.top := top + square*row;
result.Right := result.Left + square;
result.Bottom := result.Top + square;
inc(result.Left,fw);
dec(result.Bottom,fw);
end;
end;
function xy2field(x,y : word) : byte;
//convert mousex,y to field
//no field = 0
var hit : boolean;
r : Trect;
i : byte;
begin
hit := false;
i := 0;
while (hit = false) and (i < maxmove) do
begin
inc(i);
r := pos2rect(i);
hit := (x > r.Left) and (x < r.Right) and
(y > r.top ) and (y < r.Bottom);
end;//while
if hit then result := i else result := 0;
end;
procedure paintfield(nr : byte; bg : dword);
var tr : TPosTriple;
i,cc,w : byte;
r : Trect;
begin
cc := game[nr];
r := pos2rect(nr);
with form1.PaintBox1.Canvas do
begin
brush.style := bsSolid;
brush.Color := bg;
fillrect(r);
if cc > 0 then
begin
tr := pos2Triple(nr);
w := planes[tr.plane].square;
r.Left := r.Left + (w div 4);
brush.Style := bsClear;
font.height := w-18;
if cc = 1 then font.Color := $0000ff else font.color := $ff0000;
for i := 0 to fw-1 do textout(r.left - i,r.top + i,chdef[cc]);
end;//if cc
end;//with
end;
procedure paintgame;
var i : byte;
begin
for i := 1 to maxmove do paintfield(i,gameBGcolor);
end;
procedure paintframe;
var i,j,k,sq,sq3 : byte;
x,y,x1,y1 : word;
begin
for i := 0 to 2 do
begin
x1 := planes[i].left;
y1 := planes[i].top;
sq := planes[i].square;
sq3 := sq*3;
for j := 0 to 3 do multiline(x1,y1+sq*j,x1+sq3,y1+sq*j,fw,$c0c0c0); //hor
for j := 0 to 3 do multiline(x1+sq*j,y1,x1+sq*j,y1+sq3,fw,$808080); //vert
for j := 0 to 2 do
begin
y := y1 + sq*j;
for k := 0 to 2 do
begin
x := x1+sq*k;
multiline(x,y,x+fw,y,fw,$c0c0c0);//fix
end;
end;
end;
end;
procedure markwinner;
begin
Fwintriple := true;
with wintriple do
begin
paintfield(p1,markcolor);
paintfield(p2,markcolor);
paintfield(p3,markcolor);
end;
end;
procedure unmarkwinner;
begin
if Fwintriple then
with wintriple do
begin
Fwintriple := false;
paintfield(p1,gameBGcolor);
paintfield(p2,gameBGcolor);
paintfield(p3,gameBGcolor);
end;
end;
//-- call from analyser
procedure analysereport(p,score : byte);
//report analysis of move in position p
var r : Trect;
s : string;
m : byte;
colr : dword;
begin
Fscores := true; //scores painted
scores[p] := score;
m := 1 + (moveNr and 1); //next move
colr := playercolor(m);
with form1.PaintBox1.Canvas do
begin
font.Color := colr;
font.Height := 18;
brush.Style := bsClear;
s := '';
if score > 50 then s := 'W' + inttostr(101-score);
if (score > 0) and (score < 50) then s := 'L' + inttostr(score + 1);
if score = 50 then s := '=';
r := pos2rect(p);
textout(r.Left,r.Top,s);
end;
application.ProcessMessages;//show data
end;
//-- events
procedure TForm1.FormCreate(Sender: TObject);
begin
paintedges(newBtn);
paintedges(backBtn);
paintedges(analysebtn);
gamestatus := gsInitializing;
makewinlist;
initgame;
selectfield := 0;
paintbox1.Cursor := crArrow;
gamestatus := gsMoving;
displaymover;
end;
procedure TForm1.PaintBox1Paint(Sender: TObject);
var x1,y1,x2,y2 : word;
i,w1,w2 : byte;
begin
with PaintBox1 do with canvas do
begin
brush.color := gameBGcolor;
brush.Style := bsSolid;
fillrect(rect(0,0,width,height));
x1 := 0;
y1 := 0;
x2 := width-1;
y2 := height-1;
pen.Width := 1;
for i := 0 to 4 do
begin
pen.color := $e0e0e0 - abs(1-i)*$101010;
moveto(x2-i,y1+i);
lineto(x1+i,y1+i);
lineto(x1+i,y2-i);
pen.Color := $e0e0e0 - abs(3-i)*$101010;
lineto(x2-i,y2-i);
lineto(x2-i,y1+i);
end;
pen.color := $606060;
x1 := planes[0].left;
y1 := planes[0].top;
x2 := planes[2].left;
y2 := planes[2].top;
moveto(x1,y1);
lineto(x2,y2);
w1 := planes[0].square*3;
moveto(x1+w1,y1+w1);
w2 := planes[2].square*3;
lineto(x2+w2,y2+w2);
end;
paintframe;
paintgame;
end;
procedure TForm1.PaintBox1MouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
var p : byte;
begin
if (gamestatus = gsMoving) then
begin
p := xy2field(x,y); //no field --> 27
if p <> selectfield then
begin
with paintbox1 do
if (p > 0) and (game[p]=0) then cursor := crHandpoint
else cursor := crArrow;
selectfield := p;
end;
end;
end;
procedure TForm1.PaintBox1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
if (gamestatus = gsMoving) and (selectfield > 0) then
gameControl(guMove);
end;
procedure TForm1.backBtnClick(Sender: TObject);
begin
gamecontrol(guBackBtn);
end;
procedure TForm1.newBtnClick(Sender: TObject);
begin
gameControl(guNewBtn);
end;
procedure TForm1.FormKeyPress(Sender: TObject; var Key: Char);
begin
if key = #08 then gamecontrol(guBackBtn);
end;
procedure TForm1.analyse1BTnClick(Sender: TObject);
begin
gamecontrol(guAnalyseBtn);
end;
procedure TForm1.Image2Click(Sender: TObject);
begin
ShellExecute(0,'open','http://www.davdata.nl/math/', nil, nil, SW_SHOWNORMAL);
end;
procedure TForm1.Image4Click(Sender: TObject);
begin
gameControl(guNewBtn);
end;
procedure TForm1.Image1Click(Sender: TObject);
begin
gamecontrol(guBackBtn);
end;
procedure TForm1.analyseBtnClick(Sender: TObject);
begin
gamecontrol(guAnalyseBtn);
end;
//-- control helpers
procedure displaymover;
//write O,X message
var p : byte;
begin
p := 1 + (moveNr and 1);
msgproc(chdef[p] + ' move',playercolor(p));
end;
procedure moveproc;
var s : string;
m : byte;
begin
if Fscores then
begin
Fscores := false;
paintgame;
end;
s := '';
inc(moveNr);
m := 2 - (moveNr and 1);
game[selectfield] := m;
paintfield(selectfield,gameBGcolor);
node[moveNr].pos := selectfield;
selectfield := 100;
form1.PaintBox1.Cursor := crArrow;
if checkwin(wintriple,m) then
begin
s := chdef[m] + ' wins. ';
markwinner;
gamestatus := gsEnd;
end;
if moveNr = maxmove then
begin
s := s + 'End of game.';
gamestatus := gsEnd;
end;
if gamestatus = gsMoving then displaymover
else msgproc(s,$000000);
end;
procedure backproc;
var p : byte;
begin
unmarkwinner;
if Fscores then
begin
Fscores:= false;
paintgame;
end;
if moveNr > 0 then
begin
p := node[movenr].pos;
game[p] := 0;
paintfield(p,gameBGcolor);
dec(moveNr);
displaymover;
gamestatus := gsMoving;
end;
end;
procedure newproc;
begin
gamestatus := gsInitializing;
initgame;
paintgame;
gamestatus := gsMoving;
displaymover;
end;
procedure analyseproc;
var i : byte;
begin
for i := 1 to maxmove do scores[i] := 0;
gamestatus := gsAnalysing;
msgproc('analysing, please wait...',$000000);
analyse;
gamestatus := gsMoving;
displaymover;
end;
procedure GameControl(gum : TGameUpdate);
begin
case gamestatus of
gsMoving : case gum of
guMove : moveproc;
guBackBtn : backproc;
guAnalyseBtn : analyseproc;
guNewBtn : newproc;
end;//case
gsEnd : case gum of
guNewBtn : newproc;
guBackBtn : backproc;
end;//case
end;//case
end;
end.
see Delphi unit2