{-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -Wall #-}
{-# OPTIONS_HADDOCK show-extensions #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  ToySolver.Text.SDPFile
-- Copyright   :  (c) Masahiro Sakai 2012,2016
-- License     :  BSD-style
--
-- Maintainer  :  masahiro.sakai@gmail.com
-- Stability   :  provisional
-- Portability :  non-portable
--
-- References:
--
-- * SDPA (Semidefinite Programming Algorithm) User's Manual
--   <http://sdpa.indsys.chuo-u.ac.jp/~fujisawa/sdpa_doc.pdf>
--
-- * <http://euler.nmt.edu/~brian/sdplib/FORMAT>
--
-----------------------------------------------------------------------------
module ToySolver.Text.SDPFile
  ( -- * The problem type
    Problem (..)
  , Matrix
  , Block
  , mDim
  , nBlock
  , blockElem
    -- * The solution type
  , Solution (..)
  , evalPrimalObjective
  , evalDualObjective

    -- * File I/O
  , readDataFile
  , writeDataFile

    -- * Construction
  , DenseMatrix
  , DenseBlock
  , denseMatrix
  , denseBlock
  , diagBlock

    -- * Rendering
  , renderData
  , renderSparseData

    -- * Parsing
  , ParseError
  , parseData
  , parseSparseData
  ) where

import Control.Exception
import Control.Monad
import qualified Data.ByteString.Lazy as BL
import Data.ByteString.Builder (Builder)
import qualified Data.ByteString.Builder as B
import qualified Data.ByteString.Builder.Scientific as B
import Data.Char
import qualified Data.Foldable as F
import Data.List (intersperse)
#if !MIN_VERSION_base(4,11,0)
import Data.Monoid
#endif
import Data.Scientific (Scientific)
import Data.Map (Map)
import qualified Data.Map as Map
import qualified Data.IntMap as IntMap
import System.FilePath (takeExtension)
import System.IO
import qualified Text.Megaparsec as MegaParsec
#if MIN_VERSION_megaparsec(7,0,0)
import Data.Word
import Data.Void
import Text.Megaparsec hiding (ParseError, oneOf)
import Text.Megaparsec.Byte
import qualified Text.Megaparsec.Byte.Lexer as Lexer
#elif MIN_VERSION_megaparsec(6,0,0)
import Data.Word
import Data.Void
import Text.Megaparsec hiding (ParseError, oneOf)
import Text.Megaparsec.Byte hiding (oneOf)
import qualified Text.Megaparsec.Byte as MegaParsec
import qualified Text.Megaparsec.Byte.Lexer as Lexer
#else
import qualified Data.ByteString.Lazy.Char8 as BL8
import Text.Megaparsec hiding (ParseError, oneOf)
import qualified Text.Megaparsec.Lexer as Lexer
import Text.Megaparsec.Prim (MonadParsec ())
#endif

#if MIN_VERSION_megaparsec(7,0,0)
type C e s m = (MonadParsec e s m, Token s ~ Word8)
type ParseError = MegaParsec.ParseErrorBundle BL.ByteString Void
#elif MIN_VERSION_megaparsec(6,0,0)
type C e s m = (MonadParsec e s m, Token s ~ Word8)
type ParseError = MegaParsec.ParseError Word8 Void
#else
type C e s m = (MonadParsec e s m, Token s ~ Char)
type ParseError = MegaParsec.ParseError Char Dec
#endif

#if MIN_VERSION_megaparsec(7,0,0)
anyChar :: C e s m => m Word8
anyChar :: m Word8
anyChar = m Word8
forall e s (m :: * -> *). MonadParsec e s m => m (Token s)
anySingle
#endif

-- ---------------------------------------------------------------------------
-- problem description
-- ---------------------------------------------------------------------------

data Problem
  = Problem
  { Problem -> [Int]
blockStruct :: [Int]      -- ^ the block strcuture vector (bLOCKsTRUCT)
  , Problem -> [Scientific]
costs       :: [Scientific] -- ^ Constant Vector
  , Problem -> [Matrix]
matrices    :: [Matrix]   -- ^ Constraint Matrices
  }
  deriving (Int -> Problem -> ShowS
[Problem] -> ShowS
Problem -> String
(Int -> Problem -> ShowS)
-> (Problem -> String) -> ([Problem] -> ShowS) -> Show Problem
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Problem] -> ShowS
$cshowList :: [Problem] -> ShowS
show :: Problem -> String
$cshow :: Problem -> String
showsPrec :: Int -> Problem -> ShowS
$cshowsPrec :: Int -> Problem -> ShowS
Show, Eq Problem
Eq Problem
-> (Problem -> Problem -> Ordering)
-> (Problem -> Problem -> Bool)
-> (Problem -> Problem -> Bool)
-> (Problem -> Problem -> Bool)
-> (Problem -> Problem -> Bool)
-> (Problem -> Problem -> Problem)
-> (Problem -> Problem -> Problem)
-> Ord Problem
Problem -> Problem -> Bool
Problem -> Problem -> Ordering
Problem -> Problem -> Problem
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Problem -> Problem -> Problem
$cmin :: Problem -> Problem -> Problem
max :: Problem -> Problem -> Problem
$cmax :: Problem -> Problem -> Problem
>= :: Problem -> Problem -> Bool
$c>= :: Problem -> Problem -> Bool
> :: Problem -> Problem -> Bool
$c> :: Problem -> Problem -> Bool
<= :: Problem -> Problem -> Bool
$c<= :: Problem -> Problem -> Bool
< :: Problem -> Problem -> Bool
$c< :: Problem -> Problem -> Bool
compare :: Problem -> Problem -> Ordering
$ccompare :: Problem -> Problem -> Ordering
$cp1Ord :: Eq Problem
Ord, Problem -> Problem -> Bool
(Problem -> Problem -> Bool)
-> (Problem -> Problem -> Bool) -> Eq Problem
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Problem -> Problem -> Bool
$c/= :: Problem -> Problem -> Bool
== :: Problem -> Problem -> Bool
$c== :: Problem -> Problem -> Bool
Eq)

type Matrix = [Block]

type Block = Map (Int,Int) Scientific

-- | the number of primal variables (mDim)
mDim :: Problem -> Int
mDim :: Problem -> Int
mDim Problem
prob = [Matrix] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Problem -> [Matrix]
matrices Problem
prob) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1

