我的版本与 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 之间有一个Boundary matA matB从 A 到 B 的类型边界和一个Boundary matB matA从 B 到 A 的类型边界。这允许邻接关系是不对称的，但实际上，您可以决定在您的代码中使所有关系对称。
现在从理论上讲，这一切都很好而且很花哨，但是构建实际的
Cell图表是相当痛苦的。因此，为了好玩，让我们创建一个 DSL 来强制定义单元格关系，然后“打结”以生成最终图。
由于单元格有不同的类型，您不能简单地将它们存储在临时列表中或Data.Map用于打结，因此我将使用该vault包。AVault是一个类型安全的多态容器，您可以在其中存储任何类型的数据并使用Key类型编码的 a 以类型安全的方式检索它们。因此，例如，如果您有 a ，则可以从 aKey String中检索 a String，Vault如果您有 a 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
即使我们还没有实现这些功能，我们可以看到这个类型检查。此外，如果您尝试放置不一致的类型（例如使用墙功能连接相同的瓷砖类型），您会收到类型错误。
我要使用的具体类型Gen是
type Gen = ReaderT Vault (StateT Vault IO)
基本 monad 是IO因为它是创建新Vault密钥所必需的（我们也可以使用ST，但这有点简单）。我们使用State Vault存储新创建的单元格并为其添加新边界，使用 vault-key 唯一标识一个单元格并在 DSL 操作中引用它。
堆栈中的第三个 monadReader Vault用于访问处于完全构造状态的库。即，当我们在 中构建保险库时State，我们可以使用Reader“展望未来”，其中保险库已经包含所有具有最终边界的单元格。在实践中，这是通过使用mfix获取“monadic 固定点”来实现的（有关更多详细信息，请参见例如论文“Value Recursion in Monadic Computations”或MonadFix wiki 页面）。
因此，要运行我们的地图构造函数，我们定义
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(from MonadState) 访问正在构建的不完整库，并使用ask(from 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"