module Interfaces.FZSolutionParser (
getSolution
) where
import Data.Char
import Control.Applicative
import Control.Monad
import qualified Data.Map.Strict as M
import qualified Data.Set as S
import qualified Text.Parsec as P
import qualified Text.Parsec.Char as C
import qualified Text.Parsec.Combinator as C1
import Text.Parsec.String (Parser)
type Solution = [(String,String)]
getSolution :: FilePath -> IO ()
getSolution path = do
output <- readFile path
let sol = map parse $ getPairs output
print sol
getPairs :: String -> [Solution]
getPairs = groupBySolution . usefull . (map clean) . lines
groupBySolution :: [String] -> [Solution]
groupBySolution = map makePairs . groupString
groupString :: [String] -> [[String]]
groupString [] = []
groupString ["=====UNSATISFIABLE====="] = [["Unsatisfiable"]]
groupString cls = let dw = dropWhile (/= "----------") cls
in if dw == []
then (takeWhile (/= "----------") cls) : []
else (takeWhile (/= "----------") cls) : (groupString $ tail dw)
makePairs :: [String] -> Solution
makePairs [] = []
makePairs ("Unsatisfiable":ls) = [("Unsatisfiable", "Unsatisfiable")]
makePairs (l:ls) = let (name, value) = break ((==) '=') l
in (init name, value) : makePairs ls
usefull :: [String] -> [String]
usefull [] = []
usefull ("":ls) = usefull ls
usefull (('%':rs):ls) = usefull ls
usefull ("==========":ls) = usefull ls
usefull (l:ls) = l:(usefull ls)
clean :: String -> String
clean = filter (not . (`elem` [' ', ';']))
data MValue = MError String
| MInt Int
| MFloat Float
| MBool Bool
| MString String
| MArray [MValue]
| MSet (S.Set MValue)
deriving Show
runParser :: Parser a -> String -> Either P.ParseError a
runParser p = P.parse (p <* C1.eof) ""
varName :: Parser String
varName = manyTill anyChar (char '=')
digit :: Parser Char
digit = C.digit
anyChar :: Parser Char
anyChar = C.anyChar
char :: Char -> Parser Char
char = C.char
sepBy :: Parser a -> Parser b -> Parser [a]
sepBy = C1.sepBy
sepEndBy1 :: Parser a -> Parser b -> Parser [a]
sepEndBy1 = C1.sepEndBy1
between :: Parser a -> Parser b -> Parser c -> Parser c
between = C1.between
manyTill :: Parser a -> Parser b -> Parser [a]
manyTill = C1.manyTill
many1 :: Parser a -> Parser [a]
many1 = C1.many1
digitValue :: Parser Int
digitValue = do
d <- digit
return $ ord(d) ord('0')
ascendDecimal = do
return $ \x y -> x*10 + y
opposite = do
n <- natural
return (n)
natural :: Parser Int
natural = C1.chainl1 digitValue ascendDecimal
int :: Parser Int
int = (char '-' >> opposite ) <|> natural
string :: String -> Parser String
string = C.string
bool :: Parser Bool
bool = string "true" >> return True <|> (string "false" >> return False)
float :: Parser Float
float = do
ipart <- many1 digit
char '.'
dpart <- many1 digit
let a = read (ipart ++ "." ++ dpart) :: Float in
return a
set :: Parser a -> Parser [a]
set p = between (char '{') (char '}') (sepBy p (string ","))
intM :: Parser MValue
intM = MInt <$> int
boolM :: Parser MValue
boolM = MBool <$> bool
floatM :: Parser MValue
floatM = MFloat <$> float
stringM :: Parser MValue
stringM = MString <$> (P.many anyChar)
setM :: Parser MValue -> Parser MValue
setM p = MSet <$> S.fromDistinctAscList <$> (set p)
indexRange :: Parser Int
indexRange = do
a <- int
string ".."
b <- int
return (b a + 1)
arraySizes :: Parser [Int]
arraySizes = sepEndBy1 indexRange (string ",")
extract :: Parser MValue -> Parser [MValue]
extract p = between (char '[') (char ']') (sepBy p (string ","))
fixDims :: [Int] -> [MValue] -> MValue
fixDims [] _ = MError "Array dimensions error: fixDims applied on empty list"
fixDims [d] ms = MArray $ ms
fixDims ds ms = fixDims (init ds) (fix1Dim (last ds) ms)
fix1Dim :: Int -> [MValue] -> [MValue]
fix1Dim _ [] = []
fix1Dim d ms = MArray (take d ms) : (fix1Dim d (drop d ms))
array :: Parser MValue -> Parser MValue
array p = do
string "array"
manyTill anyChar (char '(')
ls <- arraySizes
es <- extract p
string ")"
return (fixDims ls es)
scalar :: Parser MValue
scalar = P.try floatM <|> intM <|> boolM <|> stringM
parser :: Parser MValue
parser = P.try floatM <|> intM <|> boolM <|> (setM scalar) <|> (array scalar) <|> stringM
parse :: Solution -> M.Map String MValue
parse [] = M.empty
parse (l:ls) =
if fst l == "Unsatisfiable"
then M.insert "Unsatisfiable" (MError "Unsatisfiable") M.empty
else let value = runParser parser (snd l) in
case value of
Right v -> M.insert (fst l) v (parse ls)
Left _ -> M.insert (fst l) (MError "General parse error") (parse ls)
parseWithLeftOver :: Parser a -> String -> Either P.ParseError (a,String)
parseWithLeftOver p = P.parse ((,) <$> p <*> leftOver) ""
where leftOver = manyTill C1.anyToken C1.eof