-- | the number of blocks (nBLOCK)
nBlock :: Problem -> Int
nBlock :: Problem -> Int
nBlock Problem
prob = [Int] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Problem -> [Int]
blockStruct Problem
prob)

blockElem :: Int -> Int -> Block -> Scientific
blockElem :: Int -> Int -> Block -> Scientific
blockElem Int
i Int
j Block
b = Scientific -> (Int, Int) -> Block -> Scientific
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Scientific
0 (Int
i,Int
j) Block
b

-- ---------------------------------------------------------------------------
-- solution
-- ---------------------------------------------------------------------------

data Solution
  = Solution
  { Solution -> [Scientific]
primalVector :: [Scientific] -- ^ The primal variable vector x
  , Solution -> Matrix
primalMatrix :: Matrix -- ^ The primal variable matrix X
  , Solution -> Matrix
dualMatrix   :: Matrix -- ^ The dual variable matrix Y
  }
  deriving (Int -> Solution -> ShowS
[Solution] -> ShowS
Solution -> String
(Int -> Solution -> ShowS)
-> (Solution -> String) -> ([Solution] -> ShowS) -> Show Solution
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Solution] -> ShowS
$cshowList :: [Solution] -> ShowS
show :: Solution -> String
$cshow :: Solution -> String
showsPrec :: Int -> Solution -> ShowS
$cshowsPrec :: Int -> Solution -> ShowS
Show, Eq Solution
Eq Solution
-> (Solution -> Solution -> Ordering)
-> (Solution -> Solution -> Bool)
-> (Solution -> Solution -> Bool)
-> (Solution -> Solution -> Bool)
-> (Solution -> Solution -> Bool)
-> (Solution -> Solution -> Solution)
-> (Solution -> Solution -> Solution)
-> Ord Solution
Solution -> Solution -> Bool
Solution -> Solution -> Ordering
Solution -> Solution -> Solution
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Solution -> Solution -> Solution
$cmin :: Solution -> Solution -> Solution
max :: Solution -> Solution -> Solution
$cmax :: Solution -> Solution -> Solution
>= :: Solution -> Solution -> Bool
$c>= :: Solution -> Solution -> Bool
> :: Solution -> Solution -> Bool
$c> :: Solution -> Solution -> Bool
<= :: Solution -> Solution -> Bool
$c<= :: Solution -> Solution -> Bool
< :: Solution -> Solution -> Bool
$c< :: Solution -> Solution -> Bool
compare :: Solution -> Solution -> Ordering
$ccompare :: Solution -> Solution -> Ordering
$cp1Ord :: Eq Solution
Ord, Solution -> Solution -> Bool
(Solution -> Solution -> Bool)
-> (Solution -> Solution -> Bool) -> Eq Solution
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Solution -> Solution -> Bool
$c/= :: Solution -> Solution -> Bool
== :: Solution -> Solution -> Bool
$c== :: Solution -> Solution -> Bool
Eq)

