{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}

-- |
-- SPDX-License-Identifier: BSD-3-Clause
--
-- Utilities for working with procedurally generated worlds.
module Swarm.Game.World.Gen where

import Control.Lens (view)
import Data.Enumeration
import Data.Int (Int32)
import Data.List (find)
import Data.Maybe (fromMaybe, mapMaybe)
import Data.Semigroup (Last (..), getLast)
import Data.Set qualified as S
import Data.Text (Text)
import Swarm.Game.Entity
import Swarm.Game.World
import Swarm.Game.World.Syntax (CellVal (..))
import Swarm.Game.World.Typecheck (Const (CCell), TTerm (..))
import Swarm.Util.Erasable

type Seed = Int

-- | Extract a list of all entities mentioned in a given world DSL term.
extractEntities :: TTerm g a -> S.Set Entity
extractEntities :: forall (g :: [*]) a. TTerm g a -> Set Entity
extractEntities (TLam TTerm (ty1 : g) ty2
t) = forall (g :: [*]) a. TTerm g a -> Set Entity
extractEntities TTerm (ty1 : g) ty2
t
extractEntities (TApp TTerm g (a1 -> a)
t1 TTerm g a1
t2) = forall (g :: [*]) a. TTerm g a -> Set Entity
extractEntities TTerm g (a1 -> a)
t1 forall a. Semigroup a => a -> a -> a
<> forall (g :: [*]) a. TTerm g a -> Set Entity
extractEntities TTerm g a1
t2
extractEntities (TConst (CCell (CellVal TerrainType
_ Erasable (Last Entity)
ee [Robot]
_))) = forall {a}. Erasable (Last a) -> Set a
getEntity Erasable (Last Entity)
ee
 where
  getEntity :: Erasable (Last a) -> Set a
getEntity (EJust (Last a
e)) = forall a. a -> Set a
S.singleton a
e
  getEntity Erasable (Last a)
_ = forall a. Set a
S.empty
extractEntities TTerm g a
_ = forall a. Set a
S.empty

-- | Offset a world by a multiple of the @skip@ in such a way that it
--   satisfies the given predicate.
findOffset :: Integer -> ((Coords -> (t, Erasable (Last e))) -> Bool) -> WorldFun t e -> WorldFun t e
findOffset :: forall t e.
Integer
-> ((Coords -> (t, Erasable (Last e))) -> Bool)
-> WorldFun t e
-> WorldFun t e
findOffset Integer
skip (Coords -> (t, Erasable (Last e))) -> Bool
isGood (WF Coords -> (t, Erasable (Last e))
f) = forall t e. (Coords -> (t, Erasable (Last e))) -> WorldFun t e
WF Coords -> (t, Erasable (Last e))
f'
 where
  offset :: Enumeration Int32
  offset :: Enumeration Int32
offset = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Integer
skip forall a. Num a => a -> a -> a
*) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Enumeration Integer
int

  f' :: Coords -> (t, Erasable (Last e))
f' =
    forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => [Char] -> a
error [Char]
"the impossible happened, no offsets were found!")
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (Coords -> (t, Erasable (Last e))) -> Bool
isGood
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (Int32, Int32) -> Coords -> (t, Erasable (Last e))
shift
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Enumeration a -> [a]
enumerate
      forall a b. (a -> b) -> a -> b
$ Enumeration Int32
offset forall a b. Enumeration a -> Enumeration b -> Enumeration (a, b)
>< Enumeration Int32
offset

  shift :: (Int32, Int32) -> Coords -> (t, Erasable (Last e))
shift (Int32
dr, Int32
dc) (Coords (Int32
r, Int32
c)) = Coords -> (t, Erasable (Last e))
f ((Int32, Int32) -> Coords
Coords (Int32
r forall a. Num a => a -> a -> a
- Int32
dr, Int32
c forall a. Num a => a -> a -> a
- Int32
dc))

