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
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
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
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)
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
allWords :: FormedWords -> [FormedWord]
allWords (FormedWords main adjacentWords _) = main : adjacentWords
allWords (FirstWord firstWord) = [firstWord]
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
wordsFormedMidGame :: Board -> Map Pos Tile -> Either ScrabbleError FormedWords
wordsFormedMidGame board tiles = placedSquares board tiles >>=
\squares -> wordsFormed board squares >>= \formed ->
let FormedWords x xs _ = formed
in if Seq.length x > Map.size squares || not (Prelude.null xs)
then Right $ FormedWords x xs squares
else Left DoesNotConnectWithWord
mainWord :: FormedWords -> FormedWord
mainWord (FirstWord word) = word
mainWord formed = main formed
adjacentWords :: FormedWords -> [FormedWord]
adjacentWords (FirstWord _) = []
adjacentWords formed = otherWords formed
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
wordsWithScores :: FormedWords -> (Int, [(String, Int)])
wordsWithScores formedWords = (overallScore formedWords, fmap wordAndScore allFormedWords)
where
allFormedWords = allWords formedWords
wordAndScore formedWord = (makeString formedWord, scoreWord (playerPlacedMap formedWords) formedWord)
bingoBonusApplied :: FormedWords -> Bool
bingoBonusApplied formed = Prelude.length (playerPlaced formed) == 7
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
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
| (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