evalPrimalObjective :: Problem -> Solution -> Scientific
evalPrimalObjective :: Problem -> Solution -> Scientific
evalPrimalObjective Problem
prob Solution
sol = [Scientific] -> Scientific
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Scientific] -> Scientific) -> [Scientific] -> Scientific
forall a b. (a -> b) -> a -> b
$ (Scientific -> Scientific -> Scientific)
-> [Scientific] -> [Scientific] -> [Scientific]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Scientific -> Scientific -> Scientific
forall a. Num a => a -> a -> a
(*) (Problem -> [Scientific]
costs Problem
prob) (Solution -> [Scientific]
primalVector Solution
sol)

evalDualObjective :: Problem -> Solution -> Scientific
evalDualObjective :: Problem -> Solution -> Scientific
evalDualObjective Problem{ matrices :: Problem -> [Matrix]
matrices = [] } Solution
_ = String -> Scientific
forall a. HasCallStack => String -> a
error String
"evalDualObjective: invalid problem data"
evalDualObjective Problem{ matrices :: Problem -> [Matrix]
matrices = Matrix
f0:[Matrix]
_ } Solution
sol =
  [Scientific] -> Scientific
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Scientific] -> Scientific) -> [Scientific] -> Scientific
forall a b. (a -> b) -> a -> b
$ (Block -> Block -> Scientific) -> Matrix -> Matrix -> [Scientific]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Block
blk1 Block
blk2 -> Block -> Scientific
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
F.sum ((Scientific -> Scientific -> Scientific) -> Block -> Block -> Block
forall k a b c.
Ord k =>
(a -> b -> c) -> Map k a -> Map k b -> Map k c
Map.intersectionWith Scientific -> Scientific -> Scientific
forall a. Num a => a -> a -> a
(*) Block
blk1 Block
blk2)) Matrix
f0 (Solution -> Matrix
dualMatrix Solution
sol)

-- ---------------------------------------------------------------------------
-- construction
-- ---------------------------------------------------------------------------

type DenseMatrix = [DenseBlock]

type DenseBlock = [[Scientific]]

denseBlock :: DenseBlock -> Block
denseBlock :: DenseBlock -> Block
denseBlock DenseBlock
xxs = [((Int, Int), Scientific)] -> Block
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [((Int
i,Int
j),Scientific
x) | (Int
i,[Scientific]
xs) <- [Int] -> DenseBlock -> [(Int, [Scientific])]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1..] DenseBlock
xxs, (Int
j,Scientific
x) <- [Int] -> [Scientific] -> [(Int, Scientific)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1..] [Scientific]
xs, Scientific
x Scientific -> Scientific -> Bool
forall a. Eq a => a -> a -> Bool
/= Scientific
0]

denseMatrix :: DenseMatrix -> Matrix
denseMatrix :: DenseMatrix -> Matrix
denseMatrix = (DenseBlock -> Block) -> DenseMatrix -> Matrix
forall a b. (a -> b) -> [a] -> [b]
map DenseBlock -> Block
denseBlock

diagBlock :: [Scientific] -> Block
diagBlock :: [Scientific] -> Block
diagBlock [Scientific]
xs = [((Int, Int), Scientific)] -> Block
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [((Int
i,Int
i),Scientific
x) | (Int
i,Scientific
x) <- [Int] -> [Scientific] -> [(Int, Scientific)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1..] [Scientific]
xs]

-- ---------------------------------------------------------------------------
-- File I/O
-- ---------------------------------------------------------------------------

-- | Parse a SDPA format file (.dat) or a SDPA sparse format file (.dat-s)..
readDataFile :: FilePath -> IO Problem
readDataFile :: String -> IO Problem
readDataFile String
fname = do
  ParsecT Void ByteString Identity Problem
