unit _fm_Main;
interface
uses
Windows, Messages, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls,
ExtCtrls, Grids, Buttons, SysUtils, ComCtrls, Menus, ImgList, IniFiles,
FMXUtils, ToolWin, JPEG, Registry;
type
Tfm_Main = class(TForm)
Panel1 : TPanel;
sg : TStringGrid;
Timer1 : TTimer;
ilMainActive: TImageList;
ilPlayers : TImageList;
ilMainHot : TImageList;
ilAddHot : TImageList;
CoolBar1 : TCoolBar;
ToolBar1 : TToolBar;
tbDic : TToolButton;
tbSetup : TToolButton;
ToolButton02: TToolButton;
tbSaveGame: TToolButton;
tbLoadGame: TToolButton;
tbAbout : TToolButton;
tbHelp : TToolButton;
ToolButton04: TToolButton;
sd : TSaveDialog;
ToolButton01: TToolButton;
tbLang : TToolButton;
Panel3 : TPanel;
stTime : TStaticText;
Panel4 : TPanel;
sb1 : TSpeedButton;
sb2 : TSpeedButton;
sb3 : TSpeedButton;
sb4 : TSpeedButton;
sb5 : TSpeedButton;
cb1 : TComboBox;
sg1 : TStringGrid;
sg2 : TStringGrid;
st2 : TStaticText;
cb2 : TComboBox;
cb3 : TComboBox;
st3 : TStaticText;
sg3 : TStringGrid;
sg4 : TStringGrid;
st4 : TStaticText;
cb4 : TComboBox;
cb5 : TComboBox;
st5 : TStaticText;
sg5 : TStringGrid;
st1 : TStaticText;
pa2 : TPanel;
I2 : TImage;
pa1 : TPanel;
I1 : TImage;
laPlayers : TLabel;
laNetMsg : TStaticText;
tmGame : TTimer;
pmLang : TPopupMenu;
English : TMenuItem;
Deutsch : TMenuItem;
Russian : TMenuItem;
ilPopupMenu: TImageList;
tmNetMsg : TTimer;
od : TOpenDialog;
ilAddActive: TImageList;
Image1 : TImage;
Image2 : TImage;
ToolButton05: TToolButton;
meAphor : TLabel;
Image3 : TImage;
ToolButton03: TToolButton;
ToolButton06: TToolButton;
ToolBar2 : TToolBar;
ToolBar3 : TToolBar;
tbPlay : TToolButton;
ToolButton1: TToolButton;
tbNet : TToolButton;
ToolButton7: TToolButton;
tbSkip : TToolButton;
ToolButton2: TToolButton;
tbSuggest : TToolButton;
ToolButton3: TToolButton;
tbBack : TToolButton;
ToolButton4: TToolButton;
tbHistory : TToolButton;
ToolButton5: TToolButton;
tbExit : TToolButton;
laPoints : TLabel;
btTop : TSpeedButton;
laLetters : TLabel;
anComp : TAnimate;
pmPlayers : TPopupMenu;
N11 : TMenuItem;
N21 : TMenuItem;
N31 : TMenuItem;
N41 : TMenuItem;
procedure btRefreshClick(Sender: TObject);
procedure sgSelectCell(Sender: TObject; ACol, ARow: Integer;
var CanSelect: Boolean);
procedure FormCreate(Sender: TObject);
procedure sgDrawCell(Sender: TObject; ACol, ARow: Integer; Rect: TRect;
State: TGridDrawState);
procedure sb345Click(Sender: TObject);
procedure tbBackClick(Sender: TObject);
procedure sg1DrawCell(Sender: TObject; ACol, ARow: Integer;
Rect: TRect; State: TGridDrawState);
procedure sg1DragOver(Sender, Source: TObject; X, Y: Integer;
State: TDragState; var Accept: Boolean);
procedure sg1DragDrop(Sender, Source: TObject; X, Y: Integer);
procedure sg1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure tbPlayClick(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
procedure tbExitClick(Sender: TObject);
procedure tbSkipClick(Sender: TObject);
procedure btSuggestClick(Sender: TObject);
procedure btDicClick(Sender: TObject);
procedure tbAboutClick(Sender: TObject);
procedure tbHistoryClick(Sender:
TObject);
procedure tbSaveGameClick(Sender:
TObject);
procedure tbLoadGameClick(Sender:
TObject);
procedure tbHelpClick(Sender:
TObject);
procedure tbSetupClick(Sender:
TObject);
procedure cb2Change(Sender:
TObject);
procedure tbLangClick(Sender:
TObject);
procedure tmGameTimer(Sender:
TObject);
procedure FormActivate(Sender:
TObject);
procedure SetLangClick(Sender:
TObject);
procedure FormClose(Sender:
TObject; var Action:
TCloseAction);
procedure btTopMouseMove(
Sender: TObject; Shift:
TShiftState; X,
Y: Integer);
procedure btTopMouseDown(
Sender: TObject; Button:
TMouseButton;
Shift: TShiftState; X, Y:
Integer);
procedure btTopClick(
Sender: TObject);
procedure sb12Click(
Sender: TObject);
procedure cb1DrawItem(
Control: TWinControl;
Index: Integer;
Rect: TRect; State:
TOwnerDrawState);
procedure cbDropDown(
Sender: TObject);
procedure tbNetClick(
Sender: TObject);
procedure FormDestroy
(Sender: TObject);
procedure
FormKeyDown(Sender:
TObject; var Key:
Word;
Shift : TShiftState);
procedure
laPlayersClick(
Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
procedure
ShowSuggestion(
Sender: TObject);
procedure
ShowComputerStep(
Sender: TObject);
procedure
RegisterExtension(
Ext:string;
DoRegister:boolean);
procedure
LoadAVIfromEXE;
end;
Tgs = (gsNoGame, gsJustStarted, gsGame);
Tcell = record
Letter: char;
Color: byte;
Weight: byte;
JustSet: boolean;
end;
TPlayer = record
Button: TSpeedButton;
Name: TComboBox;
Rec: TStaticText;
Letters: array[1..7] of char;
LettersObj: TDrawGrid;
IP: string[15];
end;
TPattern = record
DirHor: boolean;
FixPos: TPoint;
MaxL,MaxR: integer;
Pattern: ShortString;
end;
TPlayerMove = record
PlayerName: string;
DirHor: boolean;
Pos: TPoint;
Word: ShortString;
Points: integer;
Total: integer;
UsedLetters: ShortString;
ReceivedLetters: ShortString;
end;
TLanguage = (lgNone, lgENU, lgDEU, lgRUS);
TName = record
Name,
Points,
CoolWord: string;
end;
TTopAction = (taNone, taShow, taHide);
TDraft = record
Word: string;
PattNo,
WCol,
WRow: integer;
end;
const
{-------------------------------------------------------------------------}
_ProductVersion = '3.0';
_ProductVerDate = '21.04.2003';
_ProductOwner = '';
_ProductID = 'The Erudite Saved Game';
MaxWordLength = 15;
MaxPlayers = 5;
MaxLetters = 7;
MaxPatterns = 10240;
// Макс количество возможно найденных шаблонов или слов
// (с двойным запасом).
// Тестированием удалось достигнуть макс.: 5500 слов.
// При этом игрок имел на руках только звезд
очки.
MaxMoves = 255;
SuggestionValue = 3;
All7Bonus = 7;
myRed = $004F4FFF;
myBlue = $00FF9240;
myYellow = $0080FFFF;
myGreen = $0040FF40;
myGray = $007F7F7F;
myWindow = $00C0C0C0;
myWhite = clWhite;
myJustSet = $00532E2B;
myLetterBk = $00000000;
myLetter = $00FFFFFF;
myOffset = $00808080;
myActiveP = $007FFFFF;
var
{---------------------------------------------------------------------------}
fm_Main : Tfm_Main;
Field,Field2 : array[0..MaxWordLength,0..MaxWordLength] of Tcell;
Players,Players2 : array[1..MaxPlayers] of TPlayer;
{Players array}
PCurrent : byte;
{Current Player}
PCNo : byte;
sWord : string;
{Current Word}
WordCross : array[1..MaxWordLength] of Boolean;
{Array of Crossing}
SCol,SRow : integer;
{Current Word: Position}
WordDirHor: boolean;
{Current Word: Direction }
WordIllegal: boolean;
{Current Word: Status}
WWeight : integer;
{Last Word Weight}
GameState : Tgs;
{Current Game State: gsGame / gsNoGame}
EMessage : string;
Patterns : array[1..MaxPatterns] of TPattern;
PatternsCount: Integer;
Suggested : boolean;
UserSkip : boolean;
UserTime : Single;
FoundedWords,
TheBestWordNo: integer;
Drafts : array[1..MaxPatterns] of TDraft;
PlayerMove: array[1..MaxMoves] of TPlayerMove;
PlayerMoves: integer;
TopNames : array[0..9] of TName;
TopAction : TTopAction;
f1 : textfile;
FileName : shortstring;
CurrDir : string;
FacesCount: byte;
FacesUsed : array[1..255] of boolean;
AnimNow : boolean;
AnimDir : Integer;
AnimLetters: string;
{Setups}
ShowTips,
Animation : boolean;
Difficulty: byte;
TimeLimit : integer;
AutoSave : boolean;
AutoLoad : boolean;
Network : boolean;
CurrentLanguage: TLanguage;
UserName : string;
{Network}
NetRes : array[1..200] of string[20];
NetResCount: integer;
NetPlayerName,
NetPlayerIP: string[20];
_NetSelfName: array [0..MAX_COMPUTERNAME_LENGTH] of char;
NetSelfName: string;
HeadMaster: string[MAX_COMPUTERNAME_LENGTH+1];
//Name of Head Computer in NW Game
NetStartTime: TDateTime;
{Alfa channel effects----------------------------------------------------------}
const
WS_EX_LAYERED = $80000;
LWA_ALPHA = 2;
type
TSetLayeredWindowAttributes =
function (
hwnd : HWND; // handle to the layered window
crKey : TColor; // specifies the color key
bAlpha : byte; // value for the blend function
dwFlags : DWORD // action
): BOOL;
stdcall;
var
SetLayeredWindowAttributes:
TSetLayeredWindowAttributes
;
_iWindowExStyle: cardinal;
procedure SetOpacity(hwnd: THandle; Value:integer);
{------------------------------------------------------------------------------}
function LWeight(Letter:char): integer;
function CheckWordLayout: boolean;
function WordWeight: integer;
{Расчет веса слова}
function FieldNextCell(Index:integer):
Tcell
;
function SeaCheck(SCol,SRow:integer;
DirHor:boolean): boolean;
function Ending(Num:integer): string;
procedure WriteWord;
procedure CheckForUnique;
procedure NextPlayer;
procedure RepaintAll;
procedure LoadDictionary(OldLang:
TLanguage);
procedure LoadJPEGfromEXE;
implementation
{================================================================}
uses _fm_Top, _fm_Word, _fm_
WordC, Computer, _fm_DMan, _fm_
PMoves,
_fm_Sugg, _fm_Skip, _fm_Setup,
LangSupp, _fm_Net, _fm_About;
var
{---------------------------------------------------------------------------}
Multiply : integer;
{Multiply Weight}
StartDragX: Integer;
{for Dragging in Player's Letters}
DestCol,DestRow : LongInt;
AnimLeftA,AnimLeftB : Integer;
AWidth,AHeight,BWidth,BHeight : Integer;
PCurrentMov: byte;
{$R *.DFM}
{$R ADDON.RES}
{------------------------------------------------------------------------------}
function RandomLetter: char;
var
lr : array['а'..'я'] of integer;
le : array['a'..'z'] of integer;
ld : array['a'..'z'] of integer;
lt : integer;
r : real;
i : char;
begin
lt := 0;
r := 0;
i := ' ';
{Для каждой буквы записана величина, пропорциональная вероятности ее появления}
case CurrentLanguage of
lgRUS: begin
lr['а'] := 100;
lr['б'] := 20;
lr['в'] := 30;
lr['г'] := 20;
lr['д'] := 20;
lr['е'] := 50;
lr['ж'] := 7;
lr['з'] := 20;
lr['и'] := 60;
lr['й'] := 3;
lr['к'] := 60;
lr['л'] := 50;
lr['м'] := 20;
lr['н'] := 50;
lr['о'] := 100;
lr['п'] := 40;
lr['р'] := 60;
lr['с'] := 60;
lr['т'] := 60;
lr['у'] := 30;
lr['ф'] := 5;
lr['х'] := 10;
lr['ц'] := 5;
lr['ч'] := 14;
lr['ш'] := 10;
lr['щ'] := 2;
lr['ъ'] := 1;
lr['ы'] := 10;
lr['ь'] := 20;
lr['э'] := 1;
lr['ю'] := 4;
lr['я'] := 30;
lt := 30;
// ['*']
for i:='а' to 'я' do
lt:=lt + lr[i];
r := Random(lt);
lt := 0;
for i:='а' to 'я' do begin
lt := lt + lr[i];
if lt > r then
break;
end;
end;
lgENU: begin
le['a'] := 250;
le['b'] := 50;
le['c'] := 120;
le['d'] := 140;
le['e'] := 450;
le['f'] := 80;
le['g'] := 70;
le['h'] := 170;
le['i'] := 260;
le['j'] := 4;
le['k'] := 25;
le['l'] := 170;
le['m'] := 90;
le['n'] := 240;
le['o'] := 300;
le['p'] := 90;
le['q'] := 6;
le['r'] := 230;
le['s'] := 250;
le['t'] := 360;
le['u'] := 100;
le['v'] := 35;
le['w'] := 60;
le['x'] := 15;
le['y'] := 60;
le['z'] := 5;
lt := 100;
// ['*']
for i:='a' to 'z' do
lt:=lt + le[i];
r := Random(lt);
lt := 0;
for i:='a' to 'z' do begin
lt := lt + le[i];
if lt > r then
break;
end;
end;
lgDEU: begin
ld['a'] := 250;
ld['b'] := 50;
ld['c'] := 120;
ld['d'] := 140;
ld['e'] := 450;
ld['f'] := 80;
ld['g'] := 70;
ld['h'] := 170;
ld['i'] := 260;
ld['j'] := 4;
ld['k'] := 25;
ld['l'] := 170;
ld['m'] := 90;
ld['n'] := 240;
ld['o'] := 300;
ld['p'] := 90;
ld['q'] := 6;
ld['r'] := 230;
ld['s'] := 250;
ld['t'] := 360;
ld['u'] := 100;
ld['v'] := 35;
ld['w'] := 60;
ld['x'] := 15;
ld['y'] := 5;
ld['z'] := 60;
lt := 100;
// ['*']
for i:='a' to 'z' do
lt:=lt + ld[i];
r := Random(lt);
lt := 0;
for i:='a' to 'z' do begin
lt := lt + ld[i];
if lt > r then
break;
end;
end;
end;
{CASE}
if lt > r then
Result := i
else
Result := '*';
end;
{------------------------------------------------------------------------------}
function Ending(Num:integer): string;
begin
Result := '';
case CurrentLanguage of
lgRUS:
case Num of
1, 21, 31, 41, 51, 61, 71, 81, 91:
Result := 'о';
2..4, 22..24, 32..34, 42..44, 52..54, 62..64, 72..74, 82..84, 92..94:
Result := 'а';
else
Result := 'ов';
end;
lgENU:
if Num>1 then
Result := 's';
lgDEU:
if Num>1 then
Result := 'e';
end;
end;
{------------------------------------------------------------------------------}
function LWeight(Letter:char): integer;
begin
Result := 0;
case CurrentLanguage of
lgRUS: begin
if not (Letter in ['а'..'я','*']) then begin
MessageDlg(Format(_M_mLNotReg,[Letter]), mtError, [mbOk], 0);
Result := -1;
exit;
end;
if Letter in ['а','е','и','н','о'] then
Result := 1;
if Letter in ['в','д','й','к','л','м','п','р','с','т'] then
Result := 2;
if Letter in ['б','г','у','я'] then
Result := 3;
if Letter in ['ж','з','х','ч','ы','ь'] then
Result := 5;
if Letter in ['ф','ц','ш','щ','ъ','э','ю'] then
Result := 10;
end;
lgENU: begin
if not (Letter in ['a'..'z','*']) then begin
MessageDlg(Format(_M_mLNotReg,[Letter]), mtError, [mbOk], 0);
Result := -1;
exit;
end;
if Letter in ['a','e','i','n','o','r','s','t'] then
Result := 1;
if Letter in ['c','d','h','l','m','p','u','k'] then
Result := 2;
if Letter in ['b','f','g','y'] then
Result := 3;
if Letter in ['x','v','w'] then
Result := 5;
if Letter in ['j','q','z'] then
Result := 10;
end;
lgDEU: begin
if not (Letter in ['a'..'z','*']) then begin
MessageDlg(Format(_M_mLNotReg,[Letter]), mtError, [mbOk], 0);
Result := -1;
exit;
end;
if Letter in ['a','e','i','n','o','r','s','t'] then
Result := 1;
if Letter in ['c','d','h','l','m','p','u','k'] then
Result := 2;
if Letter in ['b','f','g','z'] then
Result := 3;
if Letter in ['x','v','w'] then
Result := 5;
if Letter in ['j','q','y'] then
Result := 10;
end;
end;
{CASE}
end;
{------------------------------------------------------------------------------}
procedure CheckForUnique;
var
i : integer;
WordUC : string;
begin
EMessage := '';
WordUC := '"' + AnsiUpperCase(sWord) + '"';
for i:=1 to PlayerMoves do
if Trim(PlayerMove[i].Word)=WordUC then
EMessage := Format(_M_mWUsed,[WordUC]);
end;
{------------------------------------------------------------------------------}
procedure RepaintAll;
begin
fm_Main.sg.Repaint;
fm_Main.sg1.Repaint;
fm_Main.sg2.Repaint;
fm_Main.sg3.Repaint;
fm_Main.sg4.Repaint;
fm_Main.sg5.Repaint;
fm_Main.ToolBar1.Repaint;
end;
{ $ I Computer.pas}
{------------------------------------------------------------------------------}
procedure Tfm_Main.ShowComputerStep;
var
i : integer;
begin
WordIllegal := true;
//?
while (FoundedWords>0) and (WordIllegal) do begin
SearchBestWord;
if not UserSkip then
fm_WordC.ShowModal;
end;
{while}
fm_Main.anComp.Active := false;
Screen.Cursor := crDefault;
{Компьютер подумал!}
{Остановить время}
fm_Main.tmGame.Enabled := false;
if WordIllegal then begin
MessageDlg(_M_mISkip, mtInformation, [mbOk], 0);
UserSkip := true;
sWord := '';
for i:=1 to 7 do
if (Difficulty<3) or (Players[PCurrent].Letters[i]<>'*') then
sWord := sWord + Players[PCurrent].Letters[i];
{Переход хода}
NextPlayer;
exit
end;
{Все в порядке; Компьютер благополучно сходил----------------------------------}
GameState := gsGame;
{Сохранение предыдущего состояния поля}
// Field2 := Field;
{Заполение массива поля новым словом}
WriteWord;
{Запись счета}
MessageDlg(Format(_M_mIPoints,[WWeight,Ending(WWeight)]), mtInformation, [mbOk], 0);
Players[PCurrent].Rec.Caption := IntToStr(StrToInt(Players[PCurrent].Rec.Caption)+
WWeight);
// Players[PCurrent].Points := Players[PCurrent].Points + WWeight;
{Переход хода}
NextPlayer;
end;
{------------------------------------------------------------------------------}
procedure ComputerStep;
begin
RepaintAll;
{Компьютер думает ...}
fm_Main.anComp.Active := true;
Screen.Cursor := crAppStart;
if GameState=gsGame then
SearchPatterns
else
SearchPatternsFirst;
FindMultiPatterns;
with fm_Main do
with TGetListOfWords.Create do
OnTerminate:=ShowComputerStep;
end;
{------------------------------------------------------------------------------}
procedure NextPlayer;
var
i : byte;
s : string;
c : char;
begin
EMessage := '';
fm_Main.tbBack.Enabled := true;
{Отмена выделения цветом текущего игрока}
Players[PCurrent].Name.Color := clWindow;
Players[PCurrent].Rec.Color := clWindow;
{Отмена флага о подсказке}
Suggested := false;
{Сохранение предыдущих букв игрока}
if Trim(Players[PCurrent].Name.Text)<>_M_sPPCName then
Players2 := Players;
{Запись хода в архив ходов}
inc(PlayerMoves);
PlayerMove[PlayerMoves].PlayerName := Players[PCurrent].Name.Text;
PlayerMove[PlayerMoves].DirHor := WordDirHor;
PlayerMove[PlayerMoves].Pos := Point(SCol,SRow);
if not UserSkip then
PlayerMove[PlayerMoves].Word := '"' + AnsiUpperCase(sWord) + '"'
else
PlayerMove[PlayerMoves].Word := _M_sSkip;
PlayerMove[PlayerMoves].Points := WWeight;
PlayerMove[PlayerMoves].Total := StrToInt(Players[PCurrent].Rec.Caption);
PlayerMove[PlayerMoves].UsedLetters := '';
{Заполняется чуть ниже}
PlayerMove[PlayerMoves].ReceivedLetters := '';
{Заполняется чуть ниже}
{Удаление у игрока букв, выложенных на поле}
s := '';
for i:=1 to 7 do
s:=s + Players[PCurrent].Letters[i];
for i:=1 to length(sWord) do begin
if not WordCross[i] then
if (Pos(sWord[i],s)<>0) then begin
Delete(s,Pos(sWord[i],s),1);
PlayerMove[PlayerMoves].UsedLetters := PlayerMove[PlayerMoves].UsedLetters +
' ,' + AnsiUpperCase(sWord[i]);
end
else if (Pos('*',s)<>0) then begin
Delete(s,Pos('*',s),1);
PlayerMove[PlayerMoves].UsedLetters := PlayerMove[PlayerMoves].UsedLetters +
' ,' + '*';
end
else begin
MessageDlg(Format(_M_mLNotPC,[sWord[i]]), mtWarning, [mbOk], 0);
end;
end;
if not UserSkip then
Delete(PlayerMove[PlayerMoves].UsedLetters,1,2);
{В "s" мы получили список оставшихся букв}
if (s='') and (not UserSkip) then begin
MessageDlg(Format(_M_mBonus, [MaxPlayers, All7Bonus]), mtInformation, [mbOk], 0);
Players[PCurrent].Rec.Caption :=
IntToStr(StrToInt(Players[PCurrent].Rec.Caption) + 15);
PlayerMove[PlayerMoves].Points := WWeight + 15;
PlayerMove[PlayerMoves].Total := StrToInt(Players[PCurrent].Rec.Caption);
end;
{Группировка оставшихся букв и добавление новых букв}
for i:=1 to Length(s) do
Players[PCurrent].Letters[i]:=s[i];
for i:=Length(s)+1 to 7 do begin
c := RandomLetter;
Players[PCurrent].Letters[i] := c;
PlayerMove[PlayerMoves].ReceivedLetters := PlayerMove[PlayerMoves].ReceivedLetters +
' ,' + AnsiUpperCase(c);
end;
Delete(PlayerMove[PlayerMoves].ReceivedLetters,1,2);
if sWord<>'' then
Players[PCurrent].LettersObj.Col := Length(s);
Players[PCurrent].LettersObj.Repaint;
{Расчет номера следующего игрока}
repeat
inc(PCurrent)
until (PCurrent>MaxPlayers) or (Players[PCurrent].Name.Visible);
if PCurrent>MaxPlayers then
PCurrent := 1;
{Выделения цветом текущего игрока}
Players[PCurrent].Name.Color := myActiveP;
Players[PCurrent].Rec.Color := myActiveP;
{Перерисовали экран}
RepaintAll;
UserSkip := false;
UserTime := 0;
fm_Main.tmGame.Enabled := Boolean(TimeLimit);
fm_Main.stTime.Color := clBtnFace;
fm_Main.stTime.Caption := '0:00:00';
if Trim(Players[PCurrent].Name.Text)=_M_sPPCName then
ComputerStep;
end;
{------------------------------------------------------------------------------}
procedure PrevPlayer;
begin
(*
Players[PCurrent].Name.Color:=clWindow;
Players[PCurrent].Rec.Color:=clWindow;
*)
repeat
dec(PCurrent)
until (PCurrent<1) or (Players[PCurrent].Name.Visible);
if PCurrent<1 then
PCurrent := MaxPlayers;
while not Players[PCurrent].Name.Visible do
dec(PCurrent);
(*
Players[PCurrent].Name.Color:=myActiveP;
Players[PCurrent].Rec.Color:=myActiveP;
*)
// Players[PCurrent].Rec.Caption := IntToStr(StrToInt(Players[PCurrent].Rec.Caption) -
WWeight);
Players[PCurrent].Rec.Caption := IntToStr(StrToInt(Players[PCurrent].Rec.Caption)
- PlayerMove[PlayerMoves].Points);
PlayerMove[PlayerMoves].Word := '';
dec(PlayerMoves);
if Trim(Players[PCurrent].Name.Text)=_M_sPPCName then
PrevPlayer;
//ComputerStep;
{Reset timer}
UserTime := 0;
fm_Main.tmGame.Enabled := Boolean(TimeLimit);
fm_Main.stTime.Color := clBtnFace;
fm_Main.stTime.Caption := '0:00:00';
end;
{------------------------------------------------------------------------------}
procedure Tfm_main.btRefreshClick(Sender: TObject);
begin
RepaintAll
end;
{------------------------------------------------------------------------------}
procedure ClearField;
var
i,j : byte;
begin
WordDirHor := false;
AnimNow := false;
AnimLetters := '';
PlayerMoves := 0;
EMessage := '';
PCurrent := 1;
{ Sets Player #1 as Current }
PCNo := 0;
{ Sets PC_Palyer_No as 0}
for i:=1 to MaxPlayers do
Players[i].Rec.Caption:='0';
with fm_Main do begin
{ Cleaning Field---------------------------------------------------------------}
for i:=0 to sg.ColCount do
for j:=0 to sg.RowCount do begin
Field[i,j].Letter := ' ';
Field[i,j].Weight := 0;
Field[i,j].Color := 0;
Field[i,j].JustSet := false;
end;
{ Set Cells Colors weight =====================================================}
{Center}
Field[(sg.ColCount-1) div 2,(sg.RowCount-1) div 2].Color := 5;
{Red}
Field[0,0].Color := 4;
Field[0,sg.RowCount-1].Color := 4;
Field[sg.ColCount-1,0].Color := 4;
Field[sg.ColCount-1,sg.RowCount-1].Color := 4;
Field[0,(sg.RowCount-1) div 2].Color := 4;
Field[(sg.ColCount-1) div 2,0].Color := 4;
Field[sg.ColCount-1,(sg.RowCount-1) div 2].Color := 4;
Field[(sg.ColCount-1) div 2,sg.RowCount-1].Color := 4;
{Blue}
for i:=1 to 4 do
Field[i,i].Color:=3;
for i:=1 to 4 do
Field[sg.ColCount-1-i,i].Color:=3;
for i:=1 to 4 do
Field[i,sg.RowCount-1-i].Color:=3;
for i:=1 to 4 do
Field[sg.ColCount-1-i,sg.RowCount-1-i].Color:=3;
{Yellow}
Field[1,(sg.RowCount-1) div 2 -2].Color := 2;
Field[1,(sg.RowCount-1) div 2 +2].Color := 2;
Field[(sg.ColCount-1) div 2 -2,1].Color := 2;
Field[(sg.ColCount-1) div 2 +2,1].Color := 2;
Field[sg.ColCount-2,(sg.RowCount-1) div 2 -2].Color := 2;
Field[sg.ColCount-2,(sg.RowCount-1) div 2 +2].Color := 2;
Field[(sg.ColCount-1) div 2 -2,sg.RowCount-2].Color := 2;
Field[(sg.ColCount-1) div 2 +2,sg.RowCount-2].Color := 2;
{Green}
Field[0,3].Color := 1;
Field[3,0].Color := 1;
Field[0,sg.RowCount-4].Color := 1;
Field[3,sg.RowCount-1].Color := 1;
Field[sg.ColCount-1,3].Color := 1;
Field[sg.ColCount-4,0].Color := 1;
Field[sg.ColCount-1,sg.RowCount-4].Color := 1;
Field[sg.ColCount-4,sg.RowCount-1].Color := 1;
{----------}
Field[2,(sg.RowCount-1) div 2 -1].Color := 1;
Field[2,(sg.RowCount-1) div 2 +1].Color := 1;
Field[3,(sg.RowCount-1) div 2 ].Color := 1;
Field[(sg.ColCount-1) div 2 -1,2].Color := 1;
Field[(sg.ColCount-1) div 2 +1,2].Color := 1;
Field[(sg.ColCount-1) div 2 ,3].Color := 1;
Field[sg.ColCount-3,(sg.RowCount-1) div 2 -1].Color := 1;
Field[sg.ColCount-3,(sg.RowCount-1) div 2 +1].Color := 1;
Field[sg.ColCount-4,(sg.RowCount-1) div 2 ].Color := 1;
Field[(sg.ColCount-1) div 2 -1,sg.RowCount-3].Color := 1;
Field[(sg.ColCount-1) div 2 +1,sg.RowCount-3].Color := 1;
Field[(sg.ColCount-1) div 2 ,sg.RowCount-4].Color := 1;
{----------}
Field[(sg.ColCount-1) div 2 -1,(sg.RowCount-1) div 2 -1].Color := 1;
Field[(sg.ColCount-1) div 2 -1,(sg.RowCount-1) div 2 +1].Color := 1;
Field[(sg.ColCount-1) div 2 +1,(sg.RowCount-1) div 2 -1].Color := 1;
Field[(sg.ColCount-1) div 2 +1,(sg.RowCount-1) div 2 +1].Color := 1;
{ Save first UNDO -------------------------------------------------------------}
Field2 := Field;
Players2 := Players;
tbBack.Enabled := false;
GameState := gsJustStarted;
{ Refresh Grids ---------------------------------------------------------------}
RepaintAll;
end;
{with}
end;
{------------------------------------------------------------------------------}
function FieldNextCell(Index:integer): Tcell;
begin
if (SCol+Index<1) or (SRow+Index<1) then begin
Result.Letter := ' ';
Result.Color := 0;
Result.Weight := 0;
Result.JustSet := false;
exit;
end;
if WordDirHor then
Result := Field[SCol+Index-1,SRow]
else
Result := Field[SCol,SRow+Index-1]
end;
{------------------------------------------------------------------------------}
function WordWeight: integer;
{Расчет веса слова}
var
i : byte;
begin
Result := 0;
{*}
Multiply := 1;
for i:=1 to length(sWord) do
if (FieldNextCell(i).Letter=' ') and
((FieldNextCell(i).Color=3) or (FieldNextCell(i).Color=4)) then
Multiply := FieldNextCell(i).Color-1;
{+}
for i:=1 to length(sWord) do
if FieldNextCell(i).Letter=' ' then
if FieldNextCell(i).Color<3 then
Result := Result + LWeight(sWord[i])*(FieldNextCell(i).Color+1)
else
Result := Result + LWeight(sWord[i])
else
Result := Result + (FieldNextCell(i).Weight);
{Учет начала/продолжения существующего слова}
if WordDirHor then begin
{Слово может быть приставлено в конце}
if (WordCross[1]=true) and (SCol>1) then
for i:=SCol-1 downto 0 do
if (Field[i,SRow].Letter<>' ') then
Result := Result + (Field[i,SRow].Weight)
else
break;
if WordCross[Length(sWord)]=true then
{Слово может быть приставлено в начале}
for i:=SCol+Length(sWord) to fm_Main.sg.ColCount-1 do
if (Field[i,SRow].Letter<>' ') then
Result := Result + (Field[i,SRow].Weight)
else
break;
end
else begin
{Слово может быть приставлено в конце}
if (WordCross[1]=true) and (SRow>1) then
for i:=SRow-1 downto 0 do
if (Field[SCol,i].Letter<>' ') then
WWeight := WWeight + (Field[SCol,i].Weight)
else
break;
if WordCross[Length(sWord)]=true then
{Слово может быть приставлено в начале}
for i:=SRow+Length(sWord) to fm_Main.sg.RowCount-1 do
if (Field[SCol,i].Letter<>' ') then
WWeight := WWeight + (Field[SCol,i].Weight)
else
break;
end;
Result := Result*Multiply;
end;
{------------------------------------------------------------------------------}
function CheckWordLayout: boolean;
var
i : integer;
HaveCross : boolean;
s : string;
begin
Result := true;
EMessage := '';
{$I _lg_shared.pas} {= and |}
if WordDirHor then begin
{---------------------------------------------------}
{$I _lg_hor.pas} {=}
end
else begin
{$I _lg_ver.pas} {|}
end;
{else}
end;
{------------------------------------------------------------------------------}
procedure WriteWord;
var
i,j : integer;
begin
for i:=0 to MaxWordLength-1 do
for j:=0 to MaxWordLength-1 do
Field [i,j].JustSet:=false;
if WordDirHor then
for i:=1 to length(sWord) do begin
Field[SCol+i-1,SRow].Letter := sWord[i];
Field[SCol+i-1,SRow].Weight := LWeight(sWord[i]);
Field[SCol+i-1,SRow].JustSet := true;
end
else
for i:=1 to length(sWord) do begin
Field[SCol,SRow+i-1].Letter := sWord[i];
Field[SCol,SRow+i-1].Weight := LWeight(sWord[i]);
Field[SCol,SRow+i-1].JustSet := true;
end;
RepaintAll;
end;
{------------------------------------------------------------------------------}
procedure Tfm_main.sgSelectCell(Sender: TObject; ACol,ARow: Integer; var CanSelect:
Boolean);
begin
SCol := ACol;
SRow := ARow;
{ Ввод слова ------------------------------------------------------------------}
fm_Word.ShowModal;
if EMessage='Timeout' then begin
MessageBox(0,PChar(_M_mTimeOut),
PChar(Application.Title),
MB_OK or MB_TASKMODAL or
MB_ICONINFORMATION or MB_DEFBUTTON1);
sWord := '';
UserSkip := true;
NextPlayer;
exit;
end;
if EMessage<>'' then
exit;
{Проверка на уникальность вводимого слова}
CheckForUnique;
if EMessage<>'' then begin
MessageDlg(EMessage, mtError, [mbOk], 0);
exit;
end;
{Все в порядке; Игрок благополучно сходил--------------------------------------}
GameState := gsGame;
{Остановить время}
fm_Main.tmGame.Enabled := false;
{Сохранение предыдущего состояния поля}
Field2 := Field;
{Расчет веса слова}
WWeight := WordWeight;
{Заполение массива поля новым словом}
WriteWord;
{Запись счета}
RepaintAll;
MessageDlg(Format(_M_mPoints, [WWeight, Ending(WWeight)]), mtInformation, [mbOk], 0);
Players[PCurrent].Rec.Caption := IntToStr(StrToInt(Players[PCurrent].Rec.Caption)+
WWeight);
{Переход хода}
NextPlayer;
end;
{------------------------------------------------------------------------------}
procedure Tfm_main.FormCreate(Sender: TObject);
var
i,j : integer;
c : cardinal;
begin
@SetLayeredWindowAttributes := GetProcAddress(LoadLibrary('user32.dll'),
'SetLayeredWindowAttributes');
// SetOpacity(Handle, 0);
// SetOpacity(Handle, 255);
{Install font RS Serife}
FontLoad;
LoadJPEGfromEXE;
LoadAVIfromEXE;
{Look for self name in Network}
GetComputerName(_NetSelfName, c);
NetSelfName := String(_NetSelfName);
FileName := _M_sFNGame;
CurrentLanguage := lgNone;
TopAction := taNone;
CurrDir := ExtractFilePath(Application.ExeName);
Randomize;
ClearField;
GameState := gsNoGame;
{ Set Players Array -----------------------------------------------------------}
Players[1].Button := sb1;
Players[1].Name := cb1;
Players[1].Rec := st1;
Players[1].LettersObj := sg1;
Players[2].Button := sb2;
Players[2].Name := cb2;
Players[2].Rec := st2;
Players[2].LettersObj := sg2;
Players[3].Button := sb3;
Players[3].Name := cb3;
Players[3].Rec := st3;
Players[3].LettersObj := sg3;
Players[4].Button := sb4;
Players[4].Name := cb4;
Players[4].Rec := st4;
Players[4].LettersObj := sg4;
Players[5].Button := sb5;
Players[5].Name := cb5;
Players[5].Rec := st5;
Players[5].LettersObj := sg5;
{ Bitmap #0 - is an OK picture
Bitmap #LAST - is a Computer picture
}
FacesCount := ilPlayers.Count-2;
for i:=1 to FacesCount do
FacesUsed[i]:=false;
// for i:=1 to MaxPlayers do begin
// Players[i].Face := TBitmap.Create;
// Players[i].Face.Height := 32;
// Players[i].Face.Width := 32;
//
end;
(*
{ Load Buttons icons from Resource --------------------------------------------}
ilMainActive.ResourceLoad(rtBitmap,'TB_ENABLED',clTeal);
ilMainDisabled.ResourceLoad(rtBitmap,'TB_DISABLED',clTeal);
ilMainHot.ResourceLoad(rtBitmap,'TB_HOT',clTeal);
*)
{ Set Random Face1 ------------------------------------------------------------}
for i:=1 to 2 do begin
repeat
j := Random(FacesCount)+1
until not FacesUsed[j];
ilPlayers.GetBitmap(j,Players[i].Button.Glyph);
Players[i].Button.Spacing := j;
FacesUsed[j] := true;
end;
for i:=3 to 5 do
ilPlayers.GetBitmap(0,Players[i].Button.Glyph);
// for i:=1 to 5 do
ilPlayers.Draw(Players[i].Face.Canvas,0,0,i+1);
// for i:=1 to 5 do
ilPlayers.Draw(Players[i].Button.Glyph.Canvas,0,0,1);
(*
{Ставим личико игроку #1}
i := Random(MaxPlayers)+1;
Players[1].Button.Glyph := Players[i].Face;
Players[i].FaceUsed := 1;
{Ставим личико игроку #2}
repeat
i := Random(MaxPlayers)+1
Until Players[i].FaceUsed=0;
Players[2].Button.Glyph := Players[i].Face;
Players[i].FaceUsed := 2;
for i:=3 to MaxPlayers do
ilPlayers.GetBitmap(0,Players[i].Button.Glyph);
*)
end;
{------------------------------------------------------------------------------}
procedure Tfm_main.sgDrawCell(Sender: TObject; ACol, ARow: Integer;
Rect: TRect; State: TGridDrawState);
begin
with Sender as TDrawGrid do begin
{Пустые клетки ------------------------------------------------------------}
if Field[ACol,ARow].Letter=' ' then begin
case Field[ACol,ARow].Color of
0:
Canvas.Brush.Color := myWindow;
1:
Canvas.Brush.Color := myGreen;
2:
Canvas.Brush.Color := myYellow;
3:
Canvas.Brush.Color := myBlue;
4:
Canvas.Brush.Color := myRed;
5:
Canvas.Brush.Color := myGray;
end;
if Field[ACol,ARow].JustSet then
Canvas.Brush.Color := Canvas.Brush.Color and not myOffset;
Canvas.FillRect(Rect);
end
{Клетки с буквами ---------------------------------------------------------}
else begin
if Field[ACol,ARow].JustSet then
Canvas.Brush.Color := myJustSet
else
Canvas.Brush.Color := myLetterBk;
Canvas.FillRect(Rect);
Canvas.Font.Size := 12;
Canvas.Font.Style := [fsBold];
Canvas.Font.Color := myLetter;
Canvas.TextRect(Rect, Rect.Left+1, Rect.Top-2,
AnsiUpperCase(Field[ACol,ARow].Letter));
case Field[ACol,ARow].Color of
0:
Canvas.Font.Color := myWindow;
1:
Canvas.Font.Color := myGreen;
2:
Canvas.Font.Color := myYellow;
3:
Canvas.Font.Color := myBlue;
4:
Canvas.Font.Color := myRed;
5:
Canvas.Font.Color := myGray;
end;
Canvas.Font.Name := 'Small Fonts';
Canvas.Font.Style := [];
Canvas.Font.Size := 6;
Rect.Left := Rect.Left+14;
Rect.Top := Rect.Top+14;
Canvas.TextRect(Rect, Rect.Left, Rect.Top, IntToStr(Field[ACol,ARow].Weight));
end;
end;
end;
{------------------------------------------------------------------------------}
procedure Tfm_main.sb345Click(Sender: TObject);
var
i,j : byte;
begin
if GameState<>gsNoGame then
exit;
i := 0;
Repeat
inc(i)
Until Players[i].Button=Sender;
if Players[i].Name.Visible then begin
{----------------------- Удаляем игрока}
Players[i].Button.Glyph.Canvas.Draw(5,5,Players[i].Button.Glyph);
ilPlayers.GetBitmap(0,Players[i].Button.Glyph);
FacesUsed[Players[i].Button.Spacing] := false;
Players[i].Button.Spacing := 0;
Players[i].Name.Visible := false;
Players[i].Rec.Visible := false;
Players[i].LettersObj.Visible := false;
Players[i].Rec.Caption := '0';
for j:=1 to 7 do
Players[i].Letters[j]:=#0;
end
else begin
{------------------------------------------------ Добавляем игрока}
repeat
j := Random(FacesCount)+1
Until not FacesUsed[j];
Players[i].Button.Glyph.Canvas.Draw(5,5,Players[i].Button.Glyph);
ilPlayers.GetBitmap(j,Players[i].Button.Glyph);
FacesUsed[j] := true;
Players[i].Button.Spacing := j;
Players[i].Name.Visible := true;
Players[i].Rec.Visible := true;
Players[i].LettersObj.Visible := true;
cb2Change(Sender);
end;
end;
{------------------------------------------------------------------------------}
procedure Tfm_main.tbBackClick(Sender: TObject);
var
i,j : byte;
Empty : boolean;
begin
if MessageBox(0,PChar(_M_mBack),
PChar(Application.Title),
MB_YESNO or MB_TASKMODAL or
MB_ICONQUESTION or MB_DEFBUTTON2)=IDNO then
exit;
tbBack.Enabled := false;
Field := Field2;
Players := Players2;
PrevPlayer;
RepaintAll;
{Проверяем - возвращаемся ли мы к началу игры}
Empty := true;
for i:=0 to sg.ColCount do
for j:=0 to sg.RowCount do
if Field[i,j].Letter<>' ' then begin
Empty := false;
break;
end;
if Empty then
GameState := gsJustStarted;
end;
{------------------------------------------------------------------------------}
procedure Tfm_main.sg1DrawCell(Sender: TObject; ACol, ARow: Integer;
Rect: TRect; State: TGridDrawState);
Var
PCurrentLoc: byte;
begin
with Sender as TDrawGrid do begin
PCurrentLoc := Tag;
{Пустые клетки ------------------------------------------------------------}
if Players[PCurrentLoc].Letters[ACol+1]=#0 then begin
Canvas.Brush.Color := myWindow;
Canvas.FillRect(Rect);
end
{Клетки с буквами ---------------------------------------------------------}
else begin
if (ACol=Col) and (ARow=Row) and (not AnimNow) then
Canvas.Brush.Color := clNavy
else
Canvas.Brush.Color := clBlack;
Canvas.FillRect(Rect);
Canvas.Font.Size := 12;
Canvas.Font.Style := [fsBold];
if Players[PCurrentLoc].Letters[ACol+1]='*' then begin
Canvas.Font.Color := myYellow;
Canvas.TextRect(Rect, Rect.Left+1, Rect.Top-2,
AnsiUpperCase(Players[PCurrentLoc].Letters[ACol+1]));
end
else begin
if PCurrentLoc=PCurrent then
Canvas.Font.Color := myWhite
else
Canvas.Font.Color := myGray;
Canvas.TextRect(Rect, Rect.Left+1, Rect.Top-2,
AnsiUpperCase(Players[PCurrentLoc].Letters[ACol+1]));
Canvas.Font.Color := myWhite;
Canvas.Font.Name := 'Small Fonts';
Canvas.Font.Style := [];
Canvas.Font.Size := 7;
Rect.Left := Rect.Left+14;
Rect.Top := Rect.Top+14;
Canvas.TextRect(Rect, Rect.Left, Rect.Top, IntToStr(LWeight(Players[
PCurrentLoc].Letters[ACol+1])));
end;
end;
end;
end;
{------------------------------------------------------------------------------}
procedure Tfm_main.sg1DragOver(Sender, Source: TObject; X, Y: Integer;
State: TDragState; var Accept: Boolean);
var
i : byte;
begin
if Source=Sender then begin
Accept := true;
with Sender as TStringGrid do begin
Canvas.Brush.Color := clBlack;
for i:=1 to 7 do
Canvas.FillRect(Rect(i*25-2,0,i*25,25));
Canvas.Brush.Color := clBtnFace;
for i:=1 to 7 do
Canvas.FillRect(Rect(i*25-1,0,i*25,25));
Canvas.Brush.Color := clYellow;
if x>StartDragX then
Canvas.FillRect(Rect((x+25)div 25 *25-2,0,(x+25)div 25*25,25))
else
Canvas.FillRect(Rect(x div 25 *25-2,0,x div 25*25,25));
end;
{with}
end{if}
else
Accept := false;
end;
{ Animation -------------------------------------------------------------------}
procedure Move2Blocks(Source:TDrawGrid; ARect,BRect:TRect);
begin
AWidth := ARect.Right-ARect.Left;
AHeight := ARect.Bottom-ARect.Top;
BWidth := BRect.Right-BRect.Left;
BHeight := BRect.Bottom-BRect.Top;
{Запомнили 1й блок}
BitBlt(fm_Main.I1.Canvas.Handle,0,0,AWidth,AHeight, Source.Canvas.Handle, ARect.Left,
ARect.Top, SRCCOPY);
{Запомнили 2й блок}
BitBlt(fm_Main.I2.Canvas.Handle,0,0,BWidth,BHeight, Source.Canvas.Handle, BRect.Left,
BRect.Top, SRCCOPY);
fm_Main.pa1.Top := Players[PCurrentMov].LettersObj.Top + 1;
fm_Main.pa2.Top := Players[PCurrentMov].LettersObj.Top + 2;
fm_Main.pa2.Width := BWidth-1;
with Source as TDrawGrid do begin
fm_Main.pa1.Left := Players[PCurrentMov].LettersObj.Left + 25*Col + 1;
if AnimDir>0 then begin
fm_Main.pa2.Left := Players[PCurrentMov].LettersObj.Left + 25*(Col+1) + 2;
AnimLeftA := Players[PCurrentMov].LettersObj.Left + 25*Col + fm_Main.pa2.Width +
2;
AnimLeftB := Players[PCurrentMov].LettersObj.Left + 25*Col + 2;
end
else begin
fm_Main.pa2.Left := Players[PCurrentMov].LettersObj.Left + 25*Col - fm_Main.pa2.
Width;
AnimLeftA := fm_Main.pa2.Left;
AnimLeftB := fm_Main.pa2.Left + 25;
end;
end;
fm_Main.pa1.Visible := true;
fm_Main.pa2.Visible := true;
{Инициализирум таймер вместе с его событием}
fm_Main.Timer1.Enabled := true;
end;
{------------------------------------------------------------------------------}
procedure Tfm_main.Timer1Timer(Sender: TObject);
var
i : integer;
SourCol : LongInt;
begin
with fm_Main do begin
if not Animation then begin
{сдвигаем буквы в массиве букв}
SourCol := Players[PCurrentMov].LettersObj.Col;
if DestCol>SourCol then
for i:=2 to Length(AnimLetters) do
Players[PCurrentMov].Letters[SourCol+i-1]:=AnimLetters[i]
else
for i:=2 to Length(AnimLetters) do
Players[PCurrentMov].Letters[DestCol+i]:=AnimLetters[i];
Players[PCurrentMov].Letters[DestCol+1] := AnimLetters[1];
Players[PCurrentMov].LettersObj.Repaint;
pa1.Visible := false;
pa2.Visible := false;
AnimNow := false;
Timer1.Enabled := false;
Players[PCurrentMov].LettersObj.Col := DestCol;
exit;
end;
{Создаем эффект перемещения букв двигающимися панелями}
if AnimDir>0 then begin
if (pa1.Left<AnimLeftA) and (pa1.Top>=Players[PCurrentMov].LettersObj.Top-10)
then
pa1.Top := pa1.Top-2 {поднимаем}
else if (pa1.Left<=AnimLeftA) or (pa1.Top>=Players[PCurrentMov].LettersObj.Top)
then begin
if pa1.Left<=AnimLeftA then
pa1.Left := pa1.Left+4;
{сдвигаем}
if pa2.Left>=AnimLeftB then
pa2.Left := pa2.Left-2;
end
else
pa1.Top := pa1.Top+2 {опускаем}
end
else begin
if (pa1.Left>AnimLeftA) and (pa1.Top>=Players[PCurrentMov].LettersObj.Top-10)
then
pa1.Top := pa1.Top-2
else if (pa1.Left<=AnimLeftA) and (pa1.Top<=Players[PCurrentMov].LettersObj.Top)
then
pa1.Top := pa1.Top+2
else begin
if pa1.Left>=AnimLeftA then
pa1.Left := pa1.Left-5;
if pa2.Left<=AnimLeftB then
pa2.Left := pa2.Left+2;
end;
end;
SourCol := Players[PCurrentMov].LettersObj.Col;
{Рисуем буквы на новом месте и убираем двигающиеся панели}
if (pa1.Left*AnimDir>=AnimLeftA*AnimDir) and
(pa2.Left*AnimDir<=AnimLeftB*AnimDir) and
(pa1.Top>=Players[PCurrentMov].LettersObj.Top) then begin
{сдвигаем буквы в массиве букв}
if DestCol>SourCol then
for i:=2 to Length(AnimLetters) do
Players[PCurrentMov].Letters[SourCol+i-1]:=AnimLetters[i]
else
for i:=2 to Length(AnimLetters) do
Players[PCurrentMov].Letters[DestCol+i]:=AnimLetters[i];
Players[PCurrentMov].Letters[DestCol+1] := AnimLetters[1];
Players[PCurrentMov].LettersObj.Repaint;
{Убираем панели}
pa1.Visible := false;
pa2.Visible := false;
AnimNow := false;
Timer1.Enabled := false;
Players[PCurrentMov].LettersObj.Col := DestCol;
end;
end;
{with}
end;
{------------------------------------------------------------------------------}
procedure Tfm_main.sg1DragDrop(Sender, Source: TObject; X, Y: Integer);
var
i : shortint;
Cell2 : TRect;
begin
with Sender as TDrawGrid do begin
{Sender==Source}
MouseToCell(x,y,DestCol,DestRow);
if DestCol=Col then
exit;
if DestCol<0 then
DestCol := 0;
{Исключительная ситуация, когда курсор
находится над первым пикселем (Ось Х)
TGrid и которая вызывает ошибку,
так как DestCol=-1 или -2 }
PCurrentMov := Tag;
AnimNow := true;
AnimLetters := '';
if DestCol>Col then begin
for i:=Col+1 to DestCol+1 do
AnimLetters:=AnimLetters+Players[PCurrentMov].Letters[i];
for i:=Col+1 to DestCol+1 do
Players[PCurrentMov].Letters[i]:=#0;
AnimDir := 1;
Cell2 := CellRect(Col+1,Row);
Cell2.Right := CellRect(DestCol,DestRow).Right;
Move2Blocks(Players[PCurrentMov].LettersObj,CellRect(Col,Row),Cell2);
end
else begin
AnimLetters := Players[PCurrentMov].Letters[Col+1];
for i:=DestCol+1 to Col do
AnimLetters:=AnimLetters+Players[PCurrentMov].Letters[i];
for i:=DestCol+1 to Col+1 do
Players[PCurrentMov].Letters[i]:=#0;
AnimDir := -1;
Cell2 := CellRect(DestCol,Row);
Cell2.Right := CellRect(Col-1,Row).Right;
Move2Blocks(Players[PCurrentMov].LettersObj,CellRect(Col,Row),Cell2);
end;
end;
{with}
end;
{------------------------------------------------------------------------------}
procedure Tfm_main.sg1MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState;
X, Y: Integer);
begin
with Sender as TStringGrid do
BeginDrag(False);
StartDragX := x;
end;
{------------------------------------------------------------------------------}
procedure StartGame(Start:boolean);
var
i : integer;
begin
for i:=1 to MaxPlayers do begin
Players[i].Name.Color := clWindow;
Players[i].Rec.Color := clWindow;
end;
fm_Main.stTime.Color := clBtnFace;
fm_Main.stTime.Caption := '0:00:00';
if Start then begin
for i:=1 to MaxPlayers do
Players[i].Name.Enabled:=false;
fm_Main.tbHistory.Enabled := true;
fm_Main.tbPlay.Caption := _M_sGStop;
fm_Main.tbSaveGame.Enabled := true;
fm_Main.tbSkip.Enabled := true;
fm_Main.tbLang.Enabled := false;
fm_Main.tbNet.Enabled := false;
fm_Main.tbPlay.ImageIndex := 7;
if HeadMaster='' then begin
fm_Main.anComp.Visible := true;
fm_Main.laNetMsg.Visible := false;
Screen.Cursor := crAppStart;
end
else begin
fm_Main.anComp.Visible := false;
fm_Main.laNetMsg.Visible := true;
Screen.Cursor := crDefault;
end;
fm_Main.tbSuggest.Enabled := Boolean(PCNo);
fm_Main.sg.Enabled := true;
for i:=1 to MaxPlayers do begin
Players[i].Name.Color := clWindow;
Players[i].Rec.Color := clWindow;
Players[i].Name.Enabled := false;
Players[i].LettersObj.Enabled := true;
if not Players[i].Name.Visible then
Players[i].Button.Enabled := false;
end;
Players[PCurrent].Name.Color := myActiveP;
Players[PCurrent].Rec.Color := myActiveP;
if TimeLimit>0 then
fm_Main.tmGame.Enabled := true;
UserTime := 0;
end
else begin
{----------------------------------------------------------------}
for i:=1 to MaxPlayers do begin
Players[i].Name.Enabled := true;
Players[i].Button.Enabled := true;
Players[i].LettersObj.Enabled := false;
end;
GameState := gsNoGame;
fm_Main.sg.Enabled := false;
fm_Main.tbHistory.Enabled := false;
fm_Main.tbPlay.Caption := _M_sGPlay;
fm_Main.tbSaveGame.Enabled := false;
fm_Main.tbSkip.Enabled := false;
fm_Main.tbSuggest.Enabled := false;
fm_Main.tbLang.Enabled := true;
fm_Main.tbNet.Enabled := true;
fm_Main.tbPlay.ImageIndex := 0;
if TimeLimit>0 then
fm_Main.tmGame.Enabled := false;
fm_Main.anComp.Visible := false;
fm_Main.laNetMsg.Visible := false;
Screen.Cursor := crDefault;
end;
end;
{------------------------------------------------------------------------------}
procedure Tfm_main.tbPlayClick(Sender: TObject);
var
i,j,k,p : byte;
begin
if GameState=gsNoGame then begin
{--------------------------------Начать игру}
{Проверка ниличия имен игроков}
for i:=1 to MaxPlayers do
if (Players[i].Name.Text='') and (Players[i].Name.Visible) then begin
MessageDlg(_M_mPEnter, mtError, [mbOk], 0);
exit;
end;
{Проверка уникальности имен игроков}
for i:=1 to MaxPlayers do
for j:=i+1 to MaxPlayers do
if (Trim(Players[i].Name.Text)=Trim(Players[j].Name.Text)) and
(Players[i].Name.Visible) then begin
MessageDlg(_M_mPUNames, mtError, [mbOk], 0);
exit;
end;
{Если среди игроков есть "Компьютер", то запомнить его номер}
for i:=1 to MaxPlayers do
if (Trim(Players[i].Name.Text)=_M_sPPCName) and
(Players[i].Name.Visible) then
PCNo := i;
{Выдача новых произвольных букв}
for i:=1 to MaxPlayers do
for j:=1 to MaxLetters do
Players[i].Letters[j]:=RandomLetter;
for i:=1 to MaxPlayers do
if Players[i].Name.Text='' then
Players[i].Button.Enabled := false;
for i:=1 to MaxPlayers do
Players[i].Name.Enabled:=false;
{Очистка поля, завершающие стадии перед началом игры}
GameState := gsJustStarted;
StartGame(true);
if Trim(Players[PCurrent].Name.Text)=_M_sPPCName then
ComputerStep;
end
else begin
{---------------------------------------------------{Окончить игру}
tmGame.Enabled := false;
if TimeLimit>0 then
fm_Main.Visible := false;
if GameState=gsGame then
if MessageBox(0,PChar(_M_mGIsStop),
PChar(Application.Title),
MB_YESNO or MB_TASKMODAL or
MB_ICONWARNING or MB_DEFBUTTON2)=IDNO then begin
tmGame.Enabled := Boolean(TimeLimit);
fm_Main.Visible := true;
EXIT;
end;
fm_Main.Visible := true;
for i:=1 to MaxPlayers do
Players[i].Button.Enabled:=true;
for i:=1 to MaxPlayers do
for j:=1 to MaxLetters do
Players[i].Letters[j]:=#0;
{Ввод результата игры в таблицу лидеров------------------------------------}
j := 0;
k := 1;
for i:=1 to MaxPlayers do
if StrToInt(Players[i].Rec.Caption)>j then begin
j := StrToInt(Players[i].Rec.Caption);
k := i;
end;
p := 10;
for i:=0 to 9 do
if j>StrToIntDef(TopNames[i].Points,0) then begin
p := i;
break;
end;
if p<10 then begin
for i:=9 downto p+1 do begin
TopNames[i].Name := TopNames[i-1].Name;
TopNames[i].Points := TopNames[i-1].Points;
TopNames[i].CoolWord := TopNames[i-1].CoolWord;
end;
TopNames[p].Name := Players[k].Name.Text;
TopNames[p].Points := intToStr(j);
fm_Top.edName.Caption := Players[k].Name.Text+':';
fm_Top.edPoints.Caption := intToStr(j);
TopAction := taShow;
fm_Top.Tag := p;
{Если Выиграл компьютер, то ввести фразу автоматически}
if Trim(Players[k].Name.Text)=_M_sPPCName then
fm_Top.Timer2.Tag := 1
else
fm_Top.Timer2.Tag := 0;
fm_Top.ShowModal;
end;
{Блокировка поля, завершающие стадии после игры}
ClearField;
StartGame(false);
end;
RepaintAll;
end;
{------------------------------------------------------------------------------}
procedure Tfm_main.tbExitClick(Sender: TObject);
begin
fm_Main.Close;
end;
{------------------------------------------------------------------------------}
procedure Tfm_main.tbSkipClick(Sender: TObject);
begin
fm_Skip.sb1.Caption := AnsiUpperCase(Players[PCurrent].Letters[1]);
fm_Skip.sb2.Caption := AnsiUpperCase(Players[PCurrent].Letters[2]);
fm_Skip.sb3.Caption := AnsiUpperCase(Players[PCurrent].Letters[3]);
fm_Skip.sb4.Caption := AnsiUpperCase(Players[PCurrent].Letters[4]);
fm_Skip.sb5.Caption := AnsiUpperCase(Players[PCurrent].Letters[5]);
fm_Skip.sb6.Caption := AnsiUpperCase(Players[PCurrent].Letters[6]);
fm_Skip.sb7.Caption := AnsiUpperCase(Players[PCurrent].Letters[7]);
fm_Skip.ShowModal;
end;
{------------------------------------------------------------------------------}
{Проверка соприкосновения слова по правилу морского боя}
function SeaCheck;
begin
Result := false;
if (SRow>0) and DirHor and {Проверка сверху}
(Field[SCol,SRow-1].Letter<>' ') then
exit;
if (SRow<14) and DirHor and {Проверка снизу}
(Field[SCol,SRow+1].Letter<>' ') then
exit;
if (SCol>0) and not DirHor and {Проверка слева}
(Field[SCol-1,SRow].Letter<>' ') then
exit;
if (SCol<14) and not DirHor and {Проверка справа}
(Field[SCol+1,SRow].Letter<>' ') then
exit;
Result := true;
end;
{------------------------------------------------------------------------------}
procedure Tfm_Main.ShowSuggestion;
begin
fm_Main.CoolBar1.Enabled := true;
SearchBestWord;
fm_Main.anComp.Active := false;
Screen.Cursor := crDefault;
{Компьютер подумал!}
if (UserSkip) or (sWord='') then begin
MessageDlg(_M_mINoWord, mtInformation, [mbOk], 0);
exit;
end;
fm_Suggest.ShowModal;
{Переход хода}
if not Suggested then
NextPlayer;
end;
{------------------------------------------------------------------------------}
procedure Tfm_main.btSuggestClick(Sender: TObject);
begin
if MessageBox(0,PChar(Format(_M_mHIsNeed,
[SuggestionValue, Ending(SuggestionValue)])),
PChar(Application.Title),
MB_YESNO or MB_TASKMODAL or
MB_ICONWARNING or MB_DEFBUTTON2)<>IDYES then
EXIT;
RepaintAll;
Suggested := true;
{Компьютер думает ...}
fm_Main.anComp.Active := true;
Screen.Cursor := crAppStart;
if GameState=gsGame then
SearchPatterns
else
SearchPatternsFirst;
FindMultiPatterns;
with TGetListOfWords.Create do
OnTerminate :=ShowSuggestion;
end;
{------------------------------------------------------------------------------}
procedure Tfm_main.btDicClick(Sender: TObject);
begin
fm_DMan.ShowModal;
end;
{------------------------------------------------------------------------------}
procedure Tfm_main.tbAboutClick(Sender: TObject);
begin
_iWindowExStyle := GetWindowLong(fm_main.Handle, GWL_EXSTYLE);
fm_About.FormRaise := true;
fm_About.TranspValue := 0;
fm_About.tmAppearance.Enabled := true;
fm_About.ShowModal;
end;
{------------------------------------------------------------------------------}
procedure Tfm_main.tbHistoryClick(Sender: TObject);
begin
fm_PMoves.ShowModal;
end;
{------------------------------------------------------------------------------}
function FormatS(str:string; len:integer): string;
begin
if len>10 then
Result := str + StringOfChar(' ',len-length(str))
else
Result := StringOfChar(' ',len-length(str)) + str;
if length(Result)>len then
Result := Copy(Result,1,len);
end;
{------------------------------------------------------------------------------}
procedure Tfm_main.tbSaveGameClick(Sender: TObject);
var
i,j : integer;
GameFile : TIniFile;
s,sl : string[30];
begin
if Sender = fm_Main then
if GameState=gsGame then
sd.FileName := ExtractFilePath(Application.ExeName)+'Autosave.eru'
else begin
DeleteFile(ExtractFilePath(Application.ExeName)+'Autosave.eru');
exit;
end
else begin
sd.FileName := '';
for i:=1 to MaxPlayers do
if Players[i].Name.Visible then
sd.FileName := sd.FileName + '-' + Copy(Players[i].Name.Text,1,4);
sd.FileName := Copy(sd.FileName,2,length(sd.FileName)-1);
if not sd.Execute then
exit;
end;
GameFile := TIniFile.Create(sd.FileName);
with GameFile do begin
WriteString('Common','ID',_ProductID);
WriteString('Common','Version',_ProductVersion);
case CurrentLanguage of
lgENU:
WriteString('Common','Language','English');
lgDEU:
WriteString('Common','Language','Deutsch');
lgRUS:
WriteString('Common','Language','Russian');
end;
for j:=0 to MaxWordLength-1 do begin
s := '';
for i:=0 to MaxWordLength-1 do
if Field[i,j].Letter=' ' then
s := s + '.'
else
s := s + Field[i,j].Letter;
WriteString('Field current', 'Line'+FormatFloat('00',j), s);
end;
for j:=0 to MaxWordLength-1 do begin
s := '';
for i:=0 to MaxWordLength-1 do
if Field2[i,j].Letter=' ' then
s := s + '.'
else
s := s + Field2[i,j].Letter;
WriteString('Field previous', 'Line'+FormatFloat('00',j), s);
end;
for j:=1 to MaxPlayers do
if Players[j].Name.Visible then begin
s := 'Player'+FormatFloat('0',j);
WriteString(s, 'Name', Players[j].Name.Text);
sl := '';
for i:=1 to MaxLetters do
sl:=sl + Players[j].Letters[i];
WriteString (s, 'Letters current', sl);
sl := '';
for i:=1 to MaxLetters do
sl:=sl + Players2[j].Letters[i];
WriteString (s, 'Letters previous', sl);
WriteString (s, 'Points', Players[j].Rec.Caption);
WriteInteger(s, 'Face', Players[j].Button.Spacing);
end;
if GameState=gsGame then
WriteString('Common', 'Game status', 'Game')
else
WriteString('Common', 'Game status', 'Just Started');
WriteInteger('Common', 'Current Player', PCurrent);
WriteInteger('Common', 'PC Player No', PCNo);
WriteBool ('Common', 'Suggested', Suggested);
WriteInteger('History','Turns count',PlayerMoves);
for i:=1 to PlayerMoves do begin
WriteString('History','Turn'+FormatFloat('000',i),
FormatS(PlayerMove[i].PlayerName,20) +
FormatS(PlayerMove[i].Word,MaxWordLength + 15) +
FormatS(PlayerMove[i].UsedLetters,20) +
FormatS(PlayerMove[i].ReceivedLetters,20) +
FormatS(IntToStr(PlayerMove[i].Points),3) +
FormatS(IntToStr(PlayerMove[i].Total),3) +
IntToStr(Integer(PlayerMove[i].DirHor)) +
FormatS(IntToStr(PlayerMove[i].Pos.x),2) +
FormatS(IntToStr(PlayerMove[i].Pos.y),2)
);
end;
Free;
end;
{with}
end;
{------------------------------------------------------------------------------}
procedure Tfm_main.tbLoadGameClick(Sender: TObject);
var
i,j : integer;
GameFile : TIniFile;
s, sl : string;
ch : char;
begin
if FileName <> '' then
if FileExists(FileName) then
od.FileName := FileName
else
exit
else begin
{Если игра в процессе - предупредить}
if (GameState=gsGame) and
(MessageBox(0,PChar(_M_mGIsStop),
PChar(Application.Title),
MB_YESNO or MB_TASKMODAL or
MB_ICONQUESTION or MB_DEFBUTTON2)=IDNO) then
EXIT;
od.FileName := FileName;
if not od.Execute then
exit;
end;
{------------------------------------------------------------------------------}
ClearField;
GameFile := TIniFile.Create(od.FileName);
with GameFile do begin
if ReadString('Common','ID','')<>_ProductID then begin
MessageDlg('This is not an Erudit savegame file.', mtError, [mbOk], 0);
exit;
end;
// ReadString('Common','Version',_ProductVersion);
ch := ReadString('Common','Language','English')[1];
case ch of
'D':
if CurrentLanguage<>lgDEU then
SetLangClick(Deutsch);
'R':
if CurrentLanguage<>lgRUS then
SetLangClick(Russian);
else if CurrentLanguage<>lgENU then
SetLangClick(English);
end;
{Чтение содержимого поля}
for j:=0 to MaxWordLength-1 do begin
s := ReadString('Field current', 'Line'+FormatFloat('00',j), StringOfChar('.',
MaxWordLength));
for i:=0 to MaxWordLength-1 do begin
if s[i+1]='.' then
Field[i,j].Letter := ' '
else
Field[i,j].Letter := s[i+1];
if s[i+1]='.' then
Field[i,j].Weight := 0
else
Field[i,j].Weight := LWeight(Field[i,j].Letter);
end;
end;
{Чтение содержимого поля ход назад}
for j:=0 to MaxWordLength-1 do begin
s := ReadString('Field previous', 'Line'+FormatFloat('00',j), StringOfChar('.',
MaxWordLength));
for i:=0 to MaxWordLength-1 do begin
if s[i+1]='.' then
Field2[i,j].Letter := ' '
else
Field2[i,j].Letter := s[i+1];
if s[i+1]='.' then
Field2[i,j].Weight := 0
else
Field2[i,j].Weight := LWeight(Field2[i,j].Letter);
end;
end;
{Чтение содержимого массива игроков}
for j:=1 to MaxPlayers do begin
s := 'Player'+FormatFloat('0',j);
if ReadString(s, 'Name', '')<>'' then begin
Players[j].Name.Text := ReadString(s, 'Name', '');
sl := GameFile.ReadString (s, 'Letters current', StringOfChar('*',MaxLetters))
;
if length(sl)<MaxLetters then
sl := StringOfChar('*',MaxLetters);
for i:=1 to MaxLetters do
Players[j].Letters[i]:=sl[i];
sl := ReadString (s, 'Letters previous', StringOfChar('*',MaxLetters));
if length(sl)<MaxLetters then
sl := StringOfChar('*',MaxLetters);
for i:=1 to MaxLetters do
Players2[j].Letters[i]:=sl[i];
Players[j].Rec.Caption := ReadString (s, 'Points', '0');
Players[j].Button.Spacing := ReadInteger(s, 'Face', 0);
Players[j].Name.Visible := true;
end;
end;
{Чтение главных глобальных переменных игры}
s := ReadString('Common', 'Game status', 'Game');
if s='Game' then
GameState := gsGame
else
GameState := gsJustStarted;
PCurrent := ReadInteger('Common', 'Current Player', 1);
PCNo := ReadInteger('Common', 'PC Player No', 1);
Suggested := ReadBool('Common', 'Suggested', false);
{Чтение архива ходов}
PlayerMoves := ReadInteger('History','Turns count',0);
for i:=1 to PlayerMoves do begin
s := ReadString('History','Turn'+FormatFloat('000',i),StringOfChar(' ',100));
j := 0;
PlayerMove[i].PlayerName := Copy(s, j+1, 20);
j := j + 20;
PlayerMove[i].Word := Copy(s, j+1, MaxWordLength + 15);
j := j + MaxWordLength + 15;
PlayerMove[i].UsedLetters := Copy(s, j+1, 20);
j := j + 20;
PlayerMove[i].ReceivedLetters := Copy(s, j+1, 20);
j := j + 20;
PlayerMove[i].Points := StrToInt(Copy(s, j+1, 3));
j := j + 3;
PlayerMove[i].Total := StrToInt(Copy(s, j+1, 3));
j := j + 3;
PlayerMove[i].DirHor := (Copy(s, j+1, 1)='1');
j := j + 1;
PlayerMove[i].Pos.x := StrToInt(Copy(s, j+1, 2));
j := j + 2;
PlayerMove[i].Pos.y := StrToInt(Copy(s, j+1, 2));
end;
Free;
end;
{with}
{----------------------------------------------------------------------------}
{Показываем текущих игроков}
for i:=1 to MaxPlayers do
if Players[i].Name.Visible then begin
Players[i].Rec.Visible := true;
Players[i].LettersObj.Visible := true;
Players[i].Button.Visible := true;
end
else begin
Players[i].Rec.Visible := false;
Players[i].LettersObj.Visible := false;
end;
{... и их лица...}
for i:=1 to MaxPlayers do
if Players[i].Name.Text=_M_sPPCName then begin
Players[i].Button.Glyph.Canvas.Draw(0,0,Players[i].Button.Glyph);
ilPlayers.GetBitmap(ilPlayers.Count-1,Players[i].Button.Glyph)
end
else if Players[i].Button.Spacing<>0 then begin
Players[i].Button.Glyph.Canvas.Draw(0,0,Players[i].Button.Glyph);
ilPlayers.GetBitmap(Players[i].Button.Spacing,Players[i].Button.Glyph);
FacesUsed[Players[i].Button.Spacing] := true;
end;
StartGame(true);
tbBack.Enabled := true;
EMessage := '';
Caption := 'Erudite: '+od.FileName;
RepaintAll;
if Trim(Players[PCurrent].Name.Text)=_M_sPPCName then
ComputerStep;
end;
{------------------------------------------------------------------------------}
procedure Tfm_main.tbHelpClick(Sender: TObject);
begin
case CurrentLanguage of
lgENU:
ExecuteFile(ExtractFilePath(Application.EXEName) + 'help\help_e.htm','','');
lgDEU:
ExecuteFile(ExtractFilePath(Application.EXEName) + 'help\help_d.htm','','');
lgRUS:
ExecuteFile(ExtractFilePath(Application.EXEName) + 'help\help_r.htm','','');
end;
end;
{------------------------------------------------------------------------------}
procedure Tfm_main.tbSetupClick(Sender: TObject);
begin
fm_Setup.ShowModal;
end;
{------------------------------------------------------------------------------}
procedure Tfm_main.cb2Change(Sender: TObject);
begin
with Sender as TComponent do begin
if ShowTips then begin
Players[(Sender as TComponent).Tag].LettersObj.Hint := Format(_M_hPLetters, [
Players[Tag].Name.Text]);
Players[Tag].Rec.Hint := Format(_M_hPPoints, [Players[Tag].Name.Text]);
end;
{Добавить компьютер}
if (PCNo=0) and (Trim(Players[Tag].Name.Text)=_M_sPPCName) then begin
Players[Tag].Button.Glyph.Canvas.Draw(0,0,Players[Tag].Button.Glyph);
ilPlayers.GetBitmap(ilPlayers.Count-1,Players[Tag].Button.Glyph);
end;
{Убрать компьютер}
if {(PCNo=1) or} (Players[Tag].Name.Text<>_M_sPPCName) then begin
Players[Tag].Button.Glyph.Canvas.Draw(0,0,Players[Tag].Button.Glyph);
ilPlayers.GetBitmap(Players[Tag].Button.Spacing,Players[Tag].Button.Glyph);
end;
end;
end;
{------------------------------------------------------------------------------}
procedure Tfm_main.tbLangClick(Sender: TObject);
begin
pmLang.Popup(Application.MainForm.Left + 0 , Application.MainForm.Top + 46)
end;
{------------------------------------------------------------------------------}
procedure Tfm_main.tmGameTimer(Sender: TObject);
begin
UserTime := UserTime + tmGame.Interval/1000;
stTime.Caption := TimeToStr(UserTime / (24 * 60 * 60));
if UserTime > TimeLimit then begin
tmGame.Enabled := false;
stTime.Color := clRed;
if fm_Skip.Active then
fm_Skip.Close;
if fm_About.Active then
fm_About.Close;
if fm_DMan.Active then
fm_DMan.Close;
if fm_PMoves.Active then
fm_PMoves.Close;
if fm_Setup.Active then
fm_Setup.Close;
if fm_Suggest.Active then
fm_Suggest.Close;
if fm_Top.Active then
fm_Top.Close;
if fm_Word.Active then begin
EMessage := 'Timeout';
{Must be non empty!}
fm_Word.Close;
end
else begin
MessageBox(0,PChar(_M_mTimeOut),
PChar(Application.Title),
MB_OK or MB_TASKMODAL or
MB_ICONINFORMATION or MB_DEFBUTTON1);
sWord := '';
UserSkip := true;
NextPlayer;
end;
end;
end;
(*
procedure Test;
const
wid:byte=64;
deep:byte=16;
var i,j :integer;
pAND, PXOR:pointer;
icon:HIcon;
a1,b1: array[1..64*64*2] of byte;
hdc1:HDC;
siz:integer;
begin
{-DEBUG TEST--------------------------------------------------------------------}
{Выдача новых произвольных букв}
for i:=1 to MaxPlayers do
for j:=1 to MaxLetters do
Players[i].Letters[j]:=RandomLetter;
for i:=1 to MaxPlayers do
if Players[i].Name.Text='' then
Players[i].Button.Enabled := false;
for i:=1 to MaxPlayers do
Players[i].Name.Enabled:=false;
RepaintAll;
siz := Integer(Trunc(wid*wid/8*deep));
for i:=1 to siz do begin
a1[i] := i;
b1[i] := i mod 1;
end;
// Screen.Cursors[1] := CreateCursor(HInstance,2,2,wid,wid,@a1, @b1);
// Screen.Cursors[1] := CreateIcon(HInstance,wid,wid,1,16,@a1, @b1);
fm_Main.sg.Cursor := crHandPoint;
fm_Main.sg.Enabled := true;
end;
*)
{------------------------------------------------------------------------------}
procedure Tfm_main.FormActivate(Sender: TObject);
var
i : integer;
begin
{ Load Cofiguration from file -------------------------------------------------}
LoadConfig;
case CurrentLanguage of
lgENU:
DefineConstantsENU;
lgDEU:
DefineConstantsDEU;
lgRUS:
DefineConstantsRUS;
end;
LoadConstants;
cb1.Text := cb1.Items[0];
{Set correct Computer icon}
for i:=1 to 2 do
cb2Change(Players[i].Name);
if ParamStr(1)<>'' then begin
FileName := ParamStr(1);
tbLoadGameClick(Sender)
end
else if AutoLoad then begin
FileName := ExtractFilePath(Application.ExeName)+'Autosave.eru';
tbLoadGameClick(Sender);
end;
FileName := '';
od.InitialDir := ExtractFilePath(Application.ExeName);
sd.InitialDir := ExtractFilePath(Application.ExeName);
if ToolBar1.Top<>0 then
CoolBar1.Height := CoolBar1.Height - 1;
LoadDictionary(lgNone);
end;
{------------------------------------------------------------------------------}
procedure LoadDictionary(OldLang:TLanguage);
var
s : string;
begin
case OldLang of
lgENU:
SaveDic('DATA\WordsENU.txt');
lgDEU:
SaveDic('DATA\WordsDEU.txt');
lgRUS:
SaveDic('DATA\WordsRUS.txt');
end;
ActivateControls(false);
fm_DMan.lbActive.Items.Clear;
fm_DMan.lbDraft.Items.Clear;
{Write-----------------------------------------------------------------}
case CurrentLanguage of
lgENU:
FileOpenX(CurrDir+'DATA\WordsENU.txt',foReadOnly);
lgDEU:
FileOpenX(CurrDir+'DATA\WordsDEU.txt',foReadOnly);
lgRUS:
FileOpenX(CurrDir+'DATA\WordsRUS.txt',foReadOnly);
end;
if EMessage<>'' then begin
fm_Main.Cursor := crDefault;
MessageDlg(EMessage, mtError, [mbOk], 0);
// exit
end
else begin
while not eof(f1) do begin
Readln(f1,s);
fm_DMan.lbActive.Items.Add(s);
end;
{while}
CloseFile(f1);
end;
ActivateControls(true);
end;
{------------------------------------------------------------------------------}
procedure Tfm_main.SetLangClick(Sender: TObject);
var
OldLang : TLanguage;
OldPCName : string;
i : integer;
begin
with Sender as TComponent do
case Tag of
0 : if CurrentLanguage=lgENU then
exit;
1: if CurrentLanguage=lgDEU then
exit;
2: if CurrentLanguage=lgRUS then
exit;
end;
fm_Main.Cursor := crHourGlass;
OldLang := CurrentLanguage;
OldPCName := _M_sPPCName;
with Sender as TComponent do begin
case Tag of
0:
DefineConstantsENU;
1:
DefineConstantsDEU;
2:
DefineConstantsRUS;
end;
end;
LoadConstants;
LoadDictionary(OldLang);
for i:=1 to MaxPlayers do
if Players[i].Name.Text=OldPCName then
Players[i].Name.Text := _M_sPPCName;
fm_Main.Cursor := crDefault;
end;
{------------------------------------------------------------------------------}
procedure Tfm_main.FormClose(Sender: TObject; var Action: TCloseAction);
var
i,j,k : integer;
p : array[0..9] of string;
Exist : boolean;
IniFile : TIniFile;
begin
{if file is ReadOnly (CD Start) then ignore}
if (FileExists(ExtractFilePath(Application.ExeName)+'Erudite.ini')) and
((FileGetAttr(ExtractFilePath(Application.ExeName)+'Erudite.ini') and SysUtils.
faReadOnly) <> 0) then
exit;
{Сохраяенм словарь}
case CurrentLanguage of
lgENU:
SaveDic('DATA\WordsENU.txt');
lgDEU:
SaveDic('DATA\WordsDEU.txt');
lgRUS:
SaveDic('DATA\WordsRUS.txt');
end;
{Сохраяенм текущие настройки игры}
IniFile := TIniFile.Create(ExtractFilePath(Application.ExeName)+'Erudite.ini');
with IniFile do begin
WriteString('Setup','ID','Configuration file for The Erudite');
case CurrentLanguage of
lgENU:
WriteString('Setup','Language','English');
lgDEU:
WriteString('Setup','Language','Deutsch');
lgRUS:
WriteString('Setup','Language','Russian');
end;
WriteBool('Setup','ShowTips',ShowTips);
WriteBool('Setup','Animation',Animation);
WriteInteger('Setup','Time Limit',TimeLimit);
WriteBool('Setup','AutoSave',AutoSave);
WriteBool('Setup','AutoLoad',AutoLoad);
WriteInteger('Setup','Difficulty',Difficulty);
{Сохраняем список активных игроков}
k := -1;
for i:=1 to MaxPlayers do
if (Players[i].Name.Visible) and
(Trim(Players[i].Name.Text)<>'') and
(Trim(Players[i].Name.Text)<>UserName) and
(Trim(Players[i].Name.Text)<>_M_sPPCName) then begin
inc(k);
p[k] := Trim(Players[i].Name.Text);
end;
for i:=0 to cb1.Items.Count-1 do begin
Exist := false;
for j:=0 to k do
if (Trim(cb1.Items[i])=p[j]) then
Exist := true;
if (Trim(cb1.Items[i])<>_M_sPPCName) and
(Trim(cb1.Items[i])<>UserName) and
(not Exist) then begin
inc(k);
p[k] := Trim(cb1.Items[i]);
end;
if k=10 then begin
k := 9;
break;
end;
end;
for i:=0 to k do
WriteString('Players','Player'+FormatFloat('0',i),p[i]);
for i:=k+1 to 9 do
DeleteKey('Players','Player'+FormatFloat('0',i));
{10ка лучших игроков}
for i:=0 to 9 do
if TopNames[i].Name<>'' then begin
WriteString('Top 10','Name'+FormatFloat('0',i),FormatS(TopNames[i].Name,20) +
FormatS(TopNames[i].Points,5) +
TopNames[i].CoolWord);
end;
Free;
end;
{with}
{Если AUTOSAVE то сохраняем и саму игру}
if AutoSave then
tbSaveGameClick(fm_Main);
end;
{------------------------------------------------------------------------------}
procedure Tfm_main.btTopMouseMove(Sender: TObject;
Shift: TShiftState; X, Y: Integer);
begin
btTop.Font.Color := (Round(230*sin(x/60))+20)*256*256
+ (Round(230*cos(x/120))+20)*256
+ (Round(230*sin(y/15))+20);
end;
{------------------------------------------------------------------------------}
procedure Tfm_main.btTopMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
btTop.Font.Color := clYellow
end;
{------------------------------------------------------------------------------}
procedure Tfm_main.btTopClick(Sender: TObject);
begin
fm_Top.ShowModal
end;
{------------------------------------------------------------------------------}
procedure Tfm_main.sb12Click(Sender: TObject);
var
i,j : byte;
begin
if GameState<>gsNoGame then
EXIT;
{-------------------------------------------------------}
i := 0;
repeat
inc(i)
until Players[i].Button=Sender;
repeat
j := Random(FacesCount)+1
Until not FacesUsed[j];
Players[i].Button.Glyph.Canvas.Draw(5,5,Players[i].Button.Glyph);
ilPlayers.GetBitmap(j,Players[i].Button.Glyph);
FacesUsed[j] := true;
FacesUsed[Players[i].Button.Spacing] := false;
Players[i].Button.Spacing := j;
end;
{------------------------------------------------------------------------------}
procedure Tfm_main.cb1DrawItem(Control: TWinControl; Index: Integer;
Rect: TRect; State: TOwnerDrawState);
//
var
imWidth : integer;
begin
(*
imWidth:=imNet.Width;
with Control as TComboBox do begin
if odSelected in State then
Canvas.Font.Color:=clHighlightText
else begin
Canvas.Font.Color:=clWindowText;
end;
Canvas.TextRect(Rect, Rect.Left+imWidth+5, Rect.Top-2, cb1.Items[Index]);
Canvas.CopyMode:=cmSrcCopy;
Canvas.CopyRect(Classes.Rect(2,Rect.Top,imWidth+2,Rect.Top+imWidth), imNet.Canvas, Classes.Rect(0,0,imWidth,imWidth));
end
*)
end;
{------------------------------------------------------------------------------}
procedure Tfm_main.cbDropDown(Sender: TObject);
begin
SendMessage((Sender as TComboBox).Handle, CB_SETDROPPEDWIDTH, 350, 0)
end;
{------------------------------------------------------------------------------}
procedure Tfm_main.tbNetClick(Sender: TObject);
begin
fm_Net.ShowModal;
end;
{------------------------------------------------------------------------------}
procedure Tfm_Main.FormDestroy(Sender: TObject);
begin
FontErase;
end;
{------------------------------------------------------------------------------}
procedure SetOpacity(hwnd: THandle; Value:integer);
begin
if @SetLayeredWindowAttributes <> nil then begin
SetWindowLong(hwnd, GWL_EXSTYLE, GetWindowLong(hwnd, GWL_EXSTYLE) or WS_EX_LAYERED);
SetLayeredWindowAttributes(hwnd, 0, Value, LWA_ALPHA)
end;
end;
{------------------------------------------------------------------------------}
procedure LoadJPEGfromEXE;
var
MyJPG : TJPEGImage;
ResStream : TResourceStream;
begin
try
try
MyJPG := TJPEGImage.Create;
ResStream := TResourceStream.Create(HInstance, 'JPG_SPLASH', Pchar('RSDATA'));
MyJPG.LoadFromStream(ResStream);
fm_Main.Image1.Picture.Graphic := myJPG;
fm_Main.Image2.Picture.Graphic := myJPG;
fm_Main.Image3.Picture.Graphic := myJPG;
fm_Main.CoolBar1.Bitmap.Assign(myJPG);
finally
MyJPG.Free;
ResStream.Free;
end;
except;
fm_Main.Caption := fm_Main.Caption+': Exception: Resource JPG not loaded';
end;
end;
{------------------------------------------------------------------------------}
procedure Tfm_Main.LoadAVIfromEXE;
begin
{if come error 'cannot open AVI' try to reload Delphi}
try
fm_Main.anComp.ResHandle := 0;
//HInstance;
fm_Main.anComp.ResName := 'AVI_FINDPC';
fm_Main.anComp.Active := true;
except;
Caption := Caption+': Exception: Resource AVI not loaded';
end;
end;
{------------------------------------------------------------------------------}
procedure Tfm_Main.FormKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
if Key=112 then
tbHelpClick(Self)
end;
{------------------------------------------------------------------------------}
procedure Tfm_Main.RegisterExtension(Ext:string; DoRegister:boolean);
var
Reg : TRegistry;
ExeName : string;
begin
Reg := TRegistry.Create;
ExeName := ExtractFileName(Application.ExeName);
try
Reg.RootKey := HKEY_CLASSES_ROOT;
if Reg.OpenKey (Ext, true) then
if DoRegister then
Reg.WriteString('','The Erudite')
else
Reg.DeleteValue('');
Reg.CloseKey;
if Reg.OpenKey ('The Erudite', true) then
Reg.WriteString('','The Erudite file');
Reg.CloseKey;
if Reg.OpenKey ('The Erudite\DefaultIcon', true) then
Reg.WriteString('',Application.ExeName+',0');
Reg.CloseKey;
if Reg.OpenKey ('The Erudite\shell\open\Command', true) then
Reg.WriteString('','"'+Application.ExeName+'" "%1"');
Reg.CloseKey;
if Reg.OpenKey ('Applications\'+ExeName+'\shell', true) then
Reg.WriteString('','open');
Reg.CloseKey;
if Reg.OpenKey ('Applications\'+ExeName+'\shell\open\Command', true) then
Reg.WriteString('','"'+Application.ExeName+'" "%1"');
Reg.CloseKey;
Reg.RootKey := HKEY_CURRENT_USER;
if DoRegister then begin
if Reg.OpenKey ('Software\Microsoft\Windows\CurrentVersion\Explorer\FileExts\'+
Ext, true) then
Reg.WriteString('Application',ExeName)
end
else
Reg.DeleteKey('Software\Microsoft\Windows\CurrentVersion\Explorer\FileExts\'+Ext);
Reg.CloseKey;
finally
Reg.CloseKey;
end;
Reg.Free;
end;
{------------------------------------------------------------------------------}
procedure Tfm_Main.laPlayersClick(Sender: TObject);
var
i : integer;
mi : TMenuItem;
begin
pmPlayers.Items.Clear;
ilPlayers.BkColor := clNone;
for i:=1 to 32 do begin
mi := TMenuItem.Create(Self);
mi.ImageIndex := i;
pmPlayers.Items.Add(mi);
end;
pmPlayers.Popup(Left+475,0);
ilPlayers.BkColor := clFuchsia;
end;
end.