-- |
-- SPDX-License-Identifier: BSD-3-Clause
module Swarm.TUI.Editor.Util where

import Control.Applicative ((<|>))
import Control.Lens hiding (Const, from)
import Control.Monad (guard)
import Data.Map qualified as M
import Data.Map qualified as Map
import Data.Maybe qualified as Maybe
import Data.Vector qualified as V
import Swarm.Game.Entity
import Swarm.Game.Scenario.Topography.Area qualified as EA
import Swarm.Game.Scenario.Topography.Cell
import Swarm.Game.Scenario.Topography.EntityFacade
import Swarm.Game.Scenario.Topography.WorldDescription
import Swarm.Game.Terrain (TerrainType)
import Swarm.Game.Universe
import Swarm.Game.World qualified as W
import Swarm.TUI.Editor.Model
import Swarm.Util.Erasable

getEntitiesForList :: EntityMap -> V.Vector EntityFacade
getEntitiesForList :: EntityMap -> Vector EntityFacade
getEntitiesForList EntityMap
em =
  forall a. [a] -> Vector a
V.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Entity -> EntityFacade
mkFacade [Entity]
entities
 where
  entities :: [Entity]
entities = forall k a. Map k a -> [a]
M.elems forall a b. (a -> b) -> a -> b
$ EntityMap -> Map Text Entity
entitiesByName EntityMap
em

getEditingBounds :: WorldDescription -> (Bool, Cosmic W.BoundsRectangle)
getEditingBounds :: WorldDescription -> (Bool, Cosmic BoundsRectangle)
getEditingBounds WorldDescription
myWorld =
  (AreaDimensions -> Bool
EA.isEmpty AreaDimensions
a, Cosmic BoundsRectangle
newBounds)
 where
  newBounds :: Cosmic BoundsRectangle
newBounds = forall a. SubworldName -> a -> Cosmic a
Cosmic SubworldName
DefaultRootSubworld (Location -> Coords
W.locToCoords Location
upperLeftLoc, Location -> Coords
W.locToCoords Location
lowerRightLoc)
  upperLeftLoc :: Location
upperLeftLoc = forall e. PWorldDescription e -> Location
ul WorldDescription
myWorld
  a :: AreaDimensions
a = forall a. [[a]] -> AreaDimensions
EA.getAreaDimensions forall a b. (a -> b) -> a -> b
$ forall e. PWorldDescription e -> [[PCell e]]
area WorldDescription
myWorld
  lowerRightLoc :: Location
lowerRightLoc = AreaDimensions -> Location -> Location
EA.upperLeftToBottomRight AreaDimensions
a Location
upperLeftLoc

getContentAt :: W.MultiWorld Int e -> Cosmic W.Coords -> (TerrainType, Maybe e)
getContentAt :: forall e.
MultiWorld Int e -> Cosmic Coords -> (TerrainType, Maybe e)
getContentAt MultiWorld Int e
w Cosmic Coords
coords = (TerrainType
underlyingCellTerrain, Maybe e
underlyingCellEntity)
 where
  underlyingCellEntity :: Maybe e
underlyingCellEntity = forall t e. Cosmic Coords -> MultiWorld t e -> Maybe e
W.lookupCosmicEntity Cosmic Coords
coords MultiWorld Int e
w
  underlyingCellTerrain :: TerrainType
underlyingCellTerrain = forall e.
IArray UArray Int =>
Cosmic Coords -> MultiWorld Int e -> TerrainType
W.lookupCosmicTerrain Cosmic Coords
coords MultiWorld Int e
w

getEditorContentAt ::
  WorldOverdraw ->
  W.MultiWorld Int Entity ->
  Cosmic W.Coords ->
  (TerrainType, Maybe EntityPaint)
getEditorContentAt :: WorldOverdraw
-> MultiWorld Int Entity
-> Cosmic Coords
-> (TerrainType, Maybe EntityPaint)
getEditorContentAt WorldOverdraw
editorOverdraw MultiWorld Int Entity
w Cosmic Coords
coords =
  (TerrainType
terrainWithOverride, Maybe EntityPaint
entityWithOverride)
 where
  terrainWithOverride :: TerrainType
