{-# 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 (forM_, when)
import Data.List.NonEmpty (NonEmpty)
import Data.List.NonEmpty qualified as NE
import Data.Map qualified as M
import Data.Set (Set)
import Data.Set qualified as Set
import Data.Text qualified as T
import Swarm.Game.Scenario.Topography.Placement (Orientation (..), applyOrientationTransformNE)
import Swarm.Game.Scenario.Topography.Structure.Named (recognize)
import Swarm.Game.Scenario.Topography.Structure.Recognition.Static (RotationalSymmetry (..), SymmetryAnnotatedGrid (..))
import Swarm.Game.Scenario.Topography.Structure.Recognition.Type
import Swarm.Language.Syntax.Direction (AbsoluteDir (DSouth, DWest), CoordinateOrientation, getCoordinateOrientation)
import Swarm.Util (commaList, histogram, showT)

data RedundantOrientations
  = TwoFoldRedundancy (NonEmpty CoordinateOrientation)
  | FourFoldRedundancy (Set AbsoluteDir)

renderRedundancy :: RedundantOrientations -> T.Text
renderRedundancy :: RedundantOrientations -> Text
renderRedundancy = \case
  TwoFoldRedundancy NonEmpty CoordinateOrientation
redundantOrientations ->
    [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] -> [Text])
-> [CoordinateOrientation] -> [Text]
forall a b. (a -> b) -> a -> b
$ NonEmpty CoordinateOrientation -> [CoordinateOrientation]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty CoordinateOrientation
redundantOrientations
      , Text
"orientations supplied with two-fold symmetry."
      ]
  FourFoldRedundancy Set AbsoluteDir
_xs ->
    [Text] -> Text
T.unwords
      [ Text
"Redundant orientations supplied; with four-fold symmetry, just supply 'north'."
      ]

-- | 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 ::
  Eq a =>
  ExtractedArea b a ->
  Either RedundantOrientations (SymmetryAnnotatedGrid (ExtractedArea b a))
checkSymmetry :: forall a b.
Eq a =>
ExtractedArea b a
-> Either
     RedundantOrientations (SymmetryAnnotatedGrid (ExtractedArea b a))
checkSymmetry x :: ExtractedArea b a
x@(ExtractedArea NamedArea b
origObject NonEmptyGrid (AtomicKeySymbol a)
originalRows) = do
  case RotationalSymmetry
symmetryType of
    RotationalSymmetry
FourFold ->
      Bool
-> Either RedundantOrientations ()
-> Either RedundantOrientations ()
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) (Either RedundantOrientations ()
 -> Either RedundantOrientations ())
-> (RedundantOrientations -> Either RedundantOrientations ())
-> RedundantOrientations
-> Either RedundantOrientations ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RedundantOrientations -> Either RedundantOrientations ()
forall a b. a -> Either a b
Left (RedundantOrientations -> Either RedundantOrientations ())
-> RedundantOrientations -> Either RedundantOrientations ()
forall a b. (a -> b) -> a -> b
$
        Set AbsoluteDir -> RedundantOrientations
FourFoldRedundancy Set AbsoluteDir
suppliedOrientations
    RotationalSymmetry
TwoFold ->
      Maybe (NonEmpty CoordinateOrientation)
-> (NonEmpty CoordinateOrientation
    -> Either RedundantOrientations Any)
-> Either RedundantOrientations ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([CoordinateOrientation] -> Maybe (NonEmpty CoordinateOrientation)
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty [CoordinateOrientation]
redundantOrientations) ((NonEmpty CoordinateOrientation
  -> Either RedundantOrientations Any)
 -> Either RedundantOrientations ())
-> (NonEmpty CoordinateOrientation
    -> Either RedundantOrientations Any)
-> Either RedundantOrientations ()
forall a b. (a -> b) -> a -> b
$
        RedundantOrientations -> Either RedundantOrientations Any
forall a b. a -> Either a b
Left (RedundantOrientations -> Either RedundantOrientations Any)
-> (NonEmpty CoordinateOrientation -> RedundantOrientations)
-> NonEmpty CoordinateOrientation
-> Either RedundantOrientations Any
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty CoordinateOrientation -> RedundantOrientations
TwoFoldRedundancy
     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
_ -> () -> Either RedundantOrientations ()
forall a. a -> Either RedundantOrientations a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

  SymmetryAnnotatedGrid (ExtractedArea b a)
-> Either
     RedundantOrientations (SymmetryAnnotatedGrid (ExtractedArea b a))
forall a. a -> Either RedundantOrientations a
forall (m :: * -> *) a. Monad m => a -> m a
return (SymmetryAnnotatedGrid (ExtractedArea b a)
 -> Either
      RedundantOrientations (SymmetryAnnotatedGrid (ExtractedArea b a)))
-> SymmetryAnnotatedGrid (ExtractedArea b a)
-> Either
     RedundantOrientations (SymmetryAnnotatedGrid (ExtractedArea b a))
forall a b. (a -> b) -> a -> b
$ RotationalSymmetry
-> ExtractedArea b a -> SymmetryAnnotatedGrid (ExtractedArea b a)
forall a. RotationalSymmetry -> a -> SymmetryAnnotatedGrid a
SymmetryAnnotatedGrid RotationalSymmetry
symmetryType ExtractedArea b a
x
 where
  symmetryType :: RotationalSymmetry
symmetryType
    | NonEmptyGrid (AtomicKeySymbol a)
quarterTurnRows NonEmptyGrid (AtomicKeySymbol a)
-> NonEmptyGrid (AtomicKeySymbol a) -> Bool
forall a. Eq a => a -> a -> Bool
== NonEmptyGrid (AtomicKeySymbol a)
originalRows = RotationalSymmetry
FourFold
    | NonEmptyGrid (AtomicKeySymbol a)
halfTurnRows NonEmptyGrid (AtomicKeySymbol a)
-> NonEmptyGrid (AtomicKeySymbol a) -> Bool
forall a. Eq a => a -> a -> Bool
== NonEmptyGrid (AtomicKeySymbol a)
originalRows = RotationalSymmetry
TwoFold
    | Bool
otherwise = RotationalSymmetry
NoSymmetry

  quarterTurnRows :: NonEmptyGrid (AtomicKeySymbol a)
quarterTurnRows = Orientation
-> NonEmptyGrid (AtomicKeySymbol a)
-> NonEmptyGrid (AtomicKeySymbol a)
forall a. Orientation -> NonEmptyGrid a -> NonEmptyGrid a
applyOrientationTransformNE (AbsoluteDir -> Bool -> Orientation
Orientation AbsoluteDir
DWest Bool
False) NonEmptyGrid (AtomicKeySymbol a)
originalRows
  halfTurnRows :: NonEmptyGrid (AtomicKeySymbol a)
halfTurnRows = Orientation
-> NonEmptyGrid (AtomicKeySymbol a)
-> NonEmptyGrid (AtomicKeySymbol a)
forall a. Orientation -> NonEmptyGrid a -> NonEmptyGrid a
applyOrientationTransformNE (AbsoluteDir -> Bool -> Orientation
Orientation AbsoluteDir
DSouth Bool
False) NonEmptyGrid (AtomicKeySymbol a)
originalRows

  suppliedOrientations :: Set AbsoluteDir
suppliedOrientations = NamedArea b -> Set AbsoluteDir
forall a. NamedArea a -> Set AbsoluteDir
recognize NamedArea b
origObject