module Game.Goatee.Sgf.Tree (
Collection(..), CollectionWithDeepEquality(..),
Node(..), NodeWithDeepEquality(..),
emptyNode, rootNode,
findProperty, findProperty', findPropertyValue, findPropertyValue',
addProperty, addChild, addChildAt,
validateNode,
) where
import Control.Applicative ((<$>))
import Control.Monad (forM_, unless, when)
import Control.Monad.Writer (Writer, execWriter, tell)
import Data.Function (on)
import Data.List (find, groupBy, intercalate, nub, sortBy)
import Data.Version (showVersion)
import Game.Goatee.App (applicationName)
import Game.Goatee.Sgf.Property
import Game.Goatee.Sgf.Types
import Paths_goatee (version)
data Collection = Collection { collectionTrees :: [Node]
} deriving (Show)
newtype CollectionWithDeepEquality = CollectionWithDeepEquality {
collectionWithDeepEquality :: Collection
} deriving (Show)
instance Eq CollectionWithDeepEquality where
(==) = (==) `on` map NodeWithDeepEquality . collectionTrees . collectionWithDeepEquality
data Node = Node { nodeProperties :: [Property]
, nodeChildren :: [Node]
} deriving (Show)
newtype NodeWithDeepEquality = NodeWithDeepEquality { nodeWithDeepEquality :: Node }
instance Eq NodeWithDeepEquality where
node1 == node2 =
let n1 = nodeWithDeepEquality node1
n2 = nodeWithDeepEquality node2
in propertiesSorted n1 == propertiesSorted n2 &&
deepChildren n1 == deepChildren n2
where propertiesSorted = sortBy (compare `on` show) . nodeProperties
deepChildren = map NodeWithDeepEquality . nodeChildren
emptyNode :: Node
emptyNode = Node { nodeProperties = [], nodeChildren = [] }
rootNode :: Maybe (Int, Int) -> Node
rootNode maybeSize =
let props = FF 4 :
GM 1 :
AP (toSimpleText applicationName)
(toSimpleText $ showVersion version) :
maybe [] ((:[]) . uncurry SZ) maybeSize
in Node { nodeProperties = props
, nodeChildren = []
}
findProperty :: Descriptor a => a -> Node -> Maybe Property
findProperty descriptor node = findProperty' descriptor $ nodeProperties node
findProperty' :: Descriptor a => a -> [Property] -> Maybe Property
findProperty' = find . propertyPredicate
findPropertyValue :: ValuedDescriptor a v => a -> Node -> Maybe v
findPropertyValue descriptor node = propertyValue descriptor <$> findProperty descriptor node
findPropertyValue' :: ValuedDescriptor a v => a -> [Property] -> Maybe v
findPropertyValue' descriptor properties =
propertyValue descriptor <$> findProperty' descriptor properties
addProperty :: Property -> Node -> Node
addProperty prop node = node { nodeProperties = nodeProperties node ++ [prop] }
addChild :: Node -> Node -> Node
addChild child node = node { nodeChildren = nodeChildren node ++ [child] }
addChildAt :: Int -> Node -> Node -> Node
addChildAt index child node =
let (before, after) = splitAt index $ nodeChildren node
in node { nodeChildren = before ++ child:after }
validateNode :: Bool -> Bool -> Node -> [String]
validateNode isRoot _ node = execWriter $ do
let props = nodeProperties node
let propTypes = nub $ map propertyType $ nodeProperties node
when (MoveProperty `elem` propTypes && SetupProperty `elem` propTypes) $
tell ["Node contains move and setup properties."]
let rootProps = filter ((RootProperty ==) . propertyType) props
when (not isRoot && not (null rootProps)) $
tell $ map (\p -> "Root property found on non-root node: " ++
show p ++ ".")
rootProps
validateNodeDuplicates props getMarkedCoords $ \group ->
tell ["Coordinate " ++ show (fst $ head group) ++
" is specified multiple times in properties " ++
intercalate ", " (map snd group) ++ "."]
where getMarkedCoords (CR cs) = tagMarkedCoords cs "CR"
getMarkedCoords (MA cs) = tagMarkedCoords cs "MA"
getMarkedCoords (SL cs) = tagMarkedCoords cs "SL"
getMarkedCoords (SQ cs) = tagMarkedCoords cs "SQ"
getMarkedCoords (TR cs) = tagMarkedCoords cs "TR"
getMarkedCoords _ = []
tagMarkedCoords cs tag = map (\x -> (x, tag)) $ expandCoordList cs
validateNodeDuplicates :: (Eq v, Ord v)
=> [Property]
-> (Property -> [(v, t)])
-> ([(v, t)] -> Writer [String] ())
-> Writer [String] ()
validateNodeDuplicates props getTaggedElts errAction =
let groups = groupBy ((==) `on` fst) $
sortBy (compare `on` fst) $
concatMap getTaggedElts props
in forM_ groups $ \group ->
unless (null $ tail group) $
errAction group