{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE UndecidableSuperClasses #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# OPTIONS_GHC -fno-warn-type-defaults #-}

module Algebra.Bridge.Singular
  ( singular,
    readSingularPoly,
    readSingularIdeal,
    evalSingularWith,
    evalSingular,
    evalSingularIdealWith,
    evalSingularPolyWith,
    module Algebra.Bridge.Singular.Syntax,
  )
where

import Algebra.Bridge.Singular.Syntax
import Algebra.Prelude.Core
import Algebra.Ring.Polynomial.Parser
import Data.List ()
import qualified Data.Text as T
import System.Exit
import System.Process.Text
import Text.Megaparsec
import Text.Megaparsec.Char
import qualified Text.Megaparsec.Char.Lexer as L

symbol :: Text -> Parser Text
symbol :: Text -> Parser Text
symbol = ParsecT Void Text Identity ()
-> Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
m () -> Tokens s -> m (Tokens s)
L.symbol ParsecT Void Text Identity ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space

lexeme :: Parser a -> Parser a
lexeme :: Parser a -> Parser a
lexeme = ParsecT Void Text Identity () -> Parser a -> Parser a
forall e s (m :: * -> *) a. MonadParsec e s m => m () -> m a -> m a
L.lexeme ParsecT Void Text Identity ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space

parens :: Parser a -> Parser a
parens :: Parser a -> Parser a
parens Parser a
p = Text -> Parser Text
symbol Text
"(" Parser Text -> Parser a -> Parser a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser a
p Parser a -> Parser Text -> Parser a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Text -> Parser Text
symbol Text
")"

readProcess :: FilePath -> [String] -> Text -> IO Text
readProcess :: FilePath -> [FilePath] -> Text -> IO Text
readProcess FilePath
exe [FilePath]
args Text
input = do
  (ExitCode
ec, Text
out, Text
_) <- FilePath -> [FilePath] -> Text -> IO (ExitCode, Text, Text)
readProcessWithExitCode FilePath
exe [FilePath]
args Text
input
  case ExitCode
ec of
    ExitCode
ExitSuccess -> Text -> IO Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
out
    ExitCode
_ -> FilePath -> IO Text
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail (FilePath -> IO Text) -> FilePath -> IO Text
forall a b. (a -> b) -> a -> b
$ FilePath
"Process failed: " FilePath -> FilePath -> FilePath
forall w. Monoid w => w -> w -> w
++ [FilePath] -> FilePath
unwords (FilePath
exe FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: [FilePath]
args)

singular :: Text -> IO Text
singular :: Text -> IO Text
singular = FilePath -> [FilePath] -> Text -> IO Text
readProcess FilePath
"Singular" [FilePath
"-q"]

readSingularIdeal ::
  (IsSingularPolynomial poly) =>
  proxy poly ->
  Text ->
  Maybe [poly]
readSingularIdeal :: proxy poly -> Text -> Maybe [poly]
readSingularIdeal proxy poly
p Text
code =
  (Text -> Maybe poly) -> [Text] -> Maybe [poly]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (proxy poly -> Text -> Maybe poly
forall poly (proxy :: * -> *).
IsSingularPolynomial poly =>
proxy poly -> Text -> Maybe poly
readSingularPoly proxy poly
p (Text -> Maybe poly) -> (Text -> Text) -> Text -> Maybe poly
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe (Text -> Maybe Text -> Text)
-> (Text -> Maybe Text) -> Text -> Text
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Text -> Text -> Maybe Text
T.stripSuffix Text
",")) ([Text] -> Maybe [poly]) -> [Text] -> Maybe [poly]
forall a b. (a -> b) -> a -> b
$
    Text -> [Text]
T.lines Text
code

readSingularPoly ::
  (IsSingularPolynomial poly) =>
  proxy poly ->
  Text ->
  Maybe poly
readSingularPoly :: proxy poly -> Text -> Maybe poly
readSingularPoly proxy poly
_ Text
code =
  (FilePath -> Maybe poly)
-> (poly -> Maybe poly) -> Either FilePath poly -> Maybe poly
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe poly -> FilePath -> Maybe poly
forall a b. a -> b -> a
const Maybe poly
forall a. Maybe a
Nothing) poly -> Maybe poly
forall a. a -> Maybe a
Just (Either FilePath poly -> Maybe poly)
-> Either FilePath poly -> Maybe poly
forall a b. (a -> b) -> a -> b
$ Parser (Coefficient poly)
-> VariableParser (Arity poly) -> Text -> Either FilePath poly
forall poly.
IsOrderedPolynomial poly =>
Parser (Coefficient poly)
-> VariableParser (Arity poly) -> Text -> Either FilePath poly
parsePolynomialWith Parser (Coefficient poly)
forall r. SingularCoeff r => Parser r
parseSingularCoeff VariableParser (Arity poly)
forall (n :: Nat).
KnownNat n =>
ParsecT Void Text Identity (Ordinal n)
varP Text
code
  where
    varP :: ParsecT Void Text Identity (Ordinal n)
varP = do
      Parser Text -> ParsecT Void Text Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Parser Text -> ParsecT Void Text Identity ())
-> Parser Text -> ParsecT Void Text Identity ()
forall a b. (a -> b) -> a -> b
$ Text -> Parser Text
symbol Text
"x"
      Natural
i <- Natural
-> ParsecT Void Text Identity Natural
-> ParsecT Void Text Identity Natural
forall (m :: * -> *) a. Alternative m => a -> m a -> m a
option Natural
0 (ParsecT Void Text Identity Natural
 -> ParsecT Void Text Identity Natural)
