Представление ограничений карты как ADT

A (roguelike) 2D-карта состоит из квадратных ячеек, каждая из которых имеет материал (камень или воздух).

Каждая ячейка имеет четыре границы (N, S, E и W). Каждая граница разделяется двумя ячейками.

Граница может необязательно содержать "стенную особенность", только если одна сторона представляет собой камень и другой воздух.

(Функции стены могут быть рычагами, изображениями, кнопками и т.д.)

В каком дизайне Алгебраических данных может быть место для хранения функции стены только тогда, когда одна сторона является скалой и другим воздухом? то есть структура данных не может представлять функцию стенки на границе между двумя воздушными ячейками или двумя ячейками горных пород.

Один из подходов, который я пробовал, - это XORing шаблон шахматной доски по значениям ячеек, изменение изменений и изменение.

Я держу себя в узлах из-за того, что между ячейками существует несколько эквивалентных маршрутов - SSW - это то же самое, что и SWS (версия 1D этого вопроса тривиальна).

(Я признаю, что представление ADT не будет особенно "queriable".)

Назовите восточные границы E и южные границы S. Пусть каждая граница будет либо Same, либо Diff Feature. Проблема с этим подходом заключается в том, что он позволяет создавать несовместимые маршруты, например:

Есть ли математическое имя для обозначения того, что разные маршруты должны объединяться в одну и ту же сумму?

Можно сказать, что Same равно 1, а Diff - -1, и этот продукт по каждому маршруту между любыми двумя ячейками должен быть равен (1 или -1).

Ответы

Ответ 1

Я понятия не имею, возможно ли это вообще с традиционными 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

Ответ 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 для конечных отображений.

Ответ 3

Моя версия похожа на то, что сделал Николас, но я включаю ссылку на соседнюю ячейку в 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. A 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

Хотя мы еще не реализовали функции, мы можем видеть, что этот тип проверяет. Кроме того, если вы попытаетесь установить непоследовательные типы (например, подключить одни и те же типы плитки с помощью настенной функции), вы получите ошибку типа.

Конкретный тип, который я буду использовать для Gen,

type Gen = ReaderT Vault (StateT Vault IO)

Базовая монада IO, потому что это необходимо для создания новых vault ключей (мы также можем использовать ST, но это немного проще). Мы используем State Vault для хранения вновь созданных ячеек и добавления новых границ к ним, используя ключ хранилища, чтобы однозначно идентифицировать ячейку и ссылаться на нее в операциях DSL.

Третья монада в стеке Reader Vault, которая используется для доступа к хранилищу в полностью сконструированном состоянии. То есть в то время как мы строим хранилище в State, мы можем использовать Reader для "видеть в будущем", где хранилище уже содержит все ячейки с их окончательными границами. На практике это достигается с помощью mfix, чтобы получить "монадическую неподвижную точку" (более подробно см., Например, документ "Рекурсия значения в монадических вычислениях" или страница wiki MonadFix).

Итак, чтобы запустить наш конструктор карт, определим

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 (из 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"