{-# 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.Coords
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) = TTerm (ty1 : g) ty2 -> Set Entity
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) = TTerm g (a1 -> a) -> Set Entity
forall (g :: [*]) a. TTerm g a -> Set Entity
extractEntities TTerm g (a1 -> a)
t1 Set Entity -> Set Entity -> Set Entity
forall a. Semigroup a => a -> a -> a
<> TTerm g a1 -> Set Entity
forall (g :: [*]) a. TTerm g a -> Set Entity
extractEntities TTerm g a1
t2
extractEntities (TConst (CCell (CellVal TerrainType
_ Erasable (Last Entity)
ee [TRobot]
_))) = Erasable (Last Entity) -> Set Entity
forall {a}. Erasable (Last a) -> Set a
getEntity Erasable (Last Entity)
ee
 where
  getEntity :: Erasable (Last a) -> Set a
getEntity (EJust (Last a
e)) = a -> Set a
forall a. a -> Set a
S.singleton a
e
  getEntity Erasable (Last a)
_ = Set a
forall a. Set a
S.empty
extractEntities TTerm g a
_ = Set Entity
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) = (Coords -> (t, Erasable (Last e))) -> WorldFun t e
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 = Integer -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Int32) -> (Integer -> Integer) -> Integer -> Int32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Integer
skip Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
*) (Integer -> Int32) -> Enumeration Integer -> Enumeration Int32
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Enumeration Integer
int

  f' :: Coords -> (t, Erasable (Last e))
f' =
    (Coords -> (t, Erasable (Last e)))
-> Maybe (Coords -> (t, Erasable (Last e)))
-> Coords
-> (t, Erasable (Last e))
forall a. a -> Maybe a -> a
fromMaybe ([Char] -> Coords -> (t, Erasable (Last e))
forall a. HasCallStack => [Char] -> a
error [Char]
"the impossible happened, no offsets were found!")
      (Maybe (Coords -> (t, Erasable (Last e)))
 -> Coords -> (t, Erasable (Last e)))
-> (Enumeration (Int32, Int32)
    -> Maybe (Coords -> (t, Erasable (Last e))))
-> Enumeration (Int32, Int32)
-> Coords
-> (t, Erasable (Last e))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Coords -> (t, Erasable (Last e))) -> Bool)
-> [Coords -> (t, Erasable (Last e))]
-> Maybe (Coords -> (t, Erasable (Last e)))
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (Coords -> (t, Erasable (Last e))) -> Bool
isGood
      ([Coords -> (t, Erasable (Last e))]
 -> Maybe (Coords -> (t, Erasable (Last e))))
-> (Enumeration (Int32, Int32)
    -> [Coords -> (t, Erasable (Last e))])
-> Enumeration (Int32, Int32)
-> Maybe (Coords -> (t, Erasable (Last e)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int32, Int32) -> Coords -> (t, Erasable (Last e)))
-> [(Int32, Int32)] -> [Coords -> (t, Erasable (Last e))]
forall a b. (a -> b) -> [a] -> [b]
map (Int32, Int32) -> Coords -> (t, Erasable (Last e))
shift
      ([(Int32, Int32)] -> [Coords -> (t, Erasable (Last e))])
-> (Enumeration (Int32, Int32) -> [(Int32, Int32)])
-> Enumeration (Int32, Int32)
-> [Coords -> (t, Erasable (Last e))]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Enumeration (Int32, Int32) -> [(Int32, Int32)]
forall a. Enumeration a -> [a]
enumerate
      (Enumeration (Int32, Int32) -> Coords -> (t, Erasable (Last e)))
-> Enumeration (Int32, Int32) -> Coords -> (t, Erasable (Last e))
forall a b. (a -> b) -> a -> b
$ Enumeration Int32
offset Enumeration Int32
-> Enumeration Int32 -> Enumeration (Int32, Int32)
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 Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
- Int32
dr, Int32
c Int32 -> Int32 -> Int32
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 = Integer
-> ((Coords -> (t, Erasable (Last Entity))) -> Bool)
-> WorldFun t Entity
-> WorldFun t Entity
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 = (Text -> Bool) -> [Text] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Text -> Set Text -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set Text
es) [Text]
reqs
   where
    es :: Set Text