p <- case (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower (ShowS
takeExtension String
fname) of
    String
".dat" -> ParsecT Void ByteString Identity Problem
-> IO (ParsecT Void ByteString Identity Problem)
forall (m :: * -> *) a. Monad m => a -> m a
return ParsecT Void ByteString Identity Problem
forall e s (m :: * -> *). C e s m => m Problem
pDataFile
    String
".dat-s" -> ParsecT Void ByteString Identity Problem
-> IO (ParsecT Void ByteString Identity Problem)
forall (m :: * -> *) a. Monad m => a -> m a
return ParsecT Void ByteString Identity Problem
forall e s (m :: * -> *). C e s m => m Problem
pSparseDataFile
    String
ext -> IOError -> IO (ParsecT Void ByteString Identity Problem)
forall a. IOError -> IO a
ioError (IOError -> IO (ParsecT Void ByteString Identity Problem))
-> IOError -> IO (ParsecT Void ByteString Identity Problem)
forall a b. (a -> b) -> a -> b
$ String -> IOError
userError (String -> IOError) -> String -> IOError
forall a b. (a -> b) -> a -> b
$ String
"unknown extension: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
ext
  ByteString
s <- String -> IO ByteString
BL.readFile String
fname
  case ParsecT Void ByteString Identity Problem
-> String
-> ByteString
-> Either (ParseErrorBundle ByteString Void) Problem
forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
parse (ParsecT Void ByteString Identity Problem
p ParsecT Void ByteString Identity Problem
-> ParsecT Void ByteString Identity ()
-> ParsecT Void ByteString Identity Problem
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Void ByteString Identity ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
eof) String
fname ByteString
s of
    Left ParseErrorBundle ByteString Void
e -> ParseErrorBundle ByteString Void -> IO Problem
forall a e. Exception e => e -> a
throw (ParseErrorBundle ByteString Void
e :: ParseError)
    Right Problem
prob -> Problem -> IO Problem
forall (m :: * -> *) a. Monad m => a -> m a
return Problem
prob

writeDataFile :: FilePath -> Problem -> IO ()
writeDataFile :: String -> Problem -> IO ()
writeDataFile String
fname Problem
prob = do
  Bool
isSparse <- case (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower (ShowS
takeExtension String
fname) of
    String
".dat" -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    String
".dat-s" -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
    String
ext -> IOError -> IO Bool
forall a. IOError -> IO a
ioError (IOError -> IO Bool) -> IOError -> IO Bool
forall a b. (a -> b) -> a -> b
$ String -> IOError
userError (String -> IOError) -> String -> IOError
forall a b. (a -> b) -> a -> b
$ String
"unknown extension: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
ext
  String -> IOMode -> (Handle -> IO ()) -> IO ()
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withBinaryFile String
fname IOMode
WriteMode ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Handle
h -> do
    Handle -> Builder -> IO ()
B.hPutBuilder Handle
h (Builder -> IO ()) -> Builder -> IO ()
forall a b. (a -> b) -> a -> b
$ Bool -> Problem -> Builder
renderImpl Bool
isSparse Problem
prob

-- ---------------------------------------------------------------------------
-- parsing
-- ---------------------------------------------------------------------------

-- | Parse a SDPA format (.dat) string.
parseData :: String -> BL.ByteString -> Either ParseError Problem
parseData :: String
-> ByteString -> Either (ParseErrorBundle ByteString Void) Problem
parseData = ParsecT Void ByteString Identity Problem
-> String
-> ByteString
-> Either (ParseErrorBundle ByteString Void) Problem
forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
parse (ParsecT Void ByteString Identity Problem
forall e s (m :: * -> *). C e s m => m Problem
pDataFile ParsecT Void ByteString Identity Problem
-> ParsecT Void ByteString Identity ()
-> ParsecT Void ByteString Identity Problem
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Void ByteString Identity ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
eof)

-- | Parse a SDPA sparse format (.dat-s) string.
parseSparseData :: String -> BL.ByteString -> Either ParseError Problem
parseSparseData :: String
-> ByteString -> Either (ParseErrorBundle ByteString Void) Problem
parseSparseData = ParsecT Void ByteString Identity Problem
-> String
-> ByteString
-> Either (ParseErrorBundle ByteString Void) Problem
forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
parse (ParsecT Void ByteString Identity Problem
forall e s (m :: * -> *). C e s m => m Problem
pSparseDataFile ParsecT Void ByteString Identity Problem
-> ParsecT Void ByteString Identity ()
-> ParsecT Void ByteString Identity Problem
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Void ByteString Identity ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
eof)

pDataFile :: C e s m => m Problem
pDataFile :: m Problem
pDataFile = do
  [ByteString]
_ <- m ByteString -> m [ByteString]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many m ByteString
forall e s (m :: * -> *). C e s m => m ByteString
pComment
  Integer
m  <- m Integer
forall e s (m :: * -> *). C e s m => m Integer
nat_line -- mDim
  Integer
_n <- m Integer
forall e s (m :: * -> *). C e s m => m Integer
nat_line -- nBlock
  [Int]
bs <- m [Int]
forall e s (m :: * -> *). C e s m => m [Int]
pBlockStruct -- bLOCKsTRUCT
  [Scientific]
cs <- m [Scientific]
forall e s (m :: * -> *). C e s m => m [Scientific]
pCosts
  [Matrix]
ms <- Int -> [Int] -> m [Matrix]
forall e s (m :: * -> *). C e s m => Int -> [Int] -> m [Matrix]
pDenseMatrices (Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
m) [Int]
bs
  m ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Word8) =>
m ()
space
  Problem -> m Problem
forall (m :: * -> *) a. Monad m => a -> m a
return (Problem -> m Problem) -> Problem -> m Problem
forall a b. (a -> b) -> a -> b
$
    Problem :: [Int] -> [Scientific] -> [Matrix] -> Problem
Problem
    { blockStruct :: [Int]
blockStruct = [Int]
bs
    , costs :: [Scientific]
costs       = [Scientific]
cs
    , matrices :: [Matrix]
matrices    = [Matrix]
ms
    }

pSparseDataFile :: C e s m => m Problem
pSparseDataFile :: m Problem
pSparseDataFile = do
  [ByteString]
_ <- m ByteString -> m [ByteString]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many m ByteString
forall e s (m :: * -> *). C e s m => m ByteString
pComment
  Integer
m  <- m Integer
forall e s (m :: * -> *). C e s m => m Integer
nat_line -- mDim
  Integer
_n <- m Integer
forall e s (m :: * -> *). C e s m => m Integer
nat_line -- nBlock
  [Int]
bs <- m [Int]
forall e s (m :: * -> *). C e s m => m [Int]
pBlockStruct -- bLOCKsTRUCT
  [Scientific]
cs <- m [Scientific]
forall e s (m :: * -> *). C e s m => m [Scientific]
pCosts
  [Matrix]
ms <- Int -> [Int] -> m [Matrix]
forall e s (m :: * -> *). C e s m => Int -> [Int] -> m [Matrix]
pSparseMatrices (Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
m) [Int]
bs
  m ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Word8) =>
