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 ::
W.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 ::
W.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 ::
W.BoundsRectangle ->
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]