es = [Text] -> Set Text
forall a. Ord a => [a] -> Set a
S.fromList ([Text] -> Set Text)
-> ([(Int32, Int32)] -> [Text]) -> [(Int32, Int32)] -> Set Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Entity -> Text) -> [Entity] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Getting Text Entity Text -> Entity -> Text
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Text Entity Text
Lens' Entity Text
entityName) ([Entity] -> [Text])
-> ([(Int32, Int32)] -> [Entity]) -> [(Int32, Int32)] -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int32, Int32) -> Maybe Entity) -> [(Int32, Int32)] -> [Entity]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Erasable Entity -> Maybe Entity
forall e. Erasable e -> Maybe e
erasableToMaybe (Erasable Entity -> Maybe Entity)
-> ((Int32, Int32) -> Erasable Entity)
-> (Int32, Int32)
-> Maybe Entity
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Last Entity -> Entity)
-> Erasable (Last Entity) -> Erasable Entity
forall a b. (a -> b) -> Erasable a -> Erasable b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Last Entity -> Entity
forall a. Last a -> a
getLast (Erasable (Last Entity) -> Erasable Entity)
-> ((Int32, Int32) -> Erasable (Last Entity))
-> (Int32, Int32)
-> Erasable Entity
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (t, Erasable (Last Entity)) -> Erasable (Last Entity)
forall a b. (a, b) -> b
snd ((t, Erasable (Last Entity)) -> Erasable (Last Entity))
-> ((Int32, Int32) -> (t, Erasable (Last Entity)))
-> (Int32, Int32)
-> Erasable (Last Entity)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Coords -> (t, Erasable (Last Entity))
f (Coords -> (t, Erasable (Last Entity)))
-> ((Int32, Int32) -> Coords)
-> (Int32, Int32)
-> (t, Erasable (Last Entity))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int32, Int32) -> Coords
Coords) ([(Int32, Int32)] -> Set Text) -> [(Int32, Int32)] -> Set Text
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 = Integer
-> ((Coords -> (t, Erasable (Last Entity))) -> Bool)
-> WorldFun t Entity
-> WorldFun t Entity
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 Maybe Text
forall a. Maybe a
Nothing (Int32
0, Int32
0)
      Bool -> Bool -> Bool
&& ((Int32, Int32) -> Bool) -> [(Int32, Int32)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Maybe Text -> (Int32, Int32) -> Bool
hasEntity (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"tree")) [(Int32, Int32)]
neighbors
      Bool -> Bool -> Bool
&& ((Int32, Int32) -> Bool) -> [(Int32, Int32)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\(Int32, Int32)
c -> Maybe Text -> (Int32, Int32) -> Bool
hasEntity (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"tree") (Int32, Int32)
c Bool -> Bool -> Bool
|| Maybe Text -> (Int32, Int32) -> Bool
hasEntity Maybe Text
forall a. Maybe a
Nothing (Int32, Int32)
c) [(Int32, Int32)]
neighbors
   where
    hasEntity :: Maybe Text -> (Int32, Int32) -> Bool
hasEntity Maybe Text
mayE = (Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe Text
mayE) (Maybe Text -> Bool)
-> ((Int32, Int32) -> Maybe Text) -> (Int32, Int32) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Erasable Text -> Maybe Text
forall e. Erasable e -> Maybe e
erasableToMaybe (Erasable Text -> Maybe Text)
-> ((Int32, Int32) -> Erasable Text)
-> (Int32, Int32)
-> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Last Entity -> Text) -> Erasable (Last Entity) -> Erasable Text
forall a b. (a -> b) -> Erasable a -> Erasable b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Getting Text Entity Text -> Entity -> Text
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Text Entity Text
Lens' Entity Text
entityName (Entity -> Text) -> (Last Entity -> Entity) -> Last Entity -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Last Entity -> Entity
forall a. Last a -> a
getLast) (Erasable (Last Entity) -> Erasable Text)
-> ((Int32, Int32) -> Erasable (Last Entity))
-> (Int32, Int32)
-> Erasable Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (t, Erasable (Last Entity)) -> Erasable (Last Entity)
forall a b. (a, b) -> b
snd ((t, Erasable (Last Entity)) -> Erasable (Last Entity))
-> ((Int32, Int32) -> (t, Erasable (Last Entity)))
-> (Int32, Int32)
-> Erasable (Last Entity)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Coords -> (t, Erasable (Last Entity))
f (Coords -> (t, Erasable (Last Entity)))
-> ((Int32, Int32) -> Coords)
-> (Int32, Int32)
-> (t, Erasable (Last Entity))
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 = WorldFun t Entity -> WorldFun t Entity
forall t. WorldFun t Entity -> WorldFun t Entity
findTreeOffset (WorldFun t Entity -> WorldFun t Entity)
-> (WorldFun t Entity -> WorldFun t Entity)
-> WorldFun t Entity
-> WorldFun t Entity
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> WorldFun t Entity -> WorldFun t Entity
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"]