pascalabcnet/TestSuite/CompilationSamples/BookWormABCNET.pas

uses GraphABC,ABCObjects,ABCButtons,Events;

const 
/// Примерная частота повторяемости букв
  freqcharstr='аааааааааааааааааааааааааабббббввввввввггггдддддддееееееееееееееееееееежжззззииииииииииииииииииийккккккккккккккклллллллллллммммммнннннннннннннннннооооооооооооооооооооооооппппппппрррррррррррррррррссссссссссссстттттттттттттттууууууффххцццчччшшщыыьььььэюяяяя';

const
  MaxWordLen = 12;
  scorehits: array [1..MaxWordLen] of integer = (0,1,2,4,7,11,16,22,29,37,46,56);

type 
  MySquareABC = class(SquareABC) end;

var
/// Доска с буквами
  MainBoard: ObjectBoardABC;
/// Доска высоты 1 для размещения слова
  WordBoard: ObjectBoardABC;
/// Номер первого незанятого символа на доске WordBoard
  cur: integer;
/// Количество ходов
  moves: integer;
/// Очки
  score: integer;
/// Прямоугольник для отображения информации
  Status: RectangleABC;

/// Существует ли такое слово (все слова хранятся в файле words.txt)
function WordExists(s: string): boolean;
var
  f: text;
  str: string;
begin
  s := LowerCase(s);
  Result := False;
  assign(f,'words.txt');
  reset(f);
  while not eof(f) do
  begin
    readln(f,str);
    if s=str then
    begin
      Result := True;
      break;
    end;
  end;
  close(f);
end;

procedure MyMouseDown(x,y,mb: integer);
begin
// Нажата левая мышь
  if mb=1 then
  begin
    if cur>WordBoard.DimX then
      exit;
    var ob := ObjectUnderPoint(x,y);
    if (ob is MySquareABC) and ob.Visible then
    begin
      var ob1 := WordBoard[cur,1];
      ob1.Visible := True;
      ob1.Text := ob.Text;
      Inc(cur);
      ob.Visible := False;
      var s := '';
      for var i:=1 to cur-1 do
        s := s + WordBoard[i,1].Text;
      if WordExists(s) then
        WordBoard.Color := clYellow
      else WordBoard.Color := clSkyBlue
    end;
  end
  else
// Нажата правая мышь
  begin
    for var xx:=1 to cur-1 do
      WordBoard[xx,1].Visible := False;
    for var xx:=1 to MainBoard.DimX do
    for var yy:=1 to MainBoard.DimY do
      MainBoard[xx,yy].Visible:=True;
    cur := 1;
    WordBoard.Color := clSkyBlue
  end;
end;

/// Обработчик кнопки "Новая игра"
procedure BtNewClick;
begin
  score := 0;
  moves := 0;
  Status.Text := 'Ходов: '+IntToStr(moves)+'   Очков: '+IntToStr(score);
  MyMouseDown(1,1,2);
  for var xx:=1 to MainBoard.DimX do
  for var yy:=1 to MainBoard.DimY do
    MainBoard[xx,yy].Text := UpCase(freqcharstr[Random(255)+1]);
end;

/// Обработчик кнопки "Сказать слово"
procedure BtWordClick;
begin
  if WordBoard.Color<>clYellow then
    exit;
  Inc(score,scorehits[cur-1]);
  Inc(moves);
  for var xx:=1 to cur-1 do
    WordBoard[xx,1].Visible:=False;
  for var xx:=1 to MainBoard.DimX do
  for var yy:=1 to MainBoard.DimY do
    if not MainBoard[xx,yy].Visible then
    begin
      MainBoard[xx,yy].Visible:=True;
      MainBoard[xx,yy].Text:=UpCase(freqcharstr[Random(255)+1]);
    end;
  cur := 1;
  WordBoard.Color := clSkyBlue;
  Status.Text := 'Ходов: '+IntToStr(moves)+'   Очков: '+IntToStr(score);
end;

/// Обработчик кнопки "Подсказка"
procedure BtPleaseClick;
var
  f: text;
  str,maxstr: string;
  arr,work: array ['а'..'я'] of integer;
  maxlen: integer;

  function CanConstructWord(s: string): boolean;
  begin
    work := arr;
    Result := True;
    for var i:=1 to Length(s) do
    begin
      Dec(work[s[i]]);
      if work[s[i]]<0 then
      begin
        Result := False;
        break;
      end;
    end;
  end;

begin // BtPleaseClick
  maxlen := 0;
  maxstr := '';
  for var c:='а' to 'я' do
    arr[c]:=0;

  for var xx:=1 to MainBoard.DimX do
  for var yy:=1 to MainBoard.DimY do
    Inc(arr[LowCase(MainBoard[xx,yy].Text[1])]);

  assign(f,'words.txt');
  reset(f);
  while not eof(f) do
  begin
    readln(f,str);
    if CanConstructWord(str) and (Length(str)>maxlen) and (Length(str)<=MaxWordLen) then
    begin
      maxlen := Length(str);
      maxstr := str;
    end;
  end;
  close(f);
  
  writeln(maxstr);
end;

procedure InitWindow;
begin
  SetWindowSize(640,480);
  Window.IsFixedSize := True;
  Window.Title := 'Знай русские слова!';
  Brush.Color := clMoneyGreen;
  FillRect(0,0,WindowWidth,WindowHeight);
end;

procedure InitGameVars;
begin
  cur := 1;
  moves := 0;
  score := 0;
end;

procedure InitButtons;
begin
  var btword := new ButtonABC(70,410,180,30,'Сказать слово',clGray);
  var btnew := new ButtonABC(280,410,100,30,'Заново',clLightGray);
  var btplease := new ButtonABC(410,410,160,30,'Подсказка',clGray);
  
// Привязка обработчиков к кнопкам
  btword.OnClick := BtWordClick;
  btnew.OnClick := BtNewClick;
  btplease.OnClick := BtPleaseClick;
end;


procedure InitInterface;
begin
  Status := new RectangleABC(70,350,500,30,clSkyBlue);
  Status.Text := 'Ходов: 0   Очков: 0';
  WordBoard := new ObjectBoardABC(20,40,MaxWordLen,1,50,50,clSkyBlue);
  MainBoard := new ObjectBoardABC(220,120,4,4,50,50,clMoneyGreen);
  MainBoard.BorderColor := clGreen;
  //MainBoard.Bordered := False;

  for var x:=1 to WordBoard.DimX do
  begin
    WordBoard[x,1] := new SquareABC(0,0,WordBoard.CellSizeX-6,clWhite);
    WordBoard[x,1].Visible := False;
  end;
  for var x:=1 to MainBoard.DimX do
  for var y:=1 to MainBoard.DimY do
  begin
    MainBoard[x,y] := new MySquareABC(0,0,MainBoard.CellSizeX-6,clWhite);
    MainBoard[x,y].Text := UpCase(freqcharstr[Random(freqcharstr.Length)+1]);
  end;
end;

begin
  SetConsoleIO;

  InitWindow;
  InitGameVars;
  InitInterface;
  InitButtons;

  OnMouseDown := MyMouseDown;
end.