Commit 47afebfd authored by Bastian Kauschke's avatar Bastian Kauschke

implement PrintMorphism for all functors

parent 8d95f59a
......@@ -27,6 +27,7 @@ library
, Data.Vector.Utils
, Data.Algorithm.PossibleMajorityCandidate
, Data.BlockQueue
, Data.Foldable.Utils
, Data.Partition
, Data.Partition.Common
, Data.OpenUnion
......
......@@ -33,11 +33,13 @@ import Type.Reflection
import Copar.FunctorExpression.Parser
import Copar.RefinementInterface
import Copar.Coalgebra.Parser.Class
import Copar.Coalgebra.Printer
import Copar.PrettyShow
type Suitable f
= ( RefinementInterface f
, ParseMorphism f
, PrintMorphism f
, Eq1 f
, Functor f
, FunctorDescription f
......
......@@ -23,7 +23,7 @@ import Control.Monad
import Data.Bifunctor
import Data.List.NonEmpty ( NonEmpty(..) )
import GHC.Generics ( Generic )
import Data.Maybe ( catMaybes )
import Data.Maybe ( catMaybes, fromJust, mapMaybe)
import Data.Either ( lefts
, rights
)
......@@ -34,6 +34,7 @@ import Data.Foldable
import Data.Eq.Deriving ( deriveEq1 )
import Text.Show.Deriving ( deriveShow1 )
import Data.Functor.Classes
import Data.Vector ( Vector )
import qualified Data.Vector as V
import qualified Data.Vector.Mutable as VM
......@@ -43,12 +44,15 @@ import Control.DeepSeq ( NFData
)
import Lens.Micro.Platform
import Data.Text ( Text )
import qualified Data.Text.Lazy.Builder as Build
import Text.Megaparsec
import Copar.Coalgebra.Parser
import Copar.Coalgebra.Printer
import qualified Copar.Parser.Lexer as L
import Copar.RefinementInterface
import Copar.Functors.Polynomial hiding ( PolyF1(..) )
import Copar.Functors.Polynomial hiding ( PolyF1(..) )
import qualified Copar.Functors.Polynomial as Poly
import qualified Copar.Functors.SomeFunctor as SF
import Copar.FunctorExpression.Type
import Copar.FunctorDescription
......@@ -72,7 +76,7 @@ instance FunctorDescription (AbsorbingPolynomial SF.SomeFunctor) where
syntaxExample = "2xX + X^3"
description = Nothing -- AbsorbingPolynomial is not relevant for users
precedence = 10
functorExprParser = undefined -- It is not possible to parse an AbsorbnigPolynomial directly
functorExprParser = undefined -- It is not possible to parse an AbsorbingPolynomial directly
functorExprPrinter cfg (AbsorbingPolynomial poly) =
let name = withName cfg "AbsorbingPolynomial"
......@@ -80,10 +84,17 @@ instance FunctorDescription (AbsorbingPolynomial SF.SomeFunctor) where
Direct a -> a
-- We want to always print the surrounding braces in case functor names
-- are printed.
Absorbed inner ->
if dynPrecedence (SF.someFunctorDescription inner) > 10 && name == mempty
then SF.printSomeFunctorExpr cfg inner
else "(" <> SF.printSomeFunctorExpr cfg inner <> ")"
Absorbed inner' ->
-- HACK: We currently always wrap the content of the absorbed functor in parens.
--
-- We do this because `precedence` does not care about the absorbed functor, which
-- means that otherwise would not add parens even if the absorbed functor needs them
-- as long as they wouldn't be needed for `AbsorbingPolynomial` itself.
let inner = (\v -> "(" <> v <> ")") <$> inner'
in
if dynPrecedence (SF.someFunctorDescription inner) > 10 && name == mempty
then SF.printSomeFunctorExpr cfg inner
else "(" <> SF.printSomeFunctorExpr cfg inner <> ")"
) <$> poly)
$(deriveShow1 ''AbsorbingPolynomial)
......@@ -274,11 +285,36 @@ parseInner (Direct inner) = do
x <- inner
return (Nothing, V.singleton (x, Nothing))
instance (PrintMorphism f, Show1 f, Show (Label f), Show (F1 f)) => PrintMorphism (AbsorbingPolynomial f) where
-- TODO: This currently has a runtime of O(n^2), which can still be improved
printMorphismPoint (AbsorbingPolynomial poly) f1 edges =
let
innerFunctors = toList poly
f1' = Poly.PolyF1
(polyF1Summand f1)
(foldr (\v total -> ((maybe 0 (const 1)) v) + total) 0 (polyF1Variables f1))
(polyF1Constants f1)
in
printMorphismPoint
(() <$ poly)
f1'
(fmap convertFunctor (zip innerFunctors [0..]))
where
convertFunctor :: (Inner f (), Int) -> (Label Polynomial, Build.Builder)
convertFunctor (Direct (), v) = (v, snd $ fromJust (find (\(PolyLabel n _, _) -> n == v) (edges)))
convertFunctor (Absorbed inner, v) = (v,
printMorphismPoint
inner
(fromJust $ indexSmallArray (polyF1Variables f1) v)
(mapMaybe (filterLabel v) edges)
)
filterLabel :: Int -> (Label (AbsorbingPolynomial f), Build.Builder) -> Maybe (Label f, Build.Builder)
filterLabel v ((PolyLabel k lbl), state) = if v == k then Just (fromJust lbl, state) else Nothing
instance ParseMorphism f => ParseMorphism (AbsorbingPolynomial f) where
parseMorphismPoint (AbsorbingPolynomial (Polynomial sum)) = parseSum1 sum
----------- Coproducts parser
-- | Parse either a single product or an injection into the coproduct, depending
......
......@@ -16,6 +16,7 @@ import Prelude hiding (init)
import qualified Data.Vector as V
import Text.Megaparsec
import Data.Foldable.Utils
import Data.Eq.Deriving (deriveEq1)
import Text.Show.Deriving (deriveShow1)
import qualified Data.Text.Prettyprint as Doc
......@@ -25,6 +26,7 @@ import Copar.RefinementInterface
import qualified Copar.Parser.Lexer as L
import Copar.FunctorExpression.Parser
import Copar.Coalgebra.Parser
import Copar.Coalgebra.Printer
import Copar.Functors.GroupValued
import Copar.FunctorDescription
......@@ -62,6 +64,10 @@ $(deriveShow1 ''Bag)
deriving instance Show (Bag ())
instance PrintMorphism Bag where
printMorphismPoint _ _ edges = "{" <> sepFold ", " snd edges <> "}"
instance ParseMorphism Bag where
parseMorphismPoint (Bag inner) = L.braces $ do
successors <- V.fromList <$> inner `sepBy` L.comma
......
......@@ -14,9 +14,11 @@ import Text.Show.Deriving (deriveShow1)
import qualified Data.Text.Prettyprint as Doc
import Data.Text.Prettyprint ((<+>))
import Control.Monad.Extra (unlessM)
import Data.Foldable.Utils
import Data.Float.Utils (EqDouble)
import Data.Float.Utils (EqDouble(..))
import Copar.Coalgebra.Parser
import Copar.Coalgebra.Printer
import Copar.FunctorDescription
import Copar.FunctorExpression.Parser
import Copar.Functors.GroupValued
......@@ -61,6 +63,10 @@ $(deriveShow1 ''Distribution)
deriving instance Show (Distribution ())
instance PrintMorphism Distribution where
printMorphismPoint _ _ edges = "{" <> sepFold ", " printElem edges <> "}"
where printElem (EqDouble value, state) = state <> ": " <> printFloat value
instance ParseMorphism Distribution where
parseMorphismPoint (Distribution inner) = do
(f1, succs) <- parseMorphismPoint (GroupValued @EqDouble inner)
......
......@@ -22,6 +22,7 @@ module Copar.Functors.GroupValued
import Control.Monad (when)
import Data.Complex
import Control.DeepSeq (NFData)
import Data.Foldable.Utils
import Data.Ratio
import Data.Functor.Classes
......@@ -29,13 +30,16 @@ import Data.Vector (Vector)
import qualified Data.Vector as V
import Text.Megaparsec
import Text.Show.Deriving (deriveShow1)
import qualified Data.Text.Prettyprint as Doc
import Data.Text.Prettyprint ((<+>))
import qualified Data.Text.Prettyprint as Doc
import Data.Text.Prettyprint ((<+>))
import qualified Data.Text.Lazy.Builder as Build
import qualified Data.Text.Lazy.Builder.Int as Build
import Data.Float.Utils (EqDouble)
import Data.Float.Utils (EqDouble(..))
import qualified Data.Vector.Utils as V
import Copar.RefinementInterface
import Copar.Coalgebra.Parser
import Copar.Coalgebra.Printer
import Copar.FunctorExpression.Parser
import qualified Copar.Parser.Lexer as L
import Copar.Parser.Types
......@@ -229,21 +233,45 @@ parseMorphismPointHelper inner weightParser sanity = do
{-# SPECIALIZE parseMorphismPointHelper :: MorphParser l f1 Int -> MorphParser l f1 Int -> Bool -> MorphParser l f1 (Int, Vector (Int, Int)) #-}
{-# SPECIALIZE parseMorphismPointHelper :: MorphParser l f1 Int -> MorphParser l f1 EqDouble -> Bool -> MorphParser l f1 (EqDouble, Vector (Int, EqDouble)) #-}
instance PrintMorphism (GroupValued Int) where
printMorphismPoint _ _ edges = "{" <> sepFold ", " printElem edges <> "}"
where printElem (value, state) = state <> ": " <> Build.decimal value
instance ParseMorphism (GroupValued Int) where
parseMorphismPoint (GroupValued inner) =
parseMorphismPointHelper inner (L.signed L.decimal)
=<< (not <$> noSanityChecks)
instance PrintMorphism (GroupValued EqDouble) where
printMorphismPoint _ _ edges = "{" <> sepFold ", " printElem edges <> "}"
where printElem (EqDouble value, state) = state <> ": " <> printFloat value
instance ParseMorphism (GroupValued EqDouble) where
parseMorphismPoint (GroupValued inner) =
parseMorphismPointHelper inner (L.signed L.adouble)
=<< (not <$> noSanityChecks)
instance PrintMorphism (GroupValued OrderedComplex) where
printMorphismPoint _ _ edges = "{" <> sepFold ", " printElem edges <> "}"
where
printElem (OrderedComplex value, state) =
state <> ": " <>
Build.fromString (show (realPart value)) <>
(if (imagPart value <= 0.0) then " - " else " + ") <>
Build.fromString (show (abs $ imagPart value)) <> "i"
instance ParseMorphism (GroupValued OrderedComplex) where
parseMorphismPoint (GroupValued inner) =
parseMorphismPointHelper inner (OrderedComplex <$> L.complex L.adouble)
=<< (not <$> noSanityChecks)
instance PrintMorphism (GroupValued (Ratio Int)) where
printMorphismPoint _ _ edges = "{" <> sepFold ", " printElem edges <> "}"
where
printElem (value, state) =
state <> ": " <>
Build.decimal (numerator value) <> "/" <> Build.decimal (denominator value)
instance ParseMorphism (GroupValued (Ratio Int)) where
parseMorphismPoint (GroupValued inner) =
parseMorphismPointHelper inner (L.signed (L.fraction L.decimal))
......
......@@ -20,6 +20,7 @@ module Copar.Functors.MonoidValued
)
where
import Data.Foldable.Utils
import Data.List ( foldl', intersperse )
import Data.Semigroup ( Max(..), Min(..) )
import Data.Functor.Classes
......@@ -33,6 +34,7 @@ import qualified Data.Text.Prettyprint as Doc
import Data.Text.Prettyprint ( (<+>) )
import Data.Text ( Text )
import qualified Data.Text.Lazy.Builder as Build
import qualified Data.Text.Lazy.Builder.Int as Build
import qualified Data.Vector.Utils as V
import Copar.RefinementInterface
......@@ -40,6 +42,7 @@ import Copar.FunctorDescription
import qualified Copar.Parser.Lexer as L
import Copar.FunctorExpression.Parser
import Copar.Coalgebra.Parser
import Copar.Coalgebra.Printer
import Data.Float.Utils ( MaxDouble(..)
, MinDouble(..)
)
......@@ -208,22 +211,45 @@ instance (Monoid m, Ord m) => RefinementInterface (SlowMonoidValued m) where
w2 = (sumRest <> sumS, toCWithoutS)
in (w1, f3, w2)
instance PrintMorphism (SlowMonoidValued (Max Int)) where
printMorphismPoint _ _ edges = "{" <> sepFold ", " printEdge edges <> "}"
where printEdge ((Max value), state) = state <> ": " <> Build.decimal value
instance ParseMorphism (SlowMonoidValued (Max Int)) where
parseMorphismPoint = parseMorphismPointHelper (Max <$> (L.signed L.decimal))
instance PrintMorphism (SlowMonoidValued (Min Int)) where
printMorphismPoint _ _ edges = "{" <> sepFold ", " printEdge edges <> "}"
where printEdge ((Min value), state) = state <> ": " <> Build.decimal value
instance ParseMorphism (SlowMonoidValued (Min Int)) where
parseMorphismPoint = parseMorphismPointHelper (Min <$> (L.signed L.decimal))
instance PrintMorphism (SlowMonoidValued MaxDouble) where
printMorphismPoint _ _ edges = "{" <> sepFold ", " printEdge edges <> "}"
where printEdge ((MaxDouble value), state) = state <> ": " <> printFloat value
instance ParseMorphism (SlowMonoidValued MaxDouble) where
parseMorphismPoint = parseMorphismPointHelper (MaxDouble <$> L.signed L.float)
instance PrintMorphism (SlowMonoidValued MinDouble) where
printMorphismPoint _ _ edges = "{" <> sepFold ", " printEdge edges <> "}"
where printEdge ((MinDouble value), state) = state <> ": " <> printFloat value
instance ParseMorphism (SlowMonoidValued MinDouble) where
parseMorphismPoint = parseMorphismPointHelper (MinDouble <$> L.signed L.float)
instance PrintMorphism (SlowMonoidValued (BitAnd Word64)) where
printMorphismPoint _ _ edges = "{" <> sepFold ", " printEdge edges <> "}"
where printEdge (value, state) = state <> ": 0x" <> Build.hexadecimal value
instance ParseMorphism (SlowMonoidValued (BitAnd Word64)) where
parseMorphismPoint = parseMorphismPointHelper L.hex
instance PrintMorphism (SlowMonoidValued (BitOr Word64)) where
printMorphismPoint _ _ edges = "{" <> sepFold ", " printEdge edges <> "}"
where printEdge (value, state) = state <> ": 0x" <> Build.hexadecimal value
instance ParseMorphism (SlowMonoidValued (BitOr Word64)) where
parseMorphismPoint = parseMorphismPointHelper L.hex
......
......@@ -22,10 +22,11 @@ module Copar.Functors.Polynomial
import Control.Monad
import Data.Bifunctor
import Data.Foldable.Utils
import Data.Foldable (fold)
import Data.Traversable (mapAccumL)
import Data.List.NonEmpty (NonEmpty(..))
import qualified Data.List.NonEmpty as NonEmpty
import Data.Traversable
import Data.Word (Word8)
import GHC.Generics (Generic)
import Data.Functor.Classes
......@@ -45,12 +46,13 @@ import Data.Eq.Deriving (deriveEq1)
import Text.Show.Deriving (deriveShow1)
import Lens.Micro
import Control.DeepSeq
import Data.Text.Lazy.Builder as Build
import Data.Text.Lazy.Builder.Int as Build
import qualified Data.Text.Lazy.Builder as Build
import qualified Data.Text.Lazy.Builder.Int as Build
import qualified Data.Text.Prettyprint as Doc
import Data.Text.Prettyprint ((<+>))
import Copar.Coalgebra.Parser
import Copar.Coalgebra.Printer
import qualified Copar.Parser.Lexer as L
import Copar.Parser.Types
import Copar.RefinementInterface
......@@ -289,6 +291,34 @@ type instance Weight Polynomial = VU.Vector Bool
-- documentation for Three.
type instance F3 Polynomial = VU.Vector Three
instance PrintMorphism Polynomial where
printMorphismPoint (Polynomial expr) f1 edges = printSumPoint expr f1 edges
printSumPoint :: Sum () -> F1 Polynomial -> [(Label Polynomial, Build.Builder)] -> Build.Builder
printSumPoint (Sum sum) f1 edges =
(if NonEmpty.length sum /= 1 then "inj" <> Build.decimal (polyF1Summand f1) <> " " else "")
<> printProductPoint (sum NonEmpty.!! (polyF1Summand f1)) f1 edges
printProductPoint :: Product () -> F1 Polynomial -> [(Label Polynomial, Build.Builder)] -> Build.Builder
printProductPoint (Product prod) f1 edges =
let inner = sepFold ", " id (snd (mapAccumL printFactor (0, 0) prod))
in if NonEmpty.length prod /= 1 then "(" <> inner <> ")" else inner
where
printFactor :: (Int, Int) -> Factor () -> ((Int, Int), Build.Builder)
printFactor (ct, var) (Const IntSet) = ((ct + 1, var), Build.decimal (polyF1Constants f1 VU.! ct))
printFactor (ct, var) (Const NatSet) = ((ct + 1, var), Build.decimal (polyF1Constants f1 VU.! ct))
printFactor (ct, var) (Const (FiniteNatSet _)) = ((ct + 1, var), Build.decimal (polyF1Constants f1 VU.! ct))
printFactor (ct, var) (Const (ExplicitSet elems)) = ((ct + 1, var), Build.fromText $ elems V.! (polyF1Constants f1 VU.! ct))
printFactor (ct, var) (Identity ()) = ((ct, var + 1), snd $ edges !! var)
printFactor (ct, var) (Exponential () (ExplicitExp elems)) =
let ((ct', var'), elems') = mapAccumL (printExp Build.fromText) (ct, var) elems
in ((ct', var'), "{" <> sepFold ", " id elems' <> "}")
printFactor (ct, var) (Exponential () (FiniteNatExp size)) =
let ((ct', var'), elems') = mapAccumL (printExp Build.decimal) (ct, var) (take size [(0 :: Int)..])
in ((ct', var'), "{" <> sepFold ", " id elems' <> "}")
printExp :: (a -> Build.Builder) -> (Int, Int) -> a -> ((Int, Int), Build.Builder)
printExp toBuilder (ct, var) elem = ((ct, var + 1), toBuilder elem <> ": " <> snd (edges !! var))
instance ParseMorphism Polynomial where
parseMorphismPoint (Polynomial expr) = parseSum1 expr
......
......@@ -13,6 +13,7 @@ module Copar.Functors.Powerset
import Control.Monad (when)
import Data.Word (Word8)
import Data.Bits
import Data.Foldable.Utils
import Text.Megaparsec
import qualified Data.Vector as V
......@@ -26,6 +27,7 @@ import Copar.RefinementInterface
import qualified Copar.Parser.Lexer as L
import Copar.FunctorExpression.Parser
import Copar.Coalgebra.Parser
import Copar.Coalgebra.Printer
import Copar.FunctorDescription
newtype Powerset a = Powerset a
......@@ -80,6 +82,9 @@ type instance F1 Powerset = Bool
-- - do we have edges to S?
type instance F3 Powerset = PowerF3
instance PrintMorphism Powerset where
printMorphismPoint _ _ edges = "{" <> sepFold ", " snd edges <> "}"
instance ParseMorphism Powerset where
parseMorphismPoint (Powerset inner) = do
successors' <- L.braces (inner `sepBy` L.comma)
......
......@@ -36,6 +36,7 @@ import qualified Data.Text as T
import qualified Data.Text.Lazy.Builder as Build
import Copar.Coalgebra.Parser.Class
import Copar.Coalgebra.Printer
import Copar.FunctorExpression.Parser
import Copar.PrettyShow
......@@ -200,6 +201,21 @@ instance RefinementInterface SomeFunctor where
Just HRefl -> Just l
#endif
instance PrintMorphism SomeFunctor where
printMorphismPoint (SomeFunctor (f :: f' ())) f1 edges =
printMorphismPoint f (mapF1 f1) (mapMaybe mapEdges edges)
where
mapF1 (SomeF1 fRep f1) = case eqTypeRep (typeRep @f') fRep of
Nothing -> error "unexpected F1"
Just HRefl -> f1
#ifdef RELEASE
mapEdges ((SomeLabel f2), to) = Just (unsafeCoerce f2, to)
#else
mapEdges ((SomeLabel f2 l), to) = case eqTypeRep (typeRep @f') f2 of
Nothing -> Nothing
Just HRefl -> Just (l, to)
#endif
instance ParseMorphism SomeFunctor where
parseMorphismPoint (SomeFunctor (f :: tf (MorphParser l f1 x))) = do
(f1, succs) <- parseMorphismPoint f
......
......@@ -4,7 +4,7 @@
-- | Various utilities for floating point numbers
module Data.Float.Utils
( EqDouble
( EqDouble(..)
, fromDouble
, MaxDouble(..)
, MinDouble(..)
......
module Data.Foldable.Utils (sepFold) where
import Data.List
import Data.Foldable
sepFold :: (Foldable t, Monoid m) => m -> (a -> m) -> t a -> m
sepFold sep f = fold . intersperse sep . map f . toList
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment