Commit 60926945 authored by Hans-Peter Deifel's avatar Hans-Peter Deifel 🐢
Browse files

Implement initialization for morphisms list

This allows to initialize the algorithm not only for one but for all
morphisms and is needed to test initialization from main.
parent c4268e09
......@@ -21,6 +21,7 @@ library
, Data.Functors.Powerset
, Data.Functors.FixedProduct
, Data.Functors
, Data.Sort
, Parser
, Algorithm
default-language: Haskell2010
......
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RecordWildCards #-}
module Algorithm where
module Algorithm
( initializeAll
, finalizeStates
) where
import Prelude hiding (pred)
import Control.Monad.ST
import Control.Monad
......@@ -13,6 +22,7 @@ import qualified Data.Vector as V
import Data.MorphismEncoding
import Data.RefinementInterface (RefinementInterface)
import qualified Data.RefinementInterface as RI
import Data.Sort
data AlgoState s h = AlgoState
{ toSub :: MVector s [EdgeRef]
......@@ -48,6 +58,57 @@ initialize functor encoding nextSize = do
return AlgoState {..}
data SomeAlgoState s where
SomeAlgoState :: RefinementInterface h => AlgoState s h -> SomeAlgoState s
initializeAll :: Vector Morphism -> ST s (Vector (SomeAlgoState s))
initializeAll encodings = do
let sizes = fmap (\(Morphism _ x) -> size x) encodings
forM (V.zip encodings (rotateVectorLeft sizes)) $ \(Morphism h encoding, nextSize) ->
SomeAlgoState <$> initialize h encoding nextSize
iforM_ :: Monad m => Vector a -> (Int -> a -> m b) -> m ()
iforM_ = flip V.imapM_
rotateVectorLeft :: Vector a -> Vector a
rotateVectorLeft vec =
let
len = length vec
indexVec = V.generate len (\i -> (i+1) `mod` len)
in
V.backpermute vec indexVec
-- debugging stuff
data NonSTAlgoState h = NonSTAlgoState
{ nonSTToSub :: Vector [EdgeRef]
, nonSTLastW :: Vector (RI.Weight h)
, nonSTFunctor :: h -- TODO Shouldn't be needed
, nonSTEncoding :: Encoding (RI.Label h) (RI.H1 h)
, nonSTPred :: Vector [EdgeRef]
-- refineable partition
}
deriving instance (Show h, Show (RI.Weight h), Show (RI.Label h), Show (RI.H1 h))
=> Show (NonSTAlgoState h)
finalizeState :: AlgoState s h -> ST s (NonSTAlgoState h)
finalizeState state = do
nonSTToSub <- V.freeze (toSub state)
nonSTLastW <- V.freeze (lastW state) >>= mapM readSTRef
let nonSTFunctor = functor state
nonSTEncoding = encoding state
nonSTPred = pred state
return $ NonSTAlgoState {..}
data SomeNonSTAlgoState where
SomeNonSTAlgoState :: RefinementInterface h => NonSTAlgoState h -> SomeNonSTAlgoState
deriving instance Show SomeNonSTAlgoState
finalizeStates :: Vector (SomeAlgoState s) -> ST s (Vector SomeNonSTAlgoState)
finalizeStates vec = forM vec $ \(SomeAlgoState s) ->
SomeNonSTAlgoState <$> finalizeState s
......@@ -21,7 +21,7 @@ data RefinableFunctor = forall h. RefinementInterface h => RefinableFunctor
, parseArguments :: ArgumentParser h
}
class (Show h, Show (Label h), Show (H1 h)) => RefinementInterface h where
class (Show h, Show (Label h), Show (H1 h), Show (Weight h)) => RefinementInterface h where
type Label h :: *
type Weight h :: *
type H1 h :: *
......
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE DataKinds #-}
module Data.Sort
( Morphism(..)
) where
import Data.Kind
import Data.RefinementInterface
import Data.MorphismEncoding
-- TODO This should really be somewhere else
data Morphism :: Type where
Morphism :: RefinementInterface h => h -> Encoding (Label h) (H1 h) -> Morphism
deriving instance Show Morphism
......@@ -19,7 +19,7 @@ import Data.ByteString (ByteString)
import Data.RefinementInterface
import Data.Functors (registeredFunctors)
import Data.MorphismEncoding
import Data.Sort
data SomeRefinementInterface where
......@@ -55,10 +55,7 @@ parseFunctor value =
failUnknownFunctor name = fail ("Functor " ++ T.unpack name ++ " not found")
failIllegalJson = fail "Illegal functor specification"
parseSomeEncoding :: SomeRefinementInterface -> Vector Yaml.Value -> Yaml.Parser SomeEncoding
parseSomeEncoding (SRI ri) value = SomeEncoding <$> parse ri value
newtype CoalgebraSpecification = CoalgebraSpecification { fromCoalg :: Vector SomeEncoding }
newtype CoalgebraSpecification = CoalgebraSpecification { fromCoalg :: Vector Morphism }
deriving (Show)
instance Yaml.FromJSON CoalgebraSpecification where
......@@ -67,10 +64,10 @@ instance Yaml.FromJSON CoalgebraSpecification where
morphisms :: Vector (Vector Yaml.Value) <- obj .: "morphisms"
-- TODO Ensure functors and morphisms are of equal length
encodings <- forM (V.zip functors morphisms) $ \(functor, morph) ->
parseSomeEncoding functor morph
encodings <- forM (V.zip functors morphisms) $ \(SRI functor, yamlValue) -> do
Morphism functor <$> parse functor yamlValue
return (CoalgebraSpecification encodings)
decodeCoalgebra :: ByteString -> Either String (Vector SomeEncoding)
decodeCoalgebra :: ByteString -> Either String (Vector Morphism)
decodeCoalgebra = fmap fromCoalg . Yaml.decodeEither
......@@ -7,13 +7,18 @@ import Text.Pretty.Simple (pPrint)
import System.Environment
import System.IO
import Control.Monad.ST
import Parser
import Algorithm
main :: IO ()
main = getArgs >>= \case
[file] -> BS.readFile file >>= pPrint . decodeCoalgebra
[file] -> do
content <- BS.readFile file
case decodeCoalgebra content of
Left err -> error err
Right morphs -> stToIO (initializeAll morphs >>= finalizeStates) >>= pPrint
_ -> do
prog <- getProgName
hPutStrLn stderr ("Usage: " ++ prog ++ " FILE")
Supports Markdown
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