-- | Offset the world so the base starts in a 32x32 patch containing at least one
--   of each of a list of required entities.
findPatchWith :: [Text] -> WorldFun t Entity -> WorldFun t Entity
findPatchWith :: forall t. [Text] -> WorldFun t Entity -> WorldFun t Entity
findPatchWith [Text]
reqs = forall t e.
Integer
-> ((Coords -> (t, Erasable (Last e))) -> Bool)
-> WorldFun t e
-> WorldFun t e
findOffset Integer
32 (Coords -> (t, Erasable (Last Entity))) -> Bool
isGoodPatch
 where
  patchCoords :: [(Int32, Int32)]
patchCoords = [(Int32
r, Int32
c) | Int32
r <- [-Int32
16 .. Int32
16], Int32
c <- [-Int32
16 .. Int32
16]]
  isGoodPatch :: (Coords -> (t, Erasable (Last Entity))) -> Bool
isGoodPatch Coords -> (t, Erasable (Last Entity))
f = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (forall a. Ord a => a -> Set a -> Bool
`S.member` Set Text
es) [Text]
reqs
   where
    es :: Set Text
es = forall a. Ord a => [a] -> Set a
S.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' Entity Text
entityName) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (forall e. Erasable e -> Maybe e
erasableToMaybe forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Last a -> a
getLast forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. Coords -> (t, Erasable (Last Entity))
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int32, Int32) -> Coords
Coords) forall a b. (a -> b) -> a -> b
$ [(Int32, Int32)]
patchCoords

-- | Offset the world so the base starts on empty spot next to tree and grass.
findTreeOffset :: WorldFun t Entity -> WorldFun t Entity
findTreeOffset :: forall t. WorldFun t Entity -> WorldFun t Entity
findTreeOffset = forall t e.
Integer
-> ((Coords -> (t, Erasable (Last e))) -> Bool)
-> WorldFun t e
-> WorldFun t e
findOffset Integer
1 (Coords -> (t, Erasable (Last Entity))) -> Bool
isGoodPlace
 where
  isGoodPlace :: (Coords -> (t, Erasable (Last Entity))) -> Bool
isGoodPlace Coords -> (t, Erasable (Last Entity))
f =
    Maybe Text -> (Int32, Int32) -> Bool
hasEntity forall a. Maybe a
Nothing (Int32
0, Int32
0)
      Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Maybe Text -> (Int32, Int32) -> Bool
hasEntity (forall a. a -> Maybe a
Just Text
"tree")) [(Int32, Int32)]
neighbors
      Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\(Int32, Int32)
c -> Maybe Text -> (Int32, Int32) -> Bool
hasEntity (forall a. a -> Maybe a
Just Text
"tree") (Int32, Int32)
c Bool -> Bool -> Bool
|| Maybe Text -> (Int32, Int32) -> Bool
hasEntity forall a. Maybe a
Nothing (Int32, Int32)
c) [(Int32, Int32)]
neighbors
   where
    hasEntity :: Maybe Text -> (Int32, Int32) -> Bool
hasEntity Maybe Text
mayE = (forall a. Eq a => a -> a -> Bool
== Maybe Text
mayE) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. Erasable e -> Maybe e
erasableToMaybe forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' Entity Text
entityName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Last a -> a
getLast) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. Coords -> (t, Erasable (Last Entity))
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int32, Int32) -> Coords
Coords

  neighbors :: [(Int32, Int32)]
neighbors = [(Int32
r, Int32
c) | Int32
r <- [-Int32
1 .. Int32
1], Int32
c <- [-Int32
1 .. Int32
1]]

-- | Offset the world so the base starts in a good patch (near
--   necessary items), next to a tree.
findGoodOrigin :: WorldFun t Entity -> WorldFun t Entity
findGoodOrigin :: forall t. WorldFun t Entity -> WorldFun t Entity
findGoodOrigin = forall t. WorldFun t Entity -> WorldFun t Entity
findTreeOffset forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. [Text] -> WorldFun t Entity -> WorldFun t Entity
findPatchWith [Text
"tree", Text
"copper ore", Text
"bit (0)", Text
"bit (1)", Text
"rock", Text
"lambda", Text
"water", Text
"sand"]