Задачка про Святого Клауса

Решение, использующее программные транзакции в памяти (STM)

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

Олени и эльфы

Итак, у Клауса есть две группы, одна для оленей, другая для эльфов. Каждый эльф (или олень) стремится вступить в свою группу. Когда это случается, он видит двое «врат». Певые врата позволяют Клаусу управлять тем, когда эльфы могут входить в мастерскую и знать, когда мастерская уже заполнена. Подобным образом вторые врата управляют выходом эльфов из мастерской. Клаус в своё время ожидает до тех пор, пока одна из его групп будет готова, а потом использует её врата для назначения помошникам (эльфам или оленям) их задач. Таким образом, жизнь помошников — бесконечный круг: попробовать вступить в группу, проийти через врата под управлением Клауса, а потом снова пробовать вступить в свою группу, спустя некоторое время.

Отключим предупреждения о «затемнении» имён:

Нам потребуеются слудующие подключения:

import Control.Concurrent        (ThreadId, forkIO, threadDelay)
import Control.Concurrent.STM
import Control.Monad             (forever)
import System.Random             (getStdRandom, randomR)
import System.IO                 ( BufferMode(LineBuffering)
                                 , hSetBuffering, stdout)

Переводя это словесное описание в Хаскель, мы получим следующий код для вхождения эльфа в группу:

elf1 :: Group -> Int -> IO ()
elf1 group elf_id = do
    (in_gate, out_gate) <- joinGroup group
    passGate in_gate
    meetInStudy elf_id
    passGate out_gate

Эльф отправляется в свою группу Group, а целое число Int — это порядковый номер эльфа. Этот номер используется только для вызова 𝘧 «встреча в мастерской» meetInStudy, которая просто печает сообщение о том, что происходит:

meetInStudy :: Int -> IO ()
meetInStudy idt = putStrLn $ "Эльф #" ++ show idt ++ " встретился в мастерской"

Функция «войти в группу» joinGroup вводит эльфа в группу, а 𝘧 «пройти врата» passGate проводит его через все врата.

joinGroup :: Group -> IO (Gate, Gate)
passGate :: Gate -> IO ()

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

deliverToys :: Int -> IO ()
deliverToys idt = putStrLn ("Олень #" ++ show idt ++ " развозит игрушки")

Так как действия — величины первого порядка, мы можем описать обощенный код:

helper1 :: Group -> IO () -> IO ()
helper1 group do_task = do
    (in_gate, out_gate) <- joinGroup group
    passGate in_gate
    do_task
    passGate out_gate

Второй аргумент 𝘧 «помошник1» helper1 — действие ввода—вывода — есть задание для помошника, которое он выполняет между прохождениями через врата. Теперь мы можем описать частные случаи для эльфа и оленя:

elf1, reindeer1 :: Group -> Int -> IO ()
elf1      gp idt = helper1 gp (meetInStudy idt)
reindeer1 gp idt = helper1 gp (deliverToys idt)

Врата и Группы

Первая асбтракция — это «Врата», нам нужны следующие возможности:

newGate :: Int -> STM Gate
passGate :: Gate -> IO ()
operateGate :: Gate -> IO ()

Вместимость врат ограничена числом n, которое указывается при создании врат, и переменное оставшееся свободное место. Оставшееся место убавляется, когда помошник проходит врата, если же места нет, тогда проход (вызов passGate) блокируется. В момент создания врат их свободное место устанавливается равным нулю, так что ни один помошник не может пройти в них. Клаус открывает ворота, используя 𝘧 «отпереть врата» operateGate, которая устанвливает свободное место врат равным их вместимости.

Вот возможное описание Врат:

data Gate = MkGate Int (TVar Int)

newGate n = do
    tv <- newTVar 0
    return (MkGate n tv)

passGate (MkGate _ tv) =
    atomically $ do
        n_left <- readTVar tv
        check (n_left > 0)
        writeTVar tv (n_left - 1)

operateGate (MkGate n tv) = do
    atomically (writeTVar tv n)
    atomically $ do
        n_left <- readTVar tv
        check (n_left == 0)

Первая строчка описывает новый тип данных, с единственным коструктором величин этого типа «Сделать Врата» mkGate.

У конструктора два параметра: целое число, определяющее вместимость врат, и переменная TVar, которая указывает сколько помошников могут пройти через врата до тех пор пока они не закроються. Если в переменной записан 0, значит врата заперты.

