module Wordify.Rules.FormedWord (FormedWords, FormedWord, PlacedSquares, allWords, mainWord, adjacentWords, playerPlaced, playerPlacedMap, scoreWord, overallScore, bingoBonusApplied, prettyPrintIntersections, makeString, wordStrings, wordsWithScores, wordsFormedMidGame, wordFormedFirstMove) where import Wordify.Rules.Pos import Wordify.Rules.Square import Wordify.Rules.Tile import Wordify.Rules.Board import Wordify.Rules.ScrabbleError import Data.Sequence as Seq import Data.Map as Map import Control.Applicative import Control.Monad import Data.Foldable as Foldable import qualified Data.Maybe as M import qualified Data.List.Split as S import Data.Char import Data.Functor data FormedWords = FirstWord FormedWord | FormedWords { main :: FormedWord , otherWords :: [FormedWord] , placed :: PlacedSquares } deriving (Show, Eq) type FormedWord = Seq (Pos, Square) type PlacedSquares = Map Pos Square {- | Pretty prints the places a given formed word intersects with letters that were already on the board using brackets. E.g. T(HI)S would denote that the player placed a 'T' and an 'S' on to the board, using the already placed word 'HI' to form the new word 'THIS'. -} prettyPrintIntersections :: PlacedSquares -> FormedWord -> String prettyPrintIntersections placed formedWord = denotePassThroughs placed $ Foldable.toList formedWord where denotePassThroughs :: PlacedSquares -> [(Pos, Square)] -> String denotePassThroughs placed formed = let breaks = brokenSquaresToChars $ S.split (splitter placed) formed in case breaks of (part:parts) -> part ++ (Prelude.concat $ Prelude.zipWith (++) (cycle ["(",")"]) parts) [] -> "" squareToChar :: Square -> Char squareToChar sq = maybe '_' id $ tileIfOccupied sq >>= printLetter -- Splits whenever we encounter a series of squares that the player's word passes through -- on the board splitter :: PlacedSquares -> S.Splitter (Pos, Square) splitter placed = S.condense $ S.whenElt (flip (Map.notMember . fst) placed) brokenSquaresToChars :: [[(Pos, Square)]] -> [[Char]] brokenSquaresToChars brokenSquares = (Prelude.map . Prelude.map) (squareToChar . snd) brokenSquares {- | Scores an individual word. Note: overallscore should be used to obtain the overall score as it takes into account any bingo bonuses. -} scoreWord :: PlacedSquares -> FormedWord -> Int scoreWord played formed = let (notAlreadyPlaced, onBoardAlready) = partitionPlaced played formed in scoreSquares onBoardAlready notAlreadyPlaced where partitionPlaced placed formed = (mapTuple . fmap) snd $ Seq.partition (\(pos, _) -> Map.member pos placed) formed mapTuple :: (a -> b) -> (a, a) -> (b, b) mapTuple f (a1, a2) = (f a1, f a2) {- | Calculates the overall score of the play. If a player managed to place all 7 of their letters, then they receive a bingo bonus of 50 points. -} overallScore :: FormedWords -> Int overallScore formedWords = let wordsScore = Prelude.sum $ Prelude.map (scoreWord placed) $ allWords formedWords in case (Prelude.length $ keys $ placed) of 7 -> wordsScore + 50 _ -> wordsScore where placed = playerPlacedMap formedWords {-| All the words formed by a play. -} allWords :: FormedWords -> [FormedWord] allWords (FormedWords main adjacentWords _) = main : adjacentWords allWords (FirstWord firstWord) = [firstWord] {- | Returns the word formed by the first move on the board. The word must cover the star tile, and be linear. Any blank tiles must be labeled. -} wordFormedFirstMove :: Board -> Map Pos Tile -> Either ScrabbleError FormedWords wordFormedFirstMove board tiles | starPos `Map.notMember` tiles = Left DoesNotCoverTheStarTile | otherwise = placedSquares board tiles >>= fmap (FirstWord . main) . wordsFormed board {- | Returns the words formed by the tiles played on the board. A played word must be connected to a tile already on the board (or intersect tiles on the board), and be formed linearly. Any blank tiles must be labeled. -} wordsFormedMidGame :: Board -> Map Pos Tile -> Either ScrabbleError FormedWords wordsFormedMidGame board tiles = placedSquares board tiles >>= \squares -> wordsFormed board squares >>= \formed -> let FormedWords x xs _ = formed -- Check it connects to at least one other word on the board in if Seq.length x > Map.size squares || not (Prelude.null xs) then Right $ FormedWords x xs squares else Left DoesNotConnectWithWord {- | Returns the main word formed by the played tiles. The main word is the linear stretch of tiles formed by the tiles placed. -} mainWord :: FormedWords -> FormedWord mainWord (FirstWord word) = word mainWord formed = main formed {- | Returns the list of words which were adjacent to the main word formed. -} adjacentWords :: FormedWords -> [FormedWord] adjacentWords (FirstWord _) = [] adjacentWords formed = otherWords formed {- | Returns the list of positions mapped to the squares that the player placed their tiles on. -} playerPlaced :: FormedWords -> [(Pos, Square)] playerPlaced (FirstWord word) = Foldable.toList word playerPlaced formed = Map.toList $ placed formed playerPlacedMap :: FormedWords -> Map Pos Square playerPlacedMap (FirstWord word) = Map.fromList $ Foldable.toList word playerPlacedMap formed = placed formed {- | Scores the words formed by the tiles placed. The first item in the tuple is the overall score, while the second item is the list of scores for all the words formed. -} wordsWithScores :: FormedWords -> (Int, [(String, Int)]) wordsWithScores formedWords = (overallScore formedWords, fmap wordAndScore allFormedWords) where allFormedWords = allWords formedWords wordAndScore formedWord = (makeString formedWord, scoreWord (playerPlacedMap formedWords) formedWord) {- | Returns true if the player placed all 7 of their letters while forming these words, incurring a + 50 score bonus. -} bingoBonusApplied :: FormedWords -> Bool bingoBonusApplied formed = Prelude.length (playerPlaced formed) == 7 {- | Returns the words formed by the play as strings. -} wordStrings :: FormedWords -> [String] wordStrings (FirstWord word) = [makeString word] wordStrings formed = Prelude.map makeString $ main formed : otherWords formed makeString :: FormedWord -> String makeString word = M.mapMaybe (\(_, sq) -> tileIfOccupied sq >>= tileLetter) $ Foldable.toList word {- Checks that the tiles can be placed, and if so returns a map of the squares at the placed positions. A tile may be placed if the square is not already occupied, and if it is not an unlabeled blank tile. -} placedSquares :: Board -> Map Pos Tile -> Either ScrabbleError (Map Pos Square) placedSquares board tiles = squares where squares = Map.fromList <$> sequence ((\ (pos, tile) -> posTileIfNotBlank (pos, tile) >>= squareIfUnoccupied) <$> mapAsList) posTileIfNotBlank (pos,tile) = if tile == Blank Nothing then Left (CannotPlaceBlankWithoutLetter pos) else Right (pos, tile) squareIfUnoccupied (pos,tile) = maybe (Left (PlacedTileOnOccupiedSquare pos tile)) (\sq -> Right (pos, putTileOn sq tile)) $ unoccupiedSquareAt board pos mapAsList = Map.toList tiles wordsFormed :: Board -> Map Pos Square -> Either ScrabbleError FormedWords wordsFormed board tiles | Map.null tiles = Left NoTilesPlaced | otherwise = formedWords >>= \formed -> case formed of x : xs -> Right $ FormedWords x xs tiles [] -> Left NoTilesPlaced where formedWords = maybe (Left $ MisplacedLetter maxPos) (\direction -> middleFirstWord direction >>= (\middle -> let (midWord, _) = middle in let mainLine = preceding direction minPos >< midWord >< after direction maxPos in Right $ mainLine : adjacentToMain (swapDirection direction) ) ) getDirection preceding direction pos = case direction of Horizontal -> lettersLeft board pos Vertical -> lettersBelow board pos after direction pos = case direction of Horizontal -> lettersRight board pos Vertical -> lettersAbove board pos (minPos, _) = Map.findMin tiles (maxPos, _) = Map.findMax tiles adjacentToMain direction = Prelude.filter (\word -> Seq.length word > 1) $ Prelude.map (\(pos, square) -> (preceding direction pos |> (pos, square)) >< after direction pos) placedList middleFirstWord direction = case placedList of [x] -> Right (Seq.singleton x, minPos) (x:xs) -> foldM (\(word, lastPos) (pos, square) -> if not $ stillOnPath lastPos pos direction then Left $ MisplacedLetter pos else if isDirectlyAfter lastPos pos direction then Right (word |> (pos, square), pos) else let between = after direction lastPos in if expectedLettersInbetween direction lastPos pos between then Right ( word >< ( between |> (pos,square) ), pos) else Left $ MisplacedLetter pos ) (Seq.singleton x, minPos ) xs [] -> Left NoTilesPlaced placedList = Map.toAscList tiles stillOnPath lastPos thisPos direction = staticDirectionGetter direction thisPos == staticDirectionGetter direction lastPos expectedLettersInbetween direction lastPos currentPos between = Seq.length between + 1 == movingDirectionGetter direction currentPos - movingDirectionGetter direction lastPos swapDirection direction = if direction == Horizontal then Vertical else Horizontal getDirection -- If only one tile is placed, we look for the first tile it connects with if any. If it connects with none, we return 'Nothing' | (minPos == maxPos) && (not (Seq.null (lettersLeft board minPos)) || not (Seq.null (lettersRight board minPos))) = Just Horizontal | (minPos == maxPos) && (not (Seq.null (lettersBelow board minPos)) || not (Seq.null (lettersAbove board minPos))) = Just Vertical | xPos minPos == xPos maxPos = Just Vertical | yPos minPos == yPos maxPos = Just Horizontal | otherwise = Nothing staticDirectionGetter direction pos = if direction == Horizontal then yPos pos else xPos pos movingDirectionGetter direction pos = if direction == Horizontal then xPos pos else yPos pos isDirectlyAfter pos nextPos direction = movingDirectionGetter direction nextPos == movingDirectionGetter direction pos + 1