m ()
space
  Problem -> m Problem
forall (m :: * -> *) a. Monad m => a -> m a
return (Problem -> m Problem) -> Problem -> m Problem
forall a b. (a -> b) -> a -> b
$
    Problem :: [Int] -> [Scientific] -> [Matrix] -> Problem
Problem
    { blockStruct :: [Int]
blockStruct = [Int]
bs
    , costs :: [Scientific]
costs       = [Scientific]
cs
    , matrices :: [Matrix]
matrices    = [Matrix]
ms
    }

pComment :: C e s m => m BL.ByteString
pComment :: m ByteString
pComment = do
  Word8
c <- String -> m Word8
forall e s (m :: * -> *). C e s m => String -> m Word8
oneOf String
"*\""
  [Word8]
cs <- m Word8 -> m Word8 -> m [Word8]
forall (m :: * -> *) a end. MonadPlus m => m a -> m end -> m [a]
manyTill m Word8
forall e s (m :: * -> *). C e s m => m Word8
anyChar m Word8
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Word8) =>
m (Token s)
newline
#if MIN_VERSION_megaparsec(6,0,0)
  ByteString -> m ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> m ByteString) -> ByteString -> m ByteString
forall a b. (a -> b) -> a -> b
$ [Word8] -> ByteString
BL.pack (Word8
cWord8 -> [Word8] -> [Word8]
forall a. a -> [a] -> [a]
:[Word8]
cs)
#else
  return $ BL8.pack (c:cs)
#endif

pBlockStruct :: C e s m => m [Int]
pBlockStruct :: m [Int]
pBlockStruct = do
  Maybe [Word8]
_ <- m [Word8] -> m (Maybe [Word8])
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional m [Word8]
sep
  let int' :: m Integer
int' = m Integer
forall e s (m :: * -> *). C e s m => m Integer
int m Integer -> (Integer -> m Integer) -> m Integer
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Integer
i -> m [Word8] -> m (Maybe [Word8])
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional m [Word8]
sep m (Maybe [Word8]) -> m Integer -> m Integer
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Integer -> m Integer
forall (m :: * -> *) a. Monad m => a -> m a
return Integer
i
  [Integer]
xs <- m Integer -> m [Integer]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many m Integer
int'
  [Word8]
_ <- m Word8 -> m Word8 -> m [Word8]
forall (m :: * -> *) a end. MonadPlus m => m a -> m end -> m [a]
manyTill m Word8
forall e s (m :: * -> *). C e s m => m Word8
anyChar m Word8
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Word8) =>
m (Token s)
newline
  [Int] -> m [Int]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Int] -> m [Int]) -> [Int] -> m [Int]
forall a b. (a -> b) -> a -> b
$ (Integer -> Int) -> [Integer] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral [Integer]
xs
  where
    sep :: m [Word8]
sep = m Word8 -> m [Word8]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
some (String -> m Word8
forall e s (m :: * -> *). C e s m => String -> m Word8
oneOf String
" \t(){},")

pCosts :: C e s m => m [Scientific]
pCosts :: m [Scientific]
pCosts = do
  let sep :: m [Word8]
sep = m Word8 -> m [Word8]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
some (String -> m Word8
forall e s (m :: * -> *). C e s m => String -> m Word8
oneOf String
" \t(){},")
      real' :: m Scientific
real' = m Scientific
forall e s (m :: * -> *). C e s m => m Scientific
real m Scientific -> (Scientific -> m Scientific) -> m Scientific
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Scientific
r -> m [Word8] -> m (Maybe [Word8])
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional m [Word8]
sep m (Maybe [Word8]) -> m Scientific -> m Scientific
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Scientific -> m Scientific
forall (m :: * -> *) a. Monad m => a -> m a
return Scientific
r
  Maybe [Word8]
