test

Program Scrabble;

Uses
    SysUtils,
    Windows;

Type
    TLetterArray = Array ['а' .. 'я'] Of Integer;
    TWordArray = Array Of AnsiString;
    TScoreArray = Array Of Integer;
    TPlayerStringArray = Array Of AnsiString;
    TBonusArray = Array Of Array [0 .. 1] Of Boolean;

Const
    //wb - префикс от Word Bank
    WbFilePath = 'WordBank.txt';
    StartLetterBank: TLetterArray = (10, 3, 4, 3, 4, 16, 4, 4, 12, 4, 4, 4, 4, 12, 16, 5, 4, 8, 8, 4, 10, 8, 2, 4, 4, 4, 4, 2, 2, 4, 5, 5);

Function CreateWordBank(): TWordArray;
Var
    WbSize, WbCount: Integer;
    WbInputWord: AnsiString;
    WbBaseFile: TextFile;
    WordBank: TWordArray;
Begin
    WbCount := 0;
    AssignFile(WbBaseFile, WbFilePath);
    Reset(WbBaseFile);
    Readln(WbBaseFile, WbSize);
    SetLength(WordBank, WbSize);
    While Not EoF(WbBaseFile) Do
    Begin
        Readln(WbBaseFile, WbInputWord);
        WordBank[WbCount] := WbInputWord;
        Inc(WbCount);
    End;
    CloseFile(WbBaseFile);
    CreateWordBank := WordBank;
End;

Function InputNumberOfPlayers(): Integer;
Const
    MIN_NUM = 2;
    MAX_NUM = 6;
Var
    NumOfPlayers: Integer;
    IsInputCorrect: Boolean;
Begin
    Write('Введите количество игроков (целое число в диапазоне от 2 до 6): ');
    Repeat
        IsInputCorrect := True;
        Try
            Read(NumOfPlayers);
        Except
            IsInputCorrect := False;
            Write('Введено недопустимое значение. Повторите ввод: ');
        End;
        If IsInputCorrect And ((NumOfPlayers < MIN_NUM) Or (NumOfPlayers > MAX_NUM)) Then
        Begin
            IsInputCorrect := False;
            Write('Введено число, не входящее в диапазон допустимых значений. Повторите ввод: ');
        End;
    Until IsInputCorrect;
    InputNumberOfPlayers := NumOfPlayers;
End;

Function CheckLetterCount(PlayerString: String; LetterBank: TLetterArray): Boolean;
Var
    MissingLetters, LetterCounter: Integer;
    I: AnsiChar;
    IsEnough: Boolean;
Begin
    IsEnough := True;
    MissingLetters := 10 - Length(PlayerString);
    LetterCounter := 0;
    For I := 'а' To 'я' Do
        LetterCounter := LetterCounter + LetterBank[I];
    If MissingLetters > LetterCounter Then
        IsEnough := False;
    CheckLetterCount := IsEnough;
End;

Procedure FillPlayerString(Var TempPlayerString: AnsiString; Var LetterBank: TLetterArray);
Var
    RandomLetter: AnsiChar;
    RandomIndex, CountOfLetter: Integer;
Begin
    Randomize;
    While (Length(TempPlayerString) < 10) Do //Нужно набрать 10 букв
    Begin
        RandomIndex := Random(32) + 224;
        RandomLetter := AnsiChar(RandomIndex);
        CountOfLetter := LetterBank[RandomLetter];
        If CountOfLetter > 0 Then
        Begin
            TempPlayerString := TempPlayerString + RandomLetter;
            Dec(LetterBank[RandomLetter]);
        End;
    End;
End;

Function ReadPlayersWord(Var LetterPack: AnsiString): AnsiString;
Const
    RUS_LETTERS = ['а' .. 'я'];
    MAX_LENGTH = 10;
    MOVE_SKIP = '';
    FIFTY_FIFTY = '50';
    FRIEND_HELP = '+';
Var
    CharCount, LetterCount, FoundLetters: Integer;
    InputWord, StartPack: AnsiString;
    IsInputCorrect: Boolean;
