{-# LANGUAGE TemplateHaskell #-}
module Swarm.Game.Scenario.Topography.Structure.Recognition.Type where
import Control.Arrow ((&&&))
import Control.Lens (makeLenses)
import Data.Aeson (ToJSON)
import Data.Function (on)
import Data.HashMap.Strict (HashMap)
import Data.HashSet (HashSet)
import Data.Int (Int32)
import Data.List.NonEmpty qualified as NE
import Data.Map (Map)
import Data.Maybe (catMaybes)
import Data.Ord (Down (Down))
import Data.Semigroup (Max, Min)
import Data.Text (Text)
import GHC.Generics (Generic)
import Linear (V2 (..))
import Swarm.Game.Location (Location)
import Swarm.Game.Scenario.Topography.Area
import Swarm.Game.Universe (Cosmic, offsetBy)
import Swarm.Language.Syntax.Direction (AbsoluteDir)
import Text.AhoCorasick (StateMachine)
type OriginalName = Text
type AtomicKeySymbol a = Maybe a
type SymbolSequence a = [AtomicKeySymbol a]
data StructureSearcher b a = StructureSearcher
{ forall b a.
StructureSearcher b a
-> AutomatonInfo a (SymbolSequence a) (StructureWithGrid b a)
automaton2D :: AutomatonInfo a (SymbolSequence a) (StructureWithGrid b a)
, forall b a. StructureSearcher b a -> SymbolSequence a
needleContent :: SymbolSequence a
, forall b a.
StructureSearcher b a -> NonEmpty (SingleRowEntityOccurrences b a)
singleRowItems :: NE.NonEmpty (SingleRowEntityOccurrences b a)
}
data PositionWithinRow b a = PositionWithinRow
{ forall b a. PositionWithinRow b a -> Int32
_position :: Int32
, forall b a. PositionWithinRow b a -> StructureRow b a
structureRow :: StructureRow b a
}
data SingleRowEntityOccurrences b a = SingleRowEntityOccurrences
{ forall b a. SingleRowEntityOccurrences b a -> StructureRow b a
myRow :: StructureRow b a
, forall b a. SingleRowEntityOccurrences b a -> a
myEntity :: a
, forall b a.
SingleRowEntityOccurrences b a -> NonEmpty (PositionWithinRow b a)
entityOccurrences :: NE.NonEmpty (PositionWithinRow b a)
, forall b a. SingleRowEntityOccurrences b a -> InspectionOffsets
expandedOffsets :: InspectionOffsets
}
data StructureRow b a = StructureRow
{ forall b a. StructureRow b a -> StructureWithGrid b a
wholeStructure :: StructureWithGrid b a
, forall b a. StructureRow b a -> Int32
rowIndex :: Int32
, forall b a. StructureRow b a -> SymbolSequence a
rowContent :: SymbolSequence a
}
data NamedOriginal a = NamedOriginal
{ forall a. NamedOriginal a -> OriginalName
getName :: OriginalName
, forall a. NamedOriginal a -> a
orig :: a
}
deriving (Int -> NamedOriginal a -> ShowS
[NamedOriginal a] -> ShowS
NamedOriginal a -> String
(Int -> NamedOriginal a -> ShowS)
-> (NamedOriginal a -> String)
-> ([NamedOriginal a] -> ShowS)
-> Show (NamedOriginal a)
forall a. Show a => Int -> NamedOriginal a -> ShowS
forall a. Show a => [NamedOriginal a] -> ShowS
forall a. Show a => NamedOriginal a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> NamedOriginal a -> ShowS
showsPrec :: Int -> NamedOriginal a -> ShowS
$cshow :: forall a. Show a => NamedOriginal a -> String
show :: NamedOriginal a -> String
$cshowList :: forall a. Show a => [NamedOriginal a] -> ShowS
showList :: [NamedOriginal a] -> ShowS
Show, NamedOriginal a -> NamedOriginal a -> Bool
(NamedOriginal a -> NamedOriginal a -> Bool)
-> (NamedOriginal a -> NamedOriginal a -> Bool)
-> Eq (NamedOriginal a)
forall a. Eq a => NamedOriginal a -> NamedOriginal a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => NamedOriginal a -> NamedOriginal a -> Bool
== :: NamedOriginal a -> NamedOriginal a -> Bool
$c/= :: forall a. Eq a => NamedOriginal a -> NamedOriginal a -> Bool
/= :: NamedOriginal a -> NamedOriginal a -> Bool
Eq)
data StructureWithGrid b a = StructureWithGrid
{ forall b a. StructureWithGrid b a -> NamedOriginal b
originalDefinition :: NamedOriginal b
, forall b a. StructureWithGrid b a -> AbsoluteDir
rotatedTo :: AbsoluteDir
, forall b a. StructureWithGrid b a -> [SymbolSequence a]
entityGrid :: [SymbolSequence a]
}
deriving (StructureWithGrid b a -> StructureWithGrid b a -> Bool
(StructureWithGrid b a -> StructureWithGrid b a -> Bool)
-> (StructureWithGrid b a -> StructureWithGrid b a -> Bool)
-> Eq (StructureWithGrid b a)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall b a.
(Eq b, Eq a) =>
StructureWithGrid b a -> StructureWithGrid b a -> Bool
$c== :: forall b a.
(Eq b, Eq a) =>
StructureWithGrid b a -> StructureWithGrid b a -> Bool
== :: StructureWithGrid b a -> StructureWithGrid b a -> Bool
$c/= :: forall b a.
(Eq b, Eq a) =>
StructureWithGrid b a -> StructureWithGrid b a -> Bool
/= :: StructureWithGrid b a -> StructureWithGrid b a -> Bool
Eq)
data RotationalSymmetry
=
NoSymmetry
|
TwoFold
|
FourFold
deriving (Int -> RotationalSymmetry -> ShowS
[RotationalSymmetry] -> ShowS
RotationalSymmetry -> String
(Int -> RotationalSymmetry -> ShowS)
-> (RotationalSymmetry -> String)
-> ([RotationalSymmetry] -> ShowS)
-> Show RotationalSymmetry
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RotationalSymmetry -> ShowS
showsPrec :: Int -> RotationalSymmetry -> ShowS
$cshow :: RotationalSymmetry -> String
show :: RotationalSymmetry -> String
$cshowList :: [RotationalSymmetry] -> ShowS
showList :: [RotationalSymmetry] -> ShowS
Show, RotationalSymmetry -> RotationalSymmetry -> Bool
(RotationalSymmetry -> RotationalSymmetry -> Bool)
-> (RotationalSymmetry -> RotationalSymmetry -> Bool)
-> Eq RotationalSymmetry
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RotationalSymmetry -> RotationalSymmetry -> Bool
== :: RotationalSymmetry -> RotationalSymmetry -> Bool
$c/= :: RotationalSymmetry -> RotationalSymmetry -> Bool
/= :: RotationalSymmetry -> RotationalSymmetry -> Bool
Eq)
data SymmetryAnnotatedGrid a = SymmetryAnnotatedGrid
{ forall a. SymmetryAnnotatedGrid a -> a
namedGrid :: a
, forall a. SymmetryAnnotatedGrid a -> RotationalSymmetry
symmetry :: RotationalSymmetry
}
deriving (Int -> SymmetryAnnotatedGrid a -> ShowS
[SymmetryAnnotatedGrid a] -> ShowS
SymmetryAnnotatedGrid a -> String
(Int -> SymmetryAnnotatedGrid a -> ShowS)
-> (SymmetryAnnotatedGrid a -> String)
-> ([SymmetryAnnotatedGrid a] -> ShowS)
-> Show (SymmetryAnnotatedGrid a)
forall a. Show a => Int -> SymmetryAnnotatedGrid a -> ShowS
forall a. Show a => [SymmetryAnnotatedGrid a] -> ShowS
forall a. Show a => SymmetryAnnotatedGrid a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> SymmetryAnnotatedGrid a -> ShowS
showsPrec :: Int -> SymmetryAnnotatedGrid a -> ShowS
$cshow :: forall a. Show a => SymmetryAnnotatedGrid a -> String
show :: SymmetryAnnotatedGrid a -> String
$cshowList :: forall a. Show a => [SymmetryAnnotatedGrid a] -> ShowS
showList :: [SymmetryAnnotatedGrid a] -> ShowS
Show)
data StructureInfo b a = StructureInfo
{ forall b a. StructureInfo b a -> SymmetryAnnotatedGrid b
annotatedGrid :: SymmetryAnnotatedGrid b
, forall b a. StructureInfo b a -> [SymbolSequence a]
entityProcessedGrid :: [SymbolSequence a]
, forall b a. StructureInfo b a -> Map a Int
entityCounts :: Map a Int
}
data InspectionOffsets = InspectionOffsets
{ InspectionOffsets -> Min Int32
startOffset :: Min Int32
, InspectionOffsets -> Max Int32
endOffset :: Max Int32
}
deriving (Int -> InspectionOffsets -> ShowS
[InspectionOffsets] -> ShowS
InspectionOffsets -> String
(Int -> InspectionOffsets -> ShowS)
-> (InspectionOffsets -> String)
-> ([InspectionOffsets] -> ShowS)
-> Show InspectionOffsets
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> InspectionOffsets -> ShowS
showsPrec :: Int -> InspectionOffsets -> ShowS
$cshow :: InspectionOffsets -> String
show :: InspectionOffsets -> String
$cshowList :: [InspectionOffsets] -> ShowS
showList :: [InspectionOffsets] -> ShowS
Show, (forall x. InspectionOffsets -> Rep InspectionOffsets x)
-> (forall x. Rep InspectionOffsets x -> InspectionOffsets)
-> Generic InspectionOffsets
forall x. Rep InspectionOffsets x -> InspectionOffsets
forall x. InspectionOffsets -> Rep InspectionOffsets x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. InspectionOffsets -> Rep InspectionOffsets x
from :: forall x. InspectionOffsets -> Rep InspectionOffsets x
$cto :: forall x. Rep InspectionOffsets x -> InspectionOffsets
to :: forall x. Rep InspectionOffsets x -> InspectionOffsets
Generic, [InspectionOffsets] -> Value
[InspectionOffsets] -> Encoding
InspectionOffsets -> Bool
InspectionOffsets -> Value
InspectionOffsets -> Encoding
(InspectionOffsets -> Value)
-> (InspectionOffsets -> Encoding)
-> ([InspectionOffsets] -> Value)
-> ([InspectionOffsets] -> Encoding)
-> (InspectionOffsets -> Bool)
-> ToJSON InspectionOffsets
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: InspectionOffsets -> Value
toJSON :: InspectionOffsets -> Value
$ctoEncoding :: InspectionOffsets -> Encoding
toEncoding :: InspectionOffsets -> Encoding
$ctoJSONList :: [InspectionOffsets] -> Value
toJSONList :: [InspectionOffsets] -> Value
$ctoEncodingList :: [InspectionOffsets] -> Encoding
toEncodingList :: [InspectionOffsets] -> Encoding
$comitField :: InspectionOffsets -> Bool
omitField :: InspectionOffsets -> Bool
ToJSON)
instance Semigroup InspectionOffsets where
InspectionOffsets Min Int32
l1 Max Int32
r1 <> :: InspectionOffsets -> InspectionOffsets -> InspectionOffsets
<> InspectionOffsets Min Int32
l2 Max Int32
r2 =
Min Int32 -> Max Int32 -> InspectionOffsets
InspectionOffsets (Min Int32
l1 Min Int32 -> Min Int32 -> Min Int32
forall a. Semigroup a => a -> a -> a
<> Min Int32
l2) (Max Int32
r1 Max Int32 -> Max Int32 -> Max Int32
forall a. Semigroup a => a -> a -> a
<> Max Int32
r2)
data AutomatonInfo en k v = AutomatonInfo
{ forall en k v. AutomatonInfo en k v -> HashSet en
_participatingEntities :: HashSet en
, forall en k v. AutomatonInfo en k v -> InspectionOffsets
_inspectionOffsets :: InspectionOffsets
, forall en k v. AutomatonInfo en k v -> StateMachine k v
_automaton :: StateMachine k v
}
deriving ((forall x. AutomatonInfo en k v -> Rep (AutomatonInfo en k v) x)
-> (forall x. Rep (AutomatonInfo en k v) x -> AutomatonInfo en k v)
-> Generic (AutomatonInfo en k v)
forall x. Rep (AutomatonInfo en k v) x -> AutomatonInfo en k v
forall x. AutomatonInfo en k v -> Rep (AutomatonInfo en k v) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall en k v x.
Rep (AutomatonInfo en k v) x -> AutomatonInfo en k v
forall en k v x.
AutomatonInfo en k v -> Rep (AutomatonInfo en k v) x
$cfrom :: forall en k v x.
AutomatonInfo en k v -> Rep (AutomatonInfo en k v) x
from :: forall x. AutomatonInfo en k v -> Rep (AutomatonInfo en k v) x
$cto :: forall en k v x.
Rep (AutomatonInfo en k v) x -> AutomatonInfo en k v
to :: forall x. Rep (AutomatonInfo en k v) x -> AutomatonInfo en k v
Generic)
makeLenses ''AutomatonInfo
data RecognizerAutomatons b a = RecognizerAutomatons
{ forall b a.
RecognizerAutomatons b a -> Map OriginalName (StructureInfo b a)
_originalStructureDefinitions :: Map OriginalName (StructureInfo b a)
, forall b a.
RecognizerAutomatons b a
-> HashMap
a (AutomatonInfo a (AtomicKeySymbol a) (StructureSearcher b a))
_automatonsByEntity :: HashMap a (AutomatonInfo a (AtomicKeySymbol a) (StructureSearcher b a))
}
deriving ((forall x.
RecognizerAutomatons b a -> Rep (RecognizerAutomatons b a) x)
-> (forall x.
Rep (RecognizerAutomatons b a) x -> RecognizerAutomatons b a)
-> Generic (RecognizerAutomatons b a)
forall x.
Rep (RecognizerAutomatons b a) x -> RecognizerAutomatons b a
forall x.
RecognizerAutomatons b a -> Rep (RecognizerAutomatons b a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall b a x.
Rep (RecognizerAutomatons b a) x -> RecognizerAutomatons b a
forall b a x.
RecognizerAutomatons b a -> Rep (RecognizerAutomatons b a) x
$cfrom :: forall b a x.
RecognizerAutomatons b a -> Rep (RecognizerAutomatons b a) x
from :: forall x.
RecognizerAutomatons b a -> Rep (RecognizerAutomatons b a) x
$cto :: forall b a x.
Rep (RecognizerAutomatons b a) x -> RecognizerAutomatons b a
to :: forall x.
Rep (RecognizerAutomatons b a) x -> RecognizerAutomatons b a
Generic)
makeLenses ''RecognizerAutomatons
data FoundStructure b a = FoundStructure
{ forall b a. FoundStructure b a -> StructureWithGrid b a
structureWithGrid :: StructureWithGrid b a
, forall b a. FoundStructure b a -> Cosmic Location
upperLeftCorner :: Cosmic Location
}
deriving (FoundStructure b a -> FoundStructure b a -> Bool
(FoundStructure b a -> FoundStructure b a -> Bool)
-> (FoundStructure b a -> FoundStructure b a -> Bool)
-> Eq (FoundStructure b a)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall b a.
(Eq b, Eq a) =>
FoundStructure b a -> FoundStructure b a -> Bool
$c== :: forall b a.
(Eq b, Eq a) =>
FoundStructure b a -> FoundStructure b a -> Bool
== :: FoundStructure b a -> FoundStructure b a -> Bool
$c/= :: forall b a.
(Eq b, Eq a) =>
FoundStructure b a -> FoundStructure b a -> Bool
/= :: FoundStructure b a -> FoundStructure b a -> Bool
Eq)
instance (Eq b, Eq a) => Ord (FoundStructure b a) where
compare :: FoundStructure b a -> FoundStructure b a -> Ordering
compare = (Int32, Down (Cosmic Location))
-> (Int32, Down (Cosmic Location)) -> Ordering
forall a. Ord a => a -> a -> Ordering
compare ((Int32, Down (Cosmic Location))
-> (Int32, Down (Cosmic Location)) -> Ordering)
-> (FoundStructure b a -> (Int32, Down (Cosmic Location)))
-> FoundStructure b a
-> FoundStructure b a
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (FoundStructure b a -> Int32
forall {b} {a}. FoundStructure b a -> Int32
f1 (FoundStructure b a -> Int32)
-> (FoundStructure b a -> Down (Cosmic Location))
-> FoundStructure b a
-> (Int32, Down (Cosmic Location))
forall b c c'. (b -> c) -> (b -> c') -> b -> (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& FoundStructure b a -> Down (Cosmic Location)
forall {b} {a}. FoundStructure b a -> Down (Cosmic Location)
f2)
where
f1 :: FoundStructure b a -> Int32
f1 = AreaDimensions -> Int32
computeArea (AreaDimensions -> Int32)
-> (FoundStructure b a -> AreaDimensions)
-> FoundStructure b a
-> Int32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[AtomicKeySymbol a]] -> AreaDimensions
forall a. [[a]] -> AreaDimensions
getAreaDimensions ([[AtomicKeySymbol a]] -> AreaDimensions)
-> (FoundStructure b a -> [[AtomicKeySymbol a]])
-> FoundStructure b a
-> AreaDimensions
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StructureWithGrid b a -> [[AtomicKeySymbol a]]
forall b a. StructureWithGrid b a -> [SymbolSequence a]
entityGrid (StructureWithGrid b a -> [[AtomicKeySymbol a]])
-> (FoundStructure b a -> StructureWithGrid b a)
-> FoundStructure b a
-> [[AtomicKeySymbol a]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FoundStructure b a -> StructureWithGrid b a
forall b a. FoundStructure b a -> StructureWithGrid b a
structureWithGrid
f2 :: FoundStructure b a -> Down (Cosmic Location)
f2 = Cosmic Location -> Down (Cosmic Location)
forall a. a -> Down a
Down (Cosmic Location -> Down (Cosmic Location))
-> (FoundStructure b a -> Cosmic Location)
-> FoundStructure b a
-> Down (Cosmic Location)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FoundStructure b a -> Cosmic Location
forall b a. FoundStructure b a -> Cosmic Location
upperLeftCorner
genOccupiedCoords :: FoundStructure b a -> [Cosmic Location]
genOccupiedCoords :: forall b a. FoundStructure b a -> [Cosmic Location]
genOccupiedCoords (FoundStructure StructureWithGrid b a
swg Cosmic Location
loc) =
([Maybe (Cosmic Location)] -> [Cosmic Location])
-> [[Maybe (Cosmic Location)]] -> [Cosmic Location]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap [Maybe (Cosmic Location)] -> [Cosmic Location]
forall a. [Maybe a] -> [a]
catMaybes ([[Maybe (Cosmic Location)]] -> [Cosmic Location])
-> ([[Maybe a]] -> [[Maybe (Cosmic Location)]])
-> [[Maybe a]]
-> [Cosmic Location]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int32 -> [Maybe a] -> [Maybe (Cosmic Location)])
-> [Int32] -> [[Maybe a]] -> [[Maybe (Cosmic Location)]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int32 -> [Maybe a] -> [Maybe (Cosmic Location)]
forall {f :: * -> *} {b}.
Functor f =>
Int32 -> [f b] -> [f (Cosmic Location)]
mkRow [Int32
0 ..] ([[Maybe a]] -> [Cosmic Location])
-> [[Maybe a]] -> [Cosmic Location]
forall a b. (a -> b) -> a -> b
$ StructureWithGrid b a -> [[Maybe a]]
forall b a. StructureWithGrid b a -> [SymbolSequence a]
entityGrid StructureWithGrid b a
swg
where
mkCol :: Int32 -> Int32 -> f b -> f (Cosmic Location)
mkCol Int32
y Int32
x f b
ent = Cosmic Location
loc Cosmic Location -> V2 Int32 -> Cosmic Location
`offsetBy` Int32 -> Int32 -> V2 Int32
forall a. a -> a -> V2 a
V2 Int32
x (Int32 -> Int32
forall a. Num a => a -> a
negate Int32
y) Cosmic Location -> f b -> f (Cosmic Location)
forall a b. a -> f b -> f a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ f b
ent
mkRow :: Int32 -> [f b] -> [f (Cosmic Location)]
mkRow Int32
rowIdx = (Int32 -> f b -> f (Cosmic Location))
-> [Int32] -> [f b] -> [f (Cosmic Location)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Int32 -> Int32 -> f b -> f (Cosmic Location)
forall {f :: * -> *} {b}.
Functor f =>
Int32 -> Int32 -> f b -> f (Cosmic Location)
mkCol Int32
rowIdx) [Int32
0 ..]