module Game.Goatee.Lib.Types (
supportedFormatVersions, defaultFormatVersion, supportedGameTypes,
boardSizeDefault, boardSizeMin, boardSizeMax,
Coord, CoordList, coordListSingles, coordListRects, coord1, coords, coords',
emptyCoordList, expandCoordList, buildCoordList,
starLines,
isStarPoint,
handicapStones,
Stringlike (..), convertStringlike,
Text, fromText, toText,
SimpleText, fromSimpleText, toSimpleText,
UnknownPropertyValue, fromUnknownPropertyValue, toUnknownPropertyValue,
RealValue,
DoubleValue (..),
Color (..), cnot,
VariationMode (..), VariationModeSource (..), defaultVariationMode,
toVariationMode, fromVariationMode,
ArrowList, LineList, Line (..), lineToPair, LabelList, Mark (..),
GameResult (..),
WinReason (..),
Ruleset (..), RulesetType (..), fromRuleset, toRuleset,
) where
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative ((<$>), (<*>))
#endif
import Data.Char (isSpace)
import Data.Function (on)
import Data.List (delete, groupBy, partition, sort)
import Data.Maybe (fromMaybe)
import Game.Goatee.Common
import qualified Game.Goatee.Common.Bigfloat as BF
supportedFormatVersions :: [Int]
supportedFormatVersions = [4]
defaultFormatVersion :: Int
defaultFormatVersion = 4
supportedGameTypes :: [Int]
supportedGameTypes = [1 ]
boardSizeDefault :: Int
boardSizeDefault = 19
boardSizeMin :: Int
boardSizeMin = 1
boardSizeMax :: Int
boardSizeMax = 52
type Coord = (Int, Int)
data CoordList = CoordList
{ coordListSingles :: [Coord]
, coordListRects :: [(Coord, Coord)]
} deriving (Show)
instance Eq CoordList where
(==) = (==) `on` sort . expandCoordList
coord1 :: Coord -> CoordList
coord1 xy = CoordList { coordListSingles = [xy]
, coordListRects = []
}
coords :: [Coord] -> CoordList
coords singles = CoordList { coordListSingles = singles
, coordListRects = []
}
coords' :: [Coord] -> [(Coord, Coord)] -> CoordList
coords' singles rects = CoordList { coordListSingles = singles
, coordListRects = rects
}
emptyCoordList :: CoordList
emptyCoordList = CoordList { coordListSingles = []
, coordListRects = []
}
expandCoordList :: CoordList -> [Coord]
expandCoordList cl = coordListSingles cl ++
foldr (\r@((x0, y0), (x1, y1)) rest ->
if x0 > x1 || y0 > y1
then error ("Invalid coord. rectangle: " ++ show r)
else [(x, y) | x <- [x0..x1], y <- [y0..y1]] ++ rest)
[]
(coordListRects cl)
buildCoordList :: [Coord] -> CoordList
buildCoordList = toCoordList . generateRects 0 [] . buildTruePairs . toGrid
where
toGrid :: [Coord] -> [[Bool]]
toGrid [] = []
toGrid coords = let x1 = maximum $ map fst coords
y1 = maximum $ map snd coords
in [[(x,y) `elem` coords | x <- [0..x1]] | y <- [0..y1]]
buildTruePairs :: [[Bool]] -> [[(Int, Int)]]
buildTruePairs = map $
concatMap extractTrueGroups .
groupBy ((==) `on` snd) .
zip [0..]
extractTrueGroups :: [(Int, Bool)] -> [(Int, Int)]
extractTrueGroups list@((start, True):_) = [(start, fst (last list))]
extractTrueGroups _ = []
generateRects :: Int -> [(Coord, Coord)] -> [[(Int, Int)]] -> [(Coord, Coord)]
generateRects _ acc [] = acc
generateRects topRowOffset acc ([]:rows) = generateRects (topRowOffset + 1) acc rows
generateRects topRowOffset acc rows@((span:_):_) =
let rowsWithSpan = matchRowsWithSpan span rows
rowsWithSpanCount = length rowsWithSpan
in generateRects topRowOffset
(((fst span, topRowOffset),
(snd span, topRowOffset + rowsWithSpanCount 1)) : acc)
(rowsWithSpan ++ drop rowsWithSpanCount rows)
matchRowsWithSpan :: (Int, Int) -> [[(Int, Int)]] -> [[(Int, Int)]]
matchRowsWithSpan span (row:rows)
| span `elem` row = delete span row : matchRowsWithSpan span rows
| otherwise = []
matchRowsWithSpan _ [] = []
toCoordList :: [(Coord, Coord)] -> CoordList
toCoordList rects =
let (singles, properRects) = partition (uncurry (==)) rects
in coords' (map fst singles) properRects
starLines :: Int -> Int -> Maybe [Int]
starLines 19 19 = Just [3, 9, 15]
starLines 13 13 = Just [3, 6, 9]
starLines 9 9 = Just [2, 4, 6]
starLines _ _ = Nothing
isStarPoint :: Int -> Int -> Int -> Int -> Bool
isStarPoint width height x y =
fromMaybe False $
((&&) <$> elem x <*> elem y) <$> starLines width height
handicapStoneIndices :: [[(Int, Int)]]
handicapStoneIndices =
[ []
, []
, [(2,0), (0,2)]
, (2,2) : handicapStoneIndices !! 2
, (0,0) : handicapStoneIndices !! 3
, (1,1) : handicapStoneIndices !! 4
, (0,1) : (2,1) : handicapStoneIndices !! 4
, (1,1) : handicapStoneIndices !! 6
, (1,0) : (1,2) : handicapStoneIndices !! 6
, (1,1) : handicapStoneIndices !! 8
]
handicapStones :: Int -> Int -> Int -> Maybe [Coord]
handicapStones width height handicap =
if handicap < 0 || handicap >= length handicapStoneIndices
then Nothing
else do positions <- starLines width height
return $ map (mapTuple (positions !!)) (handicapStoneIndices !! handicap)
class Stringlike a where
sgfToString :: a -> String
stringToSgf :: String -> a
instance Stringlike String where
sgfToString = id
stringToSgf = id
convertStringlike :: (Stringlike a, Stringlike b) => a -> b
convertStringlike = stringToSgf . sgfToString
newtype Text = Text
{ fromText :: String
} deriving (Eq, Show)
instance Stringlike Text where
sgfToString = fromText
stringToSgf = toText
toText :: String -> Text
toText = Text
newtype SimpleText = SimpleText
{ fromSimpleText :: String
} deriving (Eq, Show)
instance Stringlike SimpleText where
sgfToString = fromSimpleText
stringToSgf = toSimpleText
sanitizeSimpleText :: String -> String
sanitizeSimpleText = map (\c -> if isSpace c then ' ' else c)
toSimpleText :: String -> SimpleText
toSimpleText = SimpleText . sanitizeSimpleText
data UnknownPropertyValue = UnknownPropertyValue
{ fromUnknownPropertyValue :: String
} deriving (Eq, Show)
instance Stringlike UnknownPropertyValue where
sgfToString = fromUnknownPropertyValue
stringToSgf = toUnknownPropertyValue
toUnknownPropertyValue :: String -> UnknownPropertyValue
toUnknownPropertyValue = UnknownPropertyValue
type RealValue = BF.Bigfloat
data DoubleValue = Double1
| Double2
deriving (Bounded, Enum, Eq, Ord, Show)
data Color = Black
| White
deriving (Bounded, Enum, Eq, Ord, Show)
cnot :: Color -> Color
cnot Black = White
cnot White = Black
data VariationMode = VariationMode
{ variationModeSource :: VariationModeSource
, variationModeBoardMarkup :: Bool
} deriving (Eq, Show)
data VariationModeSource =
ShowChildVariations
| ShowCurrentVariations
deriving (Bounded, Enum, Eq, Ord, Show)
defaultVariationMode :: VariationMode
defaultVariationMode = VariationMode ShowChildVariations True
toVariationMode :: Int -> Maybe VariationMode
toVariationMode n = case n of
0 -> Just $ VariationMode ShowChildVariations True
1 -> Just $ VariationMode ShowCurrentVariations True
2 -> Just $ VariationMode ShowChildVariations False
3 -> Just $ VariationMode ShowCurrentVariations False
_ -> Nothing
fromVariationMode :: VariationMode -> Int
fromVariationMode mode = case mode of
VariationMode ShowChildVariations True -> 0
VariationMode ShowCurrentVariations True -> 1
VariationMode ShowChildVariations False -> 2
VariationMode ShowCurrentVariations False -> 3
type ArrowList = [(Coord, Coord)]
type LineList = [Line]
data Line = Line Coord Coord
deriving (Show)
instance Eq Line where
(Line a b) == (Line c d) = a == c && b == d || a == d && b == c
lineToPair :: Line -> (Coord, Coord)
lineToPair (Line a b) = (a, b)
type LabelList = [(Coord, SimpleText)]
data Mark = MarkCircle | MarkSquare | MarkTriangle | MarkX | MarkSelected
deriving (Bounded, Enum, Eq, Ord, Show)
data GameResult = GameResultWin Color WinReason
| GameResultDraw
| GameResultVoid
| GameResultUnknown
| GameResultOther SimpleText
deriving (Eq, Show)
instance Stringlike GameResult where
sgfToString result = case result of
GameResultWin color reason ->
(case color of { Black -> 'B'; White -> 'W' }) : '+' :
(case reason of
WinByScore diff -> show diff
WinByResignation -> "R"
WinByTime -> "T"
WinByForfeit -> "F")
GameResultDraw -> "0"
GameResultVoid -> "Void"
GameResultUnknown -> "?"
GameResultOther text -> sgfToString text
stringToSgf str = case str of
"0" -> GameResultDraw
"Draw" -> GameResultDraw
"Void" -> GameResultVoid
"?" -> GameResultUnknown
_ ->
let result = case str of
'B':'+':winReasonStr -> parseWin (GameResultWin Black) winReasonStr
'W':'+':winReasonStr -> parseWin (GameResultWin White) winReasonStr
_ -> unknownResult
parseWin builder winReasonStr = case winReasonStr of
"R" -> builder WinByResignation
"Resign" -> builder WinByResignation
"T" -> builder WinByTime
"Time" -> builder WinByTime
"F" -> builder WinByForfeit
"Forfeit" -> builder WinByForfeit
_ -> case reads winReasonStr of
(score, ""):_ -> builder $ WinByScore score
_ -> unknownResult
unknownResult = GameResultOther $ toSimpleText str
in result
data WinReason = WinByScore RealValue
| WinByResignation
| WinByTime
| WinByForfeit
deriving (Eq, Show)
data Ruleset = KnownRuleset RulesetType
| UnknownRuleset String
deriving (Eq, Show)
instance Stringlike Ruleset where
sgfToString = fromRuleset
stringToSgf = toRuleset
data RulesetType = RulesetAga
| RulesetIng
| RulesetJapanese
| RulesetNewZealand
deriving (Bounded, Enum, Eq, Ord, Show)
fromRuleset :: Ruleset -> String
fromRuleset ruleset = case ruleset of
KnownRuleset RulesetAga -> "AGA"
KnownRuleset RulesetIng -> "Goe"
KnownRuleset RulesetJapanese -> "Japanese"
KnownRuleset RulesetNewZealand -> "NZ"
UnknownRuleset str -> str
toRuleset :: String -> Ruleset
toRuleset str = case str of
"AGA" -> KnownRuleset RulesetAga
"Goe" -> KnownRuleset RulesetIng
"Japanese" -> KnownRuleset RulesetJapanese
"NZ" -> KnownRuleset RulesetNewZealand
_ -> UnknownRuleset str