_ <- m [Word8] -> m (Maybe [Word8])
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional m [Word8]
sep
  [Scientific]
cs <- m Scientific -> m [Scientific]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many m Scientific
real'
  Word8
_ <- m Word8
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Word8) =>
m (Token s)
newline
  [Scientific] -> m [Scientific]
forall (m :: * -> *) a. Monad m => a -> m a
return [Scientific]
cs

pDenseMatrices :: C e s m => Int -> [Int] -> m [Matrix]
pDenseMatrices :: Int -> [Int] -> m [Matrix]
pDenseMatrices Int
m [Int]
bs = m [()] -> m (Maybe [()])
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional m [()]
sep m (Maybe [()]) -> m [Matrix] -> m [Matrix]
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> m Matrix -> m [Matrix]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
m Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) m Matrix
pDenceMatrix
  where
    sep :: m [()]
sep = m () -> m [()]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
some ((m Word8
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Word8) =>
m (Token s)
spaceChar m Word8 -> m () -> m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) m () -> m () -> m ()
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (String -> m Word8
forall e s (m :: * -> *). C e s m => String -> m Word8
oneOf String
"(){}," m Word8 -> m () -> m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()))
    real' :: m Scientific
real' = m Scientific
forall e s (m :: * -> *). C e s m => m Scientific
real m Scientific -> (Scientific -> m Scientific) -> m Scientific
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Scientific
r -> m [()] -> m (Maybe [()])
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional m [()]
sep m (Maybe [()]) -> m Scientific -> m Scientific
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Scientific -> m Scientific
forall (m :: * -> *) a. Monad m => a -> m a
return Scientific
r
    pDenceMatrix :: m Matrix
pDenceMatrix = [Int] -> (Int -> m Block) -> m Matrix
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Int]
bs ((Int -> m Block) -> m Matrix) -> (Int -> m Block) -> m Matrix
forall a b. (a -> b) -> a -> b
$ \Int
b ->
      if Int
b Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0
      then do
        DenseBlock
xs <- Int -> m [Scientific] -> m DenseBlock
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
b (Int -> m Scientific -> m [Scientific]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
b m Scientific
real')
        Block -> m Block
forall (m :: * -> *) a. Monad m => a -> m a
return (Block -> m Block) -> Block -> m Block
forall a b. (a -> b) -> a -> b
$ DenseBlock -> Block
denseBlock DenseBlock
xs
      else do
        [Scientific]
xs <- Int -> m Scientific -> m [Scientific]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (Int -> Int
forall a. Num a => a -> a
abs Int
b) m Scientific
real'
        Block -> m Block
forall (m :: * -> *) a. Monad m => a -> m a
return (Block -> m Block) -> Block -> m Block
forall a b. (a -> b) -> a -> b
$ [Scientific] -> Block
diagBlock [Scientific]
xs

pSparseMatrices :: C e s m => Int -> [Int] -> m [Matrix]
pSparseMatrices :: Int -> [Int] -> m [Matrix]
pSparseMatrices Int
m [Int]
bs = do
  [(Int, Int, Int, Int, Scientific)]
xs <- m (Int, Int, Int, Int, Scientific)
-> m [(Int, Int, Int, Int, Scientific)]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many m (Int, Int, Int, Int, Scientific)
pLine
  let t :: IntMap (IntMap Block)
t = (IntMap Block -> IntMap Block -> IntMap Block)
-> [IntMap (IntMap Block)] -> IntMap (IntMap Block)
forall (f :: * -> *) a.
Foldable f =>
(a -> a -> a) -> f (IntMap a) -> IntMap a
IntMap.unionsWith ((Block -> Block -> Block)
-> IntMap Block -> IntMap Block -> IntMap Block
forall a. (a -> a -> a) -> IntMap a -> IntMap a -> IntMap a
IntMap.unionWith Block -> Block -> Block
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union)
            [ Int -> IntMap Block -> IntMap (IntMap Block)
forall a. Int -> a -> IntMap a
IntMap.singleton Int
matno (Int -> Block -> IntMap Block
forall a. Int -> a -> IntMap a
IntMap.singleton Int
blkno ([((Int, Int), Scientific)] -> Block
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [((Int
i,Int
j),Scientific
e),((Int
j,Int
i),Scientific
e)]))
            | (Int
matno,Int
blkno,Int
i,Int
j,Scientific
e) <- [(Int, Int, Int, Int, Scientific)]
xs ]
  [Matrix] -> m [Matrix]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Matrix] -> m [Matrix]) -> [Matrix] -> m [Matrix]