Функция «новые врата» создаёт новые Врата Gate выделяя память под переменную TVar, а потом создаёт значение используя конструктор «Создать Врата» MkGame. Функция «пройти врата» passGate, напротив, избавляется от конструктора MkGate с помощью сопоставления с образцом; после чего она уменьшает значение, хранимое в переменной, заведомо проверяя, есть ли за воротами свободное место с помощью примитива «проверить» check. Наконец, 𝘧 «отпереть врата» сначала открывает врата, записывая в переменную полную вместимость, а потом блокируется до тех пор, пока не кончится свбодное место.

Для Групп нам нужны следующие возможности:

newGroup :: Int -> IO Group
joinGroup :: Group -> IO (Gate, Gate)
awaitGroup :: Group -> STM (Gate, Gate)

И снова, Группа после создания изначально пуста, и обладает определённой вместимостью. Эльф может присоединиться к группе, используя 𝘧 «войти в группу», способную блокировать вход до тех пор, пока группа заполнена. Клаус использует 𝘧 «подождать группу» для ожидания наполнения группы; когда она заполняется Клаус получает в распоряжение Врата, а Группа в тот же момент преобразуется, получая свежую пару врат, что даёт возможность усердным эльфам формировать новые троицы.

Вот возможное описание:

data Group = MkGroup Int (TVar (Int, Gate, Gate))

newGroup n = atomically $ do
    g1 <- newGate n; g2 <- newGate n
    tv <- newTVar (n, g1, g2)
    return (MkGroup n tv)

И вновь, Группа описанна как новый тип данных, у которого есть конструктор MkGroup и два поля: полная вместимость группы и передаваемая переменная TVar, содержащая количество свободных мест и врата группы. Создание новой группы подобно созданию новых врат: создаёться новая переменная и возвращаеться структура, построенная конструктором MkGroup.

Воплощение 𝘧𝘧 joinGroup и awaitGroup так или иначе определяются этими структурами:

joinGroup (MkGroup _ tv) =
    atomically $ do
        (n_left, g1, g2) <- readTVar tv
        check (n_left > 0)
        writeTVar tv (n_left - 1, g1,g2)
        return (g1, g2)

awaitGroup (MkGroup n tv) = do
        (n_left, g1, g2) <- readTVar tv
        check (n_left == 0)
        g1' <- newGate n; g2' <- newGate n
        writeTVar tv (n, g1', g2')
        return (g1,g2)

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

Главная программа

Сперва наперво, мы определим внешнюю структуру программы, тем более что мы до сих пор не описали самого Клауса. Вот он:

main :: IO ()
main = do
    hSetBuffering stdout LineBuffering
    elf_group <- newGroup 3
    sequence_ [elf elf_group n | n <- [1..10]]

    rein_group <- newGroup 9
    sequence_ [reindeer rein_group n | n <- [1..9]]

    forever (santa elf_group rein_group)

В первой строке задётся тип буфферизации, об этом я расскажу чуть позже, пока можно смело опустить эту строку. На второй строке создаётся Группа для эльфов с вместимостью равной 3. Третья строка более таинственная: здесь используется так называемое «описание списка» (list comprehention), которое создаёт список действий ввода—вывода и применяет 𝘧 «последоватьльность» sequence_, чтобы выполнить их последовательно. Описание списка [e|x<-xs] читается как «список всех e, где x выбираются из списка xs». Таким образом, sequence_ получит в качестве аргумента следующий список:

[elf elf_group 1, elf elf_group 2, ..., elf elf_group 10]

Каждый перечисленный вызов даёт действие ввода—вывода, порождающее создаёт процессорную «нить» для эльфа. Функция sequence_ получает список действий и возвращает одно действие, которое при исполнении запустит каждое действие из полученного списка по порядку:

sequence_ :: [IO a] -> IO ()

sequence_ :: Monad m => [m a] -> m () Выполнить действия по очереди слева направо, и Evaluate each action in the sequence from left to right, and ignore the results.

Функция «эльф» elf построенна из 𝘧 elf1, но имеет две особенности. Во—первых, мы хотим, чтобы эльф бесконечно проходил один и тот же круг; во—вторых, чтобы она (функция) выполнялась в отдельной нити:

elf :: Group -> Int -> IO ThreadId
elf g n = forkIO $
    forever $ do
        elf1 g n
        randomDelay

Функция «ответвить Ввод-Вывод» forkIO порождадет новую нить и исполняет свой аргумент в ней. Аргумент forkIO в свою очередь вызывает 𝘧 «без конца» forever, которая без конца повторно исполняет свой аргумент.

forever :: IO () -> IO ()
-- постоянно исполнять одно и то же действие
forever act = do
    act
    forever act

Наконец, выражение elf1 g n — и есть то дейтсвие ввода—вывода, которое мы хотим повторять бесконечно спустя произвольно выбранный промежуток времени:

