Бесконечная петля в сортировке пузырьков через Traversable в Haskell

Я пытаюсь реализовать сортировку пузырьков по любому проходящему контейнеру, используя монаду Tardis.

{-# LANGUAGE TupleSections #-}

module Main where

import Control.DeepSeq
import Control.Monad.Tardis
import Data.Bifunctor
import Data.Traversable
import Data.Tuple
import Debug.Trace

newtype Finished = Finished { isFinished :: Bool }

instance Monoid Finished where
  mempty = Finished False
  mappend (Finished a) (Finished b) = Finished (a || b)

-- | A single iteration of bubble sort over a list.
-- If the list is unmodified, return 'Finished' 'True', else 'False'
bubble :: Ord a => [a] -> (Finished, [a])
bubble (x:y:xs)
  | x <= y = bimap id                       (x:) (bubble (y:xs))
  | x  > y = bimap (const $ Finished False) (y:) (bubble (x:xs))
bubble as = (Finished True, as)

-- | A single iteration of bubble sort over a 'Traversable'.
-- If the list is unmodified, return 'Finished' 'True', else 'Finished' 'False'
bubbleTraversable :: (Traversable t, Ord a, NFData a, Show a) => t a -> (Finished, t a)
bubbleTraversable t = extract $ flip runTardis (initFuture, initPast) $ forM t $ \here -> do
  sendPast (Just here)
  (mp, finished) <- getPast
  -- For the first element use the first element,
  -- else the biggest of the preceding.
  let this = case mp of { Nothing -> here; Just a -> a }
  mf <- force <$> getFuture -- Tardis uses lazy pattern matching,
                            -- so force has no effect here, I guess.
  traceM "1"
  traceShowM mf -- Here the program enters an infinite loop.
  traceM "2"
  case mf of
    Nothing -> do
      -- If this is the last element, there is nothing to do.
      return this
    Just next -> do
      if this <= next
        -- Store the smaller element here
        -- and give the bigger into the future.
        then do
          sendFuture (Just next, finished)
          return this
        else do
          sendFuture (Just this, Finished False)
          return next
  where
    extract :: (Traversable t) => (t a, (Maybe a, (Maybe a, Finished))) -> (Finished, t a)
    extract = swap . (snd . snd <$>)

    initPast = (Nothing, Finished True)
    initFuture = Nothing

-- | Sort a list using bubble sort.
sort :: Ord a => [a] -> [a]
sort = snd . head . dropWhile (not . isFinished . fst) . iterate (bubble =<<) . (Finished False,)

-- | Sort a 'Traversable' using bubble sort.
sortTraversable :: (Traversable t, Ord a, NFData a, Show a) => t a -> t a
sortTraversable = snd . head . dropWhile (not . isFinished . fst) . iterate (bubbleTraversable =<<) . (Finished False,)

main :: IO ()
main = do
  print $ sort ([1,4,2,5,2,5,7,3,2] :: [Int]) -- works like a charm
  print $ sortTraversable ([1,4,2,5,2,5,7,3,2] :: [Int]) -- breaks

Основное различие между bubble и bubbleTraversable заключается в обработке флага Finished: В bubble мы предполагаем, что самый правый элемент уже отсортирован и изменит флаг, если элементы слева это не так; в bubbleTraversable мы делаем это наоборот.

При попытке оценить mf в bubbleTraversable программа вводит бесконечный цикл в ленивых ссылках, о чем свидетельствует вывод ghc <<loop>>.

Вероятно, проблема состоит в том, что forM пытается последовательно оценивать элементы, прежде чем произойдет монадическое соединение (тем более что forM - flip traverse для списков). Есть ли способ спасти эту реализацию?

Ответы

Ответ 1

Прежде всего, по стилю, Finished = Data.Monoid.Any (но вы используете только бит Monoid для (bubble =<<), когда он может быть также bubble . snd, поэтому я просто отбросил его для Bool), head . dropWhile (not . isFinished . fst) = fromJust . find (isFinished . fst), case x of { Nothing -> default; Just t = f t } = maybe default f x и maybe default id = fromMaybe default.

Во-вторых, ваше предположение о том, что force ничего не делает в Tardis, неверно. Тонки не "помнят", что они были созданы в ленивом матче. force сам ничего не делает, но когда обрабатываемый thunk оценивается, это заставляет thunk, который он дал, оценивать для NF, никаких исключений. В вашем случае, что case mf of ... оценивает mf для нормальной формы (вместо просто WHNF), потому что mf имеет force в ней. Однако я не считаю, что это вызывает проблемы.

Реальная проблема заключается в том, что вы "решаете, что делать" в зависимости от будущего значения. Это означает, что вы соответствуете будущему значению, а затем используете это будущее значение для создания вычисления Tardis, которое получает (>>=) 'd в том, которое производит это значение. Это не-нет. Если это яснее: runTardis (do { x <- getFuture; x `seq` return () }) ((),()) = _|_, но runTardis (do { x <- getFuture; return $ x `seq` () }) ((),()) = ((),((),())). Вы можете использовать будущее значение для создания чистого значения, но вы не можете использовать его для определения Tardis, которое вы будете запускать. В вашем коде это при попытке case mf of { Nothing -> do ...; Just x -> do ... }.

Это также означает, что traceShowM вызывает проблему самостоятельно, поскольку печать чего-либо в IO глубоко оценивает (traceShowM приблизительно unsafePerformIO . (return () <$) . print). mf должен оцениваться по мере выполнения unsafePerformIO, но mf зависит от оценки операций Tardis, которые появляются после traceShowM, но traceShowM заставляет выполнить print, прежде чем он разрешит следующая операция Tardis (return ()). <<loop>>!

Здесь фиксированная версия:

{-# LANGUAGE TupleSections #-}

module Main where

import Control.Monad
import Control.Monad.Tardis
import Data.Bifunctor
import Data.Tuple
import Data.List hiding (sort)
import Data.Maybe

-- | A single iteration of bubble sort over a list.
-- If the list is unmodified, return 'True', else 'False'
bubble :: Ord a => [a] -> (Bool, [a])
bubble (x:y:xs)
  | x <= y = bimap id            (x:) (bubble (y:xs))
  | x  > y = bimap (const False) (y:) (bubble (x:xs))
bubble as = (True, as)

-- | A single iteration of bubble sort over a 'Traversable'.
-- If the list is unmodified, return 'True', else 'False'
bubbleTraversable :: (Traversable t, Ord a) => t a -> (Bool, t a)
bubbleTraversable t = extract $ flip runTardis init $ forM t $ \here -> do
  -- Give the current element to the past so it will have sent us biggest element
  -- so far seen. 
  sendPast (Just here)
  (mp, finished) <- getPast
  let this = fromMaybe here mp


  -- Given this element in the present and that element from the future,
  -- swap them if needed.
  -- force is fine here
  mf <- getFuture
  let (this', that', finished') = fromMaybe (this, mf, finished) $ do
                                    that <- mf
                                    guard $ that < this
                                    return (that, Just this, False)

  -- Send the bigger element back to the future
  -- Can't use mf to decide whether or not you sendFuture, but you can use it
  -- to decide WHAT you sendFuture.
  sendFuture (that', finished')

  -- Replace the element at this location with the one that belongs here
  return this'
  where
    -- If the type signature was supposed to be like a comment on how the tuple is
    -- rearranged, this one seems clearer.
    extract :: (a, (b, (c, d))) -> (d, a)
    -- Left-sectioning (f <$>) = fmap f is pointlessly unreadable
    -- I replaced fmap with second because I think it clearer, but that up for debate
    extract = swap . (second $ snd . snd)
    init = (Nothing, (Nothing, True))

-- | Sort a list using bubble sort.
sort :: Ord a => [a] -> [a]
sort = snd . fromJust . find fst . iterate (bubble . snd) . (False,)

-- | Sort a 'Traversable' using bubble sort.
sortTraversable :: (Traversable t, Ord a) => t a -> t a
sortTraversable = snd . fromJust . find fst . iterate (bubbleTraversable . snd) . (False,)

main :: IO ()
main = do
  print $ sort ([1,4,2,5,2,5,7,3,2] :: [Int]) -- works like a charm
  print $ sortTraversable ([1,4,2,5,2,5,7,3,2] :: [Int]) -- works like a polymorphic charm

-- Demonstration that force does work in Tardis
checkForce = fst $ sortTraversable [(1, ""), (2, undefined)] !! 1
-- checkForce = 2 if there is no force
-- checkForce = _|_ if there is a force

Если вы все еще хотите trace mf, вы можете mf <- traceShowId <$> getFuture, но вы можете не получить четко определенный порядок сообщений (не ожидайте, что время будет иметь смысл внутри Tardis!), хотя в этом случае он просто печатает хвосты списков назад.