Begin
    StartPack := LetterPack;
    Repeat
        Readln(InputWord);
        If (InputWord = '') Then
            Read(InputWord);
        IsInputCorrect := True;
        Trim(InputWord);
        If (InputWord <> FIFTY_FIFTY) And (InputWord <> FRIEND_HELP) And (InputWord <> MOVE_SKIP) Then
        Begin
            For CharCount := 1 To Length(InputWord) Do
                If Not(InputWord[CharCount] In RUS_LETTERS) Then
                    IsInputCorrect := False;
            If Not IsInputCorrect Or (Length(InputWord) > MAX_LENGTH) Then
            Begin
                IsInputCorrect := False;
                Write('Слово введено некорректно. Повторите ввод: ');
            End;
        End;
    Until IsInputCorrect;
    ReadPlayersWord := InputWord;
End;

Function IsWordInBank(ExpectedWord: String; WordBank: TWordArray; Var FindIndex: Integer): Boolean;
Var
    LeftIndex, RightIndex, MiddleIndex: Integer;
    IsFound: Boolean;
Begin
    LeftIndex := 0;
    IsFound := False;
    RightIndex := High(WordBank);
    FindIndex := -1;
    While (LeftIndex <= RightIndex) And (IsFound = False) Do
    Begin
        MiddleIndex := (LeftIndex + RightIndex) Div 2;
        If WordBank[MiddleIndex] = ExpectedWord Then
        Begin
            IsFound := True;
            FindIndex := MiddleIndex;
        End
        Else
        Begin
            If WordBank[MiddleIndex] < ExpectedWord Then
            Begin
                LeftIndex := MiddleIndex + 1;
                FindIndex := MiddleIndex;
            End
            Else
                RightIndex := MiddleIndex - 1;
        End;
    End;
    IsWordInBank := IsFound;
End;

//процедура очистки консоли, честно спизжена с просторов интернета
Procedure ClearConsole();
Var
    HStdOut: HWND;
    ScreenBufInfo: TConsoleScreenBufferInfo;
    Coord1: TCoord;
    Z: Integer;
Begin
    HStdOut := GetStdHandle(STD_OUTPUT_HANDLE);
    GetConsoleScreenBufferInfo(HStdOut, ScreenBufInfo);
    For Z := 1 To ScreenBufInfo.DwSize.Y Do
        WriteLn;
    Coord1.X := 0;
    Coord1.Y := 0;
    SetConsoleCursorPosition(HStdOut, Coord1);
End;

Procedure OutputMoveConditions(PlayerCount: Integer; LetterPack: AnsiString);
Var
    LetterCount: Integer;
