module System.IO.MatrixMarket (
Type(..),
Field(..),
Format(..),
MatrixType(..),
hPutVector,
hPutVectorWithDesc,
hGetVector,
hPutCoordVector,
hPutCoordVectorWithDesc,
hGetCoordVector,
hPutMatrix,
hPutMatrixWithDesc,
hGetMatrix,
hPutCoordMatrix,
hPutCoordMatrixWithDesc,
hGetCoordMatrix,
showVectorHeader,
showMatrixHeader,
readHeader,
hPutVectorBanner,
hPutMatrixBanner,
hGetBanner,
hPutVectorHeader,
hPutMatrixHeader,
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 qualified Data.ByteString.Lazy.Char8 as B
type ByteString = B.ByteString
data Type = Matrix | Vector
deriving (Eq, Read, Show)
data Field = Real | Complex | Integer | Pattern
deriving (Eq, Read, Show)
data Format = Coordinate | Array
deriving (Eq, Read, Show)
data MatrixType = General | Symmetric | Hermitian | Skew
deriving (Eq, Read, Show)
showVectorHeader :: Format -> Field -> String
showVectorHeader format field = intercalate " "
$ [ prefixStr, showMM Vector, showMM format, showMM field ]
showMatrixHeader :: Format -> Field -> MatrixType -> String
showMatrixHeader format field attr = intercalate " "
$ [ prefixStr, showMM Matrix, showMM format, showMM field, showMM attr ]
readHeader :: String -> (Type, Format, Field, Maybe MatrixType)
readHeader str =
case words str of
(p:t:ws) ->
if p == prefixStr
then case (readMM t, ws) of
(Vector, [ format, field ]) ->
(Vector, readMM format, readMM field, Nothing)
(Matrix, [ format, field, attr ]) ->
(Matrix, readMM format, readMM field, Just (readMM attr))
_ -> err
else
err
_ -> err
where
err = error "could not parse Matrix Market header"
hPutVectorBanner :: Handle -> Format -> Field -> String -> IO ()
hPutVectorBanner h format field str = do
hPutVectorHeader h format field
hPutComments h str
hPutMatrixBanner :: Handle -> Format -> Field -> MatrixType -> String -> IO ()
hPutMatrixBanner h format field attr str = do
hPutMatrixHeader h format field attr
hPutComments h str
hGetBanner :: Handle -> IO (Type, Format, Field, Maybe MatrixType)
hGetBanner h = do
header <- hGetHeader h
hGetComments h
return header
hPutVectorHeader :: Handle -> Format -> Field -> IO ()
hPutVectorHeader h format field =
hPutStrLn h $ showVectorHeader format field
hPutMatrixHeader :: Handle -> Format -> Field -> MatrixType -> IO ()
hPutMatrixHeader h format field attr =
hPutStrLn h $ showMatrixHeader format field attr
hGetHeader :: Handle -> IO (Type, Format, Field, Maybe MatrixType)
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 ""
hPutSize1 :: Handle -> Int -> IO ()
hPutSize1 h n =
hPutStrLn h $ show n
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
hGetSize1 :: Handle -> IO Int
hGetSize1 h = hGetLine h >>= return . read
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 = do
hPutVectorHeader h Array field
hPutComments h desc
hPutSize1 h n
case field of
Pattern -> return ()
_ -> mapM_ (\x -> hPutStrLn h $ show x) xs
hGetVector :: (Read a) => Handle -> Field -> IO (Int, Maybe [a])
hGetVector h field = do
(t,format,field',attr') <- hGetBanner h
if t == Vector
&& format == Array
&& field' == field
&& attr' == Nothing
then do
n <- hGetSize1 h
ls <- B.hGetContents h >>= return . B.lines
let xs = case field of
Pattern -> Nothing
_ -> Just $ map (readValue . dropLineComment) ls
return (n, xs)
else
headerError Vector Array field Nothing
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 = do
hPutVectorHeader h Coordinate field
hPutComments h desc
hPutSize2 h n nz
let showCoord = case field of
Pattern -> \(i,_) -> show i
_ -> \(i,x) -> show i ++ "\t" ++ show x
mapM_ (hPutStrLn h . showCoord) ixs
hGetCoordVector :: (Read a) =>
Handle -> Field -> IO (Int, Int, Either [Int] [(Int, a)])
hGetCoordVector h field = do
(t,format,field',attr') <- hGetBanner h
if t == Vector
&& format == Coordinate
&& field' == field
&& attr' == Nothing
then do
(n,nz) <- hGetSize2 h
ls <- B.hGetContents h >>= return . B.lines
let ixs = map readCoord ls
ixs' = case field of
Pattern -> Left $ map fst ixs
_ -> Right ixs
return (n, nz, ixs')
else
headerError Vector Coordinate field Nothing
where
readCoord l =
let (i,l') = readInt $ dropLineComment l
x = case field of
Pattern -> undefined
_ -> readValue l'
in (i,x)
hPutMatrix :: (Show a) =>
Handle -> Field -> MatrixType -> (Int,Int) -> [a] -> IO ()
hPutMatrix = flip hPutMatrixWithDesc ""
hPutMatrixWithDesc :: (Show a) =>
Handle -> String -> Field -> MatrixType -> (Int,Int) -> [a] -> IO ()
hPutMatrixWithDesc h desc field attr (m,n) xs = do
hPutMatrixHeader h Array field attr
hPutComments h desc
hPutSize2 h m n
case field of
Pattern -> return ()
_ -> mapM_ (\x -> hPutStrLn h $ show x) xs
hGetMatrix :: (Read a) =>
Handle -> Field -> MatrixType -> IO ((Int,Int), Maybe [a])
hGetMatrix h field attr = do
(t,format,field',attr') <- hGetBanner h
if t == Matrix
&& format == Array
&& field' == field
&& attr' == Just attr
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 Matrix Array field (Just attr)
hPutCoordMatrix :: (Show a) =>
Handle -> Field -> MatrixType
-> (Int,Int) -> Int -> [((Int,Int), a)] -> IO ()
hPutCoordMatrix = flip hPutCoordMatrixWithDesc ""
hPutCoordMatrixWithDesc :: (Show a) =>
Handle -> String -> Field -> MatrixType
-> (Int,Int) -> Int -> [((Int,Int), a)] -> IO ()
hPutCoordMatrixWithDesc h desc field attr (m,n) nz ijes = do
hPutMatrixHeader h Coordinate field attr
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 -> MatrixType
-> IO ((Int,Int), Int, Either [(Int,Int)] [((Int,Int), a)])
hGetCoordMatrix h field attr = do
(t, format, field', attr') <- hGetBanner h
if t == Matrix
&& format == Coordinate
&& field' == field
&& attr' == Just attr
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 Matrix Coordinate field (Just attr)
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"
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 :: Type -> Format -> Field -> Maybe MatrixType -> IO a
headerError t format field attr =
ioError $ userError $
"header does not match expected type `"
++ showMM t ++ " " ++ showMM format ++ " " ++ showMM field ++ " "
++ fromMaybe "" (attr >>= return . showMM)
++ "'."
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)