将地图约束表示为ADT

时间：2013-09-03 14:30:59

标签： haskell algebraic-data-types roguelike

这是一个玩具问题：

（roguelike）2D地图由方形单元组成，每个单元都有一种材料（岩石或空气）。

每个单元格有四个边界（N，S，E和W）。每个边界由两个单元共享。

只有当一侧是岩石而另一侧是空气时，边界可以选择性地包含“墙特征”。

（墙壁功能可以是杠杆，图片，按钮等）

只有当一边是岩石而另一边是空气时，代数数据类型设计才能有一个存储墙特征的地方？即数据结构不能代表两个气囊或两个岩石细胞之间边界上的墙壁特征。

我尝试过的一种方法是对单元格值进行XORing棋盘图案，反转变化并且不变。

由于单元格之间存在多条等效路径，因此我不断陷入困境 - SSW与SWS相同（此问题的1D版本是微不足道的）。

（我认识到ADT表示不会特别''可查询'。）

使用失败尝试进行更新：

调用东边界E和南边界S.让每个边界为Same或Diff Feature。这种方法的问题在于它允许存在不一致的路由，例如：

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

是否有一个数学名称表示不同的路线必须汇总到相同的总数？

你可以说Same是1而Diff是-1，并且任何两个单元格之间的每条路径上的乘积必须相等（1或-1）。

3 个答案:

答案 0 :(得分：6)

我不知道传统的ADT是否可行，但你可以用GADT做到这一点。这在一个维度上有一个无限的图，在另一个维度上有限：

{-# 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

答案 1 :(得分：2)

这是我想出的（如果我理解正确的要求）：

{-# 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)
 -}

我想可以在这里和那里删除一些类型变量。

在Maybe中为有限地图包裹一些东西。

答案 2 :(得分：2)

我的版本类似于Nicolas所做的，但我提供了一个参考 Boundary中的相邻单元格，以生成可遍历的图形。我的数据类型是

{-# 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)

我决定使地图有界，因此每个单元格可能有也可能没有邻居（因此，Maybe类型为边界）。 Boundary数据类型是 参数化两个相邻单元格的材料并包含一个 对目标单元格和墙要素的引用在结构上受限于连接不同材料单元格的边界。

这实际上是一个有向图，因此在每个相邻单元A和B之间存在从A到B的类型Boundary matA matB的边界和从B到A的类型Boundary matB matA的边界。这允许邻接关系是不对称的，但在实践中，你可以在你的代码中决定使所有关系对称。

现在这在理论层面上都很好，但是构建实际的 Cell图表非常痛苦。所以，只是为了好玩，让我们制作一个DSL来定义 细胞关系势在必行，然后“打结”产生最终的图形。

由于单元格具有不同的类型，您不能简单地将它们存储在临时列表中，或者Data.Map用于打结，因此我将使用vault包。 Vault是一个类型安全的多态容器，您可以在其中存储任何类型的数据，并使用类型编码的Key以类型安全的方式检索它们。因此，例如，如果您有Key String，则可以从String中检索Vault，如果您有Key Int，则可以检索Int值。

因此，让我们从定义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)

Connection类型决定了我们连接的基本方向 单元格和定义如下：

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

现在我们可以使用我们的操作构建一个简单的测试图：

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

即使我们尚未实现这些功能，我们也可以看到这种类型检查。此外，如果您尝试使用不一致的类型（例如使用wall-feature连接相同的tile类型），则会出现类型错误。

我将用于Gen的具体类型是

type Gen = ReaderT Vault (StateT Vault IO)

基础monad是IO，因为创建新的Vault密钥需要（我们也可以使用ST但这有点简单）。我们使用State Vault来存储新创建的单元格并为它们添加新的边界，使用vault-key来唯一标识单元格并在DSL操作中引用它。

堆栈中的第三个monad是Reader Vault，用于访问处于完全构造状态的Vault。即当我们在State中构建保险库时，我们可以使用Reader来“看到未来”保险库已经包含所有具有最终边界的单元格。在实践中，这可以通过使用mfix获取“monadic固定点”来实现（有关详细信息，请参阅例如论文"Value Recursion in Monadic Computations"或MonadFix wiki page）。

因此，要运行我们的地图构造函数，我们定义

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

这里我们运行有状态计算并得到类型(a, Vault)的值，即计算结果和包含所有单元格的库。通过mfix，我们可以在计算结果之前访问结果，因此我们可以将结果库作为参数提供给runReaderT。因此，在monad中，我们可以使用get（来自MonadState）来访问正在构建的不完整的保险库，并使用ask（来自MonadReader）来访问完整的保管库。

现在其余的实现很简单：

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创建一个新的保管库密钥，并使用它来插入一个没有边界的新单元格。

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通过ask访问“未来保险库”，以便我们可以从那里查找相邻的单元格并将其存储在边界内。

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几乎相同。我们还需要显式约束(b ~ Other a, a ~ Other b) 构造两个对称边界。

startFrom :: Key (Cell a) -> Gen (Cell a)
startFrom k = fmap (fromJust . V.lookup k) ask

startFrom只是使用给定的密钥检索已完成的单元格，以便我们返回 它是我们发电机的结果。

这是完整的示例源代码，其中包含用于调试的其他Show个实例，因此您可以自己尝试：

{-# 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"
相关问题
最新问题