Клітинні автомати за допомогою комонад

Одним ввечері я натрапив на статтю про реалізацію одновимірного клітинного автомата за допомогою комонад, однак матеріал неповний і трохи застарів, у зв'язку з чим вирішив написати російськомовну адаптацію (заодно розглянувши двовимірні клітинні автомати на прикладі Game of Life):
 
 life_anim
 
 Universe
Розглянемо тип даних
Universe
, певний таким чином:
 
data Universe a = Universe [a] a [a]

 
Це нескінченний в обидві сторони список, але з фокусом на деякому елементі, який ми можемо зрушувати з допомогою функцій:
 
 
left, right :: Universe a -> Universe a
left  (Universe (a:as) x bs) = Universe as a (x:bs)
right (Universe as x (b:bs)) = Universe (x:as) b bs

 
По суті це тип-застібка (zipper ), але ми можемо розглядати це як константних Сі-вказівник на нескінченну область пам'яті: до нього застосовні операції інкремента, декремента. Але як його разименовивать? Для цього визначимо функцію, що дістає сфокусоване значення:
 
 
extract :: Universe a -> a
extract (Universe _ x _) = x

 
Наприклад,
Universe [-1, -2..] 0 [1, 2..]
представляє з себе всі цілі числа. Проте,
Universe [0, -1..] 1 [2, 3..]
це ті ж самі цілі числа, але з трохи зміненим контекстом (ми вказуємо на інший елемент).
 
 integres_figure
 
Якщо ми захочемо отримати всі ступені 2, то нам потрібен спосіб застосувати функцію
(2**)
до
Universe
цілих чисел. Досить нескладно визначити інстанси класу Functor, який підпорядковується всім законам:
 
 
instance Functor Universe where
    fmap f (Universe as x bs) = Universe (fmap f as) (f x) (fmap f bs)

-- соответственно
powersOf2 = fmap (2**) (Universe [-1, -2..] 0 [1, 2..])
-- ..0.25, 0.5, 1, 2, 4..

 
У клітинному автоматі значення клітин залежать від значень всіх інших клітин на попередньому кроці. Тому ми можемо створити
Universe
всіх зрушень і правило їх згортки:
 
 
duplicate :: Universe a -> Universe (Universe a)
duplicate u = Universe (tail $ iterate left u) u (tail $ iterate right u)

 
 duplicate_figure
 
Правило згортки повинно мати тип
Universe a -> a
, таким чином для
Universe Bool
прикладом правила може послужити:
 
 
rule :: Universe Bool -> Bool
rule u = not (lx && cx && not rx || (lx==cx))
    where lx  = extract $ left  u
          rx  = extract $ right u
          cx  = extract u

 
Застосувавши правило до Universe всіх зрушень, ми отримуємо наступний стан автомата:
 
 
next :: Universe a -> (Universe a -> a) -> Universe a
next u r = fmap r (duplicate u)

-- соответственно
un = Universe (repeat False) True (repeat False) `next` rule

 
 1d_gif
 
 Комонади
Ми можемо помітити, що наші функції підпорядковуються наступним законам:
 
 
extract . duplicate      = id
fmap extract . duplicate = id
duplicate . duplicate    = fmap duplicate . duplicate

 
Тому,
Universe
утворює комонаду , а функція
next
соотвствует оператору
(=>>)
. Комонада — це дуал монади, у зв'язку з чим можна простежити якісь аналогії між їх операціями. Наприклад,
join
поєднує вкладені контексти, а
duplicate
— навпроти, подвоює контекст;
return
поміщає в контекст, а
extract
— витягує з нього, і т.д.
 
 comonad_laws
 
 Двовимірний клітинний автомат
Тепер, ми можемо з тим же успіхом реалізувати двовимірний клітинний автомат. Для початку оголосимо тип двовимірного
Universe
:
 
newtype Universe2 a = Universe2 { getUniverse2 :: Universe (Universe a) }

 
У Haskell дуже легко застосовувати функцію до вкладених контейнерів за допомогою композиції
fmap
, тому написати інстанси класу
Functor
для
Universe2
не складе жодних проблем:
 
 
instance Functor Universe2 where
    fmap f = Universe2 . (fmap . fmap) f . getUniverse2

 
Інстанси комонади робиться аналогічно із звичайним Universe, і оскільки Universe2 є лише обгорткою, ми можемо визначити методи в термінах вже наявних. Наприклад,
extract
досить просто виконати двічі. У
duplicate
, однак, ми повинні отримувати зрушення вкладених контекстів, для чого визначаться допоміжна функція
 
 
instance Comonad Universe2 where
    extract = extract . extract . getUniverse2
    duplicate = fmap Universe2 . Universe2 . shifted . shifted . getUniverse2
        where shifted :: Universe (Universe a) -> Universe (Universe (Universe a))
              shifted u = Universe (tail $ iterate (fmap left) u) u (tail $ iterate (fmap right) u)

 
