{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
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
extractEntities :: TTerm g a -> S.Set Entity
(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
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))
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
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]]
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"]