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"
