私のバージョンは 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隣接する 2 つのセルのマテリアルに対してパラメータ化され、目的のセルへの参照が含まれます。壁のフィーチャは、異なるマテリアルのセルを結合する境界に構造的に制限されます。
これは本質的に有向グラフであるため、各隣接セル A と B の間には、A から B へBoundary matA matBのタイプの境界と、B から A へのタイプの境界がありBoundary matB matAます。これにより、隣接関係を非対称にすることができますが、実際には、決定できます。コード内ですべての関係を対称にします。
これで、理論レベルでは問題なくダンディーですが、実際の
Cellグラフを作成するのは非常に面倒です。ですから、楽しみのために、セルの関係を命令的に定義するための DSL を作成してから、「結び目を結び」、最終的なグラフを作成してみましょう。
Data.Mapセルにはさまざまな種類があるため、単純に一時的なリストやノットタイイングに保存することはできないため、vaultパッケージを使用します。Aはタイプ セーフなポリモーフィック コンテナであり、タイプ エンコードされた をVault使用してタイプ セーフな方法で任意のタイプのデータを格納し、それらを取得できます。Keyたとえば、 がある場合はから をKey String取得でき、 がある場合は値を取得できます。StringVaultKey IntInt
それでは、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)
基本モナドはIO、新しいVaultキーを作成するために必要なためです (使用することもできますSTが、これは少し単純です)。新しく作成されたセルを保存し、vault-key を使用State Vaultしてセルを一意に識別し、DSL 操作で参照するために、それらに新しい境界を追加するために使用します。
スタックの 3 番目のモナドはReader Vault、vault が完全に構築された状態でアクセスするために使用されます。つまり、 でボールトを構築している間に、最終的な境界を持つすべてのセルがボールトに既に含まれている「未来を見る」ためにStateを使用できます。Reader実際には、これは を使用mfixして「モナド不動点」を取得することで実現されます (詳細については、論文「モナド計算における値の再帰」または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。したがって、モナド内では、get(from MonadState) を使用して構築中の不完全な vault にアクセスし、ask(from MonadReader) を使用して完全に完成した vault にアクセスできます。
残りの実装は簡単です。
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)また、 2 つの対称境界を構築するための明示的な制約も必要です。
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"