module System.IO.MatrixMarket (
Field(..),
Format(..),
Type(..),
hPutVector,
hPutVectorWithDesc,
hGetVector,
hPutCoordVector,
hPutCoordVectorWithDesc,
hGetCoordVector,
hPutMatrix,
hPutMatrixWithDesc,
hGetMatrix,
hPutCoordMatrix,
hPutCoordMatrixWithDesc,
hGetCoordMatrix,
showHeader,
readHeader,
hPutBanner,
hGetBanner,
hPutHeader,
hGetHeader,
commentChar,
hPutComments,
hGetComments,
) where
import Control.Monad ( forM_ )
import Data.Char ( toLower, toUpper, isSpace )
import Data.List ( intercalate )
import Data.Maybe ( fromMaybe )
import System.IO ( Handle, hGetLine, hPutStr, hPutStrLn, hLookAhead )
import Text.Printf ( printf )
import qualified Data.ByteString.Lazy.Char8 as B
type ByteString = B.ByteString
data Field = Real | Complex | Integer | Pattern
deriving (Eq, Read, Show)
data Format = Coordinate | Array
deriving (Eq, Read, Show)
data Type = General | Symmetric | Hermitian | Skew
deriving (Eq, Read, Show)
showHeader :: Format -> Field -> Type -> String
showHeader format field t = intercalate " "
$ [ prefixStr, showMM format, showMM field, showMM t ]
readHeader :: String -> (Format, Field, Type)
readHeader str =
case words str of
(mm:m:ws) ->
if mm ++ " " ++ m == prefixStr
then case ws of
[ format, field, t ] ->
(readMM format, readMM field, readMM t)
_ -> err
else
err
_ -> err
where
err = error "could not parse Matrix Market header"
hPutBanner :: Handle -> Format -> Field -> Type -> String -> IO ()
hPutBanner h format field t str = do
hPutHeader h format field t
hPutComments h str
hGetBanner :: Handle -> IO (Format, Field, Type)
hGetBanner h = do
header <- hGetHeader h
hGetComments h
return header
hPutHeader :: Handle -> Format -> Field -> Type -> IO ()
hPutHeader h format field t =
hPutStrLn h $ showHeader format field t
hGetHeader :: Handle -> IO (Format, Field, Type)
hGetHeader h = hGetLine h >>= return . readHeader
commentChar :: Char
commentChar = '%'
hPutComments :: Handle -> String -> IO ()
hPutComments h cs =
forM_ (lines cs) $ \l -> do
hPutStr h $ [ commentChar, ' ' ]
hPutStrLn h l
hGetComments :: Handle -> IO (String)
hGetComments h = do
c <- hLookAhead h
if c == commentChar
then do
(_:l) <- hGetLine h
ls <- hGetComments h
return (l ++ "\n" ++ ls)
else
return ""
hPutSize2 :: Handle -> Int -> Int -> IO ()
hPutSize2 h m n =
hPutStrLn h $ show m ++ "\t" ++ show n
hPutSize3 :: Handle -> Int -> Int -> Int -> IO ()
hPutSize3 h m n l =
hPutStrLn h $ show m ++ "\t" ++ show n ++ "\t" ++ show l
hGetSize2 :: Handle -> IO (Int,Int)
hGetSize2 h = do
l <- hGetLine h
case (words l) of
[ n1, n2 ] -> return (read n1, read n2)
_ -> ioError $ userError "could not read sizes"
hGetSize3 :: Handle -> IO (Int,Int,Int)
hGetSize3 h = do
l <- hGetLine h
case (words l) of
[ n1, n2, n3 ] -> return (read n1, read n2, read n3)
_ -> ioError $ userError "could not read sizes"
hPutVector :: (Show a) =>
Handle -> Field -> Int -> [a] -> IO ()
hPutVector = flip hPutVectorWithDesc ""
hPutVectorWithDesc :: (Show a) =>
Handle -> String -> Field -> Int -> [a] -> IO ()
hPutVectorWithDesc h desc field n xs =
hPutMatrixWithDesc h desc field General (n,1) xs
hGetVector :: (Read a) => Handle -> Field -> IO (Int, Maybe [a])
hGetVector h field = do
((m,n),xs) <- hGetMatrix h field General
case (m,n) of
(_,1) -> return (m,xs)
(1,_) -> return (n,xs)
_ ->
fail $ printf
("expecting a vector but instead got a matrix with"
++ " dimensions (%d,%d)") m n
hPutCoordVector :: (Show a) =>
Handle -> Field -> Int -> Int -> [(Int, a)] -> IO ()
hPutCoordVector = flip hPutCoordVectorWithDesc ""
hPutCoordVectorWithDesc :: (Show a) =>
Handle -> String -> Field -> Int -> Int -> [(Int, a)] -> IO ()
hPutCoordVectorWithDesc h desc field n nz ixs =
let ijxs = map (\(i,x) -> ((i,1),x)) ixs
in hPutCoordMatrixWithDesc h desc field General (n,1) nz ijxs
hGetCoordVector :: (Read a) =>
Handle -> Field -> IO (Int, Int, Either [Int] [(Int, a)])
hGetCoordVector h field = do
((m,n), nz, ijxs') <- hGetCoordMatrix h field General
case (m,n) of
(_,1) ->
let ixs = either (Left . fst . unzip )
(\ijxs -> let (ijs,xs) = unzip ijxs
is = (fst . unzip) ijs
in Right $ zip is xs)
ijxs'
in return (m, nz, ixs)
(1,_) ->
let jxs = either (Left . snd . unzip )
(\ijxs -> let (ijs,xs) = unzip ijxs
js = (snd . unzip) ijs
in Right $ zip js xs)
ijxs'
in return (n, nz, jxs)
_ ->
fail $ printf
("expecting a vector but instead got a matrix with"
++ " dimensions (%d,%d)") m n
hPutMatrix :: (Show a) =>
Handle -> Field -> Type -> (Int,Int) -> [a] -> IO ()
hPutMatrix = flip hPutMatrixWithDesc ""
hPutMatrixWithDesc :: (Show a) =>
Handle -> String -> Field -> Type -> (Int,Int) -> [a] -> IO ()
hPutMatrixWithDesc h desc field t (m,n) xs = do
hPutHeader h Array field t
hPutComments h desc
hPutSize2 h m n
case field of
Pattern -> return ()
_ -> mapM_ (\x -> hPutStrLn h $ show x) xs
hGetMatrix :: (Read a) =>
Handle -> Field -> Type -> IO ((Int,Int), Maybe [a])
hGetMatrix h field t = do
(format,field',t') <- hGetBanner h
if format == Array
&& field' == field
&& t' == t
then do
(m,n) <- hGetSize2 h
ls <- B.hGetContents h >>= return . B.lines
let xs = case field of
Pattern -> Nothing
_ -> Just $ map (readValue . dropLineComment) ls
return ((m,n), xs)
else
headerError Array field t
hPutCoordMatrix :: (Show a) =>
Handle -> Field -> Type
-> (Int,Int) -> Int -> [((Int,Int), a)] -> IO ()
hPutCoordMatrix = flip hPutCoordMatrixWithDesc ""
hPutCoordMatrixWithDesc :: (Show a) =>
Handle -> String -> Field -> Type
-> (Int,Int) -> Int -> [((Int,Int), a)] -> IO ()
hPutCoordMatrixWithDesc h desc field t (m,n) nz ijes = do
hPutHeader h Coordinate field t
hPutComments h desc
hPutSize3 h m n nz
let showCoord = case field of
Pattern -> \((i,j),_) -> show i ++ "\t" ++ show j
_ -> \((i,j),x) -> show i ++ "\t" ++ show j ++ "\t" ++ show x
mapM_ (hPutStrLn h . showCoord) ijes
hGetCoordMatrix :: (Read a) =>
Handle -> Field -> Type
-> IO ((Int,Int), Int, Either [(Int,Int)] [((Int,Int), a)])
hGetCoordMatrix h field t = do
(format, field', t') <- hGetBanner h
if format == Coordinate
&& field' == field
&& t' == t
then do
(m,n,nz) <- hGetSize3 h
ls <- B.hGetContents h >>= return . B.lines
let ixs = map parseLine ls
ixs' = case field of
Pattern -> Left $ map fst ixs
_ -> Right ixs
return ((m,n), nz, ixs')
else
headerError Coordinate field t
where
parseLine l =
let (i,l') = readInt $ dropLineComment l
(j,l'') = readInt l'
e = case field of
Pattern -> undefined
_ -> readValue l''
in ((i,j),e)
prefixStr :: String
prefixStr = "%%MatrixMarket matrix"
showMM :: (Show a) => a -> String
showMM a =
let (c:cs) = show a
in (toLower c):cs
readMM :: (Read a) => String -> a
readMM ~(c:cs) =
read $ (toUpper c):cs
headerError :: Format -> Field -> Type -> IO a
headerError format field t =
ioError $ userError $ printf
"header does not match expected type: `%s %s %s'"
(showMM format)
(showMM field)
(showMM t)
dropLineComment :: ByteString -> ByteString
dropLineComment =
B.takeWhile (/= commentChar)
readInt :: ByteString -> (Int, ByteString)
readInt s =
fromMaybe (error "could not parse integer")
$ B.readInt (B.dropWhile isSpace s)
readValue :: (Read a) => ByteString -> a
readValue s =
read $ B.unpack (B.dropWhile isSpace s)