diff --git a/src/Wordify/Rules/Board.hs b/src/Wordify/Rules/Board.hs --- a/src/Wordify/Rules/Board.hs +++ b/src/Wordify/Rules/Board.hs @@ -112,9 +112,10 @@ columnLabelSeparator = " " ++ (Prelude.take (15 * 5) $ repeat '-') ++ "\n" columnLabels = " " ++ (concat $ Prelude.take (15 * 2) . L.intersperse " " . map (: []) $ ['A' ..]) + squareToString :: Square -> String squareToString square = case (tileIfOccupied square) of - Just sq -> maybe " |_| " (\lt -> " |" ++ lt : "| ") $ tileLetter sq + Just sq -> maybe " |_| " (\lt -> " |" ++ lt ++ "| ") (tileString sq) Nothing -> case square of (Normal _) -> " N " @@ -143,7 +144,7 @@ >>= \sq -> return (nextPos, sq) {- - Represents the board as a comma delimited string where each character is either the character in the board square + Represents the board as a comma delimited string where each string is either the string in the board square or an empty string. The string is ordered by column then row, starting at position A1 and ending at O15. E.g. an empty board would be representated as 244 contiguous , characters. A @@ -158,26 +159,26 @@ squareStrings board = map getLetterRepresentation (allSquares board) getLetterRepresentation :: (Pos, Square) -> String - getLetterRepresentation square = toLetterRepresentation ((tileIfOccupied . snd) square >>= tileLetter) + getLetterRepresentation square = toLetterRepresentation ((tileIfOccupied . snd) square >>= tileString) - toLetterRepresentation :: Maybe Char -> String - toLetterRepresentation (Just char) = [char] + toLetterRepresentation :: Maybe String -> String + toLetterRepresentation (Just char) = char toLetterRepresentation Nothing = "" {- Loads a board from the string representation of the board generated by the 'textPresentation' function -} -loadFromTextRepresentation :: M.Map Char Tile -> String -> Maybe Board +loadFromTextRepresentation :: M.Map String Tile -> String -> Maybe Board loadFromTextRepresentation validTiles textRepresentation = - let positionsWithLetters = L.zip [0 ..] (S.splitOn "," textRepresentation) - in let placements = mapMaybe (uncurry positionWithLetter) positionsWithLetters + let positionsWithTileString = L.zip [0 ..] (S.splitOn "," textRepresentation) + in let placements = mapMaybe (uncurry positionWithLetter) positionsWithTileString in placeTiles emptyBoard placements where - positionWithLetter :: Int -> [Char] -> Maybe (Tile, Pos) - positionWithLetter oneDimensionalCoordinate [] = Nothing - positionWithLetter oneDimensionalCoordinate (letter: []) = do - tile <- M.lookup letter validTiles - let x = (oneDimensionalCoordinate `div` 15) + 1 + positionWithLetter :: Int -> String -> Maybe (Tile, Pos) + positionWithLetter oneDimensionalCoordinate [] = Nothing + positionWithLetter oneDimensionalCoordinate tileString = do + tile <- M.lookup tileString validTiles + let x = (oneDimensionalCoordinate `div` 15) + 1 let y = (oneDimensionalCoordinate `mod` 15) + 1 coordinate <- posAt (x, y) return (tile, coordinate) diff --git a/src/Wordify/Rules/FormedWord.hs b/src/Wordify/Rules/FormedWord.hs --- a/src/Wordify/Rules/FormedWord.hs +++ b/src/Wordify/Rules/FormedWord.hs @@ -1,260 +1,295 @@ -module Wordify.Rules.FormedWord (FormedWords, - FormedWord, - PlacedSquares, - allWords, - mainWord, - adjacentWords, - playerPlaced, - playerPlacedMap, - scoreWord, - overallScore, - bingoBonusApplied, - prettyPrintIntersections, - makeString, - wordStrings, - wordsWithScores, - wordsFormedMidGame, - wordFormedFirstMove) where +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 +import Control.Applicative +import Control.Error (note) +import Control.Monad +import Data.Char +import Data.Foldable as Foldable +import Data.Functor +import qualified Data.List.Split as S +import Data.Map as Map +import Data.Maybe (isJust) +import qualified Data.Maybe as M +import Data.Sequence as Seq +import Wordify.Rules.Board +import Wordify.Rules.LetterBag +import Wordify.Rules.Pos +import Wordify.Rules.ScrabbleError +import Wordify.Rules.Square +import Wordify.Rules.Tile - data FormedWords = FirstWord FormedWord | FormedWords { - main :: FormedWord - , otherWords :: [FormedWord] - , placed :: PlacedSquares - } deriving (Show, Eq) - - type FormedWord = Seq (Pos, Square) - type PlacedSquares = Map Pos Square +data FormedWords + = FirstWord FormedWord + | FormedWords + { main :: FormedWord, + otherWords :: [FormedWord], + placed :: PlacedSquares + } + deriving (Show, Eq) - {- | - 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) - [] -> "" +type FormedWord = Seq (Pos, Square) - squareToChar :: Square -> Char - squareToChar sq = maybe '_' id $ tileIfOccupied sq >>= printLetter +type PlacedSquares = Map Pos Square - -- 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) +-- | +-- 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 Prelude.concat (mapEverySecond wrapInBrackets breaks) - brokenSquaresToChars :: [[(Pos, Square)]] -> [[Char]] - brokenSquaresToChars brokenSquares = (Prelude.map . Prelude.map) (squareToChar . snd) brokenSquares + alreadyPlacedOpening :: String + alreadyPlacedOpening = "(" - {- | - Scores an individual word. + alreadyPlacedClosing :: String + alreadyPlacedClosing = ")" - 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 + wrapInBrackets :: String -> String + wrapInBrackets str = concat [alreadyPlacedOpening, str, alreadyPlacedClosing] - mapTuple :: (a -> b) -> (a, a) -> (b, b) - mapTuple f (a1, a2) = (f a1, f a2) + mapEverySecond :: (a -> a) -> [a] -> [a] + mapEverySecond f = Prelude.zipWith ($) (cycle [id, f]) - {- | - Calculates the overall score of the play. + squareToString :: Square -> String + squareToString sq = M.fromMaybe "_" $ tileIfOccupied sq >>= printString - 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 + -- 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) - {-| - All the words formed by a play. - -} - allWords :: FormedWords -> [FormedWord] - allWords (FormedWords main adjacentWords _) = main : adjacentWords - allWords (FirstWord firstWord) = [firstWord] + brokenSquaresToChars :: [[(Pos, Square)]] -> [String] + brokenSquaresToChars brokenSquares = Prelude.map (concatMap (squareToString . snd)) brokenSquares - {- | - 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 +-- | +-- 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 - {- | - 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 + mapTuple :: (a -> b) -> (a, a) -> (b, b) + mapTuple f (a1, a2) = (f a1, f a2) - {- | - 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 +-- | +-- 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 - {- | - Returns the list of words which were adjacent to the main word formed. - -} - adjacentWords :: FormedWords -> [FormedWord] - adjacentWords (FirstWord _) = [] - adjacentWords formed = otherWords formed +-- | +-- All the words formed by a play. +allWords :: FormedWords -> [FormedWord] +allWords (FormedWords main adjacentWords _) = main : adjacentWords +allWords (FirstWord firstWord) = [firstWord] - {- | - 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 +-- | +-- 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 - playerPlacedMap :: FormedWords -> Map Pos Square - playerPlacedMap (FirstWord word) = Map.fromList $ Foldable.toList word - playerPlacedMap formed = placed formed +-- | +-- 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 + in -- Check it connects to at least one other word on the board + if Seq.length x > Map.size squares || not (Prelude.null xs) + then Right $ FormedWords x xs squares + else Left DoesNotConnectWithWord - {- | - 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 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 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 +-- | +-- Returns the list of words which were adjacent to the main word formed. +adjacentWords :: FormedWords -> [FormedWord] +adjacentWords (FirstWord _) = [] +adjacentWords formed = otherWords formed - makeString :: FormedWord -> String - makeString word = M.mapMaybe (\(_, sq) -> tileIfOccupied sq >>= tileLetter) $ Foldable.toList word +-- | +-- 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 - {- - 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) +playerPlacedMap :: FormedWords -> Map Pos Square +playerPlacedMap (FirstWord word) = Map.fromList $ Foldable.toList word +playerPlacedMap formed = placed formed - 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 +-- | +-- 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) - 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 +-- | +-- 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 - 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 +-- | +-- 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 - (minPos, _) = Map.findMin tiles - (maxPos, _) = Map.findMax tiles +makeString :: FormedWord -> String +makeString word = concat <$> M.mapMaybe (\(_, sq) -> tileIfOccupied sq >>= tileString) $ Foldable.toList word - adjacentToMain direction = Prelude.filter (\word -> Seq.length word > 1) $ Prelude.map (\(pos, square) -> - (preceding direction pos |> (pos, square)) >< after direction pos) placedList +{- + 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) -> squareIfUnoccupied (pos, tile) + ) + <$> mapAsList + ) - 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 + squareIfUnoccupied (pos, tile) = + maybe + (Left (PlacedTileOnOccupiedSquare pos tile)) + ( \sq -> + Right (pos, putTileOn sq tile) + ) + $ unoccupiedSquareAt board pos + mapAsList = Map.toList tiles - placedList = Map.toAscList 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 - 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 + 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 - swapDirection direction = if direction == Horizontal then Vertical else Horizontal + (minPos, _) = Map.findMin tiles + (maxPos, _) = Map.findMax tiles - 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 + adjacentToMain direction = + Prelude.filter (\word -> Seq.length word > 1) $ + Prelude.map + ( \(pos, square) -> + (preceding direction pos |> (pos, square)) >< after direction pos + ) + placedList - staticDirectionGetter direction pos = if direction == Horizontal then yPos pos else xPos pos + 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 - movingDirectionGetter direction pos = if direction == Horizontal then xPos pos else yPos pos + placedList = Map.toAscList tiles - isDirectlyAfter pos nextPos direction = movingDirectionGetter direction nextPos == movingDirectionGetter direction pos + 1 + 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 diff --git a/src/Wordify/Rules/LetterBag.hs b/src/Wordify/Rules/LetterBag.hs --- a/src/Wordify/Rules/LetterBag.hs +++ b/src/Wordify/Rules/LetterBag.hs @@ -1,196 +1,192 @@ -module Wordify.Rules.LetterBag (LetterBag, - validLetters, - makeBag, - tiles, - bagFromTiles, - makeBagUsingGenerator, - takeLetters, - exchangeLetters, - shuffleBag, - shuffleWithNewGenerator, - bagSize, - getGenerator) where +module Wordify.Rules.LetterBag + ( LetterBag, + ValidTiles, + validLetters, + makeBag, + tiles, + bagFromTiles, + makeBagUsingGenerator, + takeLetters, + exchangeLetters, + shuffleBag, + shuffleWithNewGenerator, + bagSize, + getGenerator, + ) +where -import Wordify.Rules.Tile -import System.Random -import Data.Array.IO -import Control.Monad import qualified Control.Exception as Exc -import Wordify.Rules.ScrabbleError -import Text.ParserCombinators.Parsec +import Control.Monad +import Control.Monad.ST +import Data.Array.IO +import Data.Array.ST import Data.Char import qualified Data.Map as M -import Wordify.Rules.LetterBag.Internal -import System.IO -import Data.Array.ST -import Control.Monad.ST +import qualified Data.Maybe as Mb import Data.STRef import qualified Data.Set as S -import qualified Data.Maybe as Mb - -{- | - Creates a letter bag from a file where each line contains a space delimited letter character, letter value, and letter distribution. - A blank letter is represented by a '_' character and has a disribution, but no value. - - If successful, the letter bag is shuffled before it is returned. +import System.IO +import System.Random +import Text.ParserCombinators.Parsec +import Wordify.Rules.LetterBag.Internal +import Wordify.Rules.ScrabbleError +import Wordify.Rules.Tile --} +-- | +-- Creates a letter bag from a file where each line contains a space delimited letter character, letter value, and letter distribution. +-- A blank letter is represented by a '_' character and has a disribution, but no value. +-- +-- If successful, the letter bag is shuffled before it is returned. makeBag :: FilePath -> IO (Either ScrabbleError LetterBag) makeBag path = do - ioOutcome <- Exc.try $ withFile path ReadMode (hGetContents >=> parseBagString path) :: IO (Either Exc.IOException (Either ScrabbleError LetterBag)) - case ioOutcome of - Left _ -> return $ Left (LetterBagFileNotOpenable path) - Right x -> return $ fmap shuffleBag x + ioOutcome <- Exc.try $ withFile path ReadMode (hGetContents >=> parseBagString path) :: IO (Either Exc.IOException (Either ScrabbleError LetterBag)) + case ioOutcome of + Left _ -> return $ Left (LetterBagFileNotOpenable path) + Right x -> return $ fmap shuffleBag x parseBagString :: String -> String -> IO (Either ScrabbleError LetterBag) -parseBagString path bagString = - let parseResult = parseBag bagString in - case parseResult of - Left _ -> return $ Left (MalformedLetterBagFile path) - Right parsedTiles -> - do - gen <- newStdGen - return $ Right (LetterBag parsedTiles (length parsedTiles) gen (bagLetters parsedTiles)) - -{- | - Creates a letter bag from a list of tiles. The order of the tiles is retained in the resulting letter bag. +parseBagString path bagString = + let parseResult = parseBag bagString + in case parseResult of + Left err -> return $ Left (MalformedLetterBagFile path (show err)) + Right parsedTiles -> + do + gen <- newStdGen + return $ Right (LetterBag parsedTiles (length parsedTiles) gen (bagLetters parsedTiles)) - This function is effectful as it is necessary to create a stdGen for list to allow - it to be shuffled using this generator in the future. --} +-- | +-- Creates a letter bag from a list of tiles. The order of the tiles is retained in the resulting letter bag. +-- +-- This function is effectful as it is necessary to create a stdGen for list to allow +-- it to be shuffled using this generator in the future. bagFromTiles :: [Tile] -> IO LetterBag bagFromTiles bagTiles = - do - generator <- newStdGen - return $ LetterBag bagTiles (length bagTiles) generator (bagLetters bagTiles) + do + generator <- newStdGen + return $ LetterBag bagTiles (length bagTiles) generator (bagLetters bagTiles) -{-| - Helper function to construct a LetterBag. Maps the valid letters in a letter bag - to the tile representing that letter on the board. --} -bagLetters :: [Tile] -> M.Map Char Tile +-- | +-- Helper function to construct a LetterBag. Maps the valid letters in a letter bag +-- to the tile representing that letter on the board. +bagLetters :: [Tile] -> M.Map String Tile bagLetters tiles = - let maybeLetters = Mb.mapMaybe pairIfTileHasLetter tiles - in M.fromList maybeLetters - where - pairIfTileHasLetter :: Tile -> Maybe (Char, Tile) - pairIfTileHasLetter tile = - case (tileLetter tile) of - Just lettr -> Just (lettr, tile) - _ -> Nothing + let maybeLetters = Mb.mapMaybe pairIfTileHasLetter tiles + in M.fromList maybeLetters + where + pairIfTileHasLetter :: Tile -> Maybe (String, Tile) + pairIfTileHasLetter tile = + case tileString tile of + Just lettr -> Just (lettr, tile) + _ -> Nothing -{- | - Takes 'n' numbers from a letter bag, yielding 'Nothing' - if there is not enough tiles left in the bag or a 'Just' - tuple where the left value is the taken tiles, and the right - value is the new bag. --} +-- | +-- Takes 'n' numbers from a letter bag, yielding 'Nothing' +-- if there is not enough tiles left in the bag or a 'Just' +-- tuple where the left value is the taken tiles, and the right +-- value is the new bag. takeLetters :: LetterBag -> Int -> Maybe ([Tile], LetterBag) takeLetters (LetterBag bagTiles lettersLeft gen validLetters) numTake = - if (newNumLetters < 0) then Nothing - else Just (taken, LetterBag newLetters newNumLetters gen validLetters) + if newNumLetters < 0 + then Nothing + else Just (taken, LetterBag newLetters newNumLetters gen validLetters) where newNumLetters = lettersLeft - numTake (taken, newLetters) = splitAt numTake bagTiles -{- | - Exchanges given tiles for the same number of tiles from the bag. - The exchanged letters are added to the bag, the bag is then shuffled, - and then the same number of tiles as exchanged are drawn from the bag. - - Returns 'Nothing' if there are not enough letters in the bag to exchange - the given tiles for. Otherwise returns 'Just' with a tuple with the tiles - given, and the new letterbag. --} +-- | +-- Exchanges given tiles for the same number of tiles from the bag. +-- The exchanged letters are added to the bag, the bag is then shuffled, +-- and then the same number of tiles as exchanged are drawn from the bag. +-- +-- Returns 'Nothing' if there are not enough letters in the bag to exchange +-- the given tiles for. Otherwise returns 'Just' with a tuple with the tiles +-- given, and the new letterbag. exchangeLetters :: LetterBag -> [Tile] -> (Maybe ([Tile], LetterBag)) exchangeLetters (LetterBag bagTiles lettersLeft gen validLetters) exchanged = - if (lettersLeft == 0) then Nothing else takeLetters (shuffleBag intermediateBag) numLettersGiven - where - numLettersGiven = length exchanged - intermediateBag = LetterBag (exchanged ++ bagTiles) (lettersLeft + numLettersGiven) gen validLetters - -{- | - Shuffles the contents of a letter bag. The bag is shuffled using the random generator which was created - while constructing the bag. + if lettersLeft == 0 then Nothing else takeLetters (shuffleBag intermediateBag) numLettersGiven + where + numLettersGiven = length exchanged + intermediateBag = LetterBag (exchanged ++ bagTiles) (lettersLeft + numLettersGiven) gen validLetters - This function should not be used when creating an additional game with a new letter bag as - the same seed value will be shared across games (meaning tiles will come out of the bag in - the same order.) When constructing an additional game, use shuffleWithNewGenerator. --} +-- | +-- Shuffles the contents of a letter bag. The bag is shuffled using the random generator which was created +-- while constructing the bag. +-- +-- This function should not be used when creating an additional game with a new letter bag as +-- the same seed value will be shared across games (meaning tiles will come out of the bag in +-- the same order.) When constructing an additional game, use shuffleWithNewGenerator. shuffleBag :: LetterBag -> LetterBag -shuffleBag (LetterBag _ 0 gen validLetters) = LetterBag [] 0 gen validLetters +shuffleBag (LetterBag _ 0 gen validLetters) = LetterBag [] 0 gen validLetters shuffleBag (LetterBag bagTiles size gen validLetters) = let (newTiles, newGenerator) = shuffle bagTiles gen size - in (LetterBag newTiles size newGenerator validLetters) - + in (LetterBag newTiles size newGenerator validLetters) where -- Taken from http://www.haskell.org/haskellwiki/Random_shuffle - shuffle :: [a] -> StdGen -> Int -> ([a],StdGen) - shuffle xs randomGen listLength = runST (do + shuffle :: [a] -> StdGen -> Int -> ([a], StdGen) + shuffle xs randomGen listLength = + runST + ( do g <- newSTRef randomGen let randomRST lohi = do - (a,s') <- liftM (randomR lohi) (readSTRef g) + (a, s') <- liftM (randomR lohi) (readSTRef g) writeSTRef g s' return a ar <- newArr n xs - xs' <- forM [1..n] $ \i -> do - j <- randomRST (i,n) - vi <- readArray ar i - vj <- readArray ar j - writeArray ar j vi - return vj + xs' <- forM [1 .. n] $ \i -> do + j <- randomRST (i, n) + vi <- readArray ar i + vj <- readArray ar j + writeArray ar j vi + return vj gen' <- readSTRef g - return (xs',gen')) + return (xs', gen') + ) where n = listLength newArr :: Int -> [a] -> ST s (STArray s Int a) - newArr z zs = newListArray (1,z) zs + newArr z zs = newListArray (1, z) zs -{- | - Creates a letter bag using a list of tiles, and a generator which should be used when shuffling the bag. - This function allows a game to be stepped through from the beginning where the moves and original generator were - recorded, with any shuffling yielding the same bag as in the original game. --} +-- | +-- Creates a letter bag using a list of tiles, and a generator which should be used when shuffling the bag. +-- This function allows a game to be stepped through from the beginning where the moves and original generator were +-- recorded, with any shuffling yielding the same bag as in the original game. makeBagUsingGenerator :: [Tile] -> StdGen -> LetterBag makeBagUsingGenerator bagTiles randomGenerator = LetterBag bagTiles (length bagTiles) randomGenerator (bagLetters bagTiles) -{- | - Get the letter bag's current generator, which will be used to shuffle the contents of the bag in the next exchange - or shuffle. If taken at the start of the game, with the original list of tiles in the bag in order, the game moves - may be replayed in order with the original results of any shuffle retained. --} +-- | +-- Get the letter bag's current generator, which will be used to shuffle the contents of the bag in the next exchange +-- or shuffle. If taken at the start of the game, with the original list of tiles in the bag in order, the game moves +-- may be replayed in order with the original results of any shuffle retained. getGenerator :: LetterBag -> StdGen getGenerator = generator -{- | - Shuffles a letter bag using a new random generator. This function should be used when spawning a new game using - a letter bag with all the tiles remaining so that letter bags are unique between game instances. --} +-- | +-- Shuffles a letter bag using a new random generator. This function should be used when spawning a new game using +-- a letter bag with all the tiles remaining so that letter bags are unique between game instances. shuffleWithNewGenerator :: LetterBag -> IO LetterBag -shuffleWithNewGenerator letterBag = fmap (\newGen -> shuffleBag $ letterBag { generator = newGen }) newStdGen +shuffleWithNewGenerator letterBag = fmap (\newGen -> shuffleBag $ letterBag {generator = newGen}) newStdGen parseBag :: String -> Either ParseError [Tile] parseBag contents = parse bagFile "Malformed letter bag file" contents where bagFile = - do bagTiles <- many bagLine - eof - let flattenedTiles = concat bagTiles - return $ flattenedTiles + do + bagTiles <- many bagLine + eof + let flattenedTiles = concat bagTiles + return $ flattenedTiles - bagLine = - do bagTiles <- try (letterTiles) <|> blankTiles - return bagTiles + bagLine = try (letterTiles) <|> blankTiles letterTiles = do - tileCharacter <- letter - _ <- space - value <- many digit - _ <- space - distribution <- many digit - _ <- newline - return $ replicate (read distribution) (Letter (toUpper tileCharacter) (read value)) + tileCharacter <- many letter + _ <- space + value <- many digit + _ <- space + distribution <- many digit + _ <- newline + return $ replicate (read distribution) (Letter (map toUpper tileCharacter) (read value)) blankTiles = do diff --git a/src/Wordify/Rules/LetterBag/Internal.hs b/src/Wordify/Rules/LetterBag/Internal.hs --- a/src/Wordify/Rules/LetterBag/Internal.hs +++ b/src/Wordify/Rules/LetterBag/Internal.hs @@ -1,10 +1,12 @@ -module Wordify.Rules.LetterBag.Internal (LetterBag(LetterBag), tiles, bagSize, validLetters, generator) where +module Wordify.Rules.LetterBag.Internal (LetterBag (LetterBag), ValidTiles, tiles, bagSize, validLetters, generator) where - import Wordify.Rules.Tile - import System.Random - import Data.Map +import Data.Map +import System.Random +import Wordify.Rules.Tile - data LetterBag = LetterBag { tiles :: [Tile], bagSize :: Int, generator :: StdGen, validLetters :: Map Char Tile } deriving (Show) +type ValidTiles = Map String Tile - instance Eq LetterBag where - bag1 == bag2 = (bagSize bag1 == bagSize bag2 && tiles bag1 == tiles bag2) +data LetterBag = LetterBag {tiles :: [Tile], bagSize :: Int, generator :: StdGen, validLetters :: ValidTiles} deriving (Show) + +instance Eq LetterBag where + bag1 == bag2 = bagSize bag1 == bagSize bag2 && tiles bag1 == tiles bag2 diff --git a/src/Wordify/Rules/Move.hs b/src/Wordify/Rules/Move.hs --- a/src/Wordify/Rules/Move.hs +++ b/src/Wordify/Rules/Move.hs @@ -1,190 +1,210 @@ -module Wordify.Rules.Move ( - Move(PlaceTiles, Exchange, Pass) - ,GameTransition(MoveTransition, ExchangeTransition, PassTransition, GameFinished) - ,makeMove - ,newGame - ,restoreGame - ,restoreGameLazy) where +module Wordify.Rules.Move + ( Move (PlaceTiles, Exchange, Pass), + GameTransition (MoveTransition, ExchangeTransition, PassTransition, GameFinished), + makeMove, + newGame, + restoreGame, + restoreGameLazy, + ) +where - import Wordify.Rules.ScrabbleError - import Wordify.Rules.FormedWord - import Control.Monad - import Control.Applicative - import Wordify.Rules.Player - import qualified Data.Map as Map - import Wordify.Rules.Pos - import Wordify.Rules.Tile - import Wordify.Rules.LetterBag - import Wordify.Rules.Board - import Wordify.Rules.Dictionary - import Wordify.Rules.Game.Internal - import Wordify.Rules.Game - import qualified Data.List.NonEmpty as NE - import qualified Data.Traversable as T - import qualified Data.Map as M - import Control.Error.Util - import Control.Arrow +import Control.Applicative +import Control.Arrow +import Control.Error +import Control.Error.Util +import Control.Monad +import qualified Data.List.NonEmpty as NE +import Data.Map +import qualified Data.Map as M +import qualified Data.Map as Map +import qualified Data.Traversable as T +import Wordify.Rules.Board +import Wordify.Rules.Dictionary +import Wordify.Rules.FormedWord +import Wordify.Rules.Game +import Wordify.Rules.Game.Internal +import Wordify.Rules.LetterBag +import Wordify.Rules.Player +import Wordify.Rules.Pos +import Wordify.Rules.ScrabbleError +import Wordify.Rules.Tile - data GameTransition = -- | The new player (with their updated letter rack and score), new game state, and the words formed by the move - MoveTransition Player Game FormedWords - -- | The new game state, and the player with their rack before and after the exchange respectively. - | ExchangeTransition Game Player Player - -- | The new game state with the opportunity to play passed on to the next player. - | PassTransition Game - {- | - The game has finished. The final game state, and the final words formed (if the game was ended by a - player placing their final tiles.) The players before their scores were increased or decreased is also - given. - -} - | GameFinished Game (Maybe FormedWords) +data GameTransition + = -- | The new player (with their updated letter rack and score), new game state, and the words formed by the move + MoveTransition Player Game FormedWords + | -- | The new game state, and the player with their rack before and after the exchange respectively. + ExchangeTransition Game Player Player + | -- | The new game state with the opportunity to play passed on to the next player. + PassTransition Game + | -- | + -- The game has finished. The final game state, and the final words formed (if the game was ended by a + -- player placing their final tiles.) The players before their scores were increased or decreased is also + -- given. + GameFinished Game (Maybe FormedWords) - {-| - Transitiions the game to the next state. If the move places tiles, the player must have the tiles to place and - place the tiles legally. If the move exchanges tiles, the bag must not be empty and the player must have the - tiles to exchange. A ScrabbleError is returned if these condtions are not the case. - -} - makeMove :: Game -> Move -> Either ScrabbleError GameTransition - makeMove game move - | gameStatus game /= InProgress = Left GameNotInProgress - | otherwise = flip addMoveToHistory move <$> gameTransition - where - gameTransition = case move of - PlaceTiles placed -> makeBoardMove game placed - Exchange exchanged -> exchangeMove game exchanged - Pass -> (Right . passMove) game +-- | +-- Transitiions the game to the next state. If the move places tiles, the player must have the tiles to place and +-- place the tiles legally. If the move exchanges tiles, the bag must not be empty and the player must have the +-- tiles to exchange. A ScrabbleError is returned if these condtions are not the case. +makeMove :: Game -> Move -> Either ScrabbleError GameTransition +makeMove game move + | gameStatus game /= InProgress = Left GameNotInProgress + | otherwise = flip addMoveToHistory move <$> gameTransition + where + gameTransition = case move of + PlaceTiles placed -> makeBoardMove game placed + Exchange exchanged -> exchangeMove game exchanged + Pass -> (Right . passMove) game - makeBoardMove :: Game -> M.Map Pos Tile -> Either ScrabbleError GameTransition - makeBoardMove game placed = - do - formed <- formedWords - (overallScore, _) <- scoresIfWordsLegal dict formed - nextBoard <- newBoard currentBoard placed - intermediatePlayer <- removeLettersandGiveScore player playedTiles overallScore +makeBoardMove :: Game -> M.Map Pos Tile -> Either ScrabbleError GameTransition +makeBoardMove game placed = + do + validPlacedTiles <- validateTiles (validLetters letterBag) placed + let playedTiles = Map.elems validPlacedTiles + formed <- formedWords + (overallScore, _) <- scoresIfWordsLegal dict formed + nextBoard <- newBoard currentBoard validPlacedTiles + intermediatePlayer <- removeLettersandGiveScore player playedTiles overallScore - if hasEmptyRack intermediatePlayer && (bagSize letterBag == 0) - then - do - let beforeFinalisingGame = updateGame game intermediatePlayer nextBoard letterBag - let finalisedGame = finaliseGame beforeFinalisingGame - return $ GameFinished finalisedGame (Just formed) - else - do - let (newPlayer, newBag) = updatePlayerRackAndBag intermediatePlayer letterBag (Map.size placed) - let updatedGame = updateGame game newPlayer nextBoard newBag - return $ MoveTransition newPlayer updatedGame formed - where - player = currentPlayer game - playedTiles = Map.elems placed - currentBoard = board game - dict = dictionary game - letterBag = bag game + if hasEmptyRack intermediatePlayer && (bagSize letterBag == 0) + then do + let beforeFinalisingGame = updateGame game intermediatePlayer nextBoard letterBag + let finalisedGame = finaliseGame beforeFinalisingGame + return $ GameFinished finalisedGame (Just formed) + else do + let (newPlayer, newBag) = updatePlayerRackAndBag intermediatePlayer letterBag (Map.size validPlacedTiles) + let updatedGame = updateGame game newPlayer nextBoard newBag + return $ MoveTransition newPlayer updatedGame formed + where + player = currentPlayer game + currentBoard = board game + dict = dictionary game + letterBag = bag game + validTiles = validLetters letterBag - formedWords = if any isPlaceMove (movesMade game) - then wordsFormedMidGame currentBoard placed - else wordFormedFirstMove currentBoard placed + formedWords = + if any isPlaceMove (movesMade game) + then wordsFormedMidGame currentBoard placed + else wordFormedFirstMove currentBoard placed - isPlaceMove mv = case mv of - PlaceTiles _ -> True - _ -> False + isPlaceMove mv = case mv of + PlaceTiles _ -> True + _ -> False - exchangeMove :: Game -> [Tile] -> Either ScrabbleError GameTransition - exchangeMove game exchangedTiles = - let exchangeOutcome = exchangeLetters (bag game) exchangedTiles - in case exchangeOutcome of - Nothing -> Left CannotExchangeWhenNoLettersInBag - Just (givenTiles, newBag) -> +exchangeMove :: Game -> [Tile] -> Either ScrabbleError GameTransition +exchangeMove game exchangedTiles = + let exchangeOutcome = exchangeLetters (bag game) exchangedTiles + in case exchangeOutcome of + Nothing -> Left CannotExchangeWhenNoLettersInBag + Just (givenTiles, newBag) -> let newPlayer = exchange player exchangedTiles givenTiles - in maybe (Left $ PlayerCannotExchange (rack player) exchangedTiles) (\exchangedPlayer -> + in maybe + (Left $ PlayerCannotExchange (tilesOnRack player) exchangedTiles) + ( \exchangedPlayer -> let gameState = updateGame game exchangedPlayer (board game) newBag - in Right $ ExchangeTransition gameState player exchangedPlayer) newPlayer - where - player = currentPlayer game + in Right $ ExchangeTransition gameState player exchangedPlayer + ) + newPlayer + where + player = currentPlayer game - passMove :: Game -> GameTransition - passMove game = - let gameState = pass game - in - if gameFinished - then GameFinished (finaliseGame gameState) Nothing - else PassTransition gameState - where - numPasses = passes game + 1 - gameFinished = numPasses == numberOfPlayers game * 2 +passMove :: Game -> GameTransition +passMove game = + let gameState = pass game + in if gameFinished + then GameFinished (finaliseGame gameState) Nothing + else PassTransition gameState + where + numPasses = passes game + 1 + gameFinished = numPasses == numberOfPlayers game * 2 - {- | - Restores a game from a list of moves. The game must be set up in the way the original game was set up - (including the letter bag constructed with the same tiles and random generator, dictionary and the list of players - in the original order.) +-- | +-- Restores a game from a list of moves. The game must be set up in the way the original game was set up +-- (including the letter bag constructed with the same tiles and random generator, dictionary and the list of players +-- in the original order.) +-- +-- If the game is not set up as it was originally, this function will return a scrabble error with the move which was invalid +-- with the given state. For example, if the original players are not ordered in the correct way then the player will not have +-- the required tiles to make the move. +restoreGame :: Game -> NE.NonEmpty Move -> Either ScrabbleError (NE.NonEmpty GameTransition) +restoreGame game = T.sequence . restoreGameLazy game - If the game is not set up as it was originally, this function will return a scrabble error with the move which was invalid - with the given state. For example, if the original players are not ordered in the correct way then the player will not have - the required tiles to make the move. - -} - restoreGame :: Game -> NE.NonEmpty Move -> Either ScrabbleError (NE.NonEmpty GameTransition) - restoreGame game = T.sequence . restoreGameLazy game +-- | +-- Maps each move to a resulting game transition, if the move is legal. Has the same semantics as 'restoreGame' +-- but returns a list of 'Either' so that laziness can be maintained, meaning all the game transitions +-- dont have to be buffered before they can be consumed. +restoreGameLazy :: Game -> NE.NonEmpty Move -> NE.NonEmpty (Either ScrabbleError GameTransition) +restoreGameLazy game (mv NE.:| moves) = NE.scanl nextMove (makeMove game mv) moves + where + nextMove transition move = transition >>= \success -> makeMove (newGame success) move - {- | - Maps each move to a resulting game transition, if the move is legal. Has the same semantics as 'restoreGame' - but returns a list of 'Either' so that laziness can be maintained, meaning all the game transitions - dont have to be buffered before they can be consumed. - -} - restoreGameLazy :: Game -> NE.NonEmpty Move -> NE.NonEmpty (Either ScrabbleError GameTransition) - restoreGameLazy game (mv NE.:| moves) = NE.scanl nextMove (makeMove game mv) moves - where - nextMove transition move = transition >>= \success -> makeMove (newGame success) move +validateTiles :: ValidTiles -> M.Map Pos Tile -> Either ScrabbleError (M.Map Pos Tile) +validateTiles validTiles placed = fromList <$> mapM (validateTilePlacement validTiles) (toList placed) + where + validateTilePlacement :: ValidTiles -> (Pos, Tile) -> Either ScrabbleError (Pos, Tile) + validateTilePlacement validTiles (pos, Letter letters x) = (,) pos <$> note (InvalidTileLetters pos letters) (Map.lookup letters validTiles) + validateTilePlacement validTiles (pos, Blank (Just assigned)) = + note (NotAssignableToBlank pos assigned validTileStrings) (Map.lookup assigned validTiles) >>= \x -> Right (pos, Blank (Just assigned)) + validateTilePlacement validTiles (pos, Blank Nothing) = Left (CannotPlaceBlankWithoutLetter pos) - newGame :: GameTransition -> Game - newGame (MoveTransition _ game _) = game - newGame (ExchangeTransition game _ _) = game - newGame (PassTransition game) = game - newGame (GameFinished game _) = game + validTileStrings = Map.keys validTiles - addMoveToHistory :: GameTransition -> Move -> GameTransition - addMoveToHistory (MoveTransition player game formedWords) move = MoveTransition player (updateHistory game move) formedWords - addMoveToHistory (ExchangeTransition game oldPlayer newPlayer ) move = ExchangeTransition (updateHistory game move) oldPlayer newPlayer - addMoveToHistory (PassTransition game) move = PassTransition (updateHistory game move) - addMoveToHistory (GameFinished game wordsFormed) move = GameFinished (updateHistory game move) wordsFormed +newGame :: GameTransition -> Game +newGame (MoveTransition _ game _) = game +newGame (ExchangeTransition game _ _) = game +newGame (PassTransition game) = game +newGame (GameFinished game _) = game - finaliseGame :: Game -> Game - finaliseGame game - | gameStatus game == Finished = game - | otherwise = game {player1 = play1, player2 = play2, optionalPlayers = optionals, gameStatus = Finished, moveNumber = pred moveNo} - where - unplayedValues = Prelude.sum $ Prelude.map tileValues allPlayers - allPlayers = players game - moveNo = moveNumber game +addMoveToHistory :: GameTransition -> Move -> GameTransition +addMoveToHistory (MoveTransition player game formedWords) move = MoveTransition player (updateHistory game move) formedWords +addMoveToHistory (ExchangeTransition game oldPlayer newPlayer) move = ExchangeTransition (updateHistory game move) oldPlayer newPlayer +addMoveToHistory (PassTransition game) move = PassTransition (updateHistory game move) +addMoveToHistory (GameFinished game wordsFormed) move = GameFinished (updateHistory game move) wordsFormed - play1 = finalisePlayer (player1 game) - play2 = finalisePlayer (player2 game) - optionals = optionalPlayers game >>= (\(player3, maybePlayer4) -> - Just (finalisePlayer player3, finalisePlayer <$> maybePlayer4 ) ) +finaliseGame :: Game -> Game +finaliseGame game + | gameStatus game == Finished = game + | otherwise = game {player1 = play1, player2 = play2, optionalPlayers = optionals, gameStatus = Finished, moveNumber = pred moveNo} + where + unplayedValues = Prelude.sum $ Prelude.map tileValues allPlayers + allPlayers = players game + moveNo = moveNumber game - finalisePlayer player = if hasEmptyRack player then giveEndWinBonus player unplayedValues - else giveEndLosePenalty player (tileValues player) + play1 = finalisePlayer (player1 game) + play2 = finalisePlayer (player2 game) + optionals = + optionalPlayers game + >>= ( \(player3, maybePlayer4) -> + Just (finalisePlayer player3, finalisePlayer <$> maybePlayer4) + ) - updatePlayerRackAndBag :: Player -> LetterBag -> Int -> (Player, LetterBag) - updatePlayerRackAndBag player letterBag numPlayed - | tilesInBag == 0 = (player, letterBag) - | tilesInBag >= numPlayed = - maybe (player, letterBag) (first (giveTiles player)) $ takeLetters letterBag numPlayed - | otherwise = maybe (player, letterBag) (first (giveTiles player)) $ takeLetters letterBag tilesInBag - where - tilesInBag = bagSize letterBag + finalisePlayer player = + if hasEmptyRack player + then giveEndWinBonus player unplayedValues + else giveEndLosePenalty player (tileValues player) - newBoard :: Board -> M.Map Pos Tile -> Either ScrabbleError Board - newBoard currentBoard placed = foldM (\oldBoard (pos, tile) -> newBoardIfUnoccupied oldBoard pos tile) currentBoard $ Map.toList placed - where - newBoardIfUnoccupied brd pos tile = note (PlacedTileOnOccupiedSquare pos tile) $ placeTile brd tile pos +updatePlayerRackAndBag :: Player -> LetterBag -> Int -> (Player, LetterBag) +updatePlayerRackAndBag player letterBag numPlayed + | tilesInBag == 0 = (player, letterBag) + | tilesInBag >= numPlayed = + maybe (player, letterBag) (first (giveTiles player)) $ takeLetters letterBag numPlayed + | otherwise = maybe (player, letterBag) (first (giveTiles player)) $ takeLetters letterBag tilesInBag + where + tilesInBag = bagSize letterBag +newBoard :: Board -> M.Map Pos Tile -> Either ScrabbleError Board +newBoard currentBoard placed = foldM (\oldBoard (pos, tile) -> newBoardIfUnoccupied oldBoard pos tile) currentBoard $ Map.toList placed + where + newBoardIfUnoccupied brd pos tile = note (PlacedTileOnOccupiedSquare pos tile) $ placeTile brd tile pos - removeLettersandGiveScore :: Player -> [Tile] -> Int -> Either ScrabbleError Player - removeLettersandGiveScore player playedTiles justScored = - let newPlayer = flip increaseScore justScored <$> removePlayedTiles player playedTiles - in note (PlayerCannotPlace (rack player) playedTiles) newPlayer +removeLettersandGiveScore :: Player -> [Tile] -> Int -> Either ScrabbleError Player +removeLettersandGiveScore player playedTiles justScored = do + let newPlayer = flip increaseScore justScored <$> removePlayedTiles player playedTiles + in note (PlayerCannotPlace (tilesOnRack player) playedTiles) newPlayer - scoresIfWordsLegal :: Dictionary -> FormedWords -> Either ScrabbleError (Int, [(String, Int)]) - scoresIfWordsLegal dict formedWords = - let strings = wordStrings formedWords - in case invalidWords dict strings of - []-> Right $ wordsWithScores formedWords - xs -> Left $ WordsNotInDictionary xs +scoresIfWordsLegal :: Dictionary -> FormedWords -> Either ScrabbleError (Int, [(String, Int)]) +scoresIfWordsLegal dict formedWords = + let strings = wordStrings formedWords + in case invalidWords dict strings of + [] -> Right $ wordsWithScores formedWords + xs -> Left $ WordsNotInDictionary xs diff --git a/src/Wordify/Rules/Player.hs b/src/Wordify/Rules/Player.hs --- a/src/Wordify/Rules/Player.hs +++ b/src/Wordify/Rules/Player.hs @@ -1,132 +1,137 @@ -module Wordify.Rules.Player ( - Player, - LetterRack, - makePlayer, - name, - rack, - tilesOnRack, - endBonus, - score, - increaseScore, - reduceScore, - giveEndLosePenalty, - giveEndWinBonus, - giveTiles, - removePlayedTiles, - removeTiles, - hasEmptyRack, - tileValues, - exchange) where +module Wordify.Rules.Player + ( Player, + LetterRack, + makePlayer, + name, + rack, + tilesOnRack, + endBonus, + score, + increaseScore, + reduceScore, + giveEndLosePenalty, + giveEndWinBonus, + giveTiles, + removePlayedTiles, + removeTiles, + hasEmptyRack, + tileValues, + exchange, + ) +where - import Wordify.Rules.Tile - import Data.List - import Data.Maybe - import qualified Data.Map as Map +import Data.List +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Maybe +import Wordify.Rules.LetterBag +import Wordify.Rules.Tile - type Score = Int - type Name = String +type Score = Int - data LetterRack = LetterRack [Tile] deriving (Show, Eq) +type Name = String - data Player = Player {name :: Name - , rack :: LetterRack - , score :: Score - , endBonus :: Int} deriving (Show, Eq) +data LetterRack = LetterRack [Tile] deriving (Show, Eq) - makePlayer :: String -> Player - makePlayer playerName = Player playerName (LetterRack []) 0 0 +data Player = Player + { name :: Name, + rack :: LetterRack, + score :: Score, + endBonus :: Int + } + deriving (Show, Eq) - tilesOnRack :: Player -> [Tile] - tilesOnRack (Player _ (LetterRack letters) _ _) = letters +makePlayer :: String -> Player +makePlayer playerName = Player playerName (LetterRack []) 0 0 - increaseScore :: Player -> Int -> Player - increaseScore player justScored = player {score = currentScore + justScored} - where - currentScore = score player +tilesOnRack :: Player -> [Tile] +tilesOnRack (Player _ (LetterRack letters) _ _) = letters - reduceScore :: Player -> Int -> Player - reduceScore player removeScore = player {score = currentScore - removeScore} - where - currentScore = score player +increaseScore :: Player -> Int -> Player +increaseScore player justScored = player {score = currentScore + justScored} + where + currentScore = score player - giveEndLosePenalty :: Player -> Int -> Player - giveEndLosePenalty player penalty = (reduceScore player penalty) {endBonus = -penalty} +reduceScore :: Player -> Int -> Player +reduceScore player removeScore = player {score = currentScore - removeScore} + where + currentScore = score player - giveEndWinBonus :: Player -> Int -> Player - giveEndWinBonus player bonus = (increaseScore player bonus) {endBonus = bonus} +giveEndLosePenalty :: Player -> Int -> Player +giveEndLosePenalty player penalty = (reduceScore player penalty) {endBonus = - penalty} - hasEmptyRack :: Player -> Bool - hasEmptyRack player = null $ tilesOnRack player +giveEndWinBonus :: Player -> Int -> Player +giveEndWinBonus player bonus = (increaseScore player bonus) {endBonus = bonus} - tileValues :: Player -> Int - tileValues player = sum $ map tileValue (tilesOnRack player) +hasEmptyRack :: Player -> Bool +hasEmptyRack player = null $ tilesOnRack player - {- - Adds tiles to the player's tile rack. - -} - giveTiles :: Player -> [Tile] -> Player - giveTiles player newTiles = player {rack = LetterRack $ newTiles ++ tilesOnRack player} +tileValues :: Player -> Int +tileValues player = sum $ map tileValue (tilesOnRack player) - removeTiles :: Player -> [Tile] -> Player - removeTiles player toRemove = player {rack = LetterRack $ tilesOnRack player \\ toRemove} +{- + Adds tiles to the player's tile rack. +-} +giveTiles :: Player -> [Tile] -> Player +giveTiles player newTiles = player {rack = LetterRack $ newTiles ++ tilesOnRack player} - {- | - Removes played tiles from the player's tile rack, if it was possible for the player - to play those tiles in the first place. A player may play a tile on his rack, unless - it is a blank, which must first be assigned a letter. - -} - removePlayedTiles :: Player -> [Tile] -> Maybe Player - removePlayedTiles player tiles = - if (playerCanPlace player tiles) - then Just $ player `removedFromRack` tiles - else Nothing - where - removedFromRack playing playedTiles = player {rack = LetterRack (deleteFirstsBy isPlayable (tilesOnRack playing) playedTiles) } +removeTiles :: Player -> [Tile] -> Player +removeTiles player toRemove = player {rack = LetterRack $ tilesOnRack player \\ toRemove} - {- | - Returns true if the player cannot place any of the given tiles. A player cannot play - a Blank tile that they have not given a letter, or a tile not on their rack. - -} - playerCanPlace :: Player -> [Tile] -> Bool - playerCanPlace player played = isNothing $ find isInvalid playedList - where - (playedFrequencies, rackFrequencies) = tileFrequencies played $ tilesOnRack player - playedList = Map.toList playedFrequencies +-- | +-- Removes played tiles from the player's tile rack, if it was possible for the player +-- to play those tiles in the first place. A player may play a tile on his rack, unless +-- it is a blank, which must first be assigned a letter. +removePlayedTiles :: Player -> [Tile] -> Maybe Player +removePlayedTiles player tiles = + if playerCanPlace player tiles + then Just $ player `removedFromRack` tiles + else Nothing + where + removedFromRack playing playedTiles = player {rack = LetterRack (deleteFirstsBy isPlayable (tilesOnRack playing) playedTiles)} - isInvalid (tile, freq) = - case tile of - -- Tried to play a blank without a letter - Blank Nothing -> False +-- | +-- Returns true if the player cannot place any of the given tiles. A player cannot play +-- a Blank tile that they have not given a letter, or a tile not on their rack. +playerCanPlace :: Player -> [Tile] -> Bool +playerCanPlace player played = isNothing $ find isInvalid playedList + where + (playedFrequencies, rackFrequencies) = tileFrequencies played (tilesOnRack player) + playedList = Map.toList playedFrequencies + + isInvalid :: (Tile, Int) -> Bool + isInvalid (tile, freq) = + case tile of -- Player doesn't have tiles Blank _ -> freq > Map.findWithDefault 0 (Blank Nothing) rackFrequencies Letter chr val -> freq > Map.findWithDefault 0 (Letter chr val) rackFrequencies - exchange :: Player -> [Tile] -> [Tile] -> Maybe Player - exchange player exchanged received = - if not (playerCanExchange player exchanged) then Nothing - else - Just $ giveTiles (removeTiles player exchanged) received +exchange :: Player -> [Tile] -> [Tile] -> Maybe Player +exchange player exchanged received = + if not (playerCanExchange player exchanged) + then Nothing + else Just $ giveTiles (removeTiles player exchanged) received - playerCanExchange :: Player -> [Tile] -> Bool - playerCanExchange (Player _ ( LetterRack letterRack) _ _) exchanged = - isNothing $ find cannotExchange exchangedList - where - (exchangedFrequencies, rackFrequencies) = tileFrequencies exchanged letterRack - exchangedList = Map.toList exchangedFrequencies +playerCanExchange :: Player -> [Tile] -> Bool +playerCanExchange (Player _ (LetterRack letterRack) _ _) exchanged = + isNothing $ find cannotExchange exchangedList + where + (exchangedFrequencies, rackFrequencies) = tileFrequencies exchanged letterRack + exchangedList = Map.toList exchangedFrequencies - cannotExchange (tile, freq) = - case tile of + cannotExchange (tile, freq) = + case tile of -- Tried to exchange a blank letter which has been labeled. Client error. Blank (Just _) -> False -- Player doesn't have tiles Blank _ -> freq > Map.findWithDefault 0 (Blank Nothing) rackFrequencies Letter chr val -> freq > Map.findWithDefault 0 (Letter chr val) rackFrequencies - tileFrequencies :: [Tile] -> [Tile] -> ((Map.Map Tile Int), (Map.Map Tile Int)) - tileFrequencies given letterRack = (givenFrequencies, rackFrequencies) - where - buildFrequencies tiles = foldl addFrequency (Map.empty) tiles - addFrequency dict tile = Map.alter newFrequency tile dict - newFrequency m = Just $ maybe 1 succ m -- Default freq of one, or inc existing frequency - givenFrequencies = buildFrequencies given - rackFrequencies = buildFrequencies letterRack +tileFrequencies :: [Tile] -> [Tile] -> ((Map.Map Tile Int), (Map.Map Tile Int)) +tileFrequencies given letterRack = (givenFrequencies, rackFrequencies) + where + buildFrequencies tiles = foldl addFrequency (Map.empty) tiles + addFrequency dict tile = Map.alter newFrequency tile dict + newFrequency m = Just $ maybe 1 succ m -- Default freq of one, or inc existing frequency + givenFrequencies = buildFrequencies given + rackFrequencies = buildFrequencies letterRack diff --git a/src/Wordify/Rules/ScrabbleError.hs b/src/Wordify/Rules/ScrabbleError.hs --- a/src/Wordify/Rules/ScrabbleError.hs +++ b/src/Wordify/Rules/ScrabbleError.hs @@ -1,64 +1,93 @@ -module Wordify.Rules.ScrabbleError (ScrabbleError(LetterBagFileNotOpenable, MalformedLetterBagFile, - MalformedDictionaryFile, DictionaryFileNotFound, NotEnoughLettersInStartingBag, - MisplacedLetter, DoesNotConnectWithWord, NoTilesPlaced, DoesNotCoverTheStarTile, - PlacedTileOnOccupiedSquare, CannotPlaceBlankWithoutLetter, WordsNotInDictionary, PlayerCannotPlace, - GameNotInProgress, CannotExchangeWhenNoLettersInBag, PlayerCannotExchange, MiscError)) where +module Wordify.Rules.ScrabbleError + ( ScrabbleError + ( LetterBagFileNotOpenable, + MalformedLetterBagFile, + MalformedDictionaryFile, + DictionaryFileNotFound, + NotEnoughLettersInStartingBag, + MisplacedLetter, + DoesNotConnectWithWord, + NoTilesPlaced, + DoesNotCoverTheStarTile, + PlacedTileOnOccupiedSquare, + CannotPlaceBlankWithoutLetter, + InvalidTileLetters, + NotAssignableToBlank, + WordsNotInDictionary, + PlayerCannotPlace, + GameNotInProgress, + CannotExchangeWhenNoLettersInBag, + PlayerCannotExchange, + MiscError + ), + ) +where - import Wordify.Rules.Pos - import Wordify.Rules.Tile - import Wordify.Rules.Player +import Data.List +import Wordify.Rules.Pos +import Wordify.Rules.Tile - data ScrabbleError = - -- | The caller has supplied an invalid path to a letter bag file, or the file is not openable +type LettersOnRack = [Tile] + +type ValidBlankValues = [String] + +data ScrabbleError + = -- | The caller has supplied an invalid path to a letter bag file, or the file is not openable LetterBagFileNotOpenable String - -- | The letter bag file is marformed, so could not be parsed. - | MalformedLetterBagFile FilePath - -- | The path given to a dictionary file was invalid. - | DictionaryFileNotFound FilePath - -- | The dictionary file could not be parsed as it was malformed. - | MalformedDictionaryFile String - -- | A letter bag with insufficient tiles was used to create a game. - | NotEnoughLettersInStartingBag Int - -- | The player has made an illegal tile placement. Tiles placed must form a line of tiles. - | MisplacedLetter Pos - -- | The tiles the player placed do not connect with any word (applies after the first move on the board) - | DoesNotConnectWithWord - -- | The client put the player in the situation to be able to place no tiles. - | NoTilesPlaced - -- | The first move on the board does not cover the star. - | DoesNotCoverTheStarTile - -- | The client allowed the player to place tiles on a square that is already occupied with tiles. - | PlacedTileOnOccupiedSquare Pos Tile - -- | A blank tile must be labeled with a letter before being placed. - | CannotPlaceBlankWithoutLetter Pos - -- | The tiles the player placed formed one or more words which are not in the dictionary. - | WordsNotInDictionary [String] - -- | The caller allowed the client to place tiles on the board which were not in their rack. - | PlayerCannotPlace LetterRack [Tile] - -- | The caller allowed the player to attempt to exchange when no letters were left in the bag. - | CannotExchangeWhenNoLettersInBag - -- | The caller allowed the player to attempt to exchange tiles that they do not have. - | PlayerCannotExchange LetterRack [Tile] - -- | The caller allowed a move to be made when the game is finished. - | GameNotInProgress - | MiscError String deriving Eq + | -- | The letter bag file is marformed, so could not be parsed. + MalformedLetterBagFile FilePath String + | -- | The path given to a dictionary file was invalid. + DictionaryFileNotFound FilePath + | -- | The dictionary file could not be parsed as it was malformed. + MalformedDictionaryFile String + | -- | A letter bag with insufficient tiles was used to create a game. + NotEnoughLettersInStartingBag Int + | -- | The player has made an illegal tile placement. Tiles placed must form a line of tiles. + MisplacedLetter Pos + | -- | The tiles the player placed do not connect with any word (applies after the first move on the board) + DoesNotConnectWithWord + | -- | The client put the player in the situation to be able to place no tiles. + NoTilesPlaced + | -- | The first move on the board does not cover the star. + DoesNotCoverTheStarTile + | -- | The client allowed the player to place tiles on a square that is already occupied with tiles. + PlacedTileOnOccupiedSquare Pos Tile + | -- | A blank tile must be labeled with a letter before being placed. + CannotPlaceBlankWithoutLetter Pos + | -- | The tiles the player placed formed one or more words which are not in the dictionary. + WordsNotInDictionary [String] + | -- | The caller allowed the client to place tiles on the board which were not in their rack. + PlayerCannotPlace LettersOnRack [Tile] + | -- | The string applied to the blank letter isn't a valid tile value + NotAssignableToBlank Pos String ValidBlankValues + | -- | The letters on the played tile aren't valid + InvalidTileLetters Pos String + | -- | The caller allowed the player to attempt to exchange when no letters were left in the bag. + CannotExchangeWhenNoLettersInBag + | -- | The caller allowed the player to attempt to exchange tiles that they do not have. + PlayerCannotExchange LettersOnRack [Tile] + | -- | The caller allowed a move to be made when the game is finished. + GameNotInProgress + | MiscError String + deriving (Eq) - instance Show ScrabbleError - where - show (MalformedDictionaryFile reason) = "Dictionary file could not be parsed for the following reason: " ++ reason - show (MalformedLetterBagFile path) = "Letter bag file " ++ path ++ " was malformed." - show (DictionaryFileNotFound path) = "Dictionary file " ++ path ++ " was not found." - show (LetterBagFileNotOpenable path) = "Letter bag file " ++ path ++ " was not openable" - show (NotEnoughLettersInStartingBag num) = "A starting bag must have enough tiles to distribute to the players to start a game. Bag has " ++ show num ++ " tiles." - show (MisplacedLetter pos) = "Placed tiles were not legally placed. Starting at tile placed at pos: " ++ show pos - show (DoesNotConnectWithWord) = "Placed tiles do not connect with an existing word on the board." - show (NoTilesPlaced) = "No tiles were placed in the move." - show (DoesNotCoverTheStarTile) = "First move must go through the star." - show (PlacedTileOnOccupiedSquare pos _) = "Move replaces a tile already on the board at " ++ show pos ++ ". This is not a legal move." - show (CannotPlaceBlankWithoutLetter pos) = "A played blank tile must be given a letter. Blank tile played at " ++ show pos ++ " was not given a letter." - show (WordsNotInDictionary xs) = "The following words are not in the scrabble dictionary: " ++ show xs - show (PlayerCannotPlace letterRack tiles) = "The player cannot place: " ++ show tiles ++ ". Tiles on rack: " ++ show letterRack ++ ". Blank tiles must be labeled and the placed tiles must be on the rack." - show (CannotExchangeWhenNoLettersInBag) = "Cannot exchange letters when there are no letters in the bag." - show (PlayerCannotExchange letterRack tiles) = "Player does not have the letters to exchange " ++ show tiles ++ ". Tiles on rack: " ++ show letterRack ++ ". Blank tiles must not be labeled." - show (GameNotInProgress) = "A move was attempted on a game that is not in progress." - show (MiscError str) = str +instance Show ScrabbleError where + show (MalformedDictionaryFile reason) = "Dictionary file could not be parsed for the following reason: " ++ reason + show (MalformedLetterBagFile path err) = "Letter bag file " ++ path ++ " was malformed. Reason: " ++ err + show (DictionaryFileNotFound path) = "Dictionary file " ++ path ++ " was not found." + show (LetterBagFileNotOpenable path) = "Letter bag file " ++ path ++ " was not openable" + show (NotEnoughLettersInStartingBag num) = "A starting bag must have enough tiles to distribute to the players to start a game. Bag has " ++ show num ++ " tiles." + show (MisplacedLetter pos) = "Placed tiles were not legally placed. Starting at tile placed at pos: " ++ show pos + show (DoesNotConnectWithWord) = "Placed tiles do not connect with an existing word on the board." + show (NoTilesPlaced) = "No tiles were placed in the move." + show (DoesNotCoverTheStarTile) = "First move must go through the star." + show (PlacedTileOnOccupiedSquare pos _) = "Move replaces a tile already on the board at " ++ show pos ++ ". This is not a legal move." + show (CannotPlaceBlankWithoutLetter pos) = "A played blank tile must be given a letter. Blank tile played at " ++ show pos ++ " was not given a letter." + show (WordsNotInDictionary xs) = "The following words are not in the scrabble dictionary: " ++ show xs + show (InvalidTileLetters pos letters) = "A played tile is not a valid tile. " ++ letters ++ " played at " ++ show pos ++ " was not given a letter." + show (PlayerCannotPlace letterRack tiles) = "The player cannot place: " ++ show tiles ++ ". Tiles on rack: " ++ show letterRack ++ ". Blank tiles must be labeled and the placed tiles must be on the rack." + show (NotAssignableToBlank pos assigned validAssignments) = "Cannot assign value " ++ show assigned ++ " to blank tile. Valid values: " ++ (intercalate ", " validAssignments) ++ " Blank placed at " ++ show pos + show (CannotExchangeWhenNoLettersInBag) = "Cannot exchange letters when there are no letters in the bag." + show (PlayerCannotExchange letterRack tiles) = "Player does not have the letters to exchange " ++ show tiles ++ ". Tiles on rack: " ++ show letterRack ++ ". Blank tiles must not be labeled." + show (GameNotInProgress) = "A move was attempted on a game that is not in progress." + show (MiscError str) = str diff --git a/src/Wordify/Rules/Tile.hs b/src/Wordify/Rules/Tile.hs --- a/src/Wordify/Rules/Tile.hs +++ b/src/Wordify/Rules/Tile.hs @@ -1,36 +1,33 @@ -module Wordify.Rules.Tile (Tile(Letter, Blank), tileValue, isPlayable, tileLetter, printLetter) where +module Wordify.Rules.Tile (Tile (Letter, Blank), tileValue, isPlayable, tileString, printString) where import Data.Char -{- | -A tile is a letter with a value, or a Blank tile -which may have been given a letter. Blank tiles -always have the value '0'. --} -data Tile = Letter Char Int | Blank (Maybe Char) deriving (Show, Eq, Ord) +-- | +-- A tile is a string with a value, or a Blank tile +-- which may have been given a string. Blank tiles +-- always have the value '0'. +data Tile = Letter String Int | Blank (Maybe String) deriving (Show, Eq, Ord) tileValue :: Tile -> Int tileValue (Letter _ val) = val tileValue (Blank _) = 0 -tileLetter :: Tile -> Maybe Char -tileLetter (Letter char _) = Just char -tileLetter (Blank (Just char)) = Just char -tileLetter (Blank Nothing) = Nothing +tileString :: Tile -> Maybe String +tileString (Letter string _) = Just string +tileString (Blank (Just string)) = Just string +tileString (Blank Nothing) = Nothing -{- | - Prints a letter in the style found on a scoresheet. E.g. blank letters are printed in lowercase. --} -printLetter :: Tile -> Maybe Char -printLetter (Letter char _) = Just char -printLetter (Blank (Just char)) = Just $ toLower char -printLetter _ = Nothing +-- | +-- Prints a letter in the style found on a scoresheet. E.g. blank letters are printed in lowercase. +printString :: Tile -> Maybe String +printString (Letter string _) = Just string +printString (Blank (Just string)) = Just $ map toLower string +printString _ = Nothing -{- | - isPlayble, applied to a played tile and compared against a tile - returns true if a player returned a letter tile on their rack, - or if the player played a Blank that has been given a letter --} +-- | +-- isPlayble, applied to a played tile and compared against a tile +-- returns true if a player returned a letter tile on their rack, +-- or if the player played a Blank that has been given a letter isPlayable :: Tile -> Tile -> Bool isPlayable (Letter a b) (Letter x y) = (a == x) && (b == y) isPlayable (Blank (Just _)) (Blank Nothing) = True diff --git a/test/Tests/BoardTest.hs b/test/Tests/BoardTest.hs --- a/test/Tests/BoardTest.hs +++ b/test/Tests/BoardTest.hs @@ -1,154 +1,144 @@ module Tests.BoardTest where - import Wordify.Rules.Board.Internal - import Wordify.Rules.Pos - import Data.Maybe - import Wordify.Rules.Square - import Wordify.Rules.Tile - import Wordify.Rules.Square - import qualified Data.Map as M - import Wordify.Rules.Pos.Internal - import Test.HUnit.Base - import Wordify.Rules.Board - import qualified Data.Sequence as Seq - import Control.Monad - import qualified Data.Set as S - import Tests.SharedTestData - import Data.List - - allTiles = horizontals ++ verticals ++ [rogueLeft] ++ [rogueRight] ++ [rogueAbove] ++ [rogueBelow] - - {- Verifies that tiles can only be placed on squares which are empty -} - placeTileProperty :: Board -> Pos -> Tile -> Bool - placeTileProperty board pos tile = - if (isNothing targetSquare) then placeResult == Just (Board $ M.insert pos newSquare squareMap) else isNothing placeResult - where - placeResult = placeTile board tile pos - Board (squareMap) = board - targetSquare = occupiedSquareAt board pos - newSquare = putTileOn (fromJust (unoccupiedSquareAt board pos)) tile - - testBoard :: Board - testBoard = Board squareMap - where - squareMap = M.fromList $ (M.assocs emptySquares ++ allTiles) - Board (emptySquares) = emptyBoard - - occupiedSquareAtTest :: Assertion - occupiedSquareAtTest = - do - let pos = Pos 3 7 "C7" - let expected = Just $ DoubleLetter $ Just (Letter 'X' 2) - let actual = occupiedSquareAt testBoard pos - - assertEqual "Unexpected result for occupiedSquareAt function where square is occupied" expected actual - - occupiedSquareAtUnoccupiedTest :: Assertion - occupiedSquareAtUnoccupiedTest = - do - let unoccupiedPos = Pos 1 1 "A1" - let expected = Nothing - let actual = occupiedSquareAt testBoard unoccupiedPos - - assertEqual "Unexpected result for occupiedSquareAt function where square is unoccupied" expected actual - - unoccupiedSquareAtTest :: Assertion - unoccupiedSquareAtTest = - do - let unoccupiedPos = Pos 1 1 "A1" - let expected = Just $ TripleWord Nothing - let actual = unoccupiedSquareAt testBoard unoccupiedPos +import Control.Monad +import Data.List +import qualified Data.Map as M +import Data.Maybe +import qualified Data.Sequence as Seq +import qualified Data.Set as S +import Test.HUnit.Base +import Tests.SharedTestData +import Wordify.Rules.Board +import Wordify.Rules.Board.Internal +import Wordify.Rules.Pos +import Wordify.Rules.Pos.Internal +import Wordify.Rules.Square +import Wordify.Rules.Tile - assertEqual "Unexpected result for unoccupiedSquareAt function where square is unoccupied" expected actual +allTiles = horizontals ++ verticals ++ [rogueLeft] ++ [rogueRight] ++ [rogueAbove] ++ [rogueBelow] - unoccupiedSquareAtTestOccupied :: Assertion - unoccupiedSquareAtTestOccupied = - do - let occupiedPos = Pos 3 7 "C7" - let expected = Nothing - let actual = unoccupiedSquareAt testBoard occupiedPos +{- Verifies that tiles can only be placed on squares which are empty -} +placeTileProperty :: Board -> Pos -> Tile -> Bool +placeTileProperty board pos tile = + if (isNothing targetSquare) then placeResult == Just (Board $ M.insert pos newSquare squareMap) else isNothing placeResult + where + placeResult = placeTile board tile pos + Board (squareMap) = board + targetSquare = occupiedSquareAt board pos + newSquare = putTileOn (fromJust (unoccupiedSquareAt board pos)) tile - assertEqual "Unexpected result for unoccupiedSquareAt function where square is unoccupied" expected actual +testBoard :: Board +testBoard = Board squareMap + where + squareMap = M.fromList $ (M.assocs emptySquares ++ allTiles) + Board (emptySquares) = emptyBoard - allSquaresTest :: Assertion - allSquaresTest = - do - let Board (squareMap) = testBoard - let expected = M.toList squareMap - let actual = allSquares testBoard +occupiedSquareAtTest :: Assertion +occupiedSquareAtTest = + do + let pos = Pos 3 7 "C7" + let expected = Just $ DoubleLetter $ Just (Letter "X" 2) + let actual = occupiedSquareAt testBoard pos - assertEqual "Unexpected result for allSquares function" expected actual + assertEqual "Unexpected result for occupiedSquareAt function where square is occupied" expected actual - lettersLeftTest :: Assertion - lettersLeftTest = - do - let pos = Pos 9 7 "I7" - let actual = lettersLeft testBoard pos - let expected = Seq.fromList $ init horizontals +occupiedSquareAtUnoccupiedTest :: Assertion +occupiedSquareAtUnoccupiedTest = + do + let unoccupiedPos = Pos 1 1 "A1" + let expected = Nothing + let actual = occupiedSquareAt testBoard unoccupiedPos - assertEqual "Unexpected result for letters left" expected actual + assertEqual "Unexpected result for occupiedSquareAt function where square is unoccupied" expected actual - lettersRightTest :: Assertion - lettersRightTest = - do - let pos = Pos 5 7 "E7" - let actual = lettersRight testBoard pos - let expected = Seq.fromList $ tail horizontals +unoccupiedSquareAtTest :: Assertion +unoccupiedSquareAtTest = + do + let unoccupiedPos = Pos 1 1 "A1" + let expected = Just $ TripleWord Nothing + let actual = unoccupiedSquareAt testBoard unoccupiedPos - assertEqual "Unexpected result for letters left" expected actual + assertEqual "Unexpected result for unoccupiedSquareAt function where square is unoccupied" expected actual - lettersAboveTest :: Assertion - lettersAboveTest = - do - let pos = Pos 7 5 "G5" - let actual = lettersAbove testBoard pos - let expected = Seq.fromList $ tail verticals +unoccupiedSquareAtTestOccupied :: Assertion +unoccupiedSquareAtTestOccupied = + do + let occupiedPos = Pos 3 7 "C7" + let expected = Nothing + let actual = unoccupiedSquareAt testBoard occupiedPos - assertEqual "Unexpected result for letters above" expected actual + assertEqual "Unexpected result for unoccupiedSquareAt function where square is unoccupied" expected actual - lettersBelowTest :: Assertion - lettersBelowTest = - do - let pos = Pos 7 9 "G9" - let actual = lettersBelow testBoard pos - let expected = Seq.fromList $ init verticals +allSquaresTest :: Assertion +allSquaresTest = + do + let Board (squareMap) = testBoard + let expected = M.toList squareMap + let actual = allSquares testBoard - assertEqual "Unexpected result for letters below" expected actual + assertEqual "Unexpected result for allSquares function" expected actual - {- Verifies that new tiles can be placed consecutively on a board while the old board is retained -} - tilesPlacedConsecutivelyTest :: Assertion - tilesPlacedConsecutivelyTest = - do - let expected = testBoard - let tiles = map (\(pos, square) -> (pos, fromJust $ tileIfOccupied square) ) $ (S.toList . S.fromList) allTiles - let result = foldM (\board (tile, pos) -> placeTile board pos tile) emptyBoard tiles - maybe (assertFailure "Tiles placed test failed") (\actual -> assertEqual "Tiles were not placed on board" expected actual) result +lettersLeftTest :: Assertion +lettersLeftTest = + do + let pos = Pos 9 7 "I7" + let actual = lettersLeft testBoard pos + let expected = Seq.fromList $ init horizontals + assertEqual "Unexpected result for letters left" expected actual - boardCorrectlyFormed :: Assertion - boardCorrectlyFormed = - do - let expectedTripleWords = catMaybes $ map (posAt) [(1,1), (8,1), (15,1), (1,8),(15,8), (1,15), (8,15),(15,15)] - mapM_ (\pos -> assertEqual "Triple word squares not where expected" (Just (TripleWord Nothing)) (unoccupiedSquareAt emptyBoard pos)) expectedTripleWords +lettersRightTest :: Assertion +lettersRightTest = + do + let pos = Pos 5 7 "E7" + let actual = lettersRight testBoard pos + let expected = Seq.fromList $ tail horizontals - let expectedDoubleWords = catMaybes $ map (posAt) [(2,2),(3,3),(4,4),(5,5), (8,8), (14,2), (13,3),(12,4),(11,5),(11,5),(4,12),(3,13),(2,14),(5,11),(11,11),(12,12),(13,13),(14,14)] - mapM_ (\pos -> assertEqual "Double word squares not where expected" (Just (DoubleWord Nothing)) (unoccupiedSquareAt emptyBoard pos)) expectedDoubleWords + assertEqual "Unexpected result for letters left" expected actual - let expectedTripleLetters = catMaybes $ map (posAt) [(6,2), (10,2),(2,6), (6,6),(10,6),(14,6),(2,10),(6,10),(10,10),(14,10),(6,14),(10,14)] - mapM_ (\pos -> assertEqual "Triple letters squares not where expected" (Just (TripleLetter Nothing)) (unoccupiedSquareAt emptyBoard pos)) expectedTripleLetters +lettersAboveTest :: Assertion +lettersAboveTest = + do + let pos = Pos 7 5 "G5" + let actual = lettersAbove testBoard pos + let expected = Seq.fromList $ tail verticals - let expectedDoubleLetters = catMaybes $ map (posAt) [(4,1),(12,1),(7,3),(9,3),(1,4),(8,4),(15,4),(3,7),(7,7),(9,7),(13,7),(4,8),(12,8),(3,9),(7,9),(9,9),(13,9),(1,12),(8,12),(15,12),(7,13),(9,13),(4,15),(12,15)] - mapM_ (\pos -> assertEqual "Double letter squares not where expected" (Just (DoubleLetter Nothing)) (unoccupiedSquareAt emptyBoard pos)) expectedDoubleLetters + assertEqual "Unexpected result for letters above" expected actual - let allPositions = catMaybes $ map posAt $ map (\[x,y] -> (x,y)) (sequence [[posMin..posMax], [posMin..posMax]]) +lettersBelowTest :: Assertion +lettersBelowTest = + do + let pos = Pos 7 9 "G9" + let actual = lettersBelow testBoard pos + let expected = Seq.fromList $ init verticals - let expectedNormals = allPositions \\ (expectedTripleWords ++ expectedDoubleWords ++ expectedTripleLetters ++ expectedDoubleLetters) - mapM_ (\pos -> assertEqual ("Normal square not where expected " ++ show pos) (Just (Normal Nothing)) (unoccupiedSquareAt emptyBoard pos)) expectedNormals + assertEqual "Unexpected result for letters below" expected actual +{- Verifies that new tiles can be placed consecutively on a board while the old board is retained -} +tilesPlacedConsecutivelyTest :: Assertion +tilesPlacedConsecutivelyTest = + do + let expected = testBoard + let tiles = map (\(pos, square) -> (pos, fromJust $ tileIfOccupied square)) $ (S.toList . S.fromList) allTiles + let result = foldM (\board (tile, pos) -> placeTile board pos tile) emptyBoard tiles + maybe (assertFailure "Tiles placed test failed") (\actual -> assertEqual "Tiles were not placed on board" expected actual) result +boardCorrectlyFormed :: Assertion +boardCorrectlyFormed = + do + let expectedTripleWords = catMaybes $ map (posAt) [(1, 1), (8, 1), (15, 1), (1, 8), (15, 8), (1, 15), (8, 15), (15, 15)] + mapM_ (\pos -> assertEqual "Triple word squares not where expected" (Just (TripleWord Nothing)) (unoccupiedSquareAt emptyBoard pos)) expectedTripleWords + let expectedDoubleWords = catMaybes $ map (posAt) [(2, 2), (3, 3), (4, 4), (5, 5), (8, 8), (14, 2), (13, 3), (12, 4), (11, 5), (11, 5), (4, 12), (3, 13), (2, 14), (5, 11), (11, 11), (12, 12), (13, 13), (14, 14)] + mapM_ (\pos -> assertEqual "Double word squares not where expected" (Just (DoubleWord Nothing)) (unoccupiedSquareAt emptyBoard pos)) expectedDoubleWords + let expectedTripleLetters = catMaybes $ map (posAt) [(6, 2), (10, 2), (2, 6), (6, 6), (10, 6), (14, 6), (2, 10), (6, 10), (10, 10), (14, 10), (6, 14), (10, 14)] + mapM_ (\pos -> assertEqual "Triple letters squares not where expected" (Just (TripleLetter Nothing)) (unoccupiedSquareAt emptyBoard pos)) expectedTripleLetters + let expectedDoubleLetters = catMaybes $ map (posAt) [(4, 1), (12, 1), (7, 3), (9, 3), (1, 4), (8, 4), (15, 4), (3, 7), (7, 7), (9, 7), (13, 7), (4, 8), (12, 8), (3, 9), (7, 9), (9, 9), (13, 9), (1, 12), (8, 12), (15, 12), (7, 13), (9, 13), (4, 15), (12, 15)] + mapM_ (\pos -> assertEqual "Double letter squares not where expected" (Just (DoubleLetter Nothing)) (unoccupiedSquareAt emptyBoard pos)) expectedDoubleLetters - + let allPositions = catMaybes $ map posAt $ map (\[x, y] -> (x, y)) (sequence [[posMin .. posMax], [posMin .. posMax]]) + let expectedNormals = allPositions \\ (expectedTripleWords ++ expectedDoubleWords ++ expectedTripleLetters ++ expectedDoubleLetters) + mapM_ (\pos -> assertEqual ("Normal square not where expected " ++ show pos) (Just (Normal Nothing)) (unoccupiedSquareAt emptyBoard pos)) expectedNormals diff --git a/test/Tests/FormedWordsTest.hs b/test/Tests/FormedWordsTest.hs --- a/test/Tests/FormedWordsTest.hs +++ b/test/Tests/FormedWordsTest.hs @@ -1,616 +1,600 @@ module Tests.FormedWordsTest where - import Tests.SharedTestData - import Wordify.Rules.Pos - import Wordify.Rules.Tile - import Wordify.Rules.Board - import Wordify.Rules.Board.Internal - import qualified Data.Map as M - import Wordify.Rules.FormedWord - import Test.HUnit.Base - import Data.Maybe - import Data.Either - import Wordify.Rules.Pos.Internal - import qualified Data.Sequence as S - import Wordify.Rules.Square - import Control.Applicative - import Wordify.Rules.ScrabbleError - import Wordify.Rules.Pos.Internal - - testBoard :: Board - testBoard = Board squareMap - where - squareMap = M.fromList $ (M.assocs emptySquares ++ verticals ++ horizontals) - Board (emptySquares) = emptyBoard - - {- - Asserts that we can correctly add the bracket notation to a placed word, prepending to a word - -} - testPrettyPrintIntersectionPrepend :: Assertion - testPrettyPrintIntersectionPrepend = - do - let positions = take 3 $ catMaybes $ map posAt $ iterate(\(x,y) -> (x + 1,y)) (4,5) - let tiles = [Letter 'T' 1, Letter 'E' 1, Letter 'S' 1] - let placedList = zip positions $ map (Normal . Just) tiles - let placed = M.fromList placedList - - let formedPositions = catMaybes $ map posAt $ iterate(\(x,y) -> (x + 1,y)) (8,5) - let formed = (S.fromList placedList) S.>< (S.fromList $ zip formedPositions $ map (Normal . Just . flip Letter 1) ['T', 'I', 'N', 'G']) - - let actual = prettyPrintIntersections placed formed - - assertEqual "Did not form expected pretty printed intersection" "TES(TING)" actual +import Control.Applicative +import Data.Either +import qualified Data.Map as M +import Data.Maybe +import qualified Data.Sequence as S +import Test.HUnit.Base +import Tests.SharedTestData +import Wordify.Rules.Board +import Wordify.Rules.Board.Internal +import Wordify.Rules.FormedWord +import Wordify.Rules.Pos +import Wordify.Rules.Pos.Internal +import Wordify.Rules.ScrabbleError +import Wordify.Rules.Square +import Wordify.Rules.Tile - testPrettyPrintIntersectionAppend :: Assertion - testPrettyPrintIntersectionAppend = - do - let positions = take 4 $ catMaybes $ map posAt $ iterate(\(x,y) -> (x + 1,y)) (8,5) +testBoard :: Board +testBoard = Board squareMap + where + squareMap = M.fromList $ (M.assocs emptySquares ++ verticals ++ horizontals) + Board (emptySquares) = emptyBoard - let tiles = map (flip Letter 1) ['T', 'I', 'N', 'G'] - let placedList = zip positions $ map (Normal . Just) tiles - let placed = M.fromList placedList +{- + Asserts that we can correctly add the bracket notation to a placed word, prepending to a word + -} +testPrettyPrintIntersectionPrepend :: Assertion +testPrettyPrintIntersectionPrepend = + do + let positions = take 3 $ catMaybes $ map posAt $ iterate (\(x, y) -> (x + 1, y)) (4, 5) + let tiles = [Letter "T" 1, Letter "E" 1, Letter "S" 1] + let placedList = zip positions $ map (Normal . Just) tiles + let placed = M.fromList placedList - let formedPositions = take 3 $ catMaybes $ map posAt $ iterate(\(x,y) -> (x + 1,y)) (4,5) - let formed = (S.fromList $ zip formedPositions $ map (Normal . Just . flip Letter 1) ['T','E','S']) S.>< S.fromList placedList + let formedPositions = catMaybes $ map posAt $ iterate (\(x, y) -> (x + 1, y)) (8, 5) + let formed = (S.fromList placedList) S.>< (S.fromList $ zip formedPositions $ map (Normal . Just . flip Letter 1) ["T", "I", "N", "G"]) - let actual = prettyPrintIntersections placed formed + let actual = prettyPrintIntersections placed formed - assertEqual "Did not form expected pretty printed intersection" "(TES)TING" actual + assertEqual "Did not form expected pretty printed intersection" "TES(TING)" actual - testPrettyPrintIntersectionFirstWord :: Assertion - testPrettyPrintIntersectionFirstWord = - do - let positions = take 4 $ catMaybes $ map posAt $ iterate(\(x,y) -> (x + 1,y)) (8,5) - let tiles = map (flip Letter 1) ['T', 'E', 'S', 'T'] - let placedList = zip positions $ map (Normal . Just) tiles - let placed = M.fromList placedList +testPrettyPrintIntersectionAppend :: Assertion +testPrettyPrintIntersectionAppend = + do + let positions = take 4 $ catMaybes $ map posAt $ iterate (\(x, y) -> (x + 1, y)) (8, 5) - let formed = S.fromList $ zip positions $ map (Normal . Just) tiles + let tiles = map (flip Letter 1) ["T", "I", "N", "G"] + let placedList = zip positions $ map (Normal . Just) tiles + let placed = M.fromList placedList - let actual = prettyPrintIntersections placed formed - assertEqual "Did not form expected pretty printed intersection" "TEST" actual + let formedPositions = take 3 $ catMaybes $ map posAt $ iterate (\(x, y) -> (x + 1, y)) (4, 5) + let formed = (S.fromList $ zip formedPositions $ map (Normal . Just . flip Letter 1) ["T", "E", "S"]) S.>< S.fromList placedList - testPrettyPrintThroughPlacedLetters :: Assertion - testPrettyPrintThroughPlacedLetters = - do - let positions = take 4 $ catMaybes $ map posAt $ iterate(\(x,y) -> (x + 1,y)) (8,5) - let positions2 = take 2 $ catMaybes $ map posAt $ iterate(\(x,y) -> (x + 1,y)) (13,5) + let actual = prettyPrintIntersections placed formed - let tiles = map (flip Letter 1) ['T', 'I', 'N', 'G'] - let placedList = zip positions $ map (Normal . Just) tiles - let placed = M.fromList placedList + assertEqual "Did not form expected pretty printed intersection" "(TES)TING" actual - let alreadyPlacedList2 = zip positions2 $ map (Normal . Just) tiles +testPrettyPrintIntersectionFirstWord :: Assertion +testPrettyPrintIntersectionFirstWord = + do + let positions = take 4 $ catMaybes $ map posAt $ iterate (\(x, y) -> (x + 1, y)) (8, 5) + let tiles = map (flip Letter 1) ["T", "E", "S", "T"] + let placedList = zip positions $ map (Normal . Just) tiles + let placed = M.fromList placedList - let formedPositions = take 3 $ catMaybes $ map posAt $ iterate(\(x,y) -> (x + 1,y)) (4,5) - let formed = (S.fromList $ zip formedPositions $ map (Normal . Just . flip Letter 1) ['T','E','S']) S.>< S.fromList placedList S.>< S.fromList alreadyPlacedList2 + let formed = S.fromList $ zip positions $ map (Normal . Just) tiles - let actual = prettyPrintIntersections placed formed + let actual = prettyPrintIntersections placed formed + assertEqual "Did not form expected pretty printed intersection" "TEST" actual - assertEqual "Did not form expected pretty printed intersection" "(TES)TING(TI)" actual +testPrettyPrintThroughPlacedLetters :: Assertion +testPrettyPrintThroughPlacedLetters = + do + let positions = take 4 $ catMaybes $ map posAt $ iterate (\(x, y) -> (x + 1, y)) (8, 5) + let positions2 = take 2 $ catMaybes $ map posAt $ iterate (\(x, y) -> (x + 1, y)) (13, 5) + let tiles = map (flip Letter 1) ["T", "I", "N", "G"] + let placedList = zip positions $ map (Normal . Just) tiles + let placed = M.fromList placedList - attachLeftWord :: Assertion - attachLeftWord = - do - let positions = take 3 $ catMaybes $ map posAt $ iterate(\(x,y) -> (x + 1,y)) (4,5) - let tiles = [Letter 'T' 1, Letter 'E' 1, Letter 'S' 1] - let placed = M.fromList $ zip positions tiles + let alreadyPlacedList2 = zip positions2 $ map (Normal . Just) tiles - let formed = wordsFormedMidGame testBoard placed + let formedPositions = take 3 $ catMaybes $ map posAt $ iterate (\(x, y) -> (x + 1, y)) (4, 5) + let formed = (S.fromList $ zip formedPositions $ map (Normal . Just . flip Letter 1) ["T", "E", "S"]) S.>< S.fromList placedList S.>< S.fromList alreadyPlacedList2 - assertBool "Unexpected error in wordsFormedMidGame in attach left test initialisation" $ isValid formed - let Right wordsFormed = formed + let actual = prettyPrintIntersections placed formed - let expectedWord = S.fromList $ M.toList placed ++ [(Pos 7 5 "G5", Letter 'T' 1)] - assertBool "Unexpected words formed " $ (wordStrings wordsFormed) == ["TEST"] + assertEqual "Did not form expected pretty printed intersection" "(TES)TING(TI)" actual - let squares = catMaybes $ map (unoccupiedSquareAt testBoard) positions - let expectedSquares = zipWith putTileOn squares tiles +attachLeftWord :: Assertion +attachLeftWord = + do + let positions = take 3 $ catMaybes $ map posAt $ iterate (\(x, y) -> (x + 1, y)) (4, 5) + let tiles = [Letter "T" 1, Letter "E" 1, Letter "S" 1] + let placed = M.fromList $ zip positions tiles - let expectedFormedWord = S.fromList $ zip positions expectedSquares ++ [(Pos 7 5 "G5", Normal $ Just $ Letter 'T' 1)] + let formed = wordsFormedMidGame testBoard placed - assertEqual "Unexpected main word formed" expectedFormedWord (mainWord wordsFormed) + assertBool "Unexpected error in wordsFormedMidGame in attach left test initialisation" $ isValid formed + let Right wordsFormed = formed - assertEqual "Unexpected player placed" (S.take 3 expectedFormedWord) (S.fromList $ (playerPlaced wordsFormed)) + let expectedWord = S.fromList $ M.toList placed ++ [(Pos 7 5 "G5", Letter "T" 1)] + assertBool "Unexpected words formed " $ (wordStrings wordsFormed) == ["TEST"] - assertEqual "Expected empty adjecent words" [] (adjacentWords wordsFormed) + let squares = catMaybes $ map (unoccupiedSquareAt testBoard) positions + let expectedSquares = zipWith putTileOn squares tiles - let (overallscore, _) = wordsWithScores wordsFormed + let expectedFormedWord = S.fromList $ zip positions expectedSquares ++ [(Pos 7 5 "G5", Normal $ Just $ Letter "T" 1)] - assertEqual "Unexpected score for placed tiles" ((1 + 1 + 1 + 1) * 2) overallscore - - attachRightWord :: Assertion - attachRightWord = - do - let positions = take 5 $ catMaybes $ map posAt $ iterate (\(x,y) -> (x + 1,y)) (8,9) - let tiles = [Letter 'E' 1, Letter 'L' 1, Letter 'L' 1, Letter 'O' 1, Blank (Just 'W')] - let placed = M.fromList $ zip positions tiles + assertEqual "Unexpected main word formed" expectedFormedWord (mainWord wordsFormed) - let formed = wordsFormedMidGame testBoard placed + assertEqual "Unexpected player placed" (S.take 3 expectedFormedWord) (S.fromList $ (playerPlaced wordsFormed)) - assertBool "Unexpected error in wordsFormedMidGame in attach right test initialisation" $ isValid formed + assertEqual "Expected empty adjecent words" [] (adjacentWords wordsFormed) - let Right wordsFormed = formed + let (overallscore, _) = wordsWithScores wordsFormed - let expectedWord = S.fromList $ (Pos 7 9 "G7", Letter 'Y' 4) : M.toList placed + assertEqual "Unexpected score for placed tiles" ((1 + 1 + 1 + 1) * 2) overallscore - assertBool "Unexpected words formed " $ (wordStrings wordsFormed) == ["YELLOW"] +attachRightWord :: Assertion +attachRightWord = + do + let positions = take 5 $ catMaybes $ map posAt $ iterate (\(x, y) -> (x + 1, y)) (8, 9) + let tiles = [Letter "E" 1, Letter "L" 1, Letter "L" 1, Letter "O" 1, Blank (Just "W")] + let placed = M.fromList $ zip positions tiles - let squares = catMaybes $ map (unoccupiedSquareAt testBoard) positions - let expectedSquares = zipWith putTileOn squares tiles - - let expectedFormedWord = S.fromList $ ((Pos 7 9 "G9"), (DoubleLetter $ Just $ Letter 'Y' 4)) : zip positions expectedSquares + let formed = wordsFormedMidGame testBoard placed - assertEqual "Unexpected main word formed" expectedFormedWord (mainWord wordsFormed) + assertBool "Unexpected error in wordsFormedMidGame in attach right test initialisation" $ isValid formed - assertEqual "Unexpected player placed" (S.drop 1 expectedFormedWord) (S.fromList $ (playerPlaced wordsFormed)) + let Right wordsFormed = formed - assertEqual "Expected empty adjecent words" [] (adjacentWords wordsFormed) + let expectedWord = S.fromList $ (Pos 7 9 "G7", Letter "Y" 4) : M.toList placed - let (overallscore, _) = wordsWithScores wordsFormed + assertBool "Unexpected words formed " $ (wordStrings wordsFormed) == ["YELLOW"] - assertEqual "Unexpected score for placed tiles" (4 + 1 + (2 * 1) + 1 + 1 + 0) overallscore + let squares = catMaybes $ map (unoccupiedSquareAt testBoard) positions + let expectedSquares = zipWith putTileOn squares tiles - attachAboveWord :: Assertion - attachAboveWord = - do - let positions = catMaybes $ map posAt $ iterate (\(x,y) -> (x,y + 1)) (7,3) - let tiles = [Letter 'A' 1, Letter 'B' 3] - let placed = M.fromList $ zip positions tiles + let expectedFormedWord = S.fromList $ ((Pos 7 9 "G9"), (DoubleLetter $ Just $ Letter "Y" 4)) : zip positions expectedSquares - let formed = wordsFormedMidGame testBoard placed + assertEqual "Unexpected main word formed" expectedFormedWord (mainWord wordsFormed) - assertBool "Unexpected error in wordsFormedMidGame in attach above test initialisation" $ isValid formed + assertEqual "Unexpected player placed" (S.drop 1 expectedFormedWord) (S.fromList $ (playerPlaced wordsFormed)) - let Right wordsFormed = formed + assertEqual "Expected empty adjecent words" [] (adjacentWords wordsFormed) - assertBool "Unexpected words formed " $ (wordStrings wordsFormed) == ["ABTELLY"] + let (overallscore, _) = wordsWithScores wordsFormed - let squares = catMaybes $ map (unoccupiedSquareAt testBoard) positions - let expectedFormedWord = S.fromList $ zip positions $ zipWith putTileOn squares tiles ++ verticalSquares + assertEqual "Unexpected score for placed tiles" (4 + 1 + (2 * 1) + 1 + 1 + 0) overallscore - assertEqual "Unexpected main word formed" expectedFormedWord (mainWord wordsFormed) +attachAboveWord :: Assertion +attachAboveWord = + do + let positions = catMaybes $ map posAt $ iterate (\(x, y) -> (x, y + 1)) (7, 3) + let tiles = [Letter "A" 1, Letter "B" 3] + let placed = M.fromList $ zip positions tiles - assertEqual "Unexpected player placed" (S.take 2 expectedFormedWord) (S.fromList $ (playerPlaced wordsFormed)) + let formed = wordsFormedMidGame testBoard placed - assertEqual "Expected empty adjecent words" [] (adjacentWords wordsFormed) + assertBool "Unexpected error in wordsFormedMidGame in attach above test initialisation" $ isValid formed - let (overallscore, _) = wordsWithScores wordsFormed + let Right wordsFormed = formed - assertEqual "Unexpected score for placed tiles" ((2 * 1) + 3 + 1 + 1 + 1 + 1 + 4) overallscore + assertBool "Unexpected words formed " $ (wordStrings wordsFormed) == ["ABTELLY"] + let squares = catMaybes $ map (unoccupiedSquareAt testBoard) positions + let expectedFormedWord = S.fromList $ zip positions $ zipWith putTileOn squares tiles ++ verticalSquares - attachWordBelow :: Assertion - attachWordBelow = - do - let positions = take 2 $ catMaybes $ map posAt $ iterate (\(x,y) -> (x,y + 1)) (7,10) - let tiles = [Letter 'A' 1, Letter 'B' 3] - let placed = M.fromList $ zip positions tiles + assertEqual "Unexpected main word formed" expectedFormedWord (mainWord wordsFormed) - let formed = wordsFormedMidGame testBoard placed + assertEqual "Unexpected player placed" (S.take 2 expectedFormedWord) (S.fromList $ (playerPlaced wordsFormed)) - assertBool "Unexpected error in wordsFormedMidGame in attach below test initialisation" $ isValid formed + assertEqual "Expected empty adjecent words" [] (adjacentWords wordsFormed) - let Right wordsFormed = formed + let (overallscore, _) = wordsWithScores wordsFormed - assertBool "Unexpected words formed " $ (wordStrings wordsFormed) == ["TELLYAB"] + assertEqual "Unexpected score for placed tiles" ((2 * 1) + 3 + 1 + 1 + 1 + 1 + 4) overallscore - let squares = catMaybes $ map (unoccupiedSquareAt testBoard) positions +attachWordBelow :: Assertion +attachWordBelow = + do + let positions = take 2 $ catMaybes $ map posAt $ iterate (\(x, y) -> (x, y + 1)) (7, 10) + let tiles = [Letter "A" 1, Letter "B" 3] + let placed = M.fromList $ zip positions tiles - let leadingPositions = catMaybes $ map posAt $ iterate (\(x,y) -> (x,y + 1)) (7,5) - let expectedFormedWord = S.fromList $ (zip leadingPositions verticalSquares) ++ (zip positions $ zipWith putTileOn squares tiles) + let formed = wordsFormedMidGame testBoard placed - assertEqual "Unexpected main word formed" expectedFormedWord (mainWord wordsFormed) + assertBool "Unexpected error in wordsFormedMidGame in attach below test initialisation" $ isValid formed - assertEqual "Unexpected player placed" (S.drop 5 expectedFormedWord) (S.fromList $ (playerPlaced wordsFormed)) + let Right wordsFormed = formed - assertEqual "Expected empty adjecent words" [] (adjacentWords wordsFormed) + assertBool "Unexpected words formed " $ (wordStrings wordsFormed) == ["TELLYAB"] - let (overallscore, _) = wordsWithScores wordsFormed + let squares = catMaybes $ map (unoccupiedSquareAt testBoard) positions - assertEqual "Unexpected score for placed tiles" (1 + 1 + 1 + 1 + 4 + 1 + 3) overallscore + let leadingPositions = catMaybes $ map posAt $ iterate (\(x, y) -> (x, y + 1)) (7, 5) + let expectedFormedWord = S.fromList $ (zip leadingPositions verticalSquares) ++ (zip positions $ zipWith putTileOn squares tiles) + assertEqual "Unexpected main word formed" expectedFormedWord (mainWord wordsFormed) - attachAboveAndBelow :: Assertion - attachAboveAndBelow = - do - let abovePositions = catMaybes $ map posAt $ [(7,3), (7,4)] - let belowPositions = catMaybes $ map posAt $ [(7,10), (7,11)] - let placedPositions = (abovePositions ++ belowPositions) - let tiles = cycle $ [Letter 'A' 1, Letter 'B' 3] - let placed = M.fromList $ zip placedPositions tiles + assertEqual "Unexpected player placed" (S.drop 5 expectedFormedWord) (S.fromList $ (playerPlaced wordsFormed)) - let formed = wordsFormedMidGame testBoard placed + assertEqual "Expected empty adjecent words" [] (adjacentWords wordsFormed) - assertBool "Unexpected error in wordsFormedMidGame in attach above test initialisation" $ isValid formed + let (overallscore, _) = wordsWithScores wordsFormed - let Right wordsFormed = formed + assertEqual "Unexpected score for placed tiles" (1 + 1 + 1 + 1 + 4 + 1 + 3) overallscore - assertBool "Unexpected words formed " $ (wordStrings wordsFormed) == ["ABTELLYAB"] +attachAboveAndBelow :: Assertion +attachAboveAndBelow = + do + let abovePositions = catMaybes $ map posAt $ [(7, 3), (7, 4)] + let belowPositions = catMaybes $ map posAt $ [(7, 10), (7, 11)] + let placedPositions = (abovePositions ++ belowPositions) + let tiles = cycle $ [Letter "A" 1, Letter "B" 3] + let placed = M.fromList $ zip placedPositions tiles - let placedSquares = catMaybes $ map (unoccupiedSquareAt testBoard) placedPositions - let tilesOnPlaced = zipWith putTileOn placedSquares tiles + let formed = wordsFormedMidGame testBoard placed - let expectedFormedWord = S.fromList $ zip abovePositions (take 2 tilesOnPlaced) ++ (zip verticalPositions verticalSquares) ++ (zip belowPositions (drop 2 tilesOnPlaced)) + assertBool "Unexpected error in wordsFormedMidGame in attach above test initialisation" $ isValid formed - assertEqual "Unexpected main word formed" expectedFormedWord (mainWord wordsFormed) + let Right wordsFormed = formed - assertEqual "Expected empty adjecent words" [] (adjacentWords wordsFormed) + assertBool "Unexpected words formed " $ (wordStrings wordsFormed) == ["ABTELLYAB"] - let (overallscore, _) = wordsWithScores wordsFormed + let placedSquares = catMaybes $ map (unoccupiedSquareAt testBoard) placedPositions + let tilesOnPlaced = zipWith putTileOn placedSquares tiles - assertEqual "Unexpected score for placed tiles" ((2 * 1) + 3 + 1 + 1 + 1 + 1 + 4 + 1 + 3) overallscore + let expectedFormedWord = S.fromList $ zip abovePositions (take 2 tilesOnPlaced) ++ (zip verticalPositions verticalSquares) ++ (zip belowPositions (drop 2 tilesOnPlaced)) + assertEqual "Unexpected main word formed" expectedFormedWord (mainWord wordsFormed) - attachLeftAndRight :: Assertion - attachLeftAndRight = - do - let leftPositions = catMaybes $ map posAt $ [(3,7), (4,7)] - let rightPositions = catMaybes $ map posAt $ [(10,7), (11,7)] - let placedPositions = (leftPositions ++ rightPositions) - let tiles = cycle $ [Letter 'A' 1, Letter 'B' 3] - let placed = M.fromList $ zip placedPositions tiles + assertEqual "Expected empty adjecent words" [] (adjacentWords wordsFormed) - let formed = wordsFormedMidGame testBoard placed + let (overallscore, _) = wordsWithScores wordsFormed - assertBool "Unexpected error in wordsFormedMidGame test initialisation" $ isValid formed + assertEqual "Unexpected score for placed tiles" ((2 * 1) + 3 + 1 + 1 + 1 + 1 + 4 + 1 + 3) overallscore - let Right wordsFormed = formed +attachLeftAndRight :: Assertion +attachLeftAndRight = + do + let leftPositions = catMaybes $ map posAt $ [(3, 7), (4, 7)] + let rightPositions = catMaybes $ map posAt $ [(10, 7), (11, 7)] + let placedPositions = (leftPositions ++ rightPositions) + let tiles = cycle $ [Letter "A" 1, Letter "B" 3] + let placed = M.fromList $ zip placedPositions tiles - assertBool "Unexpected words formed " $ (wordStrings wordsFormed) == ["ABHELLOAB"] + let formed = wordsFormedMidGame testBoard placed - let placedSquares = catMaybes $ map (unoccupiedSquareAt testBoard) placedPositions - let tilesOnPlaced = zipWith putTileOn placedSquares tiles + assertBool "Unexpected error in wordsFormedMidGame test initialisation" $ isValid formed - let expectedFormedWord = S.fromList $ zip leftPositions (take 2 tilesOnPlaced) ++ (zip horizontalPositions horizontalSquares) ++ (zip rightPositions (drop 2 tilesOnPlaced)) + let Right wordsFormed = formed - assertEqual "Unexpected main word formed" expectedFormedWord (mainWord wordsFormed) + assertBool "Unexpected words formed " $ (wordStrings wordsFormed) == ["ABHELLOAB"] - assertEqual "Expected empty adjecent words" [] (adjacentWords wordsFormed) + let placedSquares = catMaybes $ map (unoccupiedSquareAt testBoard) placedPositions + let tilesOnPlaced = zipWith putTileOn placedSquares tiles - let (overallscore, _) = wordsWithScores wordsFormed + let expectedFormedWord = S.fromList $ zip leftPositions (take 2 tilesOnPlaced) ++ (zip horizontalPositions horizontalSquares) ++ (zip rightPositions (drop 2 tilesOnPlaced)) - assertEqual "Unexpected score for placed tiles" ((2 * 1) + 3 + 4 + 1 + 1 + 1 + 1 + 1 + 3) overallscore + assertEqual "Unexpected main word formed" expectedFormedWord (mainWord wordsFormed) - adjacentWordsLeft :: Assertion - adjacentWordsLeft = - do - let positions = catMaybes $ map posAt [(8,5), (8,6), (8,8)] - let tiles = [Letter 'O' 1, Letter 'I' 1, Letter 'S' 1] - let placedList = zip positions tiles - let placed = M.fromList $ placedList + assertEqual "Expected empty adjecent words" [] (adjacentWords wordsFormed) - let formed = wordsFormedMidGame testBoard placed + let (overallscore, _) = wordsWithScores wordsFormed - assertBool "Unexpected error in wordsFormedMidGame test initialisation" $ isValid formed + assertEqual "Unexpected score for placed tiles" ((2 * 1) + 3 + 4 + 1 + 1 + 1 + 1 + 1 + 3) overallscore - let Right wordsFormed = formed +adjacentWordsLeft :: Assertion +adjacentWordsLeft = + do + let positions = catMaybes $ map posAt [(8, 5), (8, 6), (8, 8)] + let tiles = [Letter "O" 1, Letter "I" 1, Letter "S" 1] + let placedList = zip positions tiles + let placed = M.fromList $ placedList - assertEqual "Unexpected words formed" ["OILS", "TO", "EI", "LS"] (wordStrings wordsFormed) + let formed = wordsFormedMidGame testBoard placed - let squares = zipWith putTileOn (catMaybes $ map (unoccupiedSquareAt testBoard) positions) tiles - let positionsFromTop = catMaybes $ map posAt $ iterate (\(x,y) -> (x, y + 1)) (8,5) - let squaresWithPositions = zip positionsFromTop $ (init squares) ++ [Normal $ Just $ Letter 'L' 1] ++ [last squares] - let expectedMainWord = S.fromList $ squaresWithPositions + assertBool "Unexpected error in wordsFormedMidGame test initialisation" $ isValid formed - assertEqual "Unexpected main word" expectedMainWord (mainWord wordsFormed) + let Right wordsFormed = formed - let expectedWordsWithScores = (((1 + 1 + 1 + 1) * 2) + 2 + 2 + 4, [("OILS", ((1 + 1 + 1 + 1) * 2)), ("TO", 2), ("EI", 2), ("LS", 4)] ) + assertEqual "Unexpected words formed" ["OILS", "TO", "EI", "LS"] (wordStrings wordsFormed) - assertEqual "Unexpected words with scores" expectedWordsWithScores (wordsWithScores wordsFormed) + let squares = zipWith putTileOn (catMaybes $ map (unoccupiedSquareAt testBoard) positions) tiles + let positionsFromTop = catMaybes $ map posAt $ iterate (\(x, y) -> (x, y + 1)) (8, 5) + let squaresWithPositions = zip positionsFromTop $ (init squares) ++ [Normal $ Just $ Letter "L" 1] ++ [last squares] + let expectedMainWord = S.fromList $ squaresWithPositions - let connectedTo = take 2 verticals ++ drop 3 verticals - let placedSquares = zip positions $ (init squares) ++ [last squares] - let expectedAdjacent = zipWith (\l r -> l S.<| S.singleton r) connectedTo placedSquares + assertEqual "Unexpected main word" expectedMainWord (mainWord wordsFormed) - assertEqual "Unexpected adjacent words" expectedAdjacent (adjacentWords wordsFormed) + let expectedWordsWithScores = (((1 + 1 + 1 + 1) * 2) + 2 + 2 + 4, [("OILS", ((1 + 1 + 1 + 1) * 2)), ("TO", 2), ("EI", 2), ("LS", 4)]) - adjacentWordsRight :: Assertion - adjacentWordsRight = - do - let positions = catMaybes $ map posAt [(6,4), (6,5), (6,6), (6,8)] - let tiles = [Letter 'B' 3, Letter 'I' 1, Letter 'T' 1, Letter 'R' 1] - let placedList = zip positions tiles - let placed = M.fromList $ placedList + assertEqual "Unexpected words with scores" expectedWordsWithScores (wordsWithScores wordsFormed) - let formed = wordsFormedMidGame testBoard placed + let connectedTo = take 2 verticals ++ drop 3 verticals + let placedSquares = zip positions $ (init squares) ++ [last squares] + let expectedAdjacent = zipWith (\l r -> l S.<| S.singleton r) connectedTo placedSquares - assertBool "Unexpected error in wordsFormedMidGame test initialisation" $ isValid formed + assertEqual "Unexpected adjacent words" expectedAdjacent (adjacentWords wordsFormed) - let Right wordsFormed = formed +adjacentWordsRight :: Assertion +adjacentWordsRight = + do + let positions = catMaybes $ map posAt [(6, 4), (6, 5), (6, 6), (6, 8)] + let tiles = [Letter "B" 3, Letter "I" 1, Letter "T" 1, Letter "R" 1] + let placedList = zip positions tiles + let placed = M.fromList $ placedList - assertEqual "Unexpected words formed" ["BITER", "IT", "TE", "RL"] (wordStrings wordsFormed) + let formed = wordsFormedMidGame testBoard placed - let squares = zipWith putTileOn (catMaybes $ map (unoccupiedSquareAt testBoard) positions) tiles - let positionsFromTop = catMaybes $ map posAt $ iterate (\(x,y) -> (x, y + 1)) (6,4) - let squaresWithPositions = zip positionsFromTop $ (init squares) ++ [Normal $ Just $ Letter 'E' 1] ++ [last squares] - let expectedMainWord = S.fromList $ squaresWithPositions + assertBool "Unexpected error in wordsFormedMidGame test initialisation" $ isValid formed - assertEqual "Unexpected main word" expectedMainWord (mainWord wordsFormed) + let Right wordsFormed = formed - let expectedWordsWithScores = ((3 + 1 + 3 + 1 + 1) + 2 + 4 + 2, [("BITER",(3 + 1 + 3 + 1 + 1)) , ("IT", 2), ("TE", 4), ("RL", 2)] ) + assertEqual "Unexpected words formed" ["BITER", "IT", "TE", "RL"] (wordStrings wordsFormed) - assertEqual "Unexpected words with scores" expectedWordsWithScores (wordsWithScores wordsFormed) + let squares = zipWith putTileOn (catMaybes $ map (unoccupiedSquareAt testBoard) positions) tiles + let positionsFromTop = catMaybes $ map posAt $ iterate (\(x, y) -> (x, y + 1)) (6, 4) + let squaresWithPositions = zip positionsFromTop $ (init squares) ++ [Normal $ Just $ Letter "E" 1] ++ [last squares] + let expectedMainWord = S.fromList $ squaresWithPositions - let connectedTo = take 2 verticals ++ drop 3 verticals - let placedSquares = zip positions $ (init squares) ++ [last squares] - let expectedAdjacent = zipWith (\l r -> l S.<| S.singleton r) (drop 1 placedSquares) connectedTo + assertEqual "Unexpected main word" expectedMainWord (mainWord wordsFormed) - assertEqual "Unexpected adjacent words" expectedAdjacent (adjacentWords wordsFormed) + let expectedWordsWithScores = ((3 + 1 + 3 + 1 + 1) + 2 + 4 + 2, [("BITER", (3 + 1 + 3 + 1 + 1)), ("IT", 2), ("TE", 4), ("RL", 2)]) - adjacentWordsAbove :: Assertion - adjacentWordsAbove = - do - let positions = catMaybes $ map posAt [(6,6), (8,6)] - let tiles = [Letter 'H' 4, Letter 'J' 8] - let placedList = zip positions tiles - let placed = M.fromList $ placedList + assertEqual "Unexpected words with scores" expectedWordsWithScores (wordsWithScores wordsFormed) - let formed = wordsFormedMidGame testBoard placed + let connectedTo = take 2 verticals ++ drop 3 verticals + let placedSquares = zip positions $ (init squares) ++ [last squares] + let expectedAdjacent = zipWith (\l r -> l S.<| S.singleton r) (drop 1 placedSquares) connectedTo - assertBool "Unexpected error in wordsFormedMidGame test initialisation" $ isValid formed + assertEqual "Unexpected adjacent words" expectedAdjacent (adjacentWords wordsFormed) - let Right wordsFormed = formed +adjacentWordsAbove :: Assertion +adjacentWordsAbove = + do + let positions = catMaybes $ map posAt [(6, 6), (8, 6)] + let tiles = [Letter "H" 4, Letter "J" 8] + let placedList = zip positions tiles + let placed = M.fromList $ placedList - assertEqual "Unexpected words formed" ["HEJ", "HE", "JL"] (wordStrings wordsFormed) + let formed = wordsFormedMidGame testBoard placed - let squares = zipWith putTileOn (catMaybes $ map (unoccupiedSquareAt testBoard) positions) tiles - let positionsFromLeft = catMaybes $ map posAt $ iterate (\(x,y) -> (x + 1, y)) (6,6) - let squaresWithPositions = zip positionsFromLeft $ (init squares) ++ [Normal $ Just $ Letter 'E' 1] ++ [last squares] - let expectedMainWord = S.fromList $ squaresWithPositions + assertBool "Unexpected error in wordsFormedMidGame test initialisation" $ isValid formed - assertEqual "Unexpected main word" expectedMainWord (mainWord wordsFormed) + let Right wordsFormed = formed - let expectedWordsWithScores = (((4 * 3) + 1 + 8) + 13 + 9, [("HEJ", ((4 * 3) + 1 + 8)), ("HE", 13), ("JL", 9)] ) + assertEqual "Unexpected words formed" ["HEJ", "HE", "JL"] (wordStrings wordsFormed) - assertEqual "Unexpected words with scores" expectedWordsWithScores (wordsWithScores wordsFormed) + let squares = zipWith putTileOn (catMaybes $ map (unoccupiedSquareAt testBoard) positions) tiles + let positionsFromLeft = catMaybes $ map posAt $ iterate (\(x, y) -> (x + 1, y)) (6, 6) + let squaresWithPositions = zip positionsFromLeft $ (init squares) ++ [Normal $ Just $ Letter "E" 1] ++ [last squares] + let expectedMainWord = S.fromList $ squaresWithPositions - let connectedTo = [head (drop 1 horizontals)] ++ [head $ drop 3 horizontals] - let placedSquares = zip positions $ (init squares) ++ [last squares] - let expectedAdjacent = zipWith (\l r -> l S.<| S.singleton r) placedSquares connectedTo + assertEqual "Unexpected main word" expectedMainWord (mainWord wordsFormed) - assertEqual "Unexpected adjacent words" expectedAdjacent (adjacentWords wordsFormed) + let expectedWordsWithScores = (((4 * 3) + 1 + 8) + 13 + 9, [("HEJ", ((4 * 3) + 1 + 8)), ("HE", 13), ("JL", 9)]) - adjacentWordsBelow :: Assertion - adjacentWordsBelow = - do - let positions = catMaybes $ map posAt [(6,8), (8,8)] - let tiles = [Letter 'I' 1, Letter 'L' 1] - let placedList = zip positions tiles - let placed = M.fromList $ placedList + assertEqual "Unexpected words with scores" expectedWordsWithScores (wordsWithScores wordsFormed) - let formed = wordsFormedMidGame testBoard placed + let connectedTo = [head (drop 1 horizontals)] ++ [head $ drop 3 horizontals] + let placedSquares = zip positions $ (init squares) ++ [last squares] + let expectedAdjacent = zipWith (\l r -> l S.<| S.singleton r) placedSquares connectedTo - assertBool "Unexpected error in wordsFormedMidGame test initialisation" $ isValid formed + assertEqual "Unexpected adjacent words" expectedAdjacent (adjacentWords wordsFormed) - let Right wordsFormed = formed +adjacentWordsBelow :: Assertion +adjacentWordsBelow = + do + let positions = catMaybes $ map posAt [(6, 8), (8, 8)] + let tiles = [Letter "I" 1, Letter "L" 1] + let placedList = zip positions tiles + let placed = M.fromList $ placedList - assertEqual "Unexpected words formed" ["ILL", "EI", "LL"] (wordStrings wordsFormed) + let formed = wordsFormedMidGame testBoard placed - let squares = zipWith putTileOn (catMaybes $ map (unoccupiedSquareAt testBoard) positions) tiles - let positionsFromLeft = catMaybes $ map posAt $ iterate (\(x,y) -> (x + 1, y)) (6,8) - let squaresWithPositions = zip positionsFromLeft $ (init squares) ++ [Normal $ Just $ Letter 'L' 1] ++ [last squares] - let expectedMainWord = S.fromList $ squaresWithPositions + assertBool "Unexpected error in wordsFormedMidGame test initialisation" $ isValid formed - assertEqual "Unexpected main word" expectedMainWord (mainWord wordsFormed) + let Right wordsFormed = formed - let expectedWordsWithScores = (6 + 2 + 4, [("ILL", 6), ("EI", 2), ("LL", 4)] ) + assertEqual "Unexpected words formed" ["ILL", "EI", "LL"] (wordStrings wordsFormed) - assertEqual "Unexpected words with scores" expectedWordsWithScores (wordsWithScores wordsFormed) + let squares = zipWith putTileOn (catMaybes $ map (unoccupiedSquareAt testBoard) positions) tiles + let positionsFromLeft = catMaybes $ map posAt $ iterate (\(x, y) -> (x + 1, y)) (6, 8) + let squaresWithPositions = zip positionsFromLeft $ (init squares) ++ [Normal $ Just $ Letter "L" 1] ++ [last squares] + let expectedMainWord = S.fromList $ squaresWithPositions - let connectedTo = [head (drop 1 horizontals)] ++ [head $ drop 3 horizontals] - let placedSquares = zip positions $ (init squares) ++ [last squares] - let expectedAdjacent = zipWith (\l r -> l S.<| S.singleton r) connectedTo placedSquares + assertEqual "Unexpected main word" expectedMainWord (mainWord wordsFormed) - assertEqual "Unexpected adjacent words" expectedAdjacent (adjacentWords wordsFormed) + let expectedWordsWithScores = (6 + 2 + 4, [("ILL", 6), ("EI", 2), ("LL", 4)]) - placedOneTileAbove :: Assertion - placedOneTileAbove = - do - let placed = catMaybes $ map posAt [(9,6)] - let tiles = [Letter 'Y' 4] - let placedTiles = M.fromList $ zip placed tiles + assertEqual "Unexpected words with scores" expectedWordsWithScores (wordsWithScores wordsFormed) - let formed = wordsFormedMidGame testBoard placedTiles + let connectedTo = [head (drop 1 horizontals)] ++ [head $ drop 3 horizontals] + let placedSquares = zip positions $ (init squares) ++ [last squares] + let expectedAdjacent = zipWith (\l r -> l S.<| S.singleton r) connectedTo placedSquares - assertBool "Unexpected error in wordsFormedMidGame test initialisation" $ isValid formed + assertEqual "Unexpected adjacent words" expectedAdjacent (adjacentWords wordsFormed) - let Right wordsFormed = formed +placedOneTileAbove :: Assertion +placedOneTileAbove = + do + let placed = catMaybes $ map posAt [(9, 6)] + let tiles = [Letter "Y" 4] + let placedTiles = M.fromList $ zip placed tiles - assertEqual "Unexpected words formed" ["YO"] (wordStrings wordsFormed) + let formed = wordsFormedMidGame testBoard placedTiles - placedOneTileBelow :: Assertion - placedOneTileBelow = - do - let placed = catMaybes $ map posAt [(9,8)] - let tiles = [Letter 'I' 1] - let placedTiles = M.fromList $ zip placed tiles + assertBool "Unexpected error in wordsFormedMidGame test initialisation" $ isValid formed - let formed = wordsFormedMidGame testBoard placedTiles + let Right wordsFormed = formed - assertBool "Unexpected error in wordsFormedMidGame test initialisation" $ isValid formed + assertEqual "Unexpected words formed" ["YO"] (wordStrings wordsFormed) - let Right wordsFormed = formed +placedOneTileBelow :: Assertion +placedOneTileBelow = + do + let placed = catMaybes $ map posAt [(9, 8)] + let tiles = [Letter "I" 1] + let placedTiles = M.fromList $ zip placed tiles - assertEqual "Unexpected words formed" ["OI"] (wordStrings wordsFormed) + let formed = wordsFormedMidGame testBoard placedTiles - placedOneTileRight :: Assertion - placedOneTileRight = - do - let placed = catMaybes $ map posAt [(8,5)] - let tiles = [Letter 'O' 1] - let placedTiles = M.fromList $ zip placed tiles + assertBool "Unexpected error in wordsFormedMidGame test initialisation" $ isValid formed - let formed = wordsFormedMidGame testBoard placedTiles + let Right wordsFormed = formed - assertBool "Unexpected error in wordsFormedMidGame test initialisation" $ isValid formed + assertEqual "Unexpected words formed" ["OI"] (wordStrings wordsFormed) - let Right wordsFormed = formed +placedOneTileRight :: Assertion +placedOneTileRight = + do + let placed = catMaybes $ map posAt [(8, 5)] + let tiles = [Letter "O" 1] + let placedTiles = M.fromList $ zip placed tiles - assertEqual "Unexpected words formed" ["TO"] (wordStrings wordsFormed) + let formed = wordsFormedMidGame testBoard placedTiles - placedOneTileLeft :: Assertion - placedOneTileLeft = - do - let placed = catMaybes $ map posAt [(6,9)] - let tiles = [Letter 'O' 1] - let placedTiles = M.fromList $ zip placed tiles + assertBool "Unexpected error in wordsFormedMidGame test initialisation" $ isValid formed - let formed = wordsFormedMidGame testBoard placedTiles + let Right wordsFormed = formed - assertBool "Unexpected error in wordsFormedMidGame test initialisation" $ isValid formed + assertEqual "Unexpected words formed" ["TO"] (wordStrings wordsFormed) - let Right wordsFormed = formed +placedOneTileLeft :: Assertion +placedOneTileLeft = + do + let placed = catMaybes $ map posAt [(6, 9)] + let tiles = [Letter "O" 1] + let placedTiles = M.fromList $ zip placed tiles - assertEqual "Unexpected words formed" ["OY"] (wordStrings wordsFormed) + let formed = wordsFormedMidGame testBoard placedTiles - passesAbove :: Assertion - passesAbove = - do - let positions = catMaybes $ map posAt $ iterate (\(x,y) -> (x + 1, y)) (6,4) - let tiles = [Letter 'H' 4, Letter 'A' 1, Letter 'S' 1] - let placedTiles = M.fromList $ zip positions tiles + assertBool "Unexpected error in wordsFormedMidGame test initialisation" $ isValid formed - let formed = wordsFormedMidGame testBoard placedTiles + let Right wordsFormed = formed - assertBool "Unexpected error in initialisation" $ isValid formed + assertEqual "Unexpected words formed" ["OY"] (wordStrings wordsFormed) - let Right wordsFormed = formed +passesAbove :: Assertion +passesAbove = + do + let positions = catMaybes $ map posAt $ iterate (\(x, y) -> (x + 1, y)) (6, 4) + let tiles = [Letter "H" 4, Letter "A" 1, Letter "S" 1] + let placedTiles = M.fromList $ zip positions tiles - assertEqual "Unexpected words formed" ["HAS", "ATELLY"] (wordStrings wordsFormed) + let formed = wordsFormedMidGame testBoard placedTiles - passesBelow :: Assertion - passesBelow = - do - let positions = catMaybes $ map posAt $ iterate (\(x,y) -> (x + 1, y)) (6,10) - let tiles = [Letter 'H' 4, Letter 'A' 1, Letter 'S' 1] - let placedTiles = M.fromList $ zip positions tiles + assertBool "Unexpected error in initialisation" $ isValid formed - let formed = wordsFormedMidGame testBoard placedTiles + let Right wordsFormed = formed - assertBool "Unexpected error in initialisation" $ isValid formed + assertEqual "Unexpected words formed" ["HAS", "ATELLY"] (wordStrings wordsFormed) - let Right wordsFormed = formed +passesBelow :: Assertion +passesBelow = + do + let positions = catMaybes $ map posAt $ iterate (\(x, y) -> (x + 1, y)) (6, 10) + let tiles = [Letter "H" 4, Letter "A" 1, Letter "S" 1] + let placedTiles = M.fromList $ zip positions tiles - assertEqual "Unexpected words formed" ["HAS", "TELLYA"] (wordStrings wordsFormed) + let formed = wordsFormedMidGame testBoard placedTiles - passesThroughTwoWords :: Assertion - passesThroughTwoWords = - do - let setupPositions = catMaybes $ map posAt $ iterate (\(x,y) -> (x, y + 1)) (9,8) - let setupSquares = [Normal $ Just $ Letter 'F' 4, Normal $ Just $ Letter 'F' 4] + assertBool "Unexpected error in initialisation" $ isValid formed - let boardSetup = Board $ M.fromList $ (allSquares testBoard) ++ zip setupPositions setupSquares + let Right wordsFormed = formed - let placePositions = catMaybes $ map posAt [(8,9), (10,9)] - let tiles = [Letter 'O' 1, Letter 'O' 1] - let placedTiles = M.fromList $ zip placePositions tiles + assertEqual "Unexpected words formed" ["HAS", "TELLYA"] (wordStrings wordsFormed) - let formed = wordsFormedMidGame boardSetup placedTiles +passesThroughTwoWords :: Assertion +passesThroughTwoWords = + do + let setupPositions = catMaybes $ map posAt $ iterate (\(x, y) -> (x, y + 1)) (9, 8) + let setupSquares = [Normal $ Just $ Letter "F" 4, Normal $ Just $ Letter "F" 4] - assertBool "Unexpected error in initilisation" $ isValid formed + let boardSetup = Board $ M.fromList $ (allSquares testBoard) ++ zip setupPositions setupSquares - let Right wordsFormed = formed + let placePositions = catMaybes $ map posAt [(8, 9), (10, 9)] + let tiles = [Letter "O" 1, Letter "O" 1] + let placedTiles = M.fromList $ zip placePositions tiles - assertEqual "Unexpected words formed" ["YOFO"] (wordStrings wordsFormed) + let formed = wordsFormedMidGame boardSetup placedTiles - assertEqual "Unexpected score for word formed" (10, [("YOFO", 10)])(wordsWithScores wordsFormed) + assertBool "Unexpected error in initilisation" $ isValid formed - firstWordThroughStar :: Assertion - firstWordThroughStar = - do - let positions = catMaybes $ map posAt $ iterate (\(x, y) -> (x + 1, y)) (6,8) - let tiles = map (\lett -> Letter lett 1) "LAST" - let placedList = zip positions tiles - let placed = M.fromList $ placedList + let Right wordsFormed = formed - let formed = wordFormedFirstMove emptyBoard placed + assertEqual "Unexpected words formed" ["YOFO"] (wordStrings wordsFormed) - assertBool "Unexpected error in initilisation" $ isValid formed + assertEqual "Unexpected score for word formed" (10, [("YOFO", 10)]) (wordsWithScores wordsFormed) - let Right wordsFormed = formed +firstWordThroughStar :: Assertion +firstWordThroughStar = + do + let positions = catMaybes $ map posAt $ iterate (\(x, y) -> (x + 1, y)) (6, 8) + let tiles = map (\lett -> Letter [lett] 1) "LAST" + let placedList = zip positions tiles + let placed = M.fromList $ placedList - assertEqual "Unexpected words formed by valid first move" (wordsWithScores wordsFormed) (8, [("LAST", 8)]) + let formed = wordFormedFirstMove emptyBoard placed - firstWordNotThroughStar :: Assertion - firstWordNotThroughStar = - do - let positions = catMaybes $ map posAt $ iterate (\(x, y) -> (x, y + 1)) (8,9) - let tiles = map (\lett -> Letter lett 1) "LAST" - let placedList = zip positions tiles - let placed = M.fromList $ placedList + assertBool "Unexpected error in initilisation" $ isValid formed - let formed = wordFormedFirstMove emptyBoard placed + let Right wordsFormed = formed - assertEqual "Unexpected result for placing tiles which do not intersect the star on the first move" (Left DoesNotCoverTheStarTile) formed + assertEqual "Unexpected words formed by valid first move" (wordsWithScores wordsFormed) (8, [("LAST", 8)]) - firstWordNotContigiousWord :: Assertion - firstWordNotContigiousWord = - do - let positions = catMaybes $ map posAt $ iterate (\(x, y) -> (x + 1, y)) (6,8) - let tiles = map (\lett -> Letter lett 1) "LAST" - let placedList = zip positions tiles - let placed = M.fromList $ (take 1 placedList) ++ (drop 2 placedList) +firstWordNotThroughStar :: Assertion +firstWordNotThroughStar = + do + let positions = catMaybes $ map posAt $ iterate (\(x, y) -> (x, y + 1)) (8, 9) + let tiles = map (\lett -> Letter [lett] 1) "LAST" + let placedList = zip positions tiles + let placed = M.fromList $ placedList - let formed = wordFormedFirstMove emptyBoard placed + let formed = wordFormedFirstMove emptyBoard placed - assertEqual "Unexpected error when placing tiles which are not in a connected line " (Left $ MisplacedLetter (Pos 8 8 "H8") ) formed + assertEqual "Unexpected result for placing tiles which do not intersect the star on the first move" (Left DoesNotCoverTheStarTile) formed - doesNotConnectWithWord :: Assertion - doesNotConnectWithWord = - do - let positions = catMaybes $ map posAt $ iterate (\(x, y) -> (x+1, y)) (4,15) - let tiles = map (\lett -> Letter lett 1) "LAST" - let placedList = zip positions tiles - let placed = M.fromList $ placedList +firstWordNotContigiousWord :: Assertion +firstWordNotContigiousWord = + do + let positions = catMaybes $ map posAt $ iterate (\(x, y) -> (x + 1, y)) (6, 8) + let tiles = map (\lett -> Letter [lett] 1) "LAST" + let placedList = zip positions tiles + let placed = M.fromList $ (take 1 placedList) ++ (drop 2 placedList) - let formed = wordsFormedMidGame emptyBoard placed + let formed = wordFormedFirstMove emptyBoard placed - assertEqual "Placing tiles that do not connect with a word does not throw the expected error" (Left DoesNotConnectWithWord) formed + assertEqual "Unexpected error when placing tiles which are not in a connected line " (Left $ MisplacedLetter (Pos 8 8 "H8")) formed - nonContigiousHorizontal :: Assertion - nonContigiousHorizontal = - do - let positions = catMaybes $ map posAt [(5,9), (6,9),(8,10),(9,9)] - let tiles = [Letter 'T' 1, Letter 'O' 1, Letter 'E' 1, Letter 'D' 2] - let placedList = zip positions tiles - let placed = M.fromList placedList +doesNotConnectWithWord :: Assertion +doesNotConnectWithWord = + do + let positions = catMaybes $ map posAt $ iterate (\(x, y) -> (x + 1, y)) (4, 15) + let tiles = map (\lett -> Letter [lett] 1) "LAST" + let placedList = zip positions tiles + let placed = M.fromList $ placedList - let formed = wordsFormedMidGame testBoard placed + let formed = wordsFormedMidGame emptyBoard placed - assertEqual "Unexpected outcome when placing tiles which are not in a connected line while passing through a word" (Left $ MisplacedLetter (Pos 8 10 "H10") ) formed + assertEqual "Placing tiles that do not connect with a word does not throw the expected error" (Left DoesNotConnectWithWord) formed - nonContigiousVertical :: Assertion - nonContigiousVertical = - do - let positions = catMaybes $ map posAt [(9,6), (9,8), (10,9), (9,10)] - let tiles = [Letter 'T' 1, Letter 'Y' 1, Letter 'E' 1, Letter 'D' 2] - let placedList = zip positions tiles - let placed = M.fromList placedList +nonContigiousHorizontal :: Assertion +nonContigiousHorizontal = + do + let positions = catMaybes $ map posAt [(5, 9), (6, 9), (8, 10), (9, 9)] + let tiles = [Letter "T" 1, Letter "O" 1, Letter "E" 1, Letter "D" 2] + let placedList = zip positions tiles + let placed = M.fromList placedList - let formed = wordsFormedMidGame testBoard placed + let formed = wordsFormedMidGame testBoard placed - assertEqual "Unexpected outcome when placing tiles which are not in a connected line while passing through a word" (Left $ MisplacedLetter (Pos 10 9 "J9") ) formed + assertEqual "Unexpected outcome when placing tiles which are not in a connected line while passing through a word" (Left $ MisplacedLetter (Pos 8 10 "H10")) formed - placeBlankNothing :: Assertion - placeBlankNothing = - do - let positions = catMaybes $ map posAt $ iterate (\(x, y) -> (x+1,y)) (10,7) - let tiles = [Letter 'T' 1, Blank Nothing, Letter 'A' 1] - let placed = M.fromList $ zip positions tiles +nonContigiousVertical :: Assertion +nonContigiousVertical = + do + let positions = catMaybes $ map posAt [(9, 6), (9, 8), (10, 9), (9, 10)] + let tiles = [Letter "T" 1, Letter "Y" 1, Letter "E" 1, Letter "D" 2] + let placedList = zip positions tiles + let placed = M.fromList placedList - let formed = wordsFormedMidGame testBoard placed + let formed = wordsFormedMidGame testBoard placed - assertEqual "Unexpected outcome when placing a blank tile without a chosen letter" (Left $ CannotPlaceBlankWithoutLetter $ Pos 11 7 "K7") formed + assertEqual "Unexpected outcome when placing tiles which are not in a connected line while passing through a word" (Left $ MisplacedLetter (Pos 10 9 "J9")) formed - placeOnOccupiedSquare :: Assertion - placeOnOccupiedSquare = - do - let tiles = [Letter 'T' 1, Blank Nothing, Letter 'A' 1] +placeOnOccupiedSquare :: Assertion +placeOnOccupiedSquare = + do + let tiles = [Letter "T" 1, Blank Nothing, Letter "A" 1] - let placed = M.fromList $ zip verticalPositions tiles + let placed = M.fromList $ zip verticalPositions tiles - let formed = wordsFormedMidGame testBoard placed + let formed = wordsFormedMidGame testBoard placed - assertEqual "Unexpected outcome for tiles placed on an already occupied square" (Left $ PlacedTileOnOccupiedSquare (head verticalPositions) (head tiles)) formed + assertEqual "Unexpected outcome for tiles placed on an already occupied square" (Left $ PlacedTileOnOccupiedSquare (head verticalPositions) (head tiles)) formed diff --git a/test/Tests/FullGameTest.hs b/test/Tests/FullGameTest.hs --- a/test/Tests/FullGameTest.hs +++ b/test/Tests/FullGameTest.hs @@ -1,239 +1,197 @@ module Tests.FullGameTest where - import Wordify.Rules.Dictionary - import qualified Data.Map as M - import Wordify.Rules.ScrabbleError - import Wordify.Rules.LetterBag - import Wordify.Rules.Pos - import Wordify.Rules.Tile - import Wordify.Rules.Board - import Data.Maybe - import Wordify.Rules.Move - import Test.HUnit.Base - import Wordify.Rules.Player - import Wordify.Rules.Game - import Wordify.Rules.Move - import qualified Data.List.NonEmpty as NE - import Tests.SharedTestData - import Test.HUnit.Base - import Data.Char - import qualified Data.Sequence as Seq - import qualified System.FilePath as F - import Control.Monad - import Data.List - - letterValues :: M.Map Char Int - letterValues = M.fromList $ [('A', 1), ('B',3), ('C', 3), ('D', 2), ('E', 1), ('F',4),('G',2),('H',4),('I',1),('J',8),('K',5),('L',1) ,('M',3),('N',1),('O',1),('P',3),('Q',10),('R', 1), ('S',1), ('T',1),('U',1),('V',4),('W',4),('X',8),('Y',4),('Z',10)] - - testDictionary :: IO (Either ScrabbleError Dictionary) - testDictionary = makeDictionary $ "Config" ++ [F.pathSeparator] ++ "engSet" ++ [F.pathSeparator] ++ "en.txt" - - letterBag :: IO LetterBag - letterBag = bagFromTiles $ map toTileBag tilesAsLetters - where - tilesAsLetters = "JEARVINENVO_NILLEWBKONUIEUWEAZBDESIAPAEOOURGOCDSNIADOAACAR_RMYELTUTYTEREOSITNIRFGPHAQLHESOIITXFDMETG" - - setupGame :: IO (Either ScrabbleError Game) - setupGame = - do - bag <- letterBag - dict <- testDictionary - return $ resultGame bag dict - where - resultGame bag dict = - do - dc <- dict - let [player1, player2,player3,player4] = map makePlayer ["a","b","c","d"] - makeGame (player1, player2, Just (player3, Just player4)) bag dc - - - - placeMap :: String -> Direction -> (Int, Int) -> M.Map Pos Tile - placeMap letters direction pos = M.fromList $ zip positions tiles - where - positions = - case direction of - Horizontal -> catMaybes $ takeWhile isJust <$> map posAt $ iterate (\(x,y) -> (x+1,y)) pos - Vertical -> catMaybes $ takeWhile isJust <$> map posAt $ iterate (\(x,y) -> (x, y + 1)) pos - - tiles = map toTilePlaced letters +import Control.Monad +import Data.Char +import Data.List +import qualified Data.List.NonEmpty as NE +import qualified Data.Map as M +import Data.Maybe +import qualified Data.Sequence as Seq +import qualified System.FilePath as F +import Test.HUnit.Base +import Tests.SharedTestData +import Wordify.Rules.Board +import Wordify.Rules.Dictionary +import Wordify.Rules.Game +import Wordify.Rules.LetterBag +import Wordify.Rules.Move +import Wordify.Rules.Player +import Wordify.Rules.Pos +import Wordify.Rules.ScrabbleError +import Wordify.Rules.Tile - toTileBag :: Char -> Tile - toTileBag lettr = - case lettr of - '_' -> Blank Nothing - x -> Letter x $ M.findWithDefault 0 x letterValues +letterValues :: M.Map String Int +letterValues = M.fromList $ [("A", 1), ("B", 3), ("C", 3), ("D", 2), ("E", 1), ("F", 4), ("G", 2), ("H", 4), ("I", 1), ("J", 8), ("K", 5), ("L", 1), ("M", 3), ("N", 1), ("O", 1), ("P", 3), ("Q", 10), ("R", 1), ("S", 1), ("T", 1), ("U", 1), ("V", 4), ("W", 4), ("X", 8), ("Y", 4), ("Z", 10)] - toTilePlaced :: Char -> Tile - toTilePlaced char - | isLower char = Blank $ Just (toUpper char) - | otherwise = toTileBag char +testDictionary :: IO (Either ScrabbleError Dictionary) +testDictionary = makeDictionary $ "Config" ++ [F.pathSeparator] ++ "engSet" ++ [F.pathSeparator] ++ "en.txt" - moves :: [Move] - moves = moveList +letterBag :: IO LetterBag +letterBag = bagFromTiles $ map toTileBag tilesAsLetters + where + tilesAsLetters = "JEARVINENVO_NILLEWBKONUIEUWEAZBDESIAPAEOOURGOCDSNIADOAACAR_RMYELTUTYTEREOSITNIRFGPHAQLHESOIITXFDMETG" - where - moveList = - map PlaceTiles [ - placeMap "RAVINE" Horizontal (8,8) - , placeMap "OVEl" Vertical (12,9) - , placeMap "W" Vertical (9,7) `M.union` placeMap "KE" Vertical (9,9) - , placeMap "N" Horizontal (11,9) - , placeMap "B" Horizontal (13,7) `M.union` placeMap "D" Horizontal (13,9) - , placeMap "NAI" Horizontal (9,12) - , placeMap "B" Horizontal (11,11) `M.union` placeMap "LLE" Horizontal (13,11) - , placeMap "WEE" Vertical (10,13) - , placeMap "JA" Vertical (15,9) `M.union` placeMap "GERS" Vertical (15,12) - , placeMap "CANOPI" Horizontal (4,15) `M.union` placeMap "D" Horizontal (11,15) - , placeMap "SONI" Vertical (4,11) - , placeMap "AUDIO" Vertical (3,10) - , placeMap "RAZeR" Vertical (5,8) - , placeMap "MULEY" Vertical (2,6) - , placeMap "ROOTY" Vertical (3,2) - , placeMap "ETUIS" Vertical (14,4) - , placeMap "RACING" Vertical (1,10) - , placeMap "HATP" Vertical (11,4) - , placeMap "HAES" Vertical (12,2) - , placeMap "DOUX" Vertical (15,1) - , placeMap "GEM" Vertical (13,1) - , placeMap "Q" Horizontal (4,9) `M.union` placeMap "T" Horizontal (6,9) - , placeMap "IO" Vertical (6,13) - , placeMap "FIT" Vertical (10,2) - ] +moves :: [Move] +moves = moveList + where + moveList = + map + PlaceTiles + [ placeMap "RAVINE" Horizontal (8, 8), + placeMap "OVEl" Vertical (12, 9), + placeMap "W" Vertical (9, 7) `M.union` placeMap "KE" Vertical (9, 9), + placeMap "N" Horizontal (11, 9), + placeMap "B" Horizontal (13, 7) `M.union` placeMap "D" Horizontal (13, 9), + placeMap "NAI" Horizontal (9, 12), + placeMap "B" Horizontal (11, 11) `M.union` placeMap "LLE" Horizontal (13, 11), + placeMap "WEE" Vertical (10, 13), + placeMap "JA" Vertical (15, 9) `M.union` placeMap "GERS" Vertical (15, 12), + placeMap "CANOPI" Horizontal (4, 15) `M.union` placeMap "D" Horizontal (11, 15), + placeMap "SONI" Vertical (4, 11), + placeMap "AUDIO" Vertical (3, 10), + placeMap "RAZeR" Vertical (5, 8), + placeMap "MULEY" Vertical (2, 6), + placeMap "ROOTY" Vertical (3, 2), + placeMap "ETUIS" Vertical (14, 4), + placeMap "RACING" Vertical (1, 10), + placeMap "HATP" Vertical (11, 4), + placeMap "HAES" Vertical (12, 2), + placeMap "DOUX" Vertical (15, 1), + placeMap "GEM" Vertical (13, 1), + placeMap "Q" Horizontal (4, 9) `M.union` placeMap "T" Horizontal (6, 9), + placeMap "IO" Vertical (6, 13), + placeMap "FIT" Vertical (10, 2) + ] +playThroughTest :: Assertion +playThroughTest = + do + game <- letterBag >>= setupGame + assertBool "Could not initialise game for test " $ isValid game - playThroughTest :: Assertion - playThroughTest = - do - game <- setupGame - assertBool "Could not initialise game for test " $ isValid game + let Right testGame = game + bag <- letterBag + let moveTransitions = restoreGame testGame $ NE.fromList $ moves - let Right testGame = game - bag <- letterBag - let moveTransitions = restoreGame testGame $ NE.fromList $ moves + case moveTransitions of + Left err -> + assertFailure $ "Unable to play through test game, error was: " ++ show err + Right transitions -> + do + let finalTransition = NE.last transitions + assertBool "Expect the game to have ended" $ isFinalTransition finalTransition - case moveTransitions of - Left err -> - assertFailure $ "Unable to play through test game, error was: " ++ show err - Right transitions -> - do - let finalTransition = NE.last transitions - assertBool "Expect the game to have ended" $ isFinalTransition finalTransition + let finalGame = newGame finalTransition - let finalGame = newGame finalTransition + assertEqual "Unexpected number of moves" (length moves) (moveNumber finalGame) - assertEqual "Unexpected number of moves" (length moves) (moveNumber finalGame) + assertEqual "Unexpected history for game" (History bag (Seq.fromList moves)) (history finalGame) - assertEqual "Unexpected history for game" (History bag (Seq.fromList moves)) (history finalGame) + let finalBoard = board finalGame - let finalBoard = board finalGame + let [finalPlayer1, finalPlayer2, finalPlayer3, finalPlayer4] = players finalGame - let [finalPlayer1, finalPlayer2, finalPlayer3, finalPlayer4] = players finalGame + assertEqual "Unexpected final score for player 1" (189 - 5) (score finalPlayer1) + assertEqual "Unexpected remaining tiles for player 1" [Letter "T" 1, Letter "F" 4] (tilesOnRack finalPlayer1) - assertEqual "Unexpected final score for player 1" (189 - 5) (score finalPlayer1) - assertEqual "Unexpected remaining tiles for player 1" [Letter 'T' 1, Letter 'F' 4] (tilesOnRack finalPlayer1) + assertEqual "Unexpected remaining tiles for player 2" [Letter "L" 1] (tilesOnRack finalPlayer2) + assertEqual "Unexpected final score for player 2" ((136 + 50) - 1) (score finalPlayer2) -- This player scored a bingo word + assertEqual "Unexpected remaining tiles for player 3" [Letter "E" 1] (tilesOnRack finalPlayer3) + assertEqual "Unexpected score for player 3" (110 - 1) (score finalPlayer3) - assertEqual "Unexpected remaining tiles for player 2" [Letter 'L' 1] (tilesOnRack finalPlayer2) - assertEqual "Unexpected final score for player 2" ( (136 + 50) - 1) (score finalPlayer2) -- This player scored a bingo word + assertEqual "Unexpected remaing tiles for player 4" [] (tilesOnRack finalPlayer4) + assertEqual "Unexpected score for winning player" (154 + 1 + 5 + 1) (score finalPlayer4) + where + isFinalTransition trans = + case trans of + GameFinished _ _ -> True + otherwise -> False - assertEqual "Unexpected remaining tiles for player 3" [Letter 'E' 1] (tilesOnRack finalPlayer3) - assertEqual "Unexpected score for player 3" (110 - 1) (score finalPlayer3) +gameEndsOnConsecutiveSkips :: Assertion +gameEndsOnConsecutiveSkips = + do + game <- letterBag >>= setupGame + -- 8 consecutive passes ends the game + let skipMoves = NE.fromList $ replicate 8 Pass + assertBool "Could not initialise game for test " $ isValid game - assertEqual "Unexpected remaing tiles for player 4" [] (tilesOnRack finalPlayer4) - assertEqual "Unexpected score for winning player" (154 + 1 + 5 + 1) (score finalPlayer4) - where - isFinalTransition trans = - case trans of - GameFinished _ _ -> True - otherwise -> False + let Right testGame = game + let transitions = restoreGame testGame skipMoves + let lastGame = fmap NE.last transitions + assertBool ("Unexpected failure when playing moves ") $ isValid lastGame - gameEndsOnConsecutiveSkips :: Assertion - gameEndsOnConsecutiveSkips = - do - game <- setupGame - -- 8 consecutive passes ends the game - let skipMoves = NE.fromList $ replicate 8 Pass - assertBool "Could not initialise game for test " $ isValid game + let Right finalTrans = lastGame - let Right testGame = game - let transitions = restoreGame testGame skipMoves - let lastGame = fmap NE.last transitions - assertBool ("Unexpected failure when playing moves ") $ isValid lastGame + case finalTrans of + GameFinished _ _ -> assertEqual "Unexpected move number" (moveNumber (newGame finalTrans)) 8 + otherwise -> assertFailure "Unexpected end state. Expected ' Game finished ' " - let Right finalTrans = lastGame +gameDoesNotEndOnNonConsecutiveSkips :: Assertion +gameDoesNotEndOnNonConsecutiveSkips = + do + game <- letterBag >>= setupGame + assertBool "Could not initialise game for test " $ isValid game + let Right testGame = game + let movesWithSkips = take 10 $ concat $ intersperse (replicate 4 Pass) $ splitEvery 4 moves + let transitions = restoreGame testGame $ NE.fromList movesWithSkips - case finalTrans of - GameFinished _ _ -> assertEqual "Unexpected move number" (moveNumber (newGame finalTrans)) 8 - otherwise -> assertFailure "Unexpected end state. Expected 'Game finished' " + assertBool "Unexpected error making moves" $ isValid transitions - gameDoesNotEndOnNonConsecutiveSkips :: Assertion - gameDoesNotEndOnNonConsecutiveSkips = - do - game <- setupGame - assertBool "Could not initialise game for test " $ isValid game - let Right testGame = game - let movesWithSkips = take 10 $ concat $ intersperse (replicate 4 Pass) $ splitEvery 4 moves - let transitions = restoreGame testGame $ NE.fromList movesWithSkips + let Right gameTransitions = transitions + let lastGame = newGame $ NE.last gameTransitions - assertBool "Unexpected error making moves" $ isValid transitions + assertEqual "Expected game to still be in progress" InProgress (gameStatus lastGame) + assertEqual "Unexpected player's move" ((10 `mod` 4) + 1) (playerNumber lastGame) + assertEqual "Unexpected current player" (fmap fst (optionalPlayers lastGame)) (Just (currentPlayer lastGame)) + where + splitEvery n = takeWhile (not . null) . unfoldr (Just . splitAt n) - let Right gameTransitions = transitions - let lastGame = newGame $ NE.last gameTransitions +exchangeMoveExchangesLetters :: Assertion +exchangeMoveExchangesLetters = + do + game <- letterBag >>= setupGame + assertBool "Could not initialise game for test " $ isValid game + let Right testGame = game + let firstPlayer = player1 testGame + let playerTiles = tilesOnRack firstPlayer + let move = Exchange playerTiles + let outcome = makeMove testGame move - assertEqual "Expected game to still be in progress" InProgress (gameStatus lastGame) - assertEqual "Unexpected player's move" ((10 `mod` 4) + 1) (playerNumber lastGame) - assertEqual "Unexpected current player" (fmap fst (optionalPlayers lastGame)) ( Just (currentPlayer lastGame)) + assertBool ("Expected move to be successful. ") $ isValid outcome + let Right transition = outcome - where - splitEvery n = takeWhile (not . null) . unfoldr (Just . splitAt n) + let nextGame = newGame transition + let newPlayer1 = player1 nextGame - exchangeMoveExchangesLetters :: Assertion - exchangeMoveExchangesLetters = + case transition of + ExchangeTransition game playerBefore playerAfter -> do - game <- setupGame - assertBool "Could not initialise game for test " $ isValid game - let Right testGame = game - let firstPlayer = player1 testGame - let playerTiles = tilesOnRack firstPlayer - let move = Exchange playerTiles - let outcome = makeMove testGame move - - assertBool ("Expected move to be successful. ") $ isValid outcome - let Right transition = outcome - - let nextGame = newGame transition - let newPlayer1 = player1 nextGame + assertEqual "playerBefore in the transition should be the player before making the move" (firstPlayer) playerBefore + assertEqual "playerAfter in the transition should be the player after making the move" (newPlayer1) playerAfter + assertBool ("Player 1 should have new letters on their rack. Player 1 was: " ++ (show newPlayer1)) (not $ firstPlayer == newPlayer1) - case transition of - ExchangeTransition game playerBefore playerAfter -> - do - assertEqual "playerBefore in the transition should be the player before making the move" (firstPlayer) playerBefore - assertEqual "playerAfter in the transition should be the player after making the move" (newPlayer1) playerAfter + assertEqual "Game has transitioned to the next player " (currentPlayer nextGame) (player2 testGame) - assertBool ("Player 1 should have new letters on their rack. Player 1 was: " ++ (show newPlayer1)) (not $ firstPlayer == newPlayer1) + assertBool "Player number and move number incremented" $ (playerNumber nextGame == 2) && (moveNumber nextGame) == 2 - assertEqual "Game has transitioned to the next player " (currentPlayer nextGame) (player2 testGame) + let originalLetterBag = bag testGame + let exchangedLetterBag = fmap snd (exchangeLetters originalLetterBag playerTiles) - assertBool "Player number and move number incremented" $ (playerNumber nextGame == 2) && (moveNumber nextGame) == 2 + assertEqual "The letter bag for the game transition is as expected " exchangedLetterBag (Just $ bag nextGame) - let originalLetterBag = bag testGame - let exchangedLetterBag = fmap snd (exchangeLetters originalLetterBag playerTiles) +playerInMoveTransitionIsAsExpected :: Assertion +playerInMoveTransitionIsAsExpected = + do + game <- letterBag >>= setupGame + assertBool "Could not initialise game for test " $ isValid game + let Right testGame = game - assertEqual "The letter bag for the game transition is as expected " exchangedLetterBag (Just $ bag nextGame) + let move = head moves + let outcome = makeMove testGame move - playerInMoveTransitionIsAsExpected :: Assertion - playerInMoveTransitionIsAsExpected = + case outcome of + Right (MoveTransition player game formedwords) -> do - game <- setupGame - assertBool "Could not initialise game for test " $ isValid game - let Right testGame = game - - let move = head moves - let outcome = makeMove testGame move - - case outcome of - Right (MoveTransition player game formedwords) -> - do - assertEqual "Player should be the new state of the player in the game " (player1 game) player - otherwise -> assertFailure "Failed to set up test correctly." + assertEqual "Player should be the new state of the player in the game " (player1 game) player + otherwise -> assertFailure "Failed to set up test correctly." diff --git a/test/Tests/Instances.hs b/test/Tests/Instances.hs --- a/test/Tests/Instances.hs +++ b/test/Tests/Instances.hs @@ -1,50 +1,61 @@ module Tests.Instances where - import Wordify.Rules.Tile - import Test.QuickCheck (Arbitrary, arbitrary, listOf, (==>), sized, oneof, choose, Gen, elements) - import Wordify.Rules.LetterBag - import Wordify.Rules.Pos - import Data.Char - import Wordify.Rules.Pos.Internal - import Wordify.Rules.Square - import Data.Map - import Wordify.Rules.Board - import Wordify.Rules.Board.Internal - import System.Random - import Wordify.Rules.LetterBag.Internal +import Data.Char +import Data.Map +import System.Random +import Test.QuickCheck (Arbitrary, Gen, arbitrary, choose, elements, listOf, oneof, sized, (==>)) +import Wordify.Rules.Board +import Wordify.Rules.Board.Internal +import Wordify.Rules.LetterBag +import Wordify.Rules.LetterBag.Internal +import Wordify.Rules.Pos +import Wordify.Rules.Pos.Internal +import Wordify.Rules.Square +import Wordify.Rules.Tile - instance Arbitrary Tile where - arbitrary = do - chr <- arbitrary :: Gen Char - value <- arbitrary :: Gen Int - tile <- elements [Letter chr value, Blank Nothing] - return tile +instance Arbitrary Tile where + arbitrary = do + chr <- arbitrary :: Gen String + value <- arbitrary :: Gen Int + tile <- elements [Letter chr value, Blank Nothing] + return tile - instance Arbitrary LetterBag where - arbitrary = do - tiles <- listOf (arbitrary :: Gen Tile) - seed <- arbitrary :: Gen Int - let generator = mkStdGen seed - return $ makeBagUsingGenerator tiles generator +instance Arbitrary LetterBag where + arbitrary = do + tiles <- listOf (arbitrary :: Gen Tile) + seed <- arbitrary :: Gen Int + let generator = mkStdGen seed + return $ makeBagUsingGenerator tiles generator - instance Arbitrary Pos where - arbitrary = do - x <- choose (1,15) - y <- choose (1,15) - let gridCo = [chr (x + 64)] ++ (show y) - return $ Pos x y gridCo +instance Arbitrary Pos where + arbitrary = do + x <- choose (1, 15) + y <- choose (1, 15) + let gridCo = [chr (x + 64)] ++ (show y) + return $ Pos x y gridCo - instance Arbitrary Square where - arbitrary = do - tile <- arbitrary :: Gen Tile - square <- elements [Normal (Just tile), Normal Nothing, DoubleLetter (Just tile), DoubleLetter Nothing, DoubleWord (Just tile), - DoubleWord Nothing, TripleLetter (Just tile), TripleLetter Nothing, TripleWord (Just tile), TripleWord Nothing] - return square +instance Arbitrary Square where + arbitrary = do + tile <- arbitrary :: Gen Tile + square <- + elements + [ Normal (Just tile), + Normal Nothing, + DoubleLetter (Just tile), + DoubleLetter Nothing, + DoubleWord (Just tile), + DoubleWord Nothing, + TripleLetter (Just tile), + TripleLetter Nothing, + TripleWord (Just tile), + TripleWord Nothing + ] + return square - instance Arbitrary Board where - arbitrary = do - let Board squares = emptyBoard - let originalSquares = toList squares - positions <- listOf (arbitrary :: Gen Pos) - squares <- listOf (arbitrary :: Gen Square) - return $ Board $ fromList $ originalSquares ++ (zip positions squares) +instance Arbitrary Board where + arbitrary = do + let Board squares = emptyBoard + let originalSquares = toList squares + positions <- listOf (arbitrary :: Gen Pos) + squares <- listOf (arbitrary :: Gen Square) + return $ Board $ fromList $ originalSquares ++ (zip positions squares) diff --git a/test/Tests/Internationalisation/Spanish/LetterBagTest.hs b/test/Tests/Internationalisation/Spanish/LetterBagTest.hs new file mode 100644 --- /dev/null +++ b/test/Tests/Internationalisation/Spanish/LetterBagTest.hs @@ -0,0 +1,71 @@ +module Tests.Internationalisation.Spanish.LetterBagTest (makeSpanishBagTestSuccess) where + +import Test.HUnit +import Test.HUnit.Base as H +import Wordify.Rules.LetterBag +import Wordify.Rules.LetterBag.Internal +import qualified Data.Map as M +import Wordify.Rules.Tile +import Data.Maybe(fromMaybe) + +spanishBagFilePath = "Config/spanishSet/bag.txt" + +countLetters :: [Tile] -> M.Map String Int +countLetters = foldr addTileCount M.empty + where + addTileCount :: Tile -> M.Map String Int -> M.Map String Int + addTileCount tile = M.insertWith (+) (fromMaybe "_" (tileString tile)) 1 + +makeSpanishBagTestSuccess :: Assertion +makeSpanishBagTestSuccess = do + letterBagResult <- makeBag spanishBagFilePath + + let expectedTileQuantities = + [ ("A", 11) + , ("B", 3) + , ("C", 4) + , ("D", 4) + , ("E", 11) + , ("F", 2) + , ("G", 2) + , ("H", 2) + , ("I", 6) + , ("J", 2) + , ("K", 1) + , ("L", 4) + , ("LL", 1) + , ("M", 3) + , ("N", 5) + , ("O", 8) + , ("P", 2) + , ("Q", 1) + , ("R", 4) + , ("RR", 1) + , ("S", 7) + , ("T", 4) + , ("U", 6) + , ("V", 2) + , ("W", 1) + , ("X", 1) + , ("Y", 1) + , ("Z", 1) + , ("_", 2) + , ("Ñ", 1) + ] + + + case letterBagResult of + Left err -> H.assertFailure $ "makeBag returned an error " ++ show err + Right letterBag -> do + assertEqual "Expected 28 different valid letters in the bag" (length (validLetters letterBag)) 29 + + let takeResult = takeLetters letterBag 103 + + case takeResult of + Nothing -> H.assertFailure $ "takeLetters returned Nothing, Expected Just" + Just (tiles, newBag) -> do + assertEqual "Expected 103 tiles to be taken from the bag" (length tiles) 103 + assertEqual "Expect no letters to left in the bag" (bagSize newBag) 0 + let actualTileQuantities = M.toList (countLetters tiles) + assertEqual "Expected the tiles" expectedTileQuantities actualTileQuantities + diff --git a/test/Tests/Internationalisation/Spanish/MoveTest.hs b/test/Tests/Internationalisation/Spanish/MoveTest.hs new file mode 100644 --- /dev/null +++ b/test/Tests/Internationalisation/Spanish/MoveTest.hs @@ -0,0 +1,67 @@ +module Tests.Internationalisation.Spanish.MoveTest (playSpanishMoveTest) where + + import Wordify.Rules.LetterBag + import Wordify.Rules.ScrabbleError (ScrabbleError) + import Wordify.Rules.Dictionary (Dictionary, makeDictionary) + import qualified System.FilePath as F + import Wordify.Rules.Game (Game, makeGame) + import Test.HUnit (Assertion) + import qualified Data.Map as M + import Wordify.Rules.Move (GameTransition(..), makeMove, Move (PlaceTiles)) + import Test.HUnit.Base (assertFailure) + import Wordify.Rules.Tile (Tile(Letter, Blank)) + import Wordify.Rules.Pos (starPos, rightPositions) + import Wordify.Rules.Player(makePlayer) + + testSpanishDictionary :: IO (Either ScrabbleError Dictionary) + testSpanishDictionary = makeDictionary $ "Config" ++ [F.pathSeparator] ++ "spanishSet" ++ [F.pathSeparator] ++ "dictionary.txt" + + testSpanishLetterBag :: IO LetterBag + testSpanishLetterBag = bagFromTiles tiles + where + tiles = [Letter "O" 1,Letter "Ñ" 8,Letter "S" 1, Letter "A" 1, Letter "W" 8,Letter "J" 6,Letter "L" 1,Letter "D" 2,Letter "S" 1,Letter "L" 1, + Letter "F" 4,Letter "U" 1,Letter "R" 1,Letter "L" 1,Letter "C" 2,Letter "I" 1,Letter "T" 1, + Letter "B" 3,Letter "K" 8,Blank Nothing,Letter "Z" 10,Letter "C" 2,Letter "E" 1,Letter "V" 4,Letter "I" 1, + Letter "U" 1,Letter "G" 2,Letter "A" 1,Letter "I" 1,Letter "M" 3,Letter "O" 1,Letter "H" 4, + Letter "O" 1,Letter "M" 3,Letter "L" 1,Letter "Q" 8,Letter "S" 1,Letter "M" 3,Blank Nothing,Letter "T" 1, + Letter "S" 1,Letter "X" 8,Letter "R" 1,Letter "E" 1,Letter "B" 3,Letter "E" 1,Letter "V" 4,Letter "O" 1, + Letter "U" 1,Letter "R" 1,Letter "A" 1,Letter "A" 1,Letter "G" 2,Letter "R" 1,Letter "C" 2,Letter "E" 1,Letter "A" 1, + Letter "A" 1,Letter "S" 1,Letter "B" 3,Letter "P" 3,Letter "O" 1,Letter "N" 1,Letter "I" 1,Letter "E" 1,Letter "A" 1, + Letter "E" 1,Letter "Y" 4,Letter "A" 1,Letter "I" 1,Letter "O" 1,Letter "J" 6, + Letter "A" 1,Letter "I" 1,Letter "E" 1,Letter "D" 2,Letter "LL" 8,Letter "C" 2,Letter "F" 4,Letter "O" 1, + Letter "E" 1,Letter "N" 1,Letter "T" 1,Letter "D" 2,Letter "E" 1,Letter "E" 1,Letter "U" 1,Letter "T" 1, + Letter "E" 1,Letter "U" 1,Letter "P" 3,Letter "N" 1,Letter "S" 1,Letter "O" 1,Letter "S" 1,Letter "N" 1, + Letter "U" 1,Letter "RR" 8,Letter "A" 1,Letter "D" 2,Letter "N" 1,Letter "H" 4,Letter "A" 1] + + testGame :: IO (Either ScrabbleError Game) + testGame = do + letterBag <- testSpanishLetterBag + dictionaryResult <- testSpanishDictionary + + case dictionaryResult of + Left err -> return $ Left err + Right dict -> pure $ setupGame letterBag dict + + where + setupGame :: LetterBag -> Dictionary -> Either ScrabbleError Game + setupGame bag dict = makeGame (player1, player2, Nothing) bag dict + where + player1 = makePlayer "player 1" + player2 = makePlayer "player 2" + + playSpanishMoveTest :: Assertion + playSpanishMoveTest = do + gameResult <- testGame + case gameResult of + Left err -> assertFailure $ "Failed to set up game: " ++ show err + Right game -> do + let positions = rightPositions starPos 4 + let tiles = [Letter "A" 1, Letter "Ñ" 8, Letter "O" 1, Letter "S" 1] + let moveMap = M.fromList $ zip positions tiles + let move = PlaceTiles moveMap + let result = makeMove game move + + case result of + Left err -> assertFailure $ "Failed to make move: " ++ show err + Right (MoveTransition _ _ _) -> return () + Right _ -> assertFailure "Unexpected result type" diff --git a/test/Tests/LetterBagTest.hs b/test/Tests/LetterBagTest.hs --- a/test/Tests/LetterBagTest.hs +++ b/test/Tests/LetterBagTest.hs @@ -1,118 +1,114 @@ module Tests.LetterBagTest where - import Test.QuickCheck (Property, quickCheck) - import Test.QuickCheck.Monadic as Q (assert, monadicIO, pick, pre, run) - import Wordify.Rules.LetterBag - import Wordify.Rules.LetterBag.Internal - import Wordify.Rules.Tile - import Tests.Utils - import System.IO (hPutStr, hFlush, hPutStrLn, hClose) - import Test.HUnit.Base as H - import Wordify.Rules.ScrabbleError - import Data.Map - import Data.Maybe - import qualified Data.List as L - import Tests.Instances - - bagFromTilesProperty :: [Tile] -> Property - bagFromTilesProperty inputTiles = monadicIO $ - do - bag <- run $ bagFromTiles inputTiles - let LetterBag resultingTiles numTiles generator validLetters = bag - Q.assert $ numTiles == (length inputTiles) && resultingTiles == inputTiles - - shuffleProperty :: LetterBag -> Bool - shuffleProperty bag = - let shuffled = shuffleBag bag - in if (bagSize bag < 10) then sameTiles bag shuffled else bagIsShuffled bag shuffled && sameTiles bag shuffled - - where - sameTiles originalBag shuffledBag = bagSize originalBag == (length $ (tiles originalBag) `L.intersect` (tiles shuffledBag)) - bagIsShuffled originalBag shuffledBag = not $ originalBag == shuffledBag - - shuffleTwiceProperty :: LetterBag -> Bool - shuffleTwiceProperty bag = if (bagSize bag < 10) then True else not $ bag1 == bag2 && bagSize bag1 == bagSize bag2 - where - bag1 = shuffleBag bag - bag2 = shuffleBag bag1 +import qualified Data.List as L +import Data.Map +import Data.Maybe +import System.IO (hClose, hFlush, hPutStr, hPutStrLn) +import Test.HUnit.Base as H +import Test.QuickCheck (Property, quickCheck) +import Test.QuickCheck.Monadic as Q (assert, monadicIO, pick, pre, run) +import Tests.Instances +import Tests.Utils +import Wordify.Rules.LetterBag +import Wordify.Rules.LetterBag.Internal +import Wordify.Rules.ScrabbleError +import Wordify.Rules.Tile - takeLettersProperty :: LetterBag -> Int -> Bool - takeLettersProperty letterBag numTake = - if (originalBagSize < numTake) then takeLetters letterBag numTake == Nothing - else - takeLetters letterBag numTake == Just (expectedTiles, expectedBag) - where - LetterBag originalBagTiles originalBagSize gen validLetters = letterBag - expectedTiles = L.take numTake originalBagTiles - expectedBag = LetterBag (L.drop numTake originalBagTiles) (originalBagSize - numTake) gen validLetters +bagFromTilesProperty :: [Tile] -> Property +bagFromTilesProperty inputTiles = monadicIO $ + do + bag <- run $ bagFromTiles inputTiles + let LetterBag resultingTiles numTiles generator validLetters = bag + Q.assert $ numTiles == (length inputTiles) && resultingTiles == inputTiles - exchangeLettersProperty :: LetterBag -> [Tile] -> Bool - exchangeLettersProperty letterBag toExchange = - let exchangeResult = exchangeLetters letterBag toExchange - in case exchangeResult of - Nothing -> originalNumTiles == 0 - Just (given, LetterBag newTiles newNumTiles newGenerator validLetters) -> - (originalNumTiles == newNumTiles) - && length given == length toExchange - && forAll (\tile -> (getCount tile newTileCounts) == (getCount tile originalTileCounts) + (getCount tile exchangedCounts) - (getCount tile givenCounts) ) allTiles +shuffleProperty :: LetterBag -> Bool +shuffleProperty bag = + let shuffled = shuffleBag bag + in if (bagSize bag < 10) then sameTiles bag shuffled else bagIsShuffled bag shuffled && sameTiles bag shuffled + where + sameTiles originalBag shuffledBag = bagSize originalBag == (length $ (tiles originalBag) `L.intersect` (tiles shuffledBag)) + bagIsShuffled originalBag shuffledBag = not $ originalBag == shuffledBag - where - allTiles = given ++ newTiles ++ originalTiles - givenCounts = countMap given - newTileCounts = countMap newTiles - originalTileCounts = countMap originalTiles - exchangedCounts = countMap toExchange - countMap xs = fromListWith (+) [(x, 1) | x <- xs] - getCount key m = findWithDefault 0 key m +shuffleTwiceProperty :: LetterBag -> Bool +shuffleTwiceProperty bag = if (bagSize bag < 10) then True else not $ bag1 == bag2 && bagSize bag1 == bagSize bag2 + where + bag1 = shuffleBag bag + bag2 = shuffleBag bag1 - forAll condition list = L.null $ L.filter (not . condition) list - where - LetterBag originalTiles originalNumTiles generator validLetters = letterBag +takeLettersProperty :: LetterBag -> Int -> Bool +takeLettersProperty letterBag numTake = + if (originalBagSize < numTake) + then takeLetters letterBag numTake == Nothing + else takeLetters letterBag numTake == Just (expectedTiles, expectedBag) + where + LetterBag originalBagTiles originalBagSize gen validLetters = letterBag + expectedTiles = L.take numTake originalBagTiles + expectedBag = LetterBag (L.drop numTake originalBagTiles) (originalBagSize - numTake) gen validLetters - makeBagInvalidlyFormattedBag :: Assertion - makeBagInvalidlyFormattedBag = - withTempFile $ \ filePath handle -> do - let invalidStr = "A 2 2 3 4" -- Erroneous extra number - hPutStrLn handle invalidStr - hFlush handle - hClose handle - letterBag <- makeBag filePath +exchangeLettersProperty :: LetterBag -> [Tile] -> Bool +exchangeLettersProperty letterBag toExchange = + let exchangeResult = exchangeLetters letterBag toExchange + in case exchangeResult of + Nothing -> originalNumTiles == 0 + Just (given, LetterBag newTiles newNumTiles newGenerator validLetters) -> + (originalNumTiles == newNumTiles) + && length given == length toExchange + && forAll (\tile -> (getCount tile newTileCounts) == (getCount tile originalTileCounts) + (getCount tile exchangedCounts) - (getCount tile givenCounts)) allTiles + where + allTiles = given ++ newTiles ++ originalTiles + givenCounts = countMap given + newTileCounts = countMap newTiles + originalTileCounts = countMap originalTiles + exchangedCounts = countMap toExchange + countMap xs = fromListWith (+) [(x, 1) | x <- xs] + getCount key m = findWithDefault 0 key m - case letterBag of - Left (MalformedLetterBagFile _) -> return () - x -> H.assertFailure $ "Input with invalidly formatted bag unexpectedly succeeded: " ++ show x + forAll condition list = L.null $ L.filter (not . condition) list + where + LetterBag originalTiles originalNumTiles generator validLetters = letterBag - makeBagTestSuccess :: Assertion - makeBagTestSuccess = - withTempFile $ \ filePath handle -> do - let letters = ['A' .. ] - let values = [1 .. 5] - let distributions = [1 .. 5] - let inputLines = unlines $ zipWith3 (\letter value distribution -> L.intersperse ' ' $ letter : (show value) ++ (show distribution)) letters values distributions - hPutStrLn handle "_ 2" -- 2 Blank tiles - hPutStr handle inputLines - hFlush handle - hClose handle - letterBag <- makeBag filePath +makeBagInvalidlyFormattedBag :: Assertion +makeBagInvalidlyFormattedBag = + withTempFile $ \filePath handle -> do + let invalidStr = "A 2 2 3 4" -- Erroneous extra number + hPutStrLn handle invalidStr + hFlush handle + hClose handle + letterBag <- makeBag filePath - case letterBag of - Left _ -> H.assertFailure "makeBag returned an error" - Right (LetterBag tiles numTiles generator validLetters) -> do - let expectedLetters = zipWith3 (\letter value distribution -> replicate distribution $ Letter letter value ) letters values distributions - let expectedBlanks = replicate 2 $ Blank Nothing - let expectedTiles = concat $ expectedBlanks : expectedLetters + case letterBag of + Left (MalformedLetterBagFile _ _) -> return () + x -> H.assertFailure $ "Input with invalidly formatted bag unexpectedly succeeded: " ++ show x - H.assertBool "Letter bag contains expected letters" $ expectedTiles `L.intersect` tiles == expectedTiles - H.assertBool "Letter bag contains expected number of letters" $ (length expectedTiles) == (length tiles) +makeBagTestSuccess :: Assertion +makeBagTestSuccess = + withTempFile $ \filePath handle -> do + let letters = L.map (\x -> [x]) ['A' ..] + let values = [1 .. 5] + let distributions = [1 .. 5] + let inputLines = unlines $ zipWith3 (\tileLetters value distribution -> L.intersperse ' ' $ tileLetters ++ (show value) ++ (show distribution)) letters values distributions + hPutStrLn handle "_ 2" -- 2 Blank tiles + hPutStr handle inputLines + hFlush handle + hClose handle + letterBag <- makeBag filePath - makeBagInvalidPath :: Assertion - makeBagInvalidPath = - do - letterBag <- makeBag "this is an invalid file path" - case letterBag of - Left (LetterBagFileNotOpenable _) -> return () - _ -> H.assertFailure "Unexpected success" + case letterBag of + Left _ -> H.assertFailure "makeBag returned an error" + Right (LetterBag tiles numTiles generator validLetters) -> do + let expectedLetters = zipWith3 (\letter value distribution -> replicate distribution $ Letter letter value) letters values distributions + let expectedBlanks = replicate 2 $ Blank Nothing + let expectedTiles = concat $ expectedBlanks : expectedLetters - return () + H.assertBool "Letter bag contains expected letters" $ expectedTiles `L.intersect` tiles == expectedTiles + H.assertBool "Letter bag contains expected number of letters" $ (length expectedTiles) == (length tiles) +makeBagInvalidPath :: Assertion +makeBagInvalidPath = + do + letterBag <- makeBag "this is an invalid file path" + case letterBag of + Left (LetterBagFileNotOpenable _) -> return () + _ -> H.assertFailure "Unexpected success" + return () diff --git a/test/Tests/MoveTest.hs b/test/Tests/MoveTest.hs new file mode 100644 --- /dev/null +++ b/test/Tests/MoveTest.hs @@ -0,0 +1,69 @@ +module Tests.MoveTest (movePlayedWithEmptyBlankTile, movePlayedWithInvalidBlankTileAssignment) where + +import Control.Error +import Data.Char +import qualified Data.Map as M +import qualified System.FilePath as F +import Test.HUnit (Assertion) +import Test.HUnit.Base +import Tests.SharedTestData (isValid, placeMap, setupGame, toTileBag) +import Wordify.Rules.Dictionary +import Wordify.Rules.Game +import Wordify.Rules.LetterBag +import Wordify.Rules.Move (Move (PlaceTiles), makeMove) +import Wordify.Rules.Player +import Wordify.Rules.Pos +import Wordify.Rules.Pos.Internal +import Wordify.Rules.ScrabbleError (ScrabbleError (CannotPlaceBlankWithoutLetter, NotAssignableToBlank)) +import Wordify.Rules.Tile + +letterBag :: IO LetterBag +letterBag = bagFromTiles $ map toTileBag tilesAsLetters + where + tilesAsLetters = "_JEARVINENVONILLEWBKONUIEUWEAZBDESIAPAEOOURGOCDSNIADOAACAR_RMYELTUTYTEREOSITNIRFGPHAQLHESOIITXFDMETG" + +movePlayedWithEmptyBlankTile :: Assertion +movePlayedWithEmptyBlankTile = do + bag <- letterBag + game <- setupGame bag + assertBool "Could not initialise game for test " $ isValid game + + let Right testGame = game + + let move = PlaceTiles $ placeMap "_EAR" Horizontal (8, 8) + + let moveResult = makeMove testGame move + assertBool "Expected move not to be successful. " $ (not . isValid) moveResult + let Left err = moveResult + + assertEqual "Unexpected result for placing tiles which do not intersect the star on the first move" (CannotPlaceBlankWithoutLetter (Pos 8 8 "H8")) err + +movePlayedWithInvalidBlankTileAssignment :: Assertion +movePlayedWithInvalidBlankTileAssignment = do + bag <- letterBag + game <- setupGame bag + assertBool "Could not initialise game for test " $ isValid game + + let Right testGame = game + + let move = PlaceTiles $ M.fromList [((Pos 8 8 "H8"), Blank (Just "😎"))] + + let moveResult = makeMove testGame move + assertBool "Expected move not to be successful. " $ (not . isValid) moveResult + let Left err = moveResult + + let validTiles = map (: []) ['A' .. 'Z'] + assertEqual "Unexpected result for placing blank tile with invalid value" (NotAssignableToBlank (Pos 8 8 "H8") "😎" validTiles) err + +movePlayedWithValidBlankTileAssignment :: Assertion +movePlayedWithValidBlankTileAssignment = do + bag <- letterBag + game <- setupGame bag + assertBool "Could not initialise game for test " $ isValid game + + let Right testGame = game + + let move = PlaceTiles $ M.fromList [(Pos 8 8 "H8", Blank (Just "H")), (Pos 8 9 "H9", Letter "I" 1)] + + let moveResult = makeMove testGame move + assertBool "Expected move to be successful. " $ isValid moveResult diff --git a/test/Tests/Regressions.hs b/test/Tests/Regressions.hs --- a/test/Tests/Regressions.hs +++ b/test/Tests/Regressions.hs @@ -1,79 +1,89 @@ module Tests.Regressions - ( - tests - ) where + ( tests, + ) +where import qualified Test.Framework as F import qualified Test.Framework.Providers.HUnit as F - import Tests.BoardTest -import Tests.LetterBagTest import Tests.FormedWordsTest import Tests.FullGameTest +import Tests.Internationalisation.Spanish.LetterBagTest (makeSpanishBagTestSuccess) +import Tests.LetterBagTest +import Tests.MoveTest +import Tests.Internationalisation.Spanish.MoveTest (playSpanishMoveTest) tests :: F.Test -tests = F.testGroup "Regressions" [ - - F.testGroup "LetterBag" - [ - F.testCase "Letter bag returns error when makeBag file is invalidly formatted" makeBagInvalidlyFormattedBag, - F.testCase "Letter bag from file parsed correctly" makeBagTestSuccess, - F.testCase "Letter bag returns error when makeBag file path invalid" makeBagInvalidPath +tests = + F.testGroup + "Regressions" + [ F.testGroup + "LetterBag" + [ F.testCase "Letter bag returns error when makeBag file is invalidly formatted" makeBagInvalidlyFormattedBag, + F.testCase "Letter bag from file parsed correctly" makeBagTestSuccess, + F.testCase "Letter bag returns error when makeBag file path invalid" makeBagInvalidPath ], - - F.testGroup "Board" - [ - F.testCase "allSquares function behaves as expected" allSquaresTest, - F.testCase "Board letters left function behaves as expected" lettersLeftTest, - F.testCase "Board letters right function behaves as expected" lettersRightTest, - F.testCase "Board letters above function behaves as expected" lettersAboveTest, - F.testCase "Board letters below function behaves as expected" lettersBelowTest, - F.testCase "Tiles can not be placed on empty squares" tilesPlacedConsecutivelyTest, - F.testCase "occupiedSquareAt function behaves as expected" occupiedSquareAtTest, - F.testCase "occupiedSquareAt function behaves as expected where the square is unoccupied" occupiedSquareAtUnoccupiedTest, - F.testCase "unoccupiedSquareAt function behaves as expected where the square is unoccupied" unoccupiedSquareAtTest, - F.testCase "unoccupiedSquareAt function behaves as expected where the square is occupied" unoccupiedSquareAtTestOccupied, - F.testCase "Bonus squres and normal squares are where they are expected on the board" boardCorrectlyFormed + F.testGroup + "Board" + [ F.testCase "allSquares function behaves as expected" allSquaresTest, + F.testCase "Board letters left function behaves as expected" lettersLeftTest, + F.testCase "Board letters right function behaves as expected" lettersRightTest, + F.testCase "Board letters above function behaves as expected" lettersAboveTest, + F.testCase "Board letters below function behaves as expected" lettersBelowTest, + F.testCase "Tiles can not be placed on empty squares" tilesPlacedConsecutivelyTest, + F.testCase "occupiedSquareAt function behaves as expected" occupiedSquareAtTest, + F.testCase "occupiedSquareAt function behaves as expected where the square is unoccupied" occupiedSquareAtUnoccupiedTest, + F.testCase "unoccupiedSquareAt function behaves as expected where the square is unoccupied" unoccupiedSquareAtTest, + F.testCase "unoccupiedSquareAt function behaves as expected where the square is occupied" unoccupiedSquareAtTestOccupied, + F.testCase "Bonus squres and normal squares are where they are expected on the board" boardCorrectlyFormed ], - - F.testGroup "FormedWord" - [ - F.testCase "Where placed tiles are prepended to other tiles on the board, they can be pretty printed" testPrettyPrintIntersectionPrepend, - F.testCase "Where placed tiles are appended to other tiles on the board, they can be pretty printed" testPrettyPrintIntersectionAppend, - F.testCase "Where placed tiles are placed in the middle of existing tiles the board, they can be pretty printed" testPrettyPrintThroughPlacedLetters, - F.testCase "Words can be attached to the left of an existing word" attachLeftWord, - F.testCase "Words can be attached to the right of an existing word" attachRightWord, - F.testCase "Words can be attached to the top of an existing word" attachWordBelow, - F.testCase "Words can be attached to the bottom of an existing word" attachAboveWord, - F.testCase "Words can be attached to the top and bottom of an existing word" attachAboveAndBelow, - F.testCase "Words can be attached to the left and right of an existing word" attachLeftAndRight, - F.testCase "Words can be attached with adjacent words starting from the left" adjacentWordsLeft, - F.testCase "Words can be attached with adjacent words starting from the right" adjacentWordsRight, - F.testCase "Words can be attached with adjacent words starting from above" adjacentWordsAbove, - F.testCase "Words can be attached with adjacent words starting from above" adjacentWordsBelow, - F.testCase "Words can be formed from one letter starting from above" placedOneTileAbove, - F.testCase "Words can be formed from one letter placed below" placedOneTileBelow, - F.testCase "Words can be formed from one letter placed to the right of a word" placedOneTileRight, - F.testCase "Words can be formed from one letter placed to the left of a word" placedOneTileLeft, - F.testCase "Words can be formed by 'brushing' an existing word from the top" passesAbove, - F.testCase "Words can be formed by 'brushing' an existing word from the bottom" passesBelow, - F.testCase "Words formed can pass through two existing words" passesThroughTwoWords, - F.testCase "A first word is valid if it passes through the star" firstWordThroughStar, - F.testCase "A first word is invalid if it does not pass through the star" firstWordNotThroughStar, - F.testCase "If a word does not connect with any words on the board, the expected error is returned" doesNotConnectWithWord, - F.testCase "If a word forms a horizontal line, with one placed tile in the middle not in the line, the expected error is returned" nonContigiousHorizontal, - F.testCase "If a word forms a vertical line, with one placed tile in the middle not in the line, the expected error is returned" nonContigiousVertical, - F.testCase "Cannot placed a blank tile without giving it a letter" placeBlankNothing, - F.testCase "Cannot placed a tile on a square which is already occupied" placeOnOccupiedSquare, - F.testCase "Blah" testPrettyPrintIntersectionFirstWord + F.testGroup + "FormedWord" + [ F.testCase "Where placed tiles are prepended to other tiles on the board, they can be pretty printed" testPrettyPrintIntersectionPrepend, + F.testCase "Where placed tiles are appended to other tiles on the board, they can be pretty printed" testPrettyPrintIntersectionAppend, + F.testCase "Where placed tiles are placed in the middle of existing tiles the board, they can be pretty printed" testPrettyPrintThroughPlacedLetters, + F.testCase "Words can be attached to the left of an existing word" attachLeftWord, + F.testCase "Words can be attached to the right of an existing word" attachRightWord, + F.testCase "Words can be attached to the top of an existing word" attachWordBelow, + F.testCase "Words can be attached to the bottom of an existing word" attachAboveWord, + F.testCase "Words can be attached to the top and bottom of an existing word" attachAboveAndBelow, + F.testCase "Words can be attached to the left and right of an existing word" attachLeftAndRight, + F.testCase "Words can be attached with adjacent words starting from the left" adjacentWordsLeft, + F.testCase "Words can be attached with adjacent words starting from the right" adjacentWordsRight, + F.testCase "Words can be attached with adjacent words starting from above" adjacentWordsAbove, + F.testCase "Words can be attached with adjacent words starting from above" adjacentWordsBelow, + F.testCase "Words can be formed from one letter starting from above" placedOneTileAbove, + F.testCase "Words can be formed from one letter placed below" placedOneTileBelow, + F.testCase "Words can be formed from one letter placed to the right of a word" placedOneTileRight, + F.testCase "Words can be formed from one letter placed to the left of a word" placedOneTileLeft, + F.testCase "Words can be formed by 'brushing' an existing word from the top" passesAbove, + F.testCase "Words can be formed by 'brushing' an existing word from the bottom" passesBelow, + F.testCase "Words formed can pass through two existing words" passesThroughTwoWords, + F.testCase "A first word is valid if it passes through the star" firstWordThroughStar, + F.testCase "A first word is invalid if it does not pass through the star" firstWordNotThroughStar, + F.testCase "If a word does not connect with any words on the board, the expected error is returned" doesNotConnectWithWord, + F.testCase "If a word forms a horizontal line, with one placed tile in the middle not in the line, the expected error is returned" nonContigiousHorizontal, + F.testCase "If a word forms a vertical line, with one placed tile in the middle not in the line, the expected error is returned" nonContigiousVertical, + F.testCase "Cannot placed a tile on a square which is already occupied" placeOnOccupiedSquare, + F.testCase "Blah" testPrettyPrintIntersectionFirstWord ], - - F.testGroup "PlayGameTest" - [ - F.testCase "The full game playthrough test succeeds as expected" playThroughTest, - F.testCase "The game is ended if all players skip twice consecutively" gameEndsOnConsecutiveSkips, - F.testCase "The game is not ended if skips are not consecutive twice" gameDoesNotEndOnNonConsecutiveSkips, - F.testCase "An exchange move behaves as expected" exchangeMoveExchangesLetters, - F.testCase "A player is as expected in the returned MoveTransition" playerInMoveTransitionIsAsExpected + F.testGroup + "PlayGameTest" + [ F.testCase "The full game playthrough test succeeds as expected" playThroughTest, + F.testCase "The game is ended if all players skip twice consecutively" gameEndsOnConsecutiveSkips, + F.testCase "The game is not ended if skips are not consecutive twice" gameDoesNotEndOnNonConsecutiveSkips, + F.testCase "An exchange move behaves as expected" exchangeMoveExchangesLetters, + F.testCase "A player is as expected in the returned MoveTransition" playerInMoveTransitionIsAsExpected + ], + F.testGroup + "MoveTest" + [ F.testCase "Cannot place a blank tile without an assigned level" movePlayedWithEmptyBlankTile, + F.testCase "Cannot place a blank tile with an invalid letter" movePlayedWithInvalidBlankTileAssignment, + F.testCase "Can place a blank tile with a valid assignment" movePlayedWithInvalidBlankTileAssignment + ], + F.testGroup + "Internationalisation LetterBag" + [ F.testCase "Can construct a spanish letter bag" makeSpanishBagTestSuccess, + F.testCase "Can play a move in a game setup with a spanish dictionary and letter bag" playSpanishMoveTest ] ] diff --git a/test/Tests/SharedTestData.hs b/test/Tests/SharedTestData.hs --- a/test/Tests/SharedTestData.hs +++ b/test/Tests/SharedTestData.hs @@ -1,25 +1,78 @@ module Tests.SharedTestData where - import Data.Maybe - import Wordify.Rules.Tile - import Wordify.Rules.Pos - import Wordify.Rules.Square - import Wordify.Rules.Pos.Internal - import qualified Data.Map as M - import Wordify.Rules.LetterBag +import Data.Char +import qualified Data.Map as M +import Data.Maybe +import qualified System.FilePath as F +import Wordify.Rules.Dictionary (Dictionary, makeDictionary) +import Wordify.Rules.Game +import Wordify.Rules.LetterBag +import Wordify.Rules.Player +import Wordify.Rules.Pos +import Wordify.Rules.Pos.Internal +import Wordify.Rules.ScrabbleError (ScrabbleError) +import Wordify.Rules.Square +import Wordify.Rules.Tile - horizontalPositions = catMaybes $ map posAt $ iterate (\(x,y) -> (x + 1, y)) (5,7) - horizontalSquares = [Normal $ Just (Letter 'H' 4), Normal $ Just (Letter 'E' 1), DoubleLetter $ Just (Letter 'L' 1), Normal $ Just (Letter 'L' 1), DoubleLetter $ Just (Letter 'O' 1)] - rogueLeft = (Pos 3 7 "C7", DoubleLetter $ Just (Letter 'X' 2)) - rogueRight = (Pos 11 7 "K7", Normal $ Just (Letter 'Z' 2)) - horizontals = zip horizontalPositions horizontalSquares +horizontalPositions = catMaybes $ map posAt $ iterate (\(x, y) -> (x + 1, y)) (5, 7) - verticalPositions = catMaybes $ map posAt $ iterate (\(x,y) -> (x, y + 1)) (7,5) - verticalSquares = [Normal $ Just (Letter 'T' 1), Normal $ Just (Letter 'E' 1), DoubleLetter $ Just (Letter 'L' 1), Normal $ Just (Letter 'L' 1), DoubleLetter $ Just (Letter 'Y' 4)] - rogueAbove = (Pos 7 3 "G3", DoubleLetter $ Just (Letter 'X' 2)) - rogueBelow = (Pos 7 11 "G11", Normal $ Just (Letter 'Z' 2)) - verticals = zip verticalPositions verticalSquares +horizontalSquares = [Normal $ Just (Letter "H" 4), Normal $ Just (Letter "E" 1), DoubleLetter $ Just (Letter "L" 1), Normal $ Just (Letter "L" 1), DoubleLetter $ Just (Letter "O" 1)] - isValid :: Either a b -> Bool - isValid (Right _ ) = True - isValid _ = False +rogueLeft = (Pos 3 7 "C7", DoubleLetter $ Just (Letter "X" 2)) + +rogueRight = (Pos 11 7 "K7", Normal $ Just (Letter "Z" 2)) + +horizontals = zip horizontalPositions horizontalSquares + +verticalPositions = catMaybes $ map posAt $ iterate (\(x, y) -> (x, y + 1)) (7, 5) + +verticalSquares = [Normal $ Just (Letter "T" 1), Normal $ Just (Letter "E" 1), DoubleLetter $ Just (Letter "L" 1), Normal $ Just (Letter "L" 1), DoubleLetter $ Just (Letter "Y" 4)] + +rogueAbove = (Pos 7 3 "G3", DoubleLetter $ Just (Letter "X" 2)) + +rogueBelow = (Pos 7 11 "G11", Normal $ Just (Letter "Z" 2)) + +verticals = zip verticalPositions verticalSquares + +testDictionary :: IO (Either ScrabbleError Dictionary) +testDictionary = makeDictionary $ "Config" ++ [F.pathSeparator] ++ "engSet" ++ [F.pathSeparator] ++ "en.txt" + +letterValues :: M.Map String Int +letterValues = M.fromList $ [("A", 1), ("B", 3), ("C", 3), ("D", 2), ("E", 1), ("F", 4), ("G", 2), ("H", 4), ("I", 1), ("J", 8), ("K", 5), ("L", 1), ("M", 3), ("N", 1), ("O", 1), ("P", 3), ("Q", 10), ("R", 1), ("S", 1), ("T", 1), ("U", 1), ("V", 4), ("W", 4), ("X", 8), ("Y", 4), ("Z", 10)] + +toTilePlaced :: Char -> Tile +toTilePlaced char + | isLower char = Blank $ Just ([toUpper char]) + | otherwise = toTileBag char + +placeMap :: String -> Direction -> (Int, Int) -> M.Map Pos Tile +placeMap letters direction pos = M.fromList $ zip positions tiles + where + positions = + case direction of + Horizontal -> catMaybes $ takeWhile isJust <$> map posAt $ iterate (\(x, y) -> (x + 1, y)) pos + Vertical -> catMaybes $ takeWhile isJust <$> map posAt $ iterate (\(x, y) -> (x, y + 1)) pos + + tiles = map toTilePlaced letters + +toTileBag :: Char -> Tile +toTileBag lettr = + case lettr of + '_' -> Blank Nothing + x -> Letter [x] $ M.findWithDefault 0 [x] letterValues + +setupGame :: LetterBag -> IO (Either ScrabbleError Game) +setupGame bag = + do + dict <- testDictionary + return $ resultGame bag dict + where + resultGame bag dict = + do + dc <- dict + let [player1, player2, player3, player4] = map makePlayer ["a", "b", "c", "d"] + makeGame (player1, player2, Just (player3, Just player4)) bag dc + +isValid :: Either a b -> Bool +isValid (Right _) = True +isValid _ = False diff --git a/wordify.cabal b/wordify.cabal --- a/wordify.cabal +++ b/wordify.cabal @@ -1,13 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.31.1. +-- This file has been generated from package.yaml by hpack version 0.38.0. -- -- see: https://github.com/sol/hpack --- --- hash: f28111054d235bc18dc5e0d167dd433a32a9e0c4e9627cc10c02822b5b2ac44e name: wordify -version: 0.1.1.0 +version: 0.3.0.0 description: Please see the README on GitHub at category: Game homepage: https://github.com/happy0/wordify#readme @@ -51,6 +49,8 @@ build-depends: array , base >=4.7 && <5 + , bytestring + , conduit , containers , errors , listsafe @@ -60,11 +60,9 @@ , safe , semigroups , split + , text , transformers , unordered-containers - , conduit - , text - , bytestring default-language: Haskell2010 executable wordify-exe @@ -77,6 +75,8 @@ build-depends: array , base >=4.7 && <5 + , bytestring + , conduit , containers , errors , listsafe @@ -86,6 +86,7 @@ , safe , semigroups , split + , text , transformers , unordered-containers , wordify @@ -99,7 +100,10 @@ Tests.FormedWordsTest Tests.FullGameTest Tests.Instances + Tests.Internationalisation.Spanish.LetterBagTest + Tests.Internationalisation.Spanish.MoveTest Tests.LetterBagTest + Tests.MoveTest Tests.PosTest Tests.Properties Tests.Regressions @@ -114,6 +118,8 @@ , QuickCheck , array , base >=4.7 && <5 + , bytestring + , conduit , containers , directory , errors @@ -128,6 +134,7 @@ , test-framework , test-framework-hunit , test-framework-quickcheck2 + , text , transformers , unordered-containers , wordify