Begin
    ClearConsole();
    Writeln('Ход игрока ', PlayerCount + 1, '.', #13#10);
    Writeln('Нажмите Enter, если вы хотите пропустить ход.');
    Writeln('Введите 50, если вы хотите использовать бонус "50/50".');
    Writeln('Введите +, если вы хотите использовать бонус "Помощь друга".', #13#10);
    Write('Ваш набор букв: [');
    //чуть более читаемый вывод набора букв
    For LetterCount := 1 To 9 Do
        Write(LetterPack[LetterCount], ', ');
    Writeln(LetterPack[10], '].', #13#10);
    Write('Введите ваше слово: ');
End;

Function ResultOfVote(PlayerCount, NumberOfPlayers: Integer): Boolean;
Const
    VOTE_FOR = 'да';
    VOTE_AGAINST = 'нет';
Var
    VoteCount, VotesFor, MinAmountOfVotes: Integer;
    Vote: AnsiString;
    IsInputCorrect, IsVotedFor: Boolean;
Begin
    Writeln('Введите "да", чтобы проголосовать за, и "нет", чтобы проголосовать против.', #13#10);
    MinAmountOfVotes := NumberOfPlayers Div 2 + NumberOfPlayers Mod 2;
    VotesFor := 1;
    Dec(NumberOfPlayers);
    For VoteCount := 0 To NumberOfPlayers Do
    Begin
        If (VoteCount <> PlayerCount) Then
        Begin
            Write('Игрок ', VoteCount + 1, ', ваш голос: ');
            Repeat
                IsInputCorrect := True;
                Readln(Vote);
                If (Vote = '') Then
                    Read(Vote);
                If (Vote <> VOTE_FOR) And (Vote <> VOTE_AGAINST) Then
                Begin
                    IsInputCorrect := False;
                    Write('Введено некорректное значение. Повторите ввод: ');
                End;
            Until IsInputCorrect;
            If (Vote = VOTE_FOR) Then
                Inc(VotesFor);
        End;
    End;
    If (VotesFor >= MinAmountOfVotes) Then
        IsVotedFor := True
    Else
        IsVotedFor := False;
    ResultOfVote := IsVotedFor;
End;

Function ExecuteBonus50(Var PlayerString: AnsiString; Var LetterBank: TLetterArray; Var PlayersScore: TScoreArray; NumberOfPlayer: Integer): Boolean;
Var
    CountLetters, CountChar, ChangeIndex: Integer;
    IsCorrect, IsOkay: Boolean;
    LettertoChange: AnsiChar;
    PlayersCopy, LetterStr: AnsiString;
Begin
    Randomize;
    PlayersCopy := PlayerString;
    For CountLetters := 0 To 4 Do
    Begin
        Write('Введите букву из вашего набора, которую вы хотели бы заменить: ');
        Repeat
            IsCorrect := False;
            Readln(LetterStr);
            If (LetterStr = '') Then
                Readln(LetterStr);
            If (Length(LetterStr) = 1) Then
            Begin
                LettertoChange := LetterStr[1];
                If (Ord(LettertoChange)>223) Then
                Begin
                    For CountChar := 1 To 10 Do
                        If (LetterToChange = PlayersCopy[CountChar]) Then
                        Begin
                            IsCorrect := True;
                            PlayersCopy[CountChar] := '0';
                            Repeat
                                IsOkay := True;
                                ChangeIndex := 255 - Random(32);
                                If (LetterBank[AnsiChar(ChangeIndex)] < 1) Then
                                    IsOkay := False;
                            Until (IsOkay);
                            Dec(LetterBank[AnsiChar(ChangeIndex)]);
                            PlayerString[CountChar] := AnsiChar(ChangeIndex);
                            Break;
                        End;
                    If Not(IsCorrect) Then
                        Write('В вашем наборе отсутствует такая буква или встречается меньшее количество раз. Повторите ввод: ');
                End
                Else
                    Write('Введите букву. Повторите ввод: ')
            End
            Else
                 Write('Введите только одну букву. Повторите ввод: ');
        Until (IsCorrect);
    End;
    Dec(PlayersScore[NumberOfPlayer], 2);
    ExecuteBonus50 := True;
End;

Function CheckIfContains(PlayerString: AnsiString; Var LetterIndex: Integer; NumberOfPlayer: Integer): AnsiChar;
Var
    LetterCounter: Integer;
    Letter: AnsiChar;
    LetterStr: AnsiString;
    IsCorrect: Boolean;
Begin
    Repeat
        IsCorrect := False;
        Readln(LetterStr);
        If (LetterStr = '') Then
            Readln(LetterStr);
        If (Length(LetterStr) = 1) Then
        Begin
            Letter := LetterStr[1];
            If (Ord(Letter)>223) Then
            Begin
                For LetterCounter := 1 To 10 Do
                    If (Letter = PlayerString[LetterCounter]) Then
                    Begin
                      IsCorrect := True;
                      LetterIndex := LetterCounter;
                    End;
                If Not(IsCorrect) Then
                    Write('В наборе отсутствует такая буква или встречается меньшее количество раз. Повторите ввод: ');
            End
            Else
                Write('Введите букву. Повторите ввод: ');
        End
        Else
            Write('Введите только одну букву. Повторите ввод: ');
    Until (IsCorrect);
    CheckIfContains := Letter;
End;

Function ExecuteBonusHelp(Var PlayersLetters: TPlayerStringArray; NumberOfPlayer: Integer): Boolean;
Var
    IsCorrect: Boolean;
    LetterToChange, DesiredLetter: AnsiChar;
    LetterIndexToChange, DesiredLetterIndex, OtherPlayerNumber: Integer;
Begin
    Write('Введите букву из вашего набора, которую хотели бы заменить: ');
    LetterToChange := CheckIfContains(PlayersLetters[NumberOfPlayer], LetterIndexToChange, NumberOfPlayer);
    Write('Введите номер игрока, с которым хотели бы обменяться: ');
    Repeat
        IsCorrect := True;
        Try
            Readln(OtherPlayerNumber);
        Except
            IsCorrect := False;
            Write('Введите цифру. Повторите ввод: ');
        End;
        if ((IsCorrect) And ((OtherPlayerNumber>0) And (OtherPlayerNumber<(High(PlayersLetters)+2)))) then
        Begin
            Dec(OtherPlayerNumber);
            If (OtherPlayerNumber = NumberOfPlayer) Then
            Begin
                Write('Вы не можете меняться с самим собой. Повторите ввод: ');
                IsCorrect := False;
            End;
            (*If (OtherPlayerNumber > High(PlayersLetters) ) Then
            Begin
                Write('Такого игрока не существует. Повторите ввод: ');
                IsCorrect := False;
            End;*)
        End
        Else
        Begin
            Write('Введите цифру от 1 до ', High(PlayersLetters)+1, ', кроме ', NumberOfPlayer+1,'. Повторите ввод: ');
            IsCorrect := False;
        End;
    Until (IsCorrect);
    Write('Введите букву из чужого набора, на которую вы хотели бы заменить свою букву: ');
    DesiredLetter := CheckIfContains(PlayersLetters[OtherPlayerNumber], DesiredLetterIndex, OtherPlayerNumber);
    PlayersLetters[NumberOfPlayer, LetterIndexToChange] := DesiredLetter;
    PlayersLetters[OtherPlayerNumber, DesiredLetterIndex] := LetterToChange;
    ExecuteBonusHelp := True;
End;

Procedure RefillLetterPacks(Var PlayersLetters: TPlayerStringArray);
Var
    PlayerCount, LetterCount, RandomIndex: Integer;
Begin
    Randomize;
    For PlayerCount := 0 To High(PlayersLetters) Do
        For LetterCount := 1 To Length(PlayersLetters[PlayerCount]) Do
            If (PlayersLetters[PlayerCount][LetterCount] = '0') Then
            Begin
                RandomIndex := Random(32) + 224;
                PlayersLetters[PlayerCount][LetterCount] := AnsiChar(RandomIndex);
            End;
End;

Procedure AddInsertWord(Var WordBank: TWordArray; AddWord: String);
Var
    I, FindIndex, Len: Integer;
Begin
    If Not(IsWordInBank(AddWord, WordBank, FindIndex)) Then
    Begin
        SetLength(WordBank, Length(WordBank) + 1);
        Len := FindIndex + 1; //Исправление: правильное определение Len
        For I := High(WordBank) Downto Len Do
            WordBank[I] := WordBank[I - 1];
        WordBank[FindIndex] := AddWord;
    End;
End;

Procedure RewriteWordBankFile(Var WordBank: TWordArray);
Var
    InputFile: TextFile;
    I: Integer;
Begin
    AssignFile(InputFile, WbFilePath);
    Rewrite(InputFile);
    Writeln(InputFile, Length(WordBank));
    For I := 0 To High(WordBank) Do
        Writeln(InputFile, WordBank[I]);
    CloseFile(InputFile);
End;

Procedure CalculatePoints(InputWord: AnsiString; Var LetterPack: AnsiString; Var WordBank: TWordArray; Var LastLetter: AnsiChar;
  Var PlayersScore: TScoreArray; PlayerCount: Integer);
Var
    FirstLetterCount, SecondLetterCount, FoundLetters, FindIndex, I: Integer;
    IsWordCorrect, IsVotedFor: Boolean;
Begin
    FoundLetters := 0;
    For FirstLetterCount := 1 To Length(InputWord) Do
        For SecondLetterCount := 1 To Length(LetterPack) Do
            If (InputWord[FirstLetterCount] = LetterPack[SecondLetterCount]) Then
            Begin
                Inc(FoundLetters);
                LetterPack[SecondLetterCount] := '0';
                Break;
            End;
    If (FoundLetters <> Length(InputWord)) Then
    Begin
        PlayersScore[PlayerCount] := PlayersScore[PlayerCount] + (-1) * Length(InputWord);
        Writeln('Введено неверное слово. Ваш счёт: ', PlayersScore[PlayerCount]);
    End
    Else
    Begin
        IsWordCorrect := IsWordInBank(InputWord, WordBank, FindIndex);
        If IsWordCorrect Then
        Begin
            If (InputWord[1] = LastLetter) Then
                PlayersScore[PlayerCount] := 2 * (PlayersScore[PlayerCount] + Length(InputWord))
            Else
                PlayersScore[PlayerCount] := PlayersScore[PlayerCount] + Length(InputWord);
            Writeln('Слово верное! Ваш счёт: ', PlayersScore[PlayerCount]);
        End
        Else
        Begin
            Writeln('Голосование: добавлять ли слово "', InputWord, '" в Банк Слов?');
            IsVotedFor := ResultOfVote(PlayerCount, Length(PlayersScore));
            If IsVotedFor Then
            Begin
                If (InputWord[1] = LastLetter) Then
                    PlayersScore[PlayerCount] := 2 * (PlayersScore[PlayerCount] + Length(InputWord))
                Else
                    PlayersScore[PlayerCount] := PlayersScore[PlayerCount] + Length(InputWord);
                AddInsertWord(WordBank, InputWord);
                RewriteWordBankFile(WordBank);
                Writeln(#13#10, 'Слово внесено в Банк Слов! Ваш счёт: ', PlayersScore[PlayerCount]);
            End
            Else
            Begin
                PlayersScore[PlayerCount] := PlayersScore[PlayerCount] + (-1) * Length(InputWord);
                Writeln(#13#10, 'Слово не внесено в Банк Слов. Ваш счёт: ', PlayersScore[PlayerCount]);
            End;
        End;
    End;
    For I := 0 To High(PlayersScore) Do
        Writeln('Очки ', I + 1, ' игрока: ', PlayersScore[I]);
    Writeln(#13#10, 'Нажмите Enter, чтобы перейти к следующему ходу.');
    Readln;
    //такие убогие условия иногда встречаются, какая-то проблема с самым первым считыванием
    If (LastLetter = #0) Or (InputWord = '') Then
        Readln;
End;

Procedure PlayGame(Var WordBank: TWordArray; Var NumberOfPlayers: Integer; Var PlayersScore: TScoreArray; BonusUsageArray: TBonusArray);
Const
    MOVE_SKIP = '';
    FIFTY_FIFTY = '50';
    FRIEND_HELP = '+';
Var
    LastLetter: AnsiChar;
    PlayerCount, SkippedMoves, HelpCount, CharCount: Integer;
    IsGameOver, IsInputCorrect, IsSkipped: Boolean;
    InputWord: AnsiString;
    LetterBank: TLetterArray;
    PlayersLetters: TPlayerStringArray;
Begin
    LastLetter := #0;
    InputWord := '';
    SetLength(PlayersLetters, NumberOfPlayers);
    SetLength(PlayersScore, NumberOfPlayers);
    SetLength(BonusUsageArray, NumberOfPlayers);
    LetterBank := StartLetterBank;
    IsGameOver := False;
    //заполняются наборы букв
    For PlayerCount := 0 To High(PlayersLetters) Do
        FillPlayerString(PlayersLetters[PlayerCount], LetterBank);
    Repeat
        SkippedMoves := 0;
        IsSkipped := False;
        //цикл ходов игроков в рамках одного хода игры
        For PlayerCount := 0 To High(PlayersScore) Do
        Begin
            RefillLetterPacks(PlayersLetters);
            OutputMoveConditions(PlayerCount, PlayersLetters[PlayerCount]);
            InputWord := ReadPlayersWord(PlayersLetters[PlayerCount]);
            Writeln;
            If (InputWord = MOVE_SKIP) Then
            Begin //Первый скип
                Inc(SkippedMoves);
                IsSkipped := True;
            End
            Else
                If (InputWord = FIFTY_FIFTY) Then
                Begin
                    If (BonusUsageArray[PlayerCount, 0]) Then
                        Writeln('Вы уже использовали этот бонус. Повторите ввод: ')
                    Else
                    Begin
                        BonusUsageArray[PlayerCount, 0] := ExecuteBonus50(PlayersLetters[PlayerCount], LetterBank, PlayersScore,
                          PlayerCount);
                        Write(#13#10, 'Ваш набор букв: [');
                        For CharCount := 1 To 9 Do
                            Write(PlayersLetters[PlayerCount][CharCount], ', ');
                        Writeln(PlayersLetters[PlayerCount][10], '].');
                        Write(#13#10, 'Введите ваше слово: ');
                    End;
                    Repeat
                        IsInputCorrect := True;
                        InputWord := ReadPlayersWord(PlayersLetters[PlayerCount]);
                        If (InputWord = FIFTY_FIFTY) Or (InputWord = FRIEND_HELP) Then
                        Begin
                            IsInputCorrect := False;
                            Write('Бонусы можно использовать только один раз за ход. Повторите ввод: ');
                        End;
                    Until IsInputCorrect;
                    Writeln;
                End
                Else
                    If (InputWord = FRIEND_HELP) Then
                    Begin
                        If (BonusUsageArray[PlayerCount, 0]) Then
                            Writeln('Вы уже использовали этот бонус. Повторите ввод: ')
                        Else
                        Begin
                            For HelpCount := 0 To High(PlayersLetters) Do
                                If (HelpCount <> PlayerCount) Then
                                Begin
                                    Write('Набор игрока ', HelpCount + 1, ': [');
                                    For CharCount := 1 To 9 Do
                                        Write(PlayersLetters[HelpCount][CharCount], ', ');
                                    Writeln(PlayersLetters[HelpCount][10], '].');
                                End;
                            Writeln;
                            BonusUsageArray[PlayerCount, 1] := ExecuteBonusHelp(PlayersLetters, PlayerCount);
                            Write(#13#10, 'Ваш набор букв: [');
                            For CharCount := 1 To 9 Do
                                Write(PlayersLetters[PlayerCount][CharCount], ', ');
                            Writeln(PlayersLetters[PlayerCount][10], '].');
                            Write(#13#10, 'Введите ваше слово: ');
                        End;
                        Repeat
                            IsInputCorrect := True;
                            InputWord := ReadPlayersWord(PlayersLetters[PlayerCount]);
                            If (InputWord = FIFTY_FIFTY) Or (InputWord = FRIEND_HELP) Then
                            Begin
                                IsInputCorrect := False;
                                Write('Бонусы можно использовать только один раз за ход. Повторите ввод: ');
                            End;
                        Until IsInputCorrect;
                        Writeln;
                    End;
            If (InputWord = MOVE_SKIP) And (IsSkipped = False) Then
                Inc(SkippedMoves);
            If IsSkipped = False Then
                CalculatePoints(InputWord, PlayersLetters[PlayerCount], WordBank, LastLetter, PlayersScore, PlayerCount);
            If (InputWord <> MOVE_SKIP) Then
                LastLetter := InputWord[Length(InputWord)]
        End;
        If (SkippedMoves = Length(PlayersScore)) Then
            IsGameOver := True;
        If (SkippedMoves = Length(PlayersScore)) And (LastLetter = #0) Then
            NumberOfPlayers := -1;
    Until IsGameOver;
End;

Procedure FindWinner(AmountOfPlayers: Integer; Var PlayerScore: TScoreArray);
Var
    NumberOfPlayer, Max, WinnerNumber: Integer;
Begin
    ClearConsole;
    If (AmountOfPlayers <> -1) Then
    Begin
        Max := PlayerScore[0];
        WinnerNumber := 0;
        For NumberOfPlayer := 1 To High(PlayerScore) Do
        Begin
            If PlayerScore[NumberOfPlayer] > Max Then
            Begin
                Max := PlayerScore[NumberOfPlayer];
                WinnerNumber := NumberOfPlayer;
            End;
        End;
        Writeln('Игра завершена! Победитель - игрок под номером ', WinnerNumber + 1, ' со счётом ', Max, '.');
        Writeln(#13#10, 'Поздравляем!', #13#10, #13#10, 'Нажмите Enter, чтобы выйти из игры.');
    End
    Else
    Begin
        Writeln('Не было сделано ни одного хода. Игра завершена.');
        Writeln(#13#10, 'Нажмите Enter, чтобы выйти из игры.');
    End;
    Readln;
End;

Var
    WordBank: TWordArray;
    NumberOfPlayers: Integer;
    PlayersScore: TScoreArray;
    BonusUsageArray: TBonusArray;

Begin
    WordBank := CreateWordBank();
    NumberOfPlayers := InputNumberOfPlayers();
    PlayGame(WordBank, NumberOfPlayers, PlayersScore, BonusUsageArray);
    FindWinner(NumberOfPlayers, PlayersScore);
    Readln;
End.