-> ParsecT Void Text Identity Natural
-> ParsecT Void Text Identity Natural
forall a b. (a -> b) -> a -> b
$ ParsecT Void Text Identity Natural
-> ParsecT Void Text Identity Natural
forall a. Parser a -> Parser a
parens (ParsecT Void Text Identity Natural
-> ParsecT Void Text Identity Natural
forall a. Parser a -> Parser a
lexeme ParsecT Void Text Identity Natural
forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Num a) =>
m a
L.decimal)
      case Natural -> Maybe (Ordinal n)
forall (n :: Nat). KnownNat n => Natural -> Maybe (Ordinal n)
naturalToOrd Natural
i of
        Maybe (Ordinal n)
Nothing -> FilePath -> ParsecT Void Text Identity (Ordinal n)
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail FilePath
"variable out of range"
        Just Ordinal n
o -> Ordinal n -> ParsecT Void Text Identity (Ordinal n)
forall (m :: * -> *) a. Monad m => a -> m a
return Ordinal n
o

evalSingularWith ::
  IsSingularPolynomial p =>
  [SingularLibrary] ->
  [SingularOption] ->
  SingularExpr p ->
  IO Text
evalSingularWith :: [Text] -> [Text] -> SingularExpr p -> IO Text
evalSingularWith [Text]
libs [Text]
opts SingularExpr p
expr =
  Text -> IO Text
singular (Text -> IO Text) -> Text -> IO Text
forall a b. (a -> b) -> a -> b
$
    SingularProgramM () -> Text
forall a. PrettySingular a => a -> Text
prettySingular (SingularProgramM () -> Text) -> SingularProgramM () -> Text
forall a b. (a -> b) -> a -> b
$ do
      (Text -> SingularProgramM ()) -> [Text] -> SingularProgramM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Text -> SingularProgramM ()
libC [Text]
libs
      (Text -> SingularProgramM ()) -> [Text] -> SingularProgramM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Text -> SingularProgramM ()
optionC [Text]
opts
      SingularProgramM (SingularExpr p) -> SingularProgramM ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (SingularProgramM (SingularExpr p) -> SingularProgramM ())
-> SingularProgramM (SingularExpr p) -> SingularProgramM ()
forall a b. (a -> b) -> a -> b
$ Text -> SingularExpr p -> SingularProgramM (SingularExpr p)
forall poly (proxy :: * -> *).
IsSingularPolynomial poly =>
Text -> proxy poly -> SingularProgramM (SingularExpr poly)
ringC Text
"R" SingularExpr p
expr
      SingularExpr p -> SingularProgramM ()
forall poly.
IsSingularPolynomial poly =>
SingularExpr poly -> SingularProgramM ()
printC SingularExpr p
expr
      Text -> SingularProgramM ()
directC Text
"exit"

evalSingular ::
  IsSingularPolynomial p =>
  SingularExpr p ->
  IO Text
evalSingular :: SingularExpr p -> IO Text
evalSingular = [Text] -> [Text] -> SingularExpr p -> IO Text
forall p.
IsSingularPolynomial p =>
[Text] -> [Text] -> SingularExpr p -> IO Text
evalSingularWith [] []

evalSingularIdealWith ::
  (IsSingularPolynomial r) =>
  [SingularLibrary] ->
  [SingularOption] ->
  SingularExpr r ->
  IO (Ideal r)
evalSingularIdealWith :: [Text] -> [Text] -> SingularExpr r -> IO (Ideal r)
evalSingularIdealWith [Text]
libs [Text]
opts SingularExpr r
expr =
  IO (Ideal r) -> ([r] -> IO (Ideal r)) -> Maybe [r] -> IO (Ideal r)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (FilePath -> IO (Ideal r)
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail FilePath
"Parse failed") (Ideal r -> IO (Ideal r)
forall (m :: * -> *) a. Monad m => a -> m a
return (Ideal r -> IO (Ideal r))
-> ([r] -> Ideal r) -> [r] -> IO (Ideal r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [r] -> Ideal r
forall r. (DecidableZero r, Monoidal r) => [r] -> Ideal r
toIdeal) (Maybe [r] -> IO (Ideal r))
-> (Text -> Maybe [r]) -> Text -> IO (Ideal r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SingularExpr r -> Text -> Maybe [r]
forall poly (proxy :: * -> *).
IsSingularPolynomial poly =>
proxy poly -> Text -> Maybe [poly]
readSingularIdeal SingularExpr r
expr
    (Text -> IO (Ideal r)) -> IO Text -> IO (Ideal r)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Text] -> [Text] -> SingularExpr r -> IO Text
forall p.
IsSingularPolynomial p =>
[Text] -> [Text] -> SingularExpr p -> IO Text
evalSingularWith [Text]
libs [Text]
opts SingularExpr r
expr

evalSingularPolyWith ::
  (IsSingularPolynomial r) =>
  [SingularLibrary] ->
  [SingularOption] ->
  SingularExpr r ->
  IO r
evalSingularPolyWith :: [Text] -> [Text] -> SingularExpr r -> IO r
evalSingularPolyWith [Text]
libs [Text]
opts SingularExpr r
expr =
  IO r -> (r -> IO r) -> Maybe r -> IO r
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (FilePath -> IO r
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail FilePath
"Parse failed") r -> IO r
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe r -> IO r) -> (Text -> Maybe r) -> Text -> IO r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SingularExpr r -> Text -> Maybe r
forall poly (proxy :: * -> *).
IsSingularPolynomial poly =>
proxy poly -> Text -> Maybe poly
readSingularPoly SingularExpr r
expr
    (Text -> IO r) -> IO Text -> IO r
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Text] -> [Text] -> SingularExpr r -> IO Text
forall p.
IsSingularPolynomial p =>
[Text] -> [Text] -> SingularExpr p -> IO Text
evalSingularWith [Text]
libs [Text]
opts SingularExpr r
expr