LZW рутина в Хаскеле с использованием монад

Question

Я пытаюсь реализовать сжатие LZW в Haskell, используя Monads, вот мой код с тестовыми примерами:

{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleContexts #-}
import Control.Monad.State
import Control.Monad.Writer
import Data.Char (chr, ord)
import Data.List (isPrefixOf, maximumBy)
import Data.Function
import Test.QuickCheck

type Dictionary = [String]

dictionary :: Dictionary
dictionary = [[chr x] | x <- [0..127]]


test_dictionary =
  [ map ord (concat dictionary) == [0..127]
  , all (\str -> length str == 1) dictionary
  ]

prefixes :: String -> Dictionary -> [(Int, String)]
prefixes str dict = [(x, dict!!x) | x <- [0..length dict - 1], isPrefixOf (dict!!x) str]

test_prefixes =
  [ prefixes "" dictionary == []
  , prefixes "appletree" []   == []
  , prefixes "appletree" ["ap", "apple", "tree", "pear"] == [(0, "ap"), (1, "apple")]
  , prefixes "babe" dictionary                    == [(98, "b")]
  ]

longest :: [(Int, String)] -> (Int, String)
longest prefs = maximumBy (compare `on` (\(x,y) -> length y)) prefs

test_longest =
  [ longest [(30, "a"), (20, "abc"), (15, "ab")]  == (20, "abc")
  , longest [(30, "a"), (20, "abc"), (15, "abc")] == (15, "abc")
  ]

instance MonadState Dictionary ((->) Dictionary) where
    get = \s -> s

munch :: MonadState Dictionary m => String -> m (Int, String, String)
munch str = do
        dict <- get
        let longst = longest (prefixes str dict)
        return (fst longst, snd longst, [str!!x | x <- [length (snd longst)..length str - 1]])

test_munch =
  [ evalState (munch "a")      ["a"]            == (0, "a", "")
  , evalState (munch "appletree") ["a"]            == (0, "a", "ppletree")
  , evalState (munch "peach") ["a", "ba", "b"] == (1, "ba", "be")
  ]

instance MonadState m (StateT Dictionary ((->) m)) where

append :: MonadState Dictionary m => String -> String -> m ()
append s "" = return ()
append s w = do
        dict <- get
        let newWord = s ++ (take 1 w)
        if (notElem newWord dict)
        then do
            put (dict++[newWord])
        else return ()

test_append =
  [ execState (append "a" "")   []         == []
  , execState (append "a" "")   dictionary == dictionary
  , execState (append "a" "bc") []         == ["ab"]
  , execState (append "a" "bc") ["ab"]     == ["ab"]
  ]

encode :: String -> WriterT [Int] (State Dictionary) ()
encode "" = return ()
encode w = do
        dict <- get
        let (a, b, c) = (munch w) dict
        if length dict < 256
        then do
            tell [a]
            put ((append b c) dict)
            encode c
        else return ()

test_encode =
  [ evalState (execWriterT (encode ""))         []         == []
  , evalState (execWriterT (encode "aaa"))      ["a"]      == [0, 1]
  , evalState (execWriterT (encode "aaaa"))     ["a"]      == [0, 1, 0]
  , evalState (execWriterT (encode "aaaaa"))    ["a"]      == [0, 1, 1]
  , evalState (execWriterT (encode "abababab")) ["a", "b"] == [0, 1, 2, 4, 1]
  , evalState (execWriterT (encode "aaabbbccc")) dictionary
    == [97, 128, 98, 130, 99, 132]
  ]

decode :: [Int] -> WriterT String (State Dictionary) ()
decode [] = return ()
decode [x] = do
    dict <- get
    tell (dict!!x)
decode (x:xs) = do
    dict <- get
    let f = dict!!x
    let s = if(length dict > head xs) 
            then dict!!head xs
            else f
    tell f
    put (append f s) dict
    decode xs

    test_decode =
  [ evalState (execWriterT (decode []))           []         == []
  , evalState (execWriterT (decode [0]))          ["a"]      == "a"
  , evalState (execWriterT (decode [0, 1, 1, 0])) ["a", "b"] == "abba"
  , evalState (execWriterT (decode [0, 1, 2, 0])) ["a", "b"] == "ababa"
  , evalState (execWriterT (decode [0, 1, 2, 4, 1])) ["a", "b"] == "abababab"
  , evalState (execWriterT (decode [97, 128, 98, 130, 99, 132])) dictionary
    == "aaabbbccc"
  ]

compress :: String -> [Int]
compress w = evalState (execWriterT (encode w)) dictionary

test_compress =
  [ compress ""          == []
  , compress "a"         == [97]
  , compress "aaa"       == [97, 128]
  , compress "aaabbbccc" == [97, 128, 98, 130, 99, 132]
  ]

decompress :: [Int] -> String
decompress list = evalState (execWriterT (decode list)) dictionary

test_decompress =
  [ decompress []                          == ""
  , decompress [97]                        == "a"
  , decompress [97, 128]                   == "aaa"
  , decompress [97, 128, 98, 130, 99, 132] == "aaabbbccc"
  ]

prop_compressDecompress :: String -> Bool
prop_compressDecompress w = do
    let tmp = [chr (div (ord x) 2) | x <- w]
    decompress (compress tmp) == tmp

compressFile :: FilePath -> FilePath -> IO ()
compressFile source target = do
    s <- readFile source
    let compressed = compress s
    let chars = [chr x | x <- compressed]
    writeFile target chars

decompressFile  :: FilePath -> FilePath -> IO ()
decompressFile  source target = do
    s <- readFile source
    let code = [ord x | x <- s]
    let decompressed = decompress code
    writeFile target decompressed

allTests = [test_dictionary, test_prefixes, test_longest, test_munch, test_append 
    ,test_encode
    --, test_decode, test_compress, test_decompress
    ]

main = do
    --quickCheck prop_compressDecompress
    print (allTests, and (concat allTests))

С этим кодом я получаю следующую ошибку (ссылаясь на использование функций put в функциях "encode" и "decode"):

Main.hs@80: 13-80: 16 Нет экземпляра для (MonadState () (StateT Dictionary Data.Functor.Identity.Identity)), возникающего в результате использования пут

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

Не могли бы вы помочь мне с тем, что я здесь делаю неправильно?

Answer 1

Вам не нужно писать никаких экземпляров. Вы просто используете append а также munch неправильно.

append имеет тип MonadState Dictionary m => String -> String -> m (), Если f а также s тогда строки append f s дает действие, изменяющее состояние, которое в конечном итоге возвращает (),

put имеет тип MonadState s m => s -> m (), put заменяет текущее состояние на s аргумент.

В свете этого put (append f s) dict имеет мало смысла. Вы должны поставить put единственный аргумент. И вам не нужно ничего делать с dict там; Суть использования монады State заключается в том, что состояние остается неявным, и нет необходимости передавать его.

Также, append f s само по себе уже обновляет состояние. Так что вы хотите здесь просто append f s, вместо put (append x y) dict,

Там похожая ошибка в encode с munch; у него есть один String аргумент, так (munch w) dict ошибочен Опять же, не нужно трогать dict, Также из-за munch w дает монадический результат, вы должны связать результат с <- вместо let, Итак, вы должны заменить let (a, b, c) = (much w dict) с (a, b, c) <- munch w,

Answer 2

put ((append b c) dict)

выглядит неправильно. append это уже монадическое действие, поэтому его должно быть достаточно для использования

append b c