randomDelay :: IO ()
-- Сделать произвольную задержку от 1 до 1'000'000 микросекунд
randomDelay = do
    waitTime <- getStdRandom (randomR (1, 1000000))
    threadDelay waitTime

Оставшаяся часть главной программы вполне скажет всё сама за себя: мы создаём девять оленей подобно тому, как мы создавали десять эльфов, с той лишь разницей, что мы используем 𝘧 «олень» reindeer вместо elf. Смотрите:

reindeer :: Group -> Int -> IO ThreadId
reindeer g n = forkIO $
    forever $ do
        reindeer1 g n
        randomDelay

Главный код под конец снова использует forever для постоянного повторного исполнения 𝘧 «святой клаус» santa. Теперь осталось описать только самого Клауса.

Описание Клауса

Клаус самый интересный участник этой маленькой пьесы, потому что именно он делает выбор. Он ждёт пока не соберёться одна из групп: эльфов или оленей. Как только он отдал своё предпочтение одной из групп, он должен провести её иснтруктаж. Вот и сам код:

santa :: Group -> Group -> IO ()
santa elf_gp rein_gp = do
    putStrLn "----------"
    (task, (in_gate, out_gate)) <- atomically $
        orElse (chooseGroup rein_gp "развозить игрушки")
               (chooseGroup elf_gp "идти в мастерскую")
    putStrLn $ "Хо! Хо! Хо! Пора " ++ task
    operateGate in_gate
        -- сейчас помошники выполняют задания
    operateGate out_gate
  where
    chooseGroup :: Group -> String -> STM (String, (Gate, Gate))
    chooseGroup g task = do
        gates <- awaitGroup g
        return (task, gates)

Выбор осуществляется с помощью 𝘧 «или если» orElse, которая сначала пробует выбрать группу оленей, таким образом отдавая им препочтение, а затем — группу эльфов. Функция «выбрать группу» chooseGroup исполняет действие «ждать группу» awaitGroup для указанной группы и возвращает в качестве итога пару, содержащую строку, отражающую задание (развозить игрушки или идти в мастерскую), и врата, которые нужно использовать Клаусу, чтобы назначить группе задания. Как только выбор сделан, Клаус сообщаяет об этом и оперирует вратами по—порядку.

Такое решение работает хорошо, но мы всё же рассмотрим ещё одно, более общее решение, потому что 𝘧 santa отражает очень распространённый случай в программировании. Он сводиться к следующему: процессорная нить (Клаус в нашем случае) делает выбор между одной из атомарных транзакций (группы операций, которые формируют единое целое, подробнее см. Вики), за которой следует одна или несколько транзакций, логически вытакающих друг из друга. Ещё один распространённый пример данного случая — получить сообщение из нескольких очередей с сообщениями, произвести с ним действия и повторить всё снова. В нашем случае, логические цепочки действий для эльфов и оленей были очень похожими — в обоих случаях Клаус должен напечатать сообщение и произвести действия с вратами. Однако, если Клаусу нужно будет выполнять разные действия для эльфов и оленей такой подход не сработает. Один из путей решения — возвращать логическую величину типа Bool, отражающую сделанный выбор, и выбирать дальнейшее направление действий в зависимости от этой величины; однако, как только появляется дополнительный выбор это решение становится неприемлимым. Вот другой подход, который подходит лучше:

santa :: Group -> Group -> IO ()
santa elf_gp rein_gp = do
    putStrLn "----------"
    choose [(awaitGroup rein_gp, run "развозить игрушки"),
            (awaitGroup elf_gp, run "идти в мастерскую")]
 where
   run :: String -> (Gate,Gate) -> IO ()
   run task (in_gate,out_gate) = do
       putStrLn $ "Хо! Хо! Хо! Пора " ++ task ++ "\n"
       operateGate in_gate
       operateGate out_gate

Функция «выбор» choose подобна охраняемой команде: она принимает список пар, ждёт до тех пор, когда первый компонент пары будет «готов к запуску», а потом исполняет второй компонент. Таким образом, тип choose выглядит так:

choose :: [(STM a, a -> IO ())] -> IO ()

В роли охранника здесь выступает действие, выполняющее программные транзацкии в в памяти (далее ПТП, оригинальные термин — STM), и возвращающее величину типа a; когда действие ПТП выполнено (то есть не было вызова 𝘧 «повтор» retry), choose может передать полученную величину во второй компонент, который в свою очередь должен быть функцией, ожидающей на входе величину типа a. Имея это в виду, разобраться с 𝘧 santa гораздо проще. В ней используется awaitGroup для ожидания готовой группы; 𝘧 choose использует пару врат, полученных от awaitGroup и перадаёт их функции «запуск» run. Последняя последовательно управляет вратами — впомните, operateGate делает блокировку пока эльфы (или олени) проходят через врата.

