我正在尝试使用Monads在Haskell中实现LZW压缩，这是我的代码到目前为止的测试用例：
{-# 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 in“encode”和“decode”函数）：
Main.hs@80:13-80:16因使用put而产生的（MonadState（）（StateT Dictionary Data.Functor.Identity.Identity））没有实例
我试图定义这个实例，但我能做到的最好的是“实例声明之间的功能依赖性冲突”错误。 我知道没有Monads有更简单的解决方案，但我必须使用它们，也不要修改函数的类型。
你能帮我解决一下我在做错的事吗？
答案 0 :(得分：4)
您不需要编写任何实例。您只是以错误的方式使用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 monad的一个核心点是状态是隐含的，没有必要传递它。
此外，append f s本身已经更新了状态。所以你想要的只是append f s，而不是put (append x y) dict。
encode munch出现类似错误;它有一个String参数，因此(munch w) dict是错误的。同样，无需触摸dict。此外，由于munch w会产生monadic结果，因此您必须将结果与<-而不是let绑定。因此，您应该将let (a, b, c) = (much w dict)替换为(a, b, c) <- munch w。
答案 1 :(得分：1)
put ((append b c) dict)
看起来不对。 append已经是一个monadic动作，所以它应该足够使用
append b c