{-# 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)
import Data.Scientific (Scientific)
import Data.Map (Map)
import qualified Data.Map as Map
import qualified Data.IntMap as IntMap
import Data.Void
import Data.Word
import System.FilePath (takeExtension)
import System.IO
import qualified Text.Megaparsec as MegaParsec
import Text.Megaparsec hiding (ParseError, oneOf)
import Text.Megaparsec.Byte
import qualified Text.Megaparsec.Byte.Lexer as Lexer

type C e s m = (MonadParsec e s m, Token s ~ Word8)
type ParseError = MegaParsec.ParseErrorBundle BL.ByteString Void

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

-- ---------------------------------------------------------------------------
-- 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
  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)

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
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

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)

-- ---------------------------------------------------------------------------
-- 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