{-# LANGUAGE OverloadedStrings #-}

-- |
-- SPDX-License-Identifier: BSD-3-Clause
--
-- Symmetry analysis for structure recognizer.
module Swarm.Game.Scenario.Topography.Structure.Recognition.Symmetry where

import Control.Monad (unless, when)
import Data.Map qualified as M
import Data.Set qualified as Set
import Data.Text qualified as T
import Swarm.Game.Scenario.Topography.Placement (Orientation (..), applyOrientationTransform)
import Swarm.Game.Scenario.Topography.Structure (NamedGrid)
import Swarm.Game.Scenario.Topography.Structure qualified as Structure
import Swarm.Game.Scenario.Topography.Structure.Recognition.Type (RotationalSymmetry (..), SymmetryAnnotatedGrid (..))
import Swarm.Language.Syntax.Direction (AbsoluteDir (DSouth, DWest), getCoordinateOrientation)
import Swarm.Util (commaList, failT, histogram, showT)

-- | Warns if any recognition orientations are redundant
-- by rotational symmetry.
-- We can accomplish this by testing only two rotations:
--
-- 1. Rotate 90 degrees. If identical to the original
--    orientation, then has 4-fold symmetry and we don't
--    need to check any other orientations.
--    Warn if more than one recognition orientation was supplied.
-- 2. Rotate 180 degrees.  At best, we may now have
--    2-fold symmetry.
--    Warn if two opposite orientations were supplied.
checkSymmetry ::
  (MonadFail m, Eq a) => NamedGrid a -> m (SymmetryAnnotatedGrid (NamedGrid a))
checkSymmetry :: forall (m :: * -> *) a.
(MonadFail m, Eq a) =>
NamedGrid a -> m (SymmetryAnnotatedGrid (NamedGrid a))
checkSymmetry NamedGrid a
ng = do
  case RotationalSymmetry
symmetryType of
    RotationalSymmetry
FourFold ->
      Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Set AbsoluteDir -> Int
forall a. Set a -> Int
Set.size Set AbsoluteDir
suppliedOrientations Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1)
        (m () -> m ()) -> (Text -> m ()) -> Text -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> m ()
forall (m :: * -> *) a. MonadFail m => [Text] -> m a
failT
        ([Text] -> m ()) -> (Text -> [Text]) -> Text -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.unwords [Text
"Redundant orientations supplied; with four-fold symmetry, just supply 'north'."]
    RotationalSymmetry
TwoFold ->
      Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([CoordinateOrientation] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [CoordinateOrientation]
redundantOrientations)
        (m () -> m ()) -> (Text -> m ()) -> Text -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> m ()
forall (m :: * -> *) a. MonadFail m => [Text] -> m a
failT
        ([Text] -> m ()) -> (Text -> [Text]) -> Text -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.unwords
          [ Text
"Redundant"
          , [Text] -> Text
commaList ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (CoordinateOrientation -> Text)
-> [CoordinateOrientation] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map CoordinateOrientation -> Text
forall a. Show a => a -> Text
showT [CoordinateOrientation]
redundantOrientations
          , Text
"orientations supplied with two-fold symmetry."
          ]
     where
      redundantOrientations :: [CoordinateOrientation]
redundantOrientations =
        ((CoordinateOrientation, Int) -> CoordinateOrientation)
-> [(CoordinateOrientation, Int)] -> [CoordinateOrientation]
forall a b. (a -> b) -> [a] -> [b]
map (CoordinateOrientation, Int) -> CoordinateOrientation
forall a b. (a, b) -> a
fst
          ([(CoordinateOrientation, Int)] -> [CoordinateOrientation])
-> ([AbsoluteDir] -> [(CoordinateOrientation, Int)])
-> [AbsoluteDir]
-> [CoordinateOrientation]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((CoordinateOrientation, Int) -> Bool)
-> [(CoordinateOrientation, Int)] -> [(CoordinateOrientation, Int)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1) (Int -> Bool)
-> ((CoordinateOrientation, Int) -> Int)
-> (CoordinateOrientation, Int)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CoordinateOrientation, Int) -> Int
forall a b. (a, b) -> b
snd)
          ([(CoordinateOrientation, Int)] -> [(CoordinateOrientation, Int)])
