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: