My version is similar to what Nicolas did, but I include a reference to the
neighboring cell in Boundary
to make a traversable graph. My data types are
{-# LANGUAGE GADTs #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeFamilies #-}
data Material = Rock | Air
data WallFeature = Lever | Picture | Button deriving Show
type family Other (t :: Material) :: Material
type instance Other Air = Rock
type instance Other Rock = Air
data Tile :: Material -> * where
RockTile :: Tile Rock
AirTile :: Tile Air
data Cell mat where
Cell
:: Tile mat
-> Maybe (Boundary mat n)
-> Maybe (Boundary mat s)
-> Maybe (Boundary mat e)
-> Maybe (Boundary mat w)
-> Cell mat
data Boundary (src :: Material) (dst :: Material) where
Same :: Cell mat -> Boundary mat mat
Diff :: WallFeature -> Cell (Other mat) -> Boundary mat (Other mat)
I decided to make the map bounded, so each cell might or might not have neighbors (hence, Maybe
types for boundaries). The Boundary
data type is
parameterised over the materials of the two adjoining cells and contains a
reference to the destination cell and wall features are structurally restricted to boundaries that join cells of different material.
This is essentially a directed graph so between each adjancent cell A and B there's a boundary of type Boundary matA matB
from A to B and a boundary of type Boundary matB matA
from B to A. This allows for the adjacency relation to be asymmetric, but in practice, you can decide in your code to make all relations symmetric.
Now this is all fine and dandy on a theoretical level but constructing the actual
Cell
graph is quite a pain. So, just for fun, lets make a DSL for defining the
cell relations imperatively and then "tie the knot" to produce the final graph.
Since the cells have different types, you can't simply store them in a temporary list or Data.Map
for the knot-tying so I'm going to use the vault
package. A Vault
is a type-safe, polymorphic container where you can store any type of data and retrieve them in type-safe manner using a Key
that is type-encoded. So, for example, if you have a Key String
you can retrieve a String
out of a Vault
and if you have a Key Int
you can retrieve an Int
value.
So, lets start by defining the operations in the DSL.
data Gen a
new :: Tile a -> Gen (Key (Cell a))
connectSame :: Connection a a -> Key (Cell a) -> Key (Cell a) -> Gen ()
connectDiff
:: (b ~ Other a, a ~ Other b)
=> Connection a b -> WallFeature
-> Key (Cell a) -> Key (Cell b) -> Gen ()
startFrom :: Key (Cell a) -> Gen (Cell a)
The Connection
type determines the cardinal directions where we are connecting
cells and is defined like this:
type Setter a b = Maybe (Boundary a b) -> Cell a -> Cell a
type Connection b a = (Setter a b, Setter b a)
north :: Setter a b
south :: Setter a b
east :: Setter a b
west :: Setter a b
Now we can construct a simple test map using our operations:
testMap :: Gen (Cell Rock)
testMap = do
nw <- new RockTile
ne <- new AirTile
se <- new AirTile
sw <- new AirTile
connectDiff (west,east) Lever nw ne
connectSame (north,south) ne se
connectSame (east,west) se sw
connectDiff (south,north) Button sw nw
startFrom nw
Even though we haven't implemented the functions yet, we can see that this type-checks. Also, if you try to put inconsistent types (like connecting same tile types using a wall-feature) you get a type-error.
The concrete type I'm going to use for Gen
is
type Gen = ReaderT Vault (StateT Vault IO)
The base monad is IO
because that's required to create new Vault
keys (we could also use ST
but this is a bit simpler). We use State Vault
to store newly created cells and to add new boundaries to them, using the vault-key to uniquely identify a cell and to refer to it in the DSL operations.
The third monad in the stack is Reader Vault
which is used to access the vault in its fully constructed state. I.e. while we are building the vault in State
, we can use Reader
to "see into the future" where the vault already contains all the cells with their final boundaries. In practice, this is achieved by using mfix
to get the "monadic fixed point" (for more details, see e.g. the paper "Value Recursion in Monadic Computations" or the MonadFix wiki page).
So, to run our map constructor, we define
import Control.Monad.State
import Control.Monad.Reader
import Data.Vault.Lazy as V
runGen :: Gen a -> IO a
runGen g = fmap fst $ mfix $ \(~(_, v)) -> runStateT (runReaderT g v) V.empty
Here we run the stateful computation and get out a value of type (a, Vault)
i.e. the result from the computation and the vault which contains all our cells. Via mfix
we can access the result before we compute it, so we can feed the result vault as a parameter to runReaderT
. Hence, inside the monad, we can use get
(from MonadState
) to access the incomplete vault that is being constructed and ask
(from MonadReader
) to access the fully completed vault.
Now rest of the implementation is straightforward:
new :: Tile a -> Gen (Key (Cell a))
new t = do
k <- liftIO $ newKey
modify $ V.insert k $ Cell t Nothing Nothing Nothing Nothing
return k
new
creates a new vault key and uses it to insert a new cell with no boundaries.
connectSame :: Connection a a -> Key (Cell a) -> Key (Cell a) -> Gen ()
connectSame (s2,s1) ka kb = do
v <- ask
let b1 = fmap Same $ V.lookup kb v
b2 = fmap Same $ V.lookup ka v
modify $ adjust (s1 b1) ka . adjust (s2 b2) kb
connectSame
accesses the "future vault" via ask
so we can look up the neighboring cell from there and store it in the boundary.
connectDiff
:: (b ~ Other a, a ~ Other b)
=> Connection a b -> WallFeature
-> Key (Cell a) -> Key (Cell b) -> Gen ()
connectDiff (s2, s1) wf ka kb = do
v <- ask
let b1 = fmap (Diff wf) $ V.lookup kb v
b2 = fmap (Diff wf) $ V.lookup ka v
modify $ adjust (s1 b1) ka . adjust (s2 b2) kb
connectDiff
is pretty much the same except that we provide the additional wall-feature. We also need the explicit constraint (b ~ Other a, a ~ Other b)
to
construct two symmetric boundaries.
startFrom :: Key (Cell a) -> Gen (Cell a)
startFrom k = fmap (fromJust . V.lookup k) ask
startFrom
just retrieves the completed cell with the given key so we can return
it as a result from our generator.
Here's the complete example source with additional Show
instances for debugging so you can try this yourself:
{-# LANGUAGE GADTs #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeFamilies #-}
import Control.Monad.State
import Control.Monad.Reader
import Data.Vault.Lazy as V
import Data.Maybe
data Material = Rock | Air
data WallFeature = Lever | Picture | Button deriving Show
type family Other (t :: Material) :: Material
type instance Other Air = Rock
type instance Other Rock = Air
data Tile :: Material -> * where
RockTile :: Tile Rock
AirTile :: Tile Air
data Cell mat where
Cell
:: Tile mat
-> Maybe (Boundary mat n)
-> Maybe (Boundary mat s)
-> Maybe (Boundary mat e)
-> Maybe (Boundary mat w)
-> Cell mat
data Boundary (a :: Material) (b :: Material) where
Same :: Cell mat -> Boundary mat mat
Diff :: WallFeature -> Cell (Other mat) -> Boundary mat (Other mat)
type Gen = ReaderT Vault (StateT Vault IO)
type Setter a b = Maybe (Boundary a b) -> Cell a -> Cell a
type Connection b a = (Setter a b, Setter b a)
-- Boundary setters
north :: Setter a b
north n (Cell t _ s e w) = Cell t n s e w
south :: Setter a b
south s (Cell t n _ e w) = Cell t n s e w
east :: Setter a b
east e (Cell t n s _ w) = Cell t n s e w
west :: Setter a b
west w (Cell t n s e _) = Cell t n s e w
new :: Tile a -> Gen (Key (Cell a))
new t = do
k <- liftIO $ newKey
modify $ V.insert k $ Cell t Nothing Nothing Nothing Nothing
return k
connectSame :: Connection a a -> Key (Cell a) -> Key (Cell a) -> Gen ()
connectSame (s2,s1) ka kb = do
v <- ask
let b1 = fmap Same $ V.lookup kb v
b2 = fmap Same $ V.lookup ka v
modify $ adjust (s1 b1) ka . adjust (s2 b2) kb
connectDiff
:: (b ~ Other a, a ~ Other b)
=> Connection a b -> WallFeature
-> Key (Cell a) -> Key (Cell b) -> Gen ()
connectDiff (s2, s1) wf ka kb = do
v <- ask
let b1 = fmap (Diff wf) $ V.lookup kb v
b2 = fmap (Diff wf) $ V.lookup ka v
modify $ adjust (s1 b1) ka . adjust (s2 b2) kb
startFrom :: Key (Cell a) -> Gen (Cell a)
startFrom k = fmap (fromJust . V.lookup k) ask
runGen :: Gen a -> IO a
runGen g = fmap fst $ mfix $ \(~(_, v)) -> runStateT (runReaderT g v) V.empty
testMap :: Gen (Cell Rock)
testMap = do
nw <- new RockTile
ne <- new AirTile
se <- new AirTile
sw <- new AirTile
connectDiff (west,east) Lever nw ne
connectSame (north,south) ne se
connectSame (east,west) se sw
connectDiff (south,north) Button sw nw
startFrom nw
main :: IO ()
main = do
c <- runGen testMap
print c
-- Show Instances
instance Show (Cell mat) where
show (Cell t n s e w)
= unwords ["Cell", show t, show n, show s, show e, show w]
instance Show (Boundary a b) where
show (Same _) = "<Same>"
show (Diff wf _) = "<Diff with " ++ show wf ++ ">"
instance Show (Tile mat) where
show RockTile = "RockTile"
show AirTile = "AirTile"