terrainWithOverride = forall a. a -> Maybe a -> a
Maybe.fromMaybe TerrainType
underlyingCellTerrain forall a b. (a -> b) -> a -> b
$ do
    (TerrainType
terrainOverride, Erasable EntityFacade
_) <- Maybe (TerrainType, Erasable EntityFacade)
maybePaintedCell
    forall (m :: * -> *) a. Monad m => a -> m a
return TerrainType
terrainOverride

  maybeEntityOverride :: Maybe EntityPaint
  maybeEntityOverride :: Maybe EntityPaint
maybeEntityOverride = do
    (TerrainType
_, Erasable EntityFacade
e) <- Maybe (TerrainType, Erasable EntityFacade)
maybePaintedCell
    EntityFacade -> EntityPaint
Facade forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e. Erasable e -> Maybe e
erasableToMaybe Erasable EntityFacade
e

  maybePaintedCell :: Maybe (TerrainType, Erasable EntityFacade)
maybePaintedCell = do
    forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ WorldOverdraw
editorOverdraw forall s a. s -> Getting a s a -> a
^. Lens' WorldOverdraw Bool
isWorldEditorEnabled
    forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Cosmic Coords
coords forall s a. s -> Getting a s a -> a
^. forall a1 a2. Lens (Cosmic a1) (Cosmic a2) a1 a2
planar) Map Coords (TerrainType, Erasable EntityFacade)
pm

  pm :: Map Coords (TerrainType, Erasable EntityFacade)
pm = WorldOverdraw
editorOverdraw forall s a. s -> Getting a s a -> a
^. Lens'
  WorldOverdraw (Map Coords (TerrainType, Erasable EntityFacade))
paintedTerrain

  entityWithOverride :: Maybe EntityPaint
entityWithOverride = (Entity -> EntityPaint
Ref forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Entity
underlyingCellEntity) forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe EntityPaint
maybeEntityOverride
  (TerrainType
underlyingCellTerrain, Maybe Entity
underlyingCellEntity) = forall e.
MultiWorld Int e -> Cosmic Coords -> (TerrainType, Maybe e)
getContentAt MultiWorld Int Entity
w Cosmic Coords
coords

getEditorTerrainAt ::
  WorldOverdraw ->
  W.MultiWorld Int Entity ->
  Cosmic W.Coords ->
  TerrainType
getEditorTerrainAt :: WorldOverdraw
-> MultiWorld Int Entity -> Cosmic Coords -> TerrainType
getEditorTerrainAt WorldOverdraw
editor MultiWorld Int Entity
w Cosmic Coords
coords =
  forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ WorldOverdraw
-> MultiWorld Int Entity
-> Cosmic Coords
-> (TerrainType, Maybe EntityPaint)
getEditorContentAt WorldOverdraw
editor MultiWorld Int Entity
w Cosmic Coords
coords

isOutsideTopLeftCorner ::
  -- | top left corner coords
  W.Coords ->
  -- | current coords
  W.Coords ->
  Bool
isOutsideTopLeftCorner :: Coords -> Coords -> Bool
isOutsideTopLeftCorner (W.Coords (Int32
yTop, Int32
xLeft)) (W.Coords (Int32
y, Int32
x)) =
  Int32
x forall a. Ord a => a -> a -> Bool
< Int32
xLeft Bool -> Bool -> Bool
|| Int32
y forall a. Ord a => a -> a -> Bool
< Int32
yTop

isOutsideBottomRightCorner ::
  -- | bottom right corner coords
  W.Coords ->
  -- | current coords
  W.Coords ->
  Bool
isOutsideBottomRightCorner :: Coords -> Coords -> Bool
isOutsideBottomRightCorner (W.Coords (Int32
yBottom, Int32
xRight)) (W.Coords (Int32
y, Int32
x)) =
  Int32