Це майже все! Залишилося тільки визначити правило і застосовувати його за допомогою
(=>>)
. У Game of Life новий стан клітини залежить від стану сусідніх клітин, так що визначимо функцію їх знаходження:
 
 
nearest3 :: Universe a -> [a]
nearest3 u = fmap extract [left u, u, right u]

neighbours :: (Universe2 a) -> [a]
neighbours u =
    [ nearest3 . extract . left
    , pure     . extract . left  . extract
    , pure     . extract . right . extract
    , nearest3 . extract . right
    ] >>= ($ getUniverse2 u)

 
А ось і саме правило:
 
 
data Cell = Dead | Alive
    deriving (Eq, Show)

rule :: Universe2 Cell -> Cell
rule u
    | nc == 2   = extract u
    | nc == 3   = Alive
    | otherwise = Dead
    where nc = length $ filter (==Alive) (neighbours u)

 
Залишився лише нудний висновок, який я не буду розглядати окремо.
 
 Висновок
Таким чином, ми можемо реалізувати будь клітинний автомат, всього лише визначивши функцію
rule
. Нескінченне поле ми отримуємо в подарунок, завдяки ледачим обчисленням, хоча це і створює таку проблему, як лінійне споживання пам'яті.
Справа в тому, що оскільки ми застосовуємо правило до кожного елементу нескінченного списку, то для обчислення клітин, до яких ще не було звернення, необхідно буде пройти всі попередні кроки, а значить їх потрібно зберігати в пам'яті.
 
Вихідні коди обох файлів:
 
 Universe.hs
module Universe where

import Control.Comonad

data Universe a = Universe [a] a [a]
newtype Universe2 a = Universe2 { getUniverse2 :: Universe (Universe a) }

left :: Universe a -> Universe a
left  (Universe (a:as) x bs) = Universe as a (x:bs)

right :: Universe a -> Universe a
right (Universe as x (b:bs)) = Universe (x:as) b bs

makeUniverse fl fr x = Universe (tail $ iterate fl x) x (tail $ iterate fr x)

instance Functor Universe where
    fmap f (Universe as x bs) = Universe (fmap f as) (f x) (fmap f bs)

instance Comonad Universe where
    duplicate = makeUniverse left right
    extract (Universe _ x _) = x

takeRange :: (Int, Int) -> Universe a -> [a]
takeRange (a, b) u = take (b-a+1) x
    where Universe _ _ x
            | a < 0 = iterate left u !! (-a+1)
            | otherwise = iterate right u !! (a-1)

instance Functor Universe2 where
    fmap f = Universe2 . (fmap . fmap) f . getUniverse2

instance Comonad Universe2 where
    extract = extract . extract . getUniverse2
    duplicate = fmap Universe2 . Universe2 . shifted . shifted . getUniverse2
        where shifted :: Universe (Universe a) -> Universe (Universe (Universe a))
              shifted = makeUniverse (fmap left) (fmap right)

takeRange2 :: (Int, Int) -> (Int, Int) -> Universe2 a -> [[a]]
takeRange2 (x0, y0) (x1, y1)
    = takeRange (y0, y1)
    . fmap (takeRange (x0, x1))
    . getUniverse2

 Life.hs
import Control.Comonad
import Control.Applicative
import System.Process (rawSystem)

import Universe

data Cell = Dead | Alive
    deriving (Eq, Show)

nearest3 :: Universe a -> [a]
nearest3 u = fmap extract [left u, u, right u]

neighbours :: (Universe2 a) -> [a]
neighbours u =
    [ nearest3 . extract . left
    , pure     . extract . left  . extract
    , pure     . extract . right . extract
    , nearest3 . extract . right
    ] >>= ($ getUniverse2 u)

rule :: Universe2 Cell -> Cell
rule u
    | nc == 2   = extract u
    | nc == 3   = Alive
    | otherwise = Dead
    where nc = length $ filter (==Alive) (neighbours u)

renderLife :: Universe2 Cell -> String
renderLife = unlines . map concat . map (map renderCell) . takeRange2 (-7, -7) (20, 20)
    where renderCell Alive = "██"
          renderCell Dead  = "  "

fromList :: a -> [a] -> Universe a
fromList d (x:xs) = Universe (repeat d) x (xs ++ repeat d)

fromList2 :: a -> [[a]] -> Universe2 a
fromList2 d = Universe2 . fromList ud . fmap (fromList d)
    where ud = Universe (repeat d) d (repeat d)

cells = [ [ Dead, Alive,  Dead]
        , [Alive,  Dead,  Dead]
        , [Alive, Alive, Alive] ]

main = do
    gameLoop $ fromList2 Dead cells

gameLoop :: Universe2 Cell -> IO a
gameLoop u = do
    getLine
    rawSystem "clear" []
    putStr $ renderLife u
    gameLoop (u =>> rule)

 
 
Спасибі int_index за допомогу в підготовці статті.

Джерело: Хабрахабр

0 коментарів

Тільки зареєстровані та авторизовані користувачі можуть залишати коментарі.