Код choice краток, но немного мудрён:

choose choices = do
    act <- atomically $ foldr1 orElse actions
    act
  where
    actions :: [STM (IO ())]
    actions = [ do val <- guard
                   return (rhs val)
              | (guard, rhs) <- choices ]

Сначала она формирует actions — список действий ПТП, которые в последствии соединяются функций orElse (в итоге вызова foldr1 ⊕ [x₁, … , x_n] получаем x₁ ⊕ x₂ ⊕ … ⊕ x_n). Итогом каждого такого действия ПТП так же является действие, но в контексте ввода—вывода, проще говоря, то, что нужно сделать после выбора. Вот почему каждое действие в списке имеет такой крутой тип STM (IO ()). Код 𝘧 choice сначала делает атомарную выборку из списка альтернатив, получая действие act, чей итог имеет тип IO (); в конце концов происходит выполнение действия act. Список actions определён в выражении where взятием каждой пары (guard,rhs) из списка choices, запуском охранника (действие ПТП), и возвращением действия ввода—вывода, получаемое передачей rhs в действие «пропушенное» (возвращенное) охранником.

Компиляция и запуск программы

Я (Сеймон Пейтон Джонс, автор оригинальной статьи, прим. переводчика) представил здесь весь код решения. Вы можете просто добавить подходящие подключения в самом верху, этого должно быть достаточно:

module Main where
import Control.Concurrent        (ThreadId, forkIO, threadDelay)
import Control.Concurrent.STM
import Control.Monad             (forever)
import System.Random             (getStdRandom, randomR)
import System.IO                 ( BufferMode(LineBuffering)
                                 , hSetBuffering, stdout)

Испробуйте сами (ниже приведён конечный код, предложенный автором как есть):

import Control.Concurrent.STM
import Control.Concurrent
import System.Random

main = do
    elf_gp <- newGroup 3
    sequence_ [ elf elf_gp n | n <- [1..10]]
    rein_gp <- newGroup 9
    sequence_ [ reindeer rein_gp n | n <- [1..9]]
    forever (santa elf_gp rein_gp)
  where
    elf      gp id = forkIO (forever (do elf1 gp id
                                         randomDelay))
    reindeer gp id = forkIO (forever (do reindeer1 gp id
                                         randomDelay))

santa :: Group -> Group -> IO ()
santa elf_group rein_group = do
    putStr "----------\n"
    choose [(awaitGroup rein_group, run "deliver toys"),
            (awaitGroup elf_group,  run "meet in my study")]
  where
    run :: String -> (Gate,Gate) -> IO ()
    run task (in_gate,out_gate) = do
        putStr ("Ho! Ho! Ho! let's " ++ task ++ "\n")
        operateGate in_gate
        operateGate out_gate

helper1 :: Group -> IO () -> IO ()
helper1 group do_task = do
    (in_gate, out_gate) <- joinGroup group
    passGate in_gate
    do_task
    passGate out_gate

elf1, reindeer1 :: Group -> Int -> IO ()
elf1      group id = helper1 group (meetInStudy id)
reindeer1 group id = helper1 group (deliverToys id)


meetInStudy id = putStr ("Elf " ++ show id ++ " meeting in the study\n")
deliverToys id = putStr ("Reindeer " ++ show id ++ " delivering toys\n")

---------------
data Group = MkGroup Int (TVar (Int, Gate, Gate))

newGroup :: Int -> IO Group
newGroup n = atomically (do g1 <- newGate n
                            g2 <- newGate n
                            tv <- newTVar (n, g1, g2)
                            return (MkGroup n tv))

joinGroup :: Group -> IO (Gate,Gate)
joinGroup (MkGroup n tv)
  = atomically (do (n_left, g1, g2) <- readTVar tv
                   check (n_left > 0)
                   writeTVar tv (n_left-1, g1, g2)
                   return (g1,g2))

awaitGroup :: Group -> STM (Gate,Gate)
awaitGroup (MkGroup n tv) = do
    (n_left, g1, g2) <- readTVar tv
    check (n_left == 0)
    new_g1 <- newGate n
    new_g2 <- newGate n
    writeTVar tv (n,new_g1,new_g2)
    return (g1,g2)

---------------
data Gate  = MkGate Int (TVar Int)

newGate :: Int -> STM Gate
newGate n = do
    tv <- newTVar 0
    return (MkGate n tv)