forall a b. (a -> b) -> a -> b
$
    [ [Block -> Int -> IntMap Block -> Block
forall a. a -> Int -> IntMap a -> a
IntMap.findWithDefault Block
forall k a. Map k a
Map.empty Int
blkno IntMap Block
mat | Int
blkno <- [Int
1 .. [Int] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
bs]]
    | Int
matno <- [Int
0..Int
m], let mat :: IntMap Block
mat = IntMap Block -> Int -> IntMap (IntMap Block) -> IntMap Block
forall a. a -> Int -> IntMap a -> a
IntMap.findWithDefault IntMap Block
forall a. IntMap a
IntMap.empty Int
matno IntMap (IntMap Block)
t
    ]

  where
    sep :: m ()
sep = m Word8 -> m [Word8]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
some (String -> m Word8
forall e s (m :: * -> *). C e s m => String -> m Word8
oneOf String
" \t") m [Word8] -> m () -> m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    pLine :: m (Int, Int, Int, Int, Scientific)
pLine = do
      Maybe ()
_ <- m () -> m (Maybe ())
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional m ()
sep
      Integer
matno <- m Integer
forall e s (m :: * -> *). C e s m => m Integer
nat
      m ()
sep
      Integer
blkno <- m Integer
forall e s (m :: * -> *). C e s m => m Integer
nat
      m ()
sep
      Integer
i <- m Integer
forall e s (m :: * -> *). C e s m => m Integer
nat
      m ()
sep
      Integer
j <- m Integer
forall e s (m :: * -> *). C e s m => m Integer
nat
      m ()
sep
      Scientific
e <- m Scientific
forall e s (m :: * -> *). C e s m => m Scientific
real
      Maybe ()
_ <- m () -> m (Maybe ())
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional m ()
sep
      Word8
_ <- m Word8
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Word8) =>
m (Token s)
newline
      (Int, Int, Int, Int, Scientific)
-> m (Int, Int, Int, Int, Scientific)
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
matno, Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
blkno, Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
i, Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
j, Scientific
e)

nat_line :: C e s m => m Integer
nat_line :: m Integer
nat_line = do
  m ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Word8) =>
m ()
space
  Integer
n <- m Integer
forall e s (m :: * -> *). C e s m => m Integer
nat
  [Word8]
_ <- m Word8 -> m Word8 -> m [Word8]
forall (m :: * -> *) a end. MonadPlus m => m a -> m end -> m [a]
manyTill m Word8
forall e s (m :: * -> *). C e s m => m Word8
anyChar m Word8
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Word8) =>
m (Token s)
newline
  Integer -> m Integer
forall (m :: * -> *) a. Monad m => a -> m a
return Integer
n

nat :: C e s m => m Integer
nat :: m Integer
nat = m Integer
forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Word8, Num a) =>
m a
Lexer.decimal

int :: C e s m => m Integer
int :: m Integer
int = m () -> m Integer -> m Integer
forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Word8, Num a) =>
m () -> m a -> m a
Lexer.signed (() -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) m Integer
forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Word8, Num a) =>
m a
Lexer.decimal

real :: forall e s m. C e s m => m Scientific
#if MIN_VERSION_megaparsec(6,0,0)
real :: m Scientific
real = m () -> m Scientific -> m Scientific
forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Word8, Num a) =>
m () -> m a -> m a
Lexer.signed (() -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) m Scientific
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Word8) =>
m Scientific
Lexer.scientific
#else
real = Lexer.signed (return ()) Lexer.number
#endif

#if MIN_VERSION_megaparsec(6,0,0)
oneOf :: C e s m => [Char] -> m Word8
oneOf :: String -> m Word8
oneOf = [Word8] -> m Word8
forall (f :: * -> *) e s (m :: * -> *).
(Foldable f, MonadParsec e s m) =>
f (Token s) -> m (Token s)
MegaParsec.oneOf ([Word8] -> m Word8) -> (String -> [Word8]) -> String -> m Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Word8) -> String -> [Word8]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word8) -> (Char -> Int) -> Char -> Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
forall a. Enum a => a -> Int
fromEnum)
#else
oneOf :: C e s m => [Char] -> m Char
oneOf = MegaParsec.oneOf
#endif

-- ---------------------------------------------------------------------------
-- rendering
-- ---------------------------------------------------------------------------

renderData :: Problem -> Builder
renderData :: Problem -> Builder
renderData = Bool -> Problem -> Builder
renderImpl Bool
False

renderSparseData :: Problem -> Builder
renderSparseData :: Problem -> Builder
renderSparseData = Bool -> Problem -> Builder
renderImpl Bool
True

