{-# Language OverloadedStrings #-}
{-# Language DefaultSignatures #-}
module Data.Geometry.Ipe.PathParser where

import           Data.Bifunctor
import           Data.Char (isSpace)
import           Data.Ext (ext)
import           Data.Geometry.Box
import           Data.Geometry.Ipe.ParserPrimitives
import           Data.Geometry.Ipe.Path (Operation(..))
import           Data.Geometry.Matrix
import           Data.Geometry.Point
import           Data.Geometry.Vector
import           Data.Ratio
import           Data.RealNumber.Rational
import           Data.Text (Text)
import qualified Data.Text as T
import           Text.Parsec.Error (messageString, errorMessages)


-----------------------------------------------------------------------
-- | Represent stuff that can be used as a coordinate in ipe. (similar to show/read)

class Fractional r => Coordinate r where
    -- reads a coordinate. The input is an integer representing the
    -- part before the decimal point, and a length and an integer
    -- representing the part after the decimal point
    fromSeq :: Integer -> Maybe (Int, Integer) -> r
    default fromSeq :: (Ord r, Fractional r) => Integer -> Maybe (Int, Integer) -> r
    fromSeq = Integer -> Maybe (Int, Integer) -> r
forall r.
(Ord r, Fractional r) =>
Integer -> Maybe (Int, Integer) -> r
defaultFromSeq

defaultFromSeq                :: (Ord r, Fractional r)
                              => Integer -> Maybe (Int, Integer) -> r
defaultFromSeq :: Integer -> Maybe (Int, Integer) -> r
defaultFromSeq Integer
x Maybe (Int, Integer)
Nothing      = Integer -> r
forall a. Num a => Integer -> a
fromInteger Integer
x
defaultFromSeq Integer
x (Just (Int
l,Integer
y)) = let x' :: r
x'          = Integer -> r
forall a. Num a => Integer -> a
fromInteger Integer
x
                                    y' :: r
y'          = Integer -> r
forall a. Num a => Integer -> a
fromInteger Integer
y
                                    asDecimal :: r -> r
asDecimal r
a =  r
a r -> r -> r
forall a. Num a => a -> a -> a
* (r
0.1 r -> Int -> r
forall a b. (Num a, Integral b) => a -> b -> a
^ Int
l)
                                    z :: r
z           = if r
x' r -> r -> Bool
forall a. Ord a => a -> a -> Bool
< r
0 then (-r
1) else r
1
                                in r
z r -> r -> r
forall a. Num a => a -> a -> a
* (r -> r
forall a. Num a => a -> a
abs r
x' r -> r -> r
forall a. Num a => a -> a -> a
+ r -> r
asDecimal r
y')

instance Coordinate Double
instance Coordinate Float
instance Coordinate (Ratio Integer)
instance Coordinate (RealNumber p)

-----------------------------------------------------------------------
-- | Running the parsers

readCoordinate :: Coordinate r => Text -> Either Text r
readCoordinate :: Text -> Either Text r
readCoordinate = Parser r -> Text -> Either Text r
forall a. Parser a -> Text -> Either Text a
runParser Parser r
forall r. Coordinate r => Parser r
pCoordinate

readPoint :: Coordinate r => Text -> Either Text (Point 2 r)
readPoint :: Text -> Either Text (Point 2 r)
readPoint = Parser (Point 2 r) -> Text -> Either Text (Point 2 r)
forall a. Parser a -> Text -> Either Text a
runParser Parser (Point 2 r)
forall r. Coordinate r => Parser (Point 2 r)
pPoint

runParser   :: Parser a -> Text -> Either Text a
runParser :: Parser a -> Text -> Either Text a
runParser Parser a
p = (ParseError -> Text)
-> ((a, Text) -> a) -> Either ParseError (a, Text) -> Either Text a
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap ParseError -> Text
errorText (a, Text) -> a
forall a b. (a, b) -> a
fst (Either ParseError (a, Text) -> Either Text a)
-> (Text -> Either ParseError (a, Text)) -> Text -> Either Text a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parser a -> Text -> Either ParseError (a, Text)
forall a. Parser a -> Text -> Either ParseError (a, Text)
runP Parser a
p

-- Collect errors
data Either' l r = Left' l | Right' r deriving (Int -> Either' l r -> ShowS
[Either' l r] -> ShowS
Either' l r -> String
(Int -> Either' l r -> ShowS)
-> (Either' l r -> String)
-> ([Either' l r] -> ShowS)
-> Show (Either' l r)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall l r. (Show l, Show r) => Int -> Either' l r -> ShowS
forall l r. (Show l, Show r) => [Either' l r] -> ShowS
forall l r. (Show l, Show r) => Either' l r -> String
showList :: [Either' l r] -> ShowS
$cshowList :: forall l r. (Show l, Show r) => [Either' l r] -> ShowS
show :: Either' l r -> String
$cshow :: forall l r. (Show l, Show r) => Either' l r -> String
showsPrec :: Int -> Either' l r -> ShowS
$cshowsPrec :: forall l r. (Show l, Show r) => Int -> Either' l r -> ShowS
Show,Either' l r -> Either' l r -> Bool
(Either' l r -> Either' l r -> Bool)
-> (Either' l r -> Either' l r -> Bool) -> Eq (Either' l r)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall l r. (Eq l, Eq r) => Either' l r -> Either' l r -> Bool
/= :: Either' l r -> Either' l r -> Bool
$c/= :: forall l r. (Eq l, Eq r) => Either' l r -> Either' l r -> Bool
== :: Either' l r -> Either' l r -> Bool
$c== :: forall l r. (Eq l, Eq r) => Either' l r -> Either' l r -> Bool
Eq)

instance (Semigroup l, Semigroup r) => Semigroup (Either' l r) where
  (Left' l
l)  <> :: Either' l r -> Either' l r -> Either' l r
<> (Left' l
l')  = l -> Either' l r
forall l r. l -> Either' l r
Left' (l -> Either' l r) -> l -> Either' l r
forall a b. (a -> b) -> a -> b
$ l
l l -> l -> l
forall a. Semigroup a => a -> a -> a
<> l
l'
  (Left' l
l)  <> Either' l r
_           = l -> Either' l r
forall l r. l -> Either' l r
Left' l
l
  Either' l r
_          <> (Left' l
l')  = l -> Either' l r
forall l r. l -> Either' l r
Left' l
l'
  (Right' r
r) <> (Right' r
r') = r -> Either' l r
forall l r. r -> Either' l r
Right' (r -> Either' l r) -> r -> Either' l r
forall a b. (a -> b) -> a -> b
$ r
r r -> r -> r
forall a. Semigroup a => a -> a -> a
<> r
r'

instance (Semigroup l, Semigroup r, Monoid r) => Monoid (Either' l r) where
  mempty :: Either' l r
mempty = r -> Either' l r
forall l r. r -> Either' l r
Right' r
forall a. Monoid a => a
mempty
  mappend :: Either' l r -> Either' l r -> Either' l r
mappend = Either' l r -> Either' l r -> Either' l r
forall a. Semigroup a => a -> a -> a
(<>)
either' :: (l -> a) -> (r -> a) -> Either' l r -> a
either' :: (l -> a) -> (r -> a) -> Either' l r -> a
either' l -> a
lf r -> a
_  (Left' l
l)  = l -> a
lf l
l
either' l -> a
_  r -> a
rf (Right' r
r) = r -> a
rf r
r
-- TODO: Use Validation instead of this home-brew one

readPathOperations :: Coordinate r => Text -> Either Text [Operation r]
readPathOperations :: Text -> Either Text [Operation r]
readPathOperations = Either' [ParseError] [Operation r] -> Either Text [Operation r]
forall b. Either' [ParseError] b -> Either Text b
unWrap (Either' [ParseError] [Operation r] -> Either Text [Operation r])
-> (Text -> Either' [ParseError] [Operation r])
-> Text
-> Either Text [Operation r]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Either' [ParseError] [Operation r]]
-> Either' [ParseError] [Operation r]
forall a. Monoid a => [a] -> a
mconcat ([Either' [ParseError] [Operation r]]
 -> Either' [ParseError] [Operation r])
-> (Text -> [Either' [ParseError] [Operation r]])
-> Text
-> Either' [ParseError] [Operation r]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Either' [ParseError] [Operation r])
-> [Text] -> [Either' [ParseError] [Operation r]]
forall a b. (a -> b) -> [a] -> [b]
map (Either ParseError (Operation r, Text)
-> Either' [ParseError] [Operation r]
forall a a b. Either a (a, b) -> Either' [a] [a]
wrap (Either ParseError (Operation r, Text)
 -> Either' [ParseError] [Operation r])
-> (Text -> Either ParseError (Operation r, Text))
-> Text
-> Either' [ParseError] [Operation r]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parser (Operation r)
-> Text -> Either ParseError (Operation r, Text)
forall a. Parser a -> Text -> Either ParseError (a, Text)
runP Parser (Operation r)
forall r. Coordinate r => Parser (Operation r)
pOperation)
                   ([Text] -> [Either' [ParseError] [Operation r]])
-> (Text -> [Text]) -> Text -> [Either' [ParseError] [Operation r]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> [Text]
clean ([Text] -> [Text]) -> (Text -> [Text]) -> Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text -> [Text]
splitKeepDelims String
"mlcqeasuh"
    where
      -- Unwrap the Either'. If it is a Left containing all our errors,
      -- combine them into one error. Otherwise just ReWrap it in an proper Either
      unWrap :: Either' [ParseError] b -> Either Text b
unWrap = ([ParseError] -> Either Text b)
-> (b -> Either Text b) -> Either' [ParseError] b -> Either Text b
forall l a r. (l -> a) -> (r -> a) -> Either' l r -> a
either' (Text -> Either Text b
forall a b. a -> Either a b
Left (Text -> Either Text b)
-> ([ParseError] -> Text) -> [ParseError] -> Either Text b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ParseError] -> Text
combineErrors) b -> Either Text b
forall a b. b -> Either a b
Right
      -- for the lefts: wrap the error in a list, for the rights: we only care
      -- about the result, so wrap that in a list as well. Collecting the
      -- results is done using the Semigroup instance of Either'
      wrap :: Either a (a, b) -> Either' [a] [a]
wrap   = (a -> Either' [a] [a])
-> ((a, b) -> Either' [a] [a])
-> Either a (a, b)
-> Either' [a] [a]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ([a] -> Either' [a] [a]
forall l r. l -> Either' l r
Left' ([a] -> Either' [a] [a]) -> (a -> [a]) -> a -> Either' [a] [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> [a] -> [a]
forall a. a -> [a] -> [a]
:[])) ([a] -> Either' [a] [a]
forall l r. r -> Either' l r
Right' ([a] -> Either' [a] [a])
-> ((a, b) -> [a]) -> (a, b) -> Either' [a] [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> [a] -> [a]
forall a. a -> [a] -> [a]
:[]) (a -> [a]) -> ((a, b) -> a) -> (a, b) -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, b) -> a
forall a b. (a, b) -> a
fst)
      -- Split the input string in pieces, each piece represents one operation
      trim :: Text -> Text
trim   = (Char -> Bool) -> Text -> Text
T.dropWhile Char -> Bool
isSpace
      clean :: [Text] -> [Text]
clean  = (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Text -> Bool) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Bool
T.null) ([Text] -> [Text]) -> ([Text] -> [Text]) -> [Text] -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Text
trim
      -- TODO: Do the splitting on the Text rather than unpacking and packing
      -- the thing

errorText :: ParseError -> Text
errorText :: ParseError -> Text
errorText = String -> Text
T.pack (String -> Text) -> (ParseError -> String) -> ParseError -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unlines ([String] -> String)
-> (ParseError -> [String]) -> ParseError -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Message -> String) -> [Message] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Message -> String
messageString ([Message] -> [String])
-> (ParseError -> [Message]) -> ParseError -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseError -> [Message]
errorMessages

combineErrors :: [ParseError] -> Text
combineErrors :: [ParseError] -> Text
combineErrors = [Text] -> Text
T.unlines ([Text] -> Text)
-> ([ParseError] -> [Text]) -> [ParseError] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ParseError -> Text) -> [ParseError] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map ParseError -> Text
errorText


splitKeepDelims          :: [Char] -> Text -> [Text]
splitKeepDelims :: String -> Text -> [Text]
splitKeepDelims String
delims Text
t = [Text] -> ((Char, Text) -> [Text]) -> Maybe (Char, Text) -> [Text]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Text]
mPref (Char, Text) -> [Text]
continue (Maybe (Char, Text) -> [Text]) -> Maybe (Char, Text) -> [Text]
forall a b. (a -> b) -> a -> b
$ Text -> Maybe (Char, Text)
T.uncons Text
rest
  where
    mPref :: [Text]
mPref           = if Text -> Bool
T.null Text
pref then [] else [Text
pref]
    (Text
pref,Text
rest)     = (Char -> Bool) -> Text -> (Text, Text)
T.break (Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
delims) Text
t
    continue :: (Char, Text) -> [Text]
continue (Char
c,Text
t') = Text
pref Text -> Char -> Text
`T.snoc` Char
c Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: String -> Text -> [Text]
splitKeepDelims String
delims Text
t'


readMatrix :: Coordinate r => Text -> Either Text (Matrix 3 3 r)
readMatrix :: Text -> Either Text (Matrix 3 3 r)
readMatrix = Parser (Matrix 3 3 r) -> Text -> Either Text (Matrix 3 3 r)
forall a. Parser a -> Text -> Either Text a
runParser Parser (Matrix 3 3 r)
forall r. Coordinate r => Parser (Matrix 3 3 r)
pMatrix


readRectangle :: Coordinate r => Text -> Either Text (Rectangle () r)
readRectangle :: Text -> Either Text (Rectangle () r)
readRectangle = Parser (Rectangle () r) -> Text -> Either Text (Rectangle () r)
forall a. Parser a -> Text -> Either Text a
runParser Parser (Rectangle () r)
forall r. Coordinate r => Parser (Rectangle () r)
pRectangle

-----------------------------------------------------------------------
-- | The parsers themselves


pOperation :: forall r. Coordinate r => Parser (Operation r)
pOperation :: Parser (Operation r)
pOperation = [Parser (Operation r)] -> Parser (Operation r)
forall a. [Parser a] -> Parser a
pChoice [ Point 2 r -> Operation r
forall r. Point 2 r -> Operation r
MoveTo       (Point 2 r -> Operation r)
-> ParsecT Text () Identity (Point 2 r) -> Parser (Operation r)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Text () Identity (Point 2 r)
forall r. Coordinate r => Parser (Point 2 r)
pPoint                         ParsecT Text () Identity (Point 2 r)
-> Char -> ParsecT Text () Identity (Point 2 r)
forall b.
ParsecT Text () Identity b -> Char -> ParsecT Text () Identity b
*>> Char
'm'
                     , Point 2 r -> Operation r
forall r. Point 2 r -> Operation r
LineTo       (Point 2 r -> Operation r)
-> ParsecT Text () Identity (Point 2 r) -> Parser (Operation r)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Text () Identity (Point 2 r)
forall r. Coordinate r => Parser (Point 2 r)
pPoint                         ParsecT Text () Identity (Point 2 r)
-> Char -> ParsecT Text () Identity (Point 2 r)
forall b.
ParsecT Text () Identity b -> Char -> ParsecT Text () Identity b
*>> Char
'l'
                     , Point 2 r -> Point 2 r -> Point 2 r -> Operation r
forall r. Point 2 r -> Point 2 r -> Point 2 r -> Operation r
CurveTo      (Point 2 r -> Point 2 r -> Point 2 r -> Operation r)
-> ParsecT Text () Identity (Point 2 r)
-> ParsecT Text () Identity (Point 2 r -> Point 2 r -> Operation r)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Text () Identity (Point 2 r)
forall r. Coordinate r => Parser (Point 2 r)
pPoint ParsecT Text () Identity (Point 2 r -> Point 2 r -> Operation r)
-> ParsecT Text () Identity (Point 2 r)
-> ParsecT Text () Identity (Point 2 r -> Operation r)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT Text () Identity (Point 2 r)
pPoint' ParsecT Text () Identity (Point 2 r -> Operation r)
-> ParsecT Text () Identity (Point 2 r) -> Parser (Operation r)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT Text () Identity (Point 2 r)
pPoint' ParsecT Text () Identity (Point 2 r)
-> Char -> ParsecT Text () Identity (Point 2 r)
forall b.
ParsecT Text () Identity b -> Char -> ParsecT Text () Identity b
*>> Char
'c'
                     , Point 2 r -> Point 2 r -> Operation r
forall r. Point 2 r -> Point 2 r -> Operation r
QCurveTo     (Point 2 r -> Point 2 r -> Operation r)
-> ParsecT Text () Identity (Point 2 r)
-> ParsecT Text () Identity (Point 2 r -> Operation r)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Text () Identity (Point 2 r)
forall r. Coordinate r => Parser (Point 2 r)
pPoint ParsecT Text () Identity (Point 2 r -> Operation r)
-> ParsecT Text () Identity (Point 2 r) -> Parser (Operation r)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT Text () Identity (Point 2 r)
pPoint'             ParsecT Text () Identity (Point 2 r)
-> Char -> ParsecT Text () Identity (Point 2 r)
forall b.
ParsecT Text () Identity b -> Char -> ParsecT Text () Identity b
*>> Char
'q'
                     , Matrix 3 3 r -> Operation r
forall r. Matrix 3 3 r -> Operation r
Ellipse      (Matrix 3 3 r -> Operation r)
-> ParsecT Text () Identity (Matrix 3 3 r) -> Parser (Operation r)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Text () Identity (Matrix 3 3 r)
forall r. Coordinate r => Parser (Matrix 3 3 r)
pMatrix                        ParsecT Text () Identity (Matrix 3 3 r)
-> Char -> ParsecT Text () Identity (Matrix 3 3 r)
forall b.
ParsecT Text () Identity b -> Char -> ParsecT Text () Identity b
*>> Char
'e'
                     , Matrix 3 3 r -> Point 2 r -> Operation r
forall r. Matrix 3 3 r -> Point 2 r -> Operation r
ArcTo        (Matrix 3 3 r -> Point 2 r -> Operation r)
-> ParsecT Text () Identity (Matrix 3 3 r)
-> ParsecT Text () Identity (Point 2 r -> Operation r)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Text () Identity (Matrix 3 3 r)
forall r. Coordinate r => Parser (Matrix 3 3 r)
pMatrix ParsecT Text () Identity (Point 2 r -> Operation r)
-> ParsecT Text () Identity (Point 2 r) -> Parser (Operation r)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT Text () Identity (Point 2 r)
pPoint'            ParsecT Text () Identity (Point 2 r)
-> Char -> ParsecT Text () Identity (Point 2 r)
forall b.
ParsecT Text () Identity b -> Char -> ParsecT Text () Identity b
*>> Char
'a'
                     , [Point 2 r] -> Operation r
forall r. [Point 2 r] -> Operation r
Spline       ([Point 2 r] -> Operation r)
-> ParsecT Text () Identity [Point 2 r] -> Parser (Operation r)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Text () Identity (Point 2 r)
forall r. Coordinate r => Parser (Point 2 r)
pPoint ParsecT Text () Identity (Point 2 r)
-> Parser String -> ParsecT Text () Identity [Point 2 r]
forall a b. Parser a -> Parser b -> Parser [a]
`pSepBy` Parser String
pWhiteSpace    ParsecT Text () Identity [Point 2 r]
-> Char -> ParsecT Text () Identity [Point 2 r]
forall b.
ParsecT Text () Identity b -> Char -> ParsecT Text () Identity b
*>> Char
's'
                     , [Point 2 r] -> Operation r
forall r. [Point 2 r] -> Operation r
ClosedSpline ([Point 2 r] -> Operation r)
-> ParsecT Text () Identity [Point 2 r] -> Parser (Operation r)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Text () Identity (Point 2 r)
forall r. Coordinate r => Parser (Point 2 r)
pPoint ParsecT Text () Identity (Point 2 r)
-> Parser String -> ParsecT Text () Identity [Point 2 r]
forall a b. Parser a -> Parser b -> Parser [a]
`pSepBy` Parser String
pWhiteSpace    ParsecT Text () Identity [Point 2 r]
-> Char -> ParsecT Text () Identity [Point 2 r]
forall b.
ParsecT Text () Identity b -> Char -> ParsecT Text () Identity b
*>> Char
'u'
                     , Char -> Parser Char
pChar Char
'h'  Parser Char -> Parser (Operation r) -> Parser (Operation r)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Operation r -> Parser (Operation r)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Operation r
forall r. Operation r
ClosePath
                     ]
             where
               pPoint' :: ParsecT Text () Identity (Point 2 r)
pPoint' = Parser String
pWhiteSpace Parser String
-> ParsecT Text () Identity (Point 2 r)
-> ParsecT Text () Identity (Point 2 r)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Text () Identity (Point 2 r)
forall r. Coordinate r => Parser (Point 2 r)
pPoint
               ParsecT Text () Identity b
p *>> :: ParsecT Text () Identity b -> Char -> ParsecT Text () Identity b
*>> Char
c = ParsecT Text () Identity b
p ParsecT Text () Identity b
-> Parser Char -> ParsecT Text () Identity b
forall s (m :: * -> *) t u b a.
(Stream s m t, Reversable s) =>
ParsecT s u m b -> ParsecT s u m a -> ParsecT s u m b
<*>< Parser String
pWhiteSpace Parser String -> Parser Char -> Parser Char
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
***> Char -> Parser Char
pChar Char
c



pPoint :: Coordinate r => Parser (Point 2 r)
pPoint :: Parser (Point 2 r)
pPoint = r -> r -> Point 2 r
forall r. r -> r -> Point 2 r
Point2 (r -> r -> Point 2 r)
-> ParsecT Text () Identity r
-> ParsecT Text () Identity (r -> Point 2 r)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Text () Identity r
forall r. Coordinate r => Parser r
pCoordinate ParsecT Text () Identity (r -> Point 2 r)
-> Parser String -> ParsecT Text () Identity (r -> Point 2 r)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser String
pWhiteSpace ParsecT Text () Identity (r -> Point 2 r)
-> ParsecT Text () Identity r -> Parser (Point 2 r)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT Text () Identity r
forall r. Coordinate r => Parser r
pCoordinate


pCoordinate :: Coordinate r => Parser r
pCoordinate :: Parser r
pCoordinate = Integer -> Maybe (Int, Integer) -> r
forall r. Coordinate r => Integer -> Maybe (Int, Integer) -> r
fromSeq (Integer -> Maybe (Int, Integer) -> r)
-> ParsecT Text () Identity Integer
-> ParsecT Text () Identity (Maybe (Int, Integer) -> r)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Text () Identity Integer
pInteger ParsecT Text () Identity (Maybe (Int, Integer) -> r)
-> ParsecT Text () Identity (Maybe (Int, Integer)) -> Parser r
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT Text () Identity (Maybe (Int, Integer))
pDecimal
              where
                pDecimal :: ParsecT Text () Identity (Maybe (Int, Integer))
pDecimal  = Parser (Int, Integer)
-> ParsecT Text () Identity (Maybe (Int, Integer))
forall a. Parser a -> Parser (Maybe a)
pMaybe (Char -> Parser Char
pChar Char
'.' Parser Char -> Parser (Int, Integer) -> Parser (Int, Integer)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser (Int, Integer)
pPaddedNatural)


pRectangle :: Coordinate r => Parser (Rectangle () r)
pRectangle :: Parser (Rectangle () r)
pRectangle = (\Point 2 r
p Point 2 r
q -> (Point 2 r :+ ()) -> (Point 2 r :+ ()) -> Rectangle () r
forall (d :: Nat) r p.
(Point d r :+ p) -> (Point d r :+ p) -> Box d p r
box (Point 2 r -> Point 2 r :+ ()
forall a. a -> a :+ ()
ext Point 2 r
p) (Point 2 r -> Point 2 r :+ ()
forall a. a -> a :+ ()
ext Point 2 r
q)) (Point 2 r -> Point 2 r -> Rectangle () r)
-> ParsecT Text () Identity (Point 2 r)
-> ParsecT Text () Identity (Point 2 r -> Rectangle () r)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Text () Identity (Point 2 r)
forall r. Coordinate r => Parser (Point 2 r)
pPoint
                                           ParsecT Text () Identity (Point 2 r -> Rectangle () r)
-> Parser String
-> ParsecT Text () Identity (Point 2 r -> Rectangle () r)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<*  Parser String
pWhiteSpace
                                           ParsecT Text () Identity (Point 2 r -> Rectangle () r)
-> ParsecT Text () Identity (Point 2 r) -> Parser (Rectangle () r)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT Text () Identity (Point 2 r)
forall r. Coordinate r => Parser (Point 2 r)
pPoint

pMatrix :: Coordinate r => Parser (Matrix 3 3 r)
pMatrix :: Parser (Matrix 3 3 r)
pMatrix = (\r
a [r]
b -> [r] -> Matrix 3 3 r
forall r. Coordinate r => [r] -> Matrix 3 3 r
mkMatrix (r
ar -> [r] -> [r]
forall a. a -> [a] -> [a]
:[r]
b)) (r -> [r] -> Matrix 3 3 r)
-> ParsecT Text () Identity r
-> ParsecT Text () Identity ([r] -> Matrix 3 3 r)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Text () Identity r
forall r. Coordinate r => Parser r
pCoordinate
                                   ParsecT Text () Identity ([r] -> Matrix 3 3 r)
-> ParsecT Text () Identity [r] -> Parser (Matrix 3 3 r)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> ParsecT Text () Identity r -> ParsecT Text () Identity [r]
forall a. Int -> Parser a -> Parser [a]
pCount Int
5 (Parser String
pWhiteSpace Parser String
-> ParsecT Text () Identity r -> ParsecT Text () Identity r
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Text () Identity r
forall r. Coordinate r => Parser r
pCoordinate)


-- | Generate a matrix from a list of 6 coordinates.
mkMatrix               :: Coordinate r => [r] -> Matrix 3 3 r
mkMatrix :: [r] -> Matrix 3 3 r
mkMatrix [r
a,r
b,r
c,r
d,r
e,r
f] = Vector 3 (Vector 3 r) -> Matrix 3 3 r
forall (n :: Nat) (m :: Nat) r.
Vector n (Vector m r) -> Matrix n m r
Matrix (Vector 3 (Vector 3 r) -> Matrix 3 3 r)
-> Vector 3 (Vector 3 r) -> Matrix 3 3 r
forall a b. (a -> b) -> a -> b
$ Vector 3 r -> Vector 3 r -> Vector 3 r -> Vector 3 (Vector 3 r)
forall r. r -> r -> r -> Vector 3 r
Vector3 (r -> r -> r -> Vector 3 r
forall r. r -> r -> r -> Vector 3 r
Vector3 r
a r
c r
e)
                                          (r -> r -> r -> Vector 3 r
forall r. r -> r -> r -> Vector 3 r
Vector3 r
b r
d r
f)
                                          (r -> r -> r -> Vector 3 r
forall r. r -> r -> r -> Vector 3 r
Vector3 r
0 r
0 r
1)
                           -- We need the matrix in the following order:
                         -- 012
                         -- 345
                         --
                         -- But ipe uses the following order:
                         -- 024
                         -- 135
mkMatrix [r]
_             = String -> Matrix 3 3 r
forall a. HasCallStack => String -> a
error String
"mkMatrix: need exactly 6 arguments"