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.