x forall a. Ord a => a -> a -> Bool
> Int32
xRight Bool -> Bool -> Bool
|| Int32
y forall a. Ord a => a -> a -> Bool
> Int32
yBottom

isOutsideRegion ::
  -- | full bounds
  W.BoundsRectangle ->
  -- | current coords
  W.Coords ->
  Bool
isOutsideRegion :: BoundsRectangle -> Coords -> Bool
isOutsideRegion (Coords
tl, Coords
br) Coords
coord =
  Coords -> Coords -> Bool
isOutsideTopLeftCorner Coords
tl Coords
coord Bool -> Bool -> Bool
|| Coords -> Coords -> Bool
isOutsideBottomRightCorner Coords
br Coords
coord

getEditedMapRectangle ::
  WorldOverdraw ->
  Maybe (Cosmic W.BoundsRectangle) ->
  W.MultiWorld Int Entity ->
  [[CellPaintDisplay]]
getEditedMapRectangle :: WorldOverdraw
-> Maybe (Cosmic BoundsRectangle)
-> MultiWorld Int Entity
-> [[CellPaintDisplay]]
getEditedMapRectangle WorldOverdraw
_ Maybe (Cosmic BoundsRectangle)
Nothing MultiWorld Int Entity
_ = []
getEditedMapRectangle WorldOverdraw
worldEditor (Just (Cosmic SubworldName
subworldName BoundsRectangle
coords)) MultiWorld Int Entity
w =
  forall d e.
(d -> e)
-> (Coords -> (TerrainType, Maybe d))
-> BoundsRectangle
-> [[PCell e]]
getMapRectangle EntityPaint -> EntityFacade
toFacade Coords -> (TerrainType, Maybe EntityPaint)
getContent BoundsRectangle
coords
 where
  getContent :: Coords -> (TerrainType, Maybe EntityPaint)
getContent = WorldOverdraw
-> MultiWorld Int Entity
-> Cosmic Coords
-> (TerrainType, Maybe EntityPaint)
getEditorContentAt WorldOverdraw
worldEditor MultiWorld Int Entity
w forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. SubworldName -> a -> Cosmic a
Cosmic SubworldName
subworldName

getMapRectangle ::
  (d -> e) ->
  (W.Coords -> (TerrainType, Maybe d)) ->
  W.BoundsRectangle ->
  [[PCell e]]
getMapRectangle :: forall d e.
(d -> e)
-> (Coords -> (TerrainType, Maybe d))
-> BoundsRectangle
-> [[PCell e]]
getMapRectangle d -> e
paintTransform Coords -> (TerrainType, Maybe d)
contentFunc BoundsRectangle
coords =
  forall a b. (a -> b) -> [a] -> [b]
map Int32 -> [PCell e]
renderRow [Int32
yTop .. Int32
yBottom]
 where
  (W.Coords (Int32
yTop, Int32
xLeft), W.Coords (Int32
yBottom, Int32
xRight)) = BoundsRectangle
coords

  drawCell :: (d -> e) -> Int32 -> Int32 -> PCell e
drawCell d -> e
f Int32
rowIndex Int32
colIndex =
    forall e. TerrainType -> Erasable e -> [IndexedTRobot] -> PCell e
Cell
      TerrainType
terrain
      (d -> e
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e. Maybe e -> Erasable e
maybeToErasable Maybe d
erasableEntity)
      []
   where
    (TerrainType
terrain, Maybe d
erasableEntity) = Coords -> (TerrainType, Maybe d)
contentFunc forall a b. (a -> b) -> a -> b
$ (Int32, Int32) -> Coords
W.Coords (Int32
rowIndex, Int32
colIndex)

  renderRow :: Int32 -> [PCell e]
renderRow Int32
rowIndex = forall a b. (a -> b) -> [a] -> [b]
map (forall {e}. (d -> e) -> Int32 -> Int32 -> PCell e
drawCell d -> e
paintTransform Int32
rowIndex) [Int32
xLeft .. Int32
xRight]