Representing map constraints as a ADT

StackOverflow https://stackoverflow.com/questions/18594882

Question

Here's a toy problem:

A (roguelike) 2D map consists of square cells which each have a material (rock or air).

Each cell has four boundaries (N, S, E and W). Each boundary is shared by two cells.

A boundary can optionally contain a "wall feature" only if one side is rock and the other air.

(Wall features could be levers, pictures, buttons, etc.)

What Algebraic Data Type design could have a place to store a wall feature only when one side is rock and the other air? i.e. the data structure cannot represent a wall feature on a boundary between two air cells or two rock cells.

One approach I've tried is XORing a chess-board pattern over the cell values, reversing changes and non-changed.

I keep getting myself in knots over the fact there are multiple equivalent routes between cells - SSW is the same as SWS (the 1D version of this question is trivial).

(I recognise that the ADT representation will not be particularly 'queriable'.)

Update with Failed Attempt:

Call the East boundaries E and the South boundaries S. Let each boundary be either Same or Diff Feature. The problem with this approach is that it lets inconsistent routes exist, such as:

E<0,0> Same
S<1,0> Same
S<0,0> Same
E<0,1> Diff

Is there a mathematical name for saying that different routes must aggregate to the same total?

You could say that Same was 1 and Diff was -1 and that product along every route between any two cells must be equal (either 1 or -1).

Was it helpful?

Solution

I have no idea if this is possible at all with traditional ADTs, but you can do it with GADTs. This has a map infinite in one dimension, and finite in the other:

{-# LANGUAGE GADTs #-}


data Nil
type AirEnd = AirCell Nil
type RockEnd = RockCell Nil

data AirCell next
data RockCell next

data WallFeature = Lever | Picture | Buttons | Etc ()
type Wall = Maybe WallFeature


data RogueStrip contents neighbour where

  AirEnd_ngbAir :: RogueStrip AirEnd AirEnd
  AirEnd_ngbRock :: Wall -> RogueStrip AirEnd RockEnd
  RockEnd_ngbAir :: Wall -> RogueStrip RockEnd AirEnd
  RockEnd_ngbRock :: RogueStrip RockEnd RockEnd

  AirCons_nextAir_ngbAir ::
          RogueStrip          (AirCell next')           neighbourNext
       -> RogueStrip (AirCell (AirCell next')) (AirCell neighbourNext)
  AirCons_nextAir_ngbRock :: Wall ->
          RogueStrip          (AirCell next')            neighbourNext
       -> RogueStrip (AirCell (AirCell next')) (RockCell neighbourNext)
  AirCons_nextRock_ngbAir :: Wall ->
          RogueStrip          (RockCell next')           neighbourNext
       -> RogueStrip (AirCell (RockCell next')) (AirCell neighbourNext)
  AirCons_nextRock_ngbRock :: Wall -> Wall ->
          RogueStrip          (RockCell next')            neighbourNext
       -> RogueStrip (AirCell (RockCell next')) (RockCell neighbourNext)
  RockCons_nextAir_ngbAir :: Wall -> Wall ->
          RogueStrip           (AirCell next')           neighbourNext
       -> RogueStrip (RockCell (AirCell next')) (AirCell neighbourNext)
  RockCons_nextAir_ngbRock :: Wall ->
          RogueStrip           (AirCell next')            neighbourNext
       -> RogueStrip (RockCell (AirCell next')) (RockCell neighbourNext)
  RockCons_nextRock_ngbAir :: Wall ->
          RogueStrip           (RockCell next')           neighbourNext
       -> RogueStrip (RockCell (RockCell next')) (AirCell neighbourNext)
  RockCons_nextRock_ngbRock ::
          RogueStrip           (RockCell next')            neighbourNext
       -> RogueStrip (RockCell (RockCell next')) (RockCell neighbourNext)


data RogueSList topStrip where
  StripCons :: RogueStrip topStrip nextStrip -> RogueSList nextStrip
                                             -> RogueSList topStrip

data RogueMap where
  RogueMap :: RogueSList top -> RogueMap

OTHER TIPS

Here's what I'd come up with (if I understand the requirements correctly):

{-# LANGUAGE GADTs, DataKinds, TypeFamilies #-}

module Features where

data CellType = Rock | Air

type family Other (c :: CellType) :: CellType
type instance Other Rock = Air
type instance Other Air = Rock

data Cell (a :: CellType) where
    RockCell :: Cell Rock
    AirCell :: Cell Air

data BoundaryType = Picture | Button

data Boundary (a :: CellType) (b :: CellType) where
    NoBoundary :: Boundary a b
    Boundary :: (b ~ Other a) => BoundaryType -> Boundary a b

data Tile m n e s w where
    Tile :: Cell m ->
            Cell n -> Boundary m n ->
            Cell e -> Boundary m e ->
            Cell s -> Boundary m s ->
            Cell w -> Boundary m w ->
            Tile m n e s w

demo :: Tile Rock Air Air Rock Air
demo = Tile RockCell
            AirCell NoBoundary
            AirCell (Boundary Picture)
            RockCell NoBoundary
            AirCell (Boundary Button)

{- Invalid: -}

demo2 = Tile RockCell
             RockCell (Boundary Picture)
             AirCell (Boundary Button)
             RockCell NoBoundary
             AirCell (Boundary Picture)

{-
 -   Couldn't match type `'Air' with `'Rock'
 -   In the third argument of `Tile', namely `(Boundary Picture)'
 -   In the expression:
 -     Tile
 -       RockCell
 -       RockCell
 -       (Boundary Picture)
 -       AirCell
 -       (Boundary Button)
 -       RockCell
 -       NoBoundary
 -       AirCell
 -       (Boundary Picture)
 -   In an equation for `demo2':
 -       demo2
 -         = Tile
 -             RockCell
 -             RockCell
 -             (Boundary Picture)
 -             AirCell
 -             (Boundary Button)
 -             RockCell
 -             NoBoundary
 -             AirCell
 -             (Boundary Picture)
 -}

I guess some type variables could be removed here and there.

Wrap some things in Maybe for finite maps.

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"
Licensed under: CC-BY-SA with attribution
Not affiliated with StackOverflow
scroll top