{-# LANGUAGE CPP #-}
module Game.Goatee.Lib.Tree (
Collection(..), CollectionWithDeepEquality(..),
Node(..), NodeWithDeepEquality(..),
emptyNode, rootNode,
findProperty, findProperty', findPropertyValue, findPropertyValue',
addProperty, addChild, addChildAt, deleteChildAt,
validateNode,
) where
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.Ord (comparing)
import Data.Version (showVersion)
import Game.Goatee.App (applicationName)
import Game.Goatee.Common
import Game.Goatee.Lib.Property
import Game.Goatee.Lib.Types
import Paths_goatee (version)
data Collection = Collection
{ Collection -> [Node]
collectionTrees :: [Node]
} deriving (Int -> Collection -> ShowS
[Collection] -> ShowS
Collection -> String
(Int -> Collection -> ShowS)
-> (Collection -> String)
-> ([Collection] -> ShowS)
-> Show Collection
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Collection] -> ShowS
$cshowList :: [Collection] -> ShowS
show :: Collection -> String
$cshow :: Collection -> String
showsPrec :: Int -> Collection -> ShowS
$cshowsPrec :: Int -> Collection -> ShowS
Show)
newtype CollectionWithDeepEquality = CollectionWithDeepEquality
{ CollectionWithDeepEquality -> Collection
collectionWithDeepEquality :: Collection
} deriving (Int -> CollectionWithDeepEquality -> ShowS
[CollectionWithDeepEquality] -> ShowS
CollectionWithDeepEquality -> String
(Int -> CollectionWithDeepEquality -> ShowS)
-> (CollectionWithDeepEquality -> String)
-> ([CollectionWithDeepEquality] -> ShowS)
-> Show CollectionWithDeepEquality
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CollectionWithDeepEquality] -> ShowS
$cshowList :: [CollectionWithDeepEquality] -> ShowS
show :: CollectionWithDeepEquality -> String
$cshow :: CollectionWithDeepEquality -> String
showsPrec :: Int -> CollectionWithDeepEquality -> ShowS
$cshowsPrec :: Int -> CollectionWithDeepEquality -> ShowS
Show)
instance Eq CollectionWithDeepEquality where
== :: CollectionWithDeepEquality -> CollectionWithDeepEquality -> Bool
(==) = [NodeWithDeepEquality] -> [NodeWithDeepEquality] -> Bool
forall a. Eq a => a -> a -> Bool
(==) ([NodeWithDeepEquality] -> [NodeWithDeepEquality] -> Bool)
-> (CollectionWithDeepEquality -> [NodeWithDeepEquality])
-> CollectionWithDeepEquality
-> CollectionWithDeepEquality
-> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (Node -> NodeWithDeepEquality) -> [Node] -> [NodeWithDeepEquality]
forall a b. (a -> b) -> [a] -> [b]
map Node -> NodeWithDeepEquality
NodeWithDeepEquality ([Node] -> [NodeWithDeepEquality])
-> (CollectionWithDeepEquality -> [Node])
-> CollectionWithDeepEquality
-> [NodeWithDeepEquality]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Collection -> [Node]
collectionTrees (Collection -> [Node])
-> (CollectionWithDeepEquality -> Collection)
-> CollectionWithDeepEquality
-> [Node]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CollectionWithDeepEquality -> Collection
collectionWithDeepEquality
data Node = Node
{ Node -> [Property]
nodeProperties :: [Property]
, Node -> [Node]
nodeChildren :: [Node]
} deriving (Int -> Node -> ShowS
[Node] -> ShowS
Node -> String
(Int -> Node -> ShowS)
-> (Node -> String) -> ([Node] -> ShowS) -> Show Node
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Node] -> ShowS
$cshowList :: [Node] -> ShowS
show :: Node -> String
$cshow :: Node -> String
showsPrec :: Int -> Node -> ShowS
$cshowsPrec :: Int -> Node -> ShowS
Show)
newtype NodeWithDeepEquality = NodeWithDeepEquality { NodeWithDeepEquality -> Node
nodeWithDeepEquality :: Node }
instance Eq NodeWithDeepEquality where
NodeWithDeepEquality
node1 == :: NodeWithDeepEquality -> NodeWithDeepEquality -> Bool
== NodeWithDeepEquality
node2 =
let n1 :: Node
n1 = NodeWithDeepEquality -> Node
nodeWithDeepEquality NodeWithDeepEquality
node1
n2 :: Node
n2 = NodeWithDeepEquality -> Node
nodeWithDeepEquality NodeWithDeepEquality
node2
in Node -> [Property]
propertiesSorted Node
n1 [Property] -> [Property] -> Bool
forall a. Eq a => a -> a -> Bool
== Node -> [Property]
propertiesSorted Node
n2 Bool -> Bool -> Bool
&&
Node -> [NodeWithDeepEquality]
deepChildren Node
n1 [NodeWithDeepEquality] -> [NodeWithDeepEquality] -> Bool
forall a. Eq a => a -> a -> Bool
== Node -> [NodeWithDeepEquality]
deepChildren Node
n2
where propertiesSorted :: Node -> [Property]
propertiesSorted = (Property -> Property -> Ordering) -> [Property] -> [Property]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy ((Property -> String) -> Property -> Property -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing Property -> String
forall a. Show a => a -> String
show) ([Property] -> [Property])
-> (Node -> [Property]) -> Node -> [Property]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Node -> [Property]
nodeProperties
deepChildren :: Node -> [NodeWithDeepEquality]
deepChildren = (Node -> NodeWithDeepEquality) -> [Node] -> [NodeWithDeepEquality]
forall a b. (a -> b) -> [a] -> [b]
map Node -> NodeWithDeepEquality
NodeWithDeepEquality ([Node] -> [NodeWithDeepEquality])
-> (Node -> [Node]) -> Node -> [NodeWithDeepEquality]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Node -> [Node]
nodeChildren
emptyNode :: Node
emptyNode :: Node
emptyNode = Node :: [Property] -> [Node] -> Node
Node { nodeProperties :: [Property]
nodeProperties = [], nodeChildren :: [Node]
nodeChildren = [] }
rootNode :: Maybe (Int, Int) -> Node
rootNode :: Maybe (Int, Int) -> Node
rootNode Maybe (Int, Int)
maybeSize =
let props :: [Property]
props = Int -> Property
FF Int
4 Property -> [Property] -> [Property]
forall a. a -> [a] -> [a]
:
Int -> Property
GM Int
1 Property -> [Property] -> [Property]
forall a. a -> [a] -> [a]
:
SimpleText -> SimpleText -> Property
AP (String -> SimpleText
toSimpleText String
applicationName)
(String -> SimpleText
toSimpleText (String -> SimpleText) -> String -> SimpleText
forall a b. (a -> b) -> a -> b
$ Version -> String
showVersion Version
version) Property -> [Property] -> [Property]
forall a. a -> [a] -> [a]
:
[Property]
-> ((Int, Int) -> [Property]) -> Maybe (Int, Int) -> [Property]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] ((Property -> [Property] -> [Property]
forall a. a -> [a] -> [a]
:[]) (Property -> [Property])
-> ((Int, Int) -> Property) -> (Int, Int) -> [Property]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Int -> Property) -> (Int, Int) -> Property
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Int -> Int -> Property
SZ) Maybe (Int, Int)
maybeSize
in Node :: [Property] -> [Node] -> Node
Node { nodeProperties :: [Property]
nodeProperties = [Property]
props
, nodeChildren :: [Node]
nodeChildren = []
}
findProperty :: Descriptor a => a -> Node -> Maybe Property
findProperty :: a -> Node -> Maybe Property
findProperty a
descriptor Node
node = a -> [Property] -> Maybe Property
forall a. Descriptor a => a -> [Property] -> Maybe Property
findProperty' a
descriptor ([Property] -> Maybe Property) -> [Property] -> Maybe Property
forall a b. (a -> b) -> a -> b
$ Node -> [Property]
nodeProperties Node
node
findProperty' :: Descriptor a => a -> [Property] -> Maybe Property
findProperty' :: a -> [Property] -> Maybe Property
findProperty' = (Property -> Bool) -> [Property] -> Maybe Property
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((Property -> Bool) -> [Property] -> Maybe Property)
-> (a -> Property -> Bool) -> a -> [Property] -> Maybe Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Property -> Bool
forall a. Descriptor a => a -> Property -> Bool
propertyPredicate
findPropertyValue :: ValuedDescriptor v a => a -> Node -> Maybe v
findPropertyValue :: a -> Node -> Maybe v
findPropertyValue a
descriptor Node
node = a -> Property -> v
forall v a. ValuedDescriptor v a => a -> Property -> v
propertyValue a
descriptor (Property -> v) -> Maybe Property -> Maybe v
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> Node -> Maybe Property
forall a. Descriptor a => a -> Node -> Maybe Property
findProperty a
descriptor Node
node
findPropertyValue' :: ValuedDescriptor v a => a -> [Property] -> Maybe v
findPropertyValue' :: a -> [Property] -> Maybe v
findPropertyValue' a
descriptor [Property]
properties =
a -> Property -> v
forall v a. ValuedDescriptor v a => a -> Property -> v
propertyValue a
descriptor (Property -> v) -> Maybe Property -> Maybe v
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> [Property] -> Maybe Property
forall a. Descriptor a => a -> [Property] -> Maybe Property
findProperty' a
descriptor [Property]
properties
addProperty :: Property -> Node -> Node
addProperty :: Property -> Node -> Node
addProperty Property
prop Node
node = Node
node { nodeProperties :: [Property]
nodeProperties = Node -> [Property]
nodeProperties Node
node [Property] -> [Property] -> [Property]
forall a. [a] -> [a] -> [a]
++ [Property
prop] }
addChild :: Node -> Node -> Node
addChild :: Node -> Node -> Node
addChild Node
child Node
node = Node
node { nodeChildren :: [Node]
nodeChildren = Node -> [Node]
nodeChildren Node
node [Node] -> [Node] -> [Node]
forall a. [a] -> [a] -> [a]
++ [Node
child] }
addChildAt :: Int -> Node -> Node -> Node
addChildAt :: Int -> Node -> Node -> Node
addChildAt Int
index Node
child Node
node =
let ([Node]
before, [Node]
after) = Int -> [Node] -> ([Node], [Node])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
index ([Node] -> ([Node], [Node])) -> [Node] -> ([Node], [Node])
forall a b. (a -> b) -> a -> b
$ Node -> [Node]
nodeChildren Node
node
in Node
node { nodeChildren :: [Node]
nodeChildren = [Node]
before [Node] -> [Node] -> [Node]
forall a. [a] -> [a] -> [a]
++ Node
childNode -> [Node] -> [Node]
forall a. a -> [a] -> [a]
:[Node]
after }
deleteChildAt :: Int -> Node -> Node
deleteChildAt :: Int -> Node -> Node
deleteChildAt Int
index Node
node =
let children :: [Node]
children = Node -> [Node]
nodeChildren Node
node
in if Int
index Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 Bool -> Bool -> Bool
|| Int
index Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> [Node] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Node]
children
then Node
node
else Node
node { nodeChildren :: [Node]
nodeChildren = Int -> [Node] -> [Node]
forall a. Int -> [a] -> [a]
listDeleteAt Int
index [Node]
children }
validateNode :: Bool -> Bool -> Node -> [String]
validateNode :: Bool -> Bool -> Node -> [String]
validateNode Bool
isRoot Bool
_ Node
node = Writer [String] () -> [String]
forall w a. Writer w a -> w
execWriter (Writer [String] () -> [String]) -> Writer [String] () -> [String]
forall a b. (a -> b) -> a -> b
$ do
let props :: [Property]
props = Node -> [Property]
nodeProperties Node
node
let propTypes :: [PropertyType]
propTypes = [PropertyType] -> [PropertyType]
forall a. Eq a => [a] -> [a]
nub ([PropertyType] -> [PropertyType])
-> [PropertyType] -> [PropertyType]
forall a b. (a -> b) -> a -> b
$ (Property -> PropertyType) -> [Property] -> [PropertyType]
forall a b. (a -> b) -> [a] -> [b]
map Property -> PropertyType
forall a. Descriptor a => a -> PropertyType
propertyType ([Property] -> [PropertyType]) -> [Property] -> [PropertyType]
forall a b. (a -> b) -> a -> b
$ Node -> [Property]
nodeProperties Node
node
Bool -> Writer [String] () -> Writer [String] ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (PropertyType
MoveProperty PropertyType -> [PropertyType] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [PropertyType]
propTypes Bool -> Bool -> Bool
&& PropertyType
SetupProperty PropertyType -> [PropertyType] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [PropertyType]
propTypes) (Writer [String] () -> Writer [String] ())
-> Writer [String] () -> Writer [String] ()
forall a b. (a -> b) -> a -> b
$
[String] -> Writer [String] ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [String
"Node contains move and setup properties."]
let rootProps :: [Property]
rootProps = (Property -> Bool) -> [Property] -> [Property]
forall a. (a -> Bool) -> [a] -> [a]
filter ((PropertyType
RootProperty PropertyType -> PropertyType -> Bool
forall a. Eq a => a -> a -> Bool
==) (PropertyType -> Bool)
-> (Property -> PropertyType) -> Property -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Property -> PropertyType
forall a. Descriptor a => a -> PropertyType
propertyType) [Property]
props
Bool -> Writer [String] () -> Writer [String] ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
isRoot Bool -> Bool -> Bool
&& Bool -> Bool
not ([Property] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Property]
rootProps)) (Writer [String] () -> Writer [String] ())
-> Writer [String] () -> Writer [String] ()
forall a b. (a -> b) -> a -> b
$
[String] -> Writer [String] ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell ([String] -> Writer [String] ()) -> [String] -> Writer [String] ()
forall a b. (a -> b) -> a -> b
$ (Property -> String) -> [Property] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\Property
p -> String
"Root property found on non-root node: " String -> ShowS
forall a. [a] -> [a] -> [a]
++
Property -> String
forall a. Show a => a -> String
show Property
p String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
".")
[Property]
rootProps
[Property]
-> (Property -> [((Int, Int), String)])
-> ([((Int, Int), String)] -> Writer [String] ())
-> Writer [String] ()
forall v t.
(Eq v, Ord v) =>
[Property]
-> (Property -> [(v, t)])
-> ([(v, t)] -> Writer [String] ())
-> Writer [String] ()
validateNodeDuplicates [Property]
props Property -> [((Int, Int), String)]
getMarkedCoords (([((Int, Int), String)] -> Writer [String] ())
-> Writer [String] ())
-> ([((Int, Int), String)] -> Writer [String] ())
-> Writer [String] ()
forall a b. (a -> b) -> a -> b
$ \[((Int, Int), String)]
group ->
[String] -> Writer [String] ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [String
"Coordinate " String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Int, Int) -> String
forall a. Show a => a -> String
show (((Int, Int), String) -> (Int, Int)
forall a b. (a, b) -> a
fst (((Int, Int), String) -> (Int, Int))
-> ((Int, Int), String) -> (Int, Int)
forall a b. (a -> b) -> a -> b
$ [((Int, Int), String)] -> ((Int, Int), String)
forall a. [a] -> a
head [((Int, Int), String)]
group) String -> ShowS
forall a. [a] -> [a] -> [a]
++
String
" is specified multiple times in properties " String -> ShowS
forall a. [a] -> [a] -> [a]
++
String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " ((((Int, Int), String) -> String)
-> [((Int, Int), String)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ((Int, Int), String) -> String
forall a b. (a, b) -> b
snd [((Int, Int), String)]
group) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"."]
where getMarkedCoords :: Property -> [((Int, Int), String)]
getMarkedCoords (CR CoordList
cs) = CoordList -> String -> [((Int, Int), String)]
forall b. CoordList -> b -> [((Int, Int), b)]
tagMarkedCoords CoordList
cs String
"CR"
getMarkedCoords (MA CoordList
cs) = CoordList -> String -> [((Int, Int), String)]
forall b. CoordList -> b -> [((Int, Int), b)]
tagMarkedCoords CoordList
cs String
"MA"
getMarkedCoords (SL CoordList
cs) = CoordList -> String -> [((Int, Int), String)]
forall b. CoordList -> b -> [((Int, Int), b)]
tagMarkedCoords CoordList
cs String
"SL"
getMarkedCoords (SQ CoordList
cs) = CoordList -> String -> [((Int, Int), String)]
forall b. CoordList -> b -> [((Int, Int), b)]
tagMarkedCoords CoordList
cs String
"SQ"
getMarkedCoords (TR CoordList
cs) = CoordList -> String -> [((Int, Int), String)]
forall b. CoordList -> b -> [((Int, Int), b)]
tagMarkedCoords CoordList
cs String
"TR"
getMarkedCoords Property
_ = []
tagMarkedCoords :: CoordList -> b -> [((Int, Int), b)]
tagMarkedCoords CoordList
cs b
tag = ((Int, Int) -> ((Int, Int), b))
-> [(Int, Int)] -> [((Int, Int), b)]
forall a b. (a -> b) -> [a] -> [b]
map (\(Int, Int)
x -> ((Int, Int)
x, b
tag)) ([(Int, Int)] -> [((Int, Int), b)])
-> [(Int, Int)] -> [((Int, Int), b)]
forall a b. (a -> b) -> a -> b
$ CoordList -> [(Int, Int)]
expandCoordList CoordList
cs
validateNodeDuplicates :: (Eq v, Ord v)
=> [Property]
-> (Property -> [(v, t)])
-> ([(v, t)] -> Writer [String] ())
-> Writer [String] ()
validateNodeDuplicates :: [Property]
-> (Property -> [(v, t)])
-> ([(v, t)] -> Writer [String] ())
-> Writer [String] ()
validateNodeDuplicates [Property]
props Property -> [(v, t)]
getTaggedElts [(v, t)] -> Writer [String] ()
errAction =
let groups :: [[(v, t)]]
groups = ((v, t) -> (v, t) -> Bool) -> [(v, t)] -> [[(v, t)]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy (v -> v -> Bool
forall a. Eq a => a -> a -> Bool
(==) (v -> v -> Bool) -> ((v, t) -> v) -> (v, t) -> (v, t) -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (v, t) -> v
forall a b. (a, b) -> a
fst) ([(v, t)] -> [[(v, t)]]) -> [(v, t)] -> [[(v, t)]]
forall a b. (a -> b) -> a -> b
$
((v, t) -> (v, t) -> Ordering) -> [(v, t)] -> [(v, t)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (((v, t) -> v) -> (v, t) -> (v, t) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (v, t) -> v
forall a b. (a, b) -> a
fst) ([(v, t)] -> [(v, t)]) -> [(v, t)] -> [(v, t)]
forall a b. (a -> b) -> a -> b
$
(Property -> [(v, t)]) -> [Property] -> [(v, t)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Property -> [(v, t)]
getTaggedElts [Property]
props
in [[(v, t)]]
-> ([(v, t)] -> Writer [String] ()) -> Writer [String] ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [[(v, t)]]
groups (([(v, t)] -> Writer [String] ()) -> Writer [String] ())
-> ([(v, t)] -> Writer [String] ()) -> Writer [String] ()
forall a b. (a -> b) -> a -> b
$ \[(v, t)]
group ->
Bool -> Writer [String] () -> Writer [String] ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([(v, t)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([(v, t)] -> Bool) -> [(v, t)] -> Bool
forall a b. (a -> b) -> a -> b
$ [(v, t)] -> [(v, t)]
forall a. [a] -> [a]
tail [(v, t)]
group) (Writer [String] () -> Writer [String] ())
-> Writer [String] () -> Writer [String] ()
forall a b. (a -> b) -> a -> b
$
[(v, t)] -> Writer [String] ()
errAction [(v, t)]
group