renderImpl :: Bool -> Problem -> Builder
renderImpl :: Bool -> Problem -> Builder
renderImpl Bool
sparse Problem
prob = [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat
  [
  -- mDim
    Int -> Builder
B.intDec (Problem -> Int
mDim Problem
prob) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
" = mDIM\n"

  -- nBlock
  , Int -> Builder
B.intDec (Problem -> Int
nBlock Problem
prob) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
" = nBlock\n"

  -- blockStruct
  , Char -> Builder
B.char7 Char
'('
  , [Builder] -> Builder -> Builder
sepByS [Int -> Builder
B.intDec Int
i | Int
i <- Problem -> [Int]
blockStruct Problem
prob] Builder
", "
  , Char -> Builder
B.char7 Char
')'
  , Builder
" = bLOCKsTRUCT\n"

  -- costs
  , Char -> Builder
B.char7 Char
'('
  , [Builder] -> Builder -> Builder
sepByS [Scientific -> Builder
B.scientificBuilder Scientific
c | Scientific
c <- Problem -> [Scientific]
costs Problem
prob] Builder
", "
  , Builder
")\n"

  -- matrices
  , if Bool
sparse
    then [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat [Int -> Matrix -> Builder
renderSparseMatrix Int
matno Matrix
m | (Int
matno, Matrix
m) <- [Int] -> [Matrix] -> [(Int, Matrix)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] (Problem -> [Matrix]
matrices Problem
prob)]
    else [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat ([Builder] -> Builder) -> [Builder] -> Builder
forall a b. (a -> b) -> a -> b
$ (Matrix -> Builder) -> [Matrix] -> [Builder]
forall a b. (a -> b) -> [a] -> [b]
map Matrix -> Builder
renderDenseMatrix (Problem -> [Matrix]
matrices Problem
prob)
  ]

  where
    renderSparseMatrix :: Int -> Matrix -> Builder
    renderSparseMatrix :: Int -> Matrix -> Builder
renderSparseMatrix Int
matno Matrix
m =
      [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat [ Int -> Builder
B.intDec Int
matno Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
B.char7 Char
' ' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
                Int -> Builder
B.intDec Int
blkno Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
B.char7 Char
' ' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
                Int -> Builder
B.intDec Int
i Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
B.char7 Char
' ' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
                Int -> Builder
B.intDec Int
j Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
B.char7 Char
' ' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
                Scientific -> Builder
B.scientificBuilder Scientific
e Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
B.char7 Char
'\n'
              | (Int
blkno, Block
blk) <- [Int] -> Matrix -> [(Int, Block)]
forall a b. [a] -> [b] -> [(a, b)]
zip [(Int
1::Int)..] Matrix
m, ((Int
i,Int
j),Scientific
e) <- Block -> [((Int, Int), Scientific)]
forall k a. Map k a -> [(k, a)]
Map.toList Block
blk, Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
j ]

    renderDenseMatrix :: Matrix -> Builder
    renderDenseMatrix :: Matrix -> Builder
renderDenseMatrix Matrix
m =
      Builder
"{\n" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
      [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat [Block -> Int -> Builder
renderDenseBlock Block
b Int
s Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"\n" | (Block
b,Int
s) <- Matrix -> [Int] -> [(Block, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip Matrix
m (Problem -> [Int]
blockStruct Problem
prob)] Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
      Builder
"}\n"

    renderDenseBlock :: Block -> Int -> Builder
    renderDenseBlock :: Block -> Int -> Builder
renderDenseBlock Block
b Int
s
      | Int
s Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 =
          Builder
"  " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> [Scientific] -> Builder
renderVec [Int -> Int -> Block -> Scientific
blockElem Int
i Int
i Block
b | Int
i <- [Int
1 .. Int -> Int
forall a. Num a => a -> a
abs Int
s]]
      | Bool
otherwise =
          Builder
"  { " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
          [Builder] -> Builder -> Builder
sepByS [Int -> Builder
renderRow Int
i | Int
i <- [Int
1..Int
s]] Builder
", " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
          Builder
" }"
      where
        renderRow :: Int -> Builder
renderRow Int
i = [Scientific] -> Builder
renderVec [Int -> Int -> Block -> Scientific
blockElem Int
i Int
j Block
b | Int
j <- [Int
1..Int
s]]

renderVec :: [Scientific] -> Builder
renderVec :: [Scientific] -> Builder
renderVec [Scientific]
xs =
  Char -> Builder
B.char7 Char
'{' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
  [Builder] -> Builder -> Builder
sepByS ((Scientific -> Builder) -> [Scientific] -> [Builder]
forall a b. (a -> b) -> [a] -> [b]
map Scientific -> Builder
B.scientificBuilder [Scientific]
xs) Builder
", " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
  Char -> Builder
B.char7 Char
'}'

sepByS :: [Builder] -> Builder -> Builder
sepByS :: [Builder] -> Builder -> Builder
sepByS [Builder]
xs Builder
sep = [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat ([Builder] -> Builder) -> [Builder] -> Builder
forall a b. (a -> b) -> a -> b
$ Builder -> [Builder] -> [Builder]
forall a. a -> [a] -> [a]
intersperse Builder
sep [Builder]
xs