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

Question

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

{-# 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 для списков). Есть ли способ спасти эту реализацию?

Answer 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 неправильно. Thunks не "помнят", что они были созданы в матче ленивого образца. force сам по себе ничего не делает, но когда оценивается созданный им thunk, он приводит к тому, что thunk, который ему был передан, оценивается как NF, без исключений. В вашем случае это case mf of ... оценивает mf к нормальной форме (а не просто WHNF), потому что mf имеет force в этом. Я не верю, что это вызывает здесь какие-то проблемы.

Настоящая проблема в том, что вы "решаете, что делать" в зависимости от будущей ценности. Это означает, что вы сопоставляете будущую стоимость, и затем вы используете эту будущую стоимость для создания Tardis вычисление, которое получает (>>=)в тот, который производит это значение. Это нет-нет. Если понятнее: 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
    -- No need to be clever
    extract (a, (_, (_, b))) = (b, a)
    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

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