passGate :: Gate -> IO ()
passGate (MkGate n tv)
  = atomically (do n_left <- readTVar tv
                   check (n_left > 0)
                   writeTVar tv (n_left-1))

operateGate :: Gate -> IO ()
operateGate (MkGate n tv) = do
    atomically (writeTVar tv n)
    atomically (do n_left <- readTVar tv
                   check (n_left == 0))

----------------
forever :: IO () -> IO ()
-- Repeatedly perform the action
forever act = forever' act 10
  where -- cheating here to make it stop eventually
    forever' :: IO () -> Int -> IO ()
    forever' act 0 = return ()
    forever' act n = do
        act
        forever' act (n - 1)

randomDelay :: IO ()
-- Delay for a random time between 1 and 1000,000 microseconds
randomDelay = do
    waitTime <- getStdRandom (randomR (1, 1000000))
    threadDelay waitTime

choose :: [(STM a, a -> IO ())] -> IO ()
choose choices = do
    to_do <- atomically (foldr1 orElse stm_actions)
    to_do
  where
    stm_actions :: [STM (IO ())]
    stm_actions = [ do val <- guard
                       return (rhs val)
                  | (guard, rhs) <- choices ]

[1 of 1] Compiling Main             ( santa.lhs, interpreted )
Ok, modules loaded: Main.
*Main> main
----------
Хо! Хо! Хо! Пора развозить игрушки

Олень #1 развозит игрушки
Олень #2 развозит игрушки
Олень #3 развозит игрушки
Олень #4 развозит игрушки
Олень #5 развозит игрушки
Олень #6 развозит игрушки
Олень #7 развозит игрушки
Олень #8 развозит игрушки
Олень #9 развозит игрушки
----------
Хо! Хо! Хо! Пора идти в мастерскую

Эльф #1 встретился в мастерской
Эльф #2 встретился в мастерской
Эльф #3 встретился в мастерской
----------
Хо! Хо! Хо! Пора идти в мастерскую

Эльф #4 встретился в мастерской
Эльф #5 встретился в мастерской
Эльф #6 встретился в мастерской
----------
Хо! Хо! Хо! Пора идти в мастерскую

Эльф #7 встретился в мастерской
Эльф #8 встретился в мастерской
Эльф #9 встретился в мастерской

Несколько слов про буфферизацию (от переводчика)

В оригинальной статье не было упомянуто о буфферизации, в моей системе полученная программа давала такой вывод:

[1 of 1] Compiling Main             ( santa.lhs, interpreted )
Ok, modules loaded: Main.
*Main> main
----------
Хо! Хо! Хо! Пора развозить игрушки

Олень #1 развозитО ОООООООлилллллллегееееееенрннннннньуььььььь ш       #к#######2и3456789
       ррррррррааааааааззззззззввввввввооооооооззззззззиииииииитттттттт        ииииииииггггггггрррррррруууууууушшшшшшшшккккккккииииииии







----------
Хо! Хо! Хо! Пора идти в мастерскую

ЭльЭфЭл ль#ьф1ф   #в#2с3 т врвсестттрирелетстияил лсвся я м вав с мтмаеасрстстекерорсйск
коойй

----------
Хо! Хо! Хо! Пора идти в мастерскую

ЭльЭфЭл ль#ьф4ф   #в#5с6 т врвсестттрирелетстияил лсвся я м вав с мтмаеасрстстекерорсйск
коойй

----------

Эльфы и олени «живут» в отдельных процессорных нитях, не мешая друг другу. Так все олени входят в свою группу почти одновременно. Как только олень присоединяется к группе, печатается сообщение. В моей систему буфферизация по умолчанию выключена, это приводит к тому, что вывод из всех нитей перемешивается, создавая эффект «заикания». Чтобы получить нормальный вывод нужно включить построчную буфферизацию для стандартного вывода stdout, чтобы сообщения разных нитей печатались целыми строками, а не по—символьно.

Вместо заключения

Если вам интересно увидеть полный перевод всех статьей из цикла «Beautiful Concurrency» Саймона Пейтона Джонса об использовании ПТП, дайте мне знать, я постараюсь перевести недостающие части.

P.S. Автор перевода старается переводить все термины (даже хорошо устоявшиеся) на русский язык, так как перевод, изобилующий большим количеством иностранных терминов, жаргонных и заимствованных для меня ничем не отличается от неперведённого текста.

P.P.S. Ввиду этого, я буду очень признателен, если кто—нибудь предложит хорошое слово на замену транзакции. Ещё одно слово, которое трудно сходу заменяется — альтернатива.