-> ([AbsoluteDir] -> [(CoordinateOrientation, Int)])
-> [AbsoluteDir]
-> [(CoordinateOrientation, Int)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map CoordinateOrientation Int -> [(CoordinateOrientation, Int)]
forall k a. Map k a -> [(k, a)]
M.toList
          (Map CoordinateOrientation Int -> [(CoordinateOrientation, Int)])
-> ([AbsoluteDir] -> Map CoordinateOrientation Int)
-> [AbsoluteDir]
-> [(CoordinateOrientation, Int)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [CoordinateOrientation] -> Map CoordinateOrientation Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> Map a Int
histogram
          ([CoordinateOrientation] -> Map CoordinateOrientation Int)
-> ([AbsoluteDir] -> [CoordinateOrientation])
-> [AbsoluteDir]
-> Map CoordinateOrientation Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AbsoluteDir -> CoordinateOrientation)
-> [AbsoluteDir] -> [CoordinateOrientation]
forall a b. (a -> b) -> [a] -> [b]
map AbsoluteDir -> CoordinateOrientation
getCoordinateOrientation
          ([AbsoluteDir] -> [CoordinateOrientation])
-> [AbsoluteDir] -> [CoordinateOrientation]
forall a b. (a -> b) -> a -> b
$ Set AbsoluteDir -> [AbsoluteDir]
forall a. Set a -> [a]
Set.toList Set AbsoluteDir
suppliedOrientations
    RotationalSymmetry
_ -> () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

  SymmetryAnnotatedGrid (NamedGrid a)
-> m (SymmetryAnnotatedGrid (NamedGrid a))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (SymmetryAnnotatedGrid (NamedGrid a)
 -> m (SymmetryAnnotatedGrid (NamedGrid a)))
-> SymmetryAnnotatedGrid (NamedGrid a)
-> m (SymmetryAnnotatedGrid (NamedGrid a))
forall a b. (a -> b) -> a -> b
$ NamedGrid a
-> RotationalSymmetry -> SymmetryAnnotatedGrid (NamedGrid a)
forall a. a -> RotationalSymmetry -> SymmetryAnnotatedGrid a
SymmetryAnnotatedGrid NamedGrid a
ng RotationalSymmetry
symmetryType
 where
  symmetryType :: RotationalSymmetry
symmetryType
    | Grid a
quarterTurnRows Grid a -> Grid a -> Bool
forall a. Eq a => a -> a -> Bool
== Grid a
originalRows = RotationalSymmetry
FourFold
    | Grid a
halfTurnRows Grid a -> Grid a -> Bool
forall a. Eq a => a -> a -> Bool
== Grid a
originalRows = RotationalSymmetry
TwoFold
    | Bool
otherwise = RotationalSymmetry
NoSymmetry

  quarterTurnRows :: Grid a
quarterTurnRows = Orientation -> Grid a -> Grid a
forall a. Orientation -> Grid a -> Grid a
applyOrientationTransform (AbsoluteDir -> Bool -> Orientation
Orientation AbsoluteDir
DWest Bool
False) Grid a
originalRows
  halfTurnRows :: Grid a
halfTurnRows = Orientation -> Grid a -> Grid a
forall a. Orientation -> Grid a -> Grid a
applyOrientationTransform (AbsoluteDir -> Bool -> Orientation
Orientation AbsoluteDir
DSouth Bool
False) Grid a
originalRows

  suppliedOrientations :: Set AbsoluteDir
suppliedOrientations = NamedGrid a -> Set AbsoluteDir
forall a. NamedArea a -> Set AbsoluteDir
Structure.recognize NamedGrid a
ng
  originalRows :: Grid a
originalRows = NamedGrid a -> Grid a
forall a. NamedArea a -> a
Structure.structure NamedGrid a
ng