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

Implement initialization for single morphisms

parent 1950889c
......@@ -20,8 +20,9 @@ library
, Data.RefinementInterface
, Data.Functors.Powerset
, Data.Functors.FixedProduct
, Parser
, Data.Functors
, Parser
, Algorithm
default-language: Haskell2010
build-depends: base
, vector
......
{-# LANGUAGE RecordWildCards #-}
module Algorithm where
import Control.Monad.ST
import Control.Monad
import Data.STRef
import Data.Vector.Mutable (MVector)
import qualified Data.Vector.Mutable as VM
import Data.Vector (Vector)
import qualified Data.Vector as V
import Data.MorphismEncoding
import Data.RefinementInterface (RefinementInterface)
import qualified Data.RefinementInterface as RI
data AlgoState s h = AlgoState
{ toSub :: MVector s [EdgeRef]
, lastW :: MVector s (STRef s (RI.Weight h))
, functor :: h -- TODO Shouldn't be needed
, encoding :: Encoding (RI.Label h) (RI.H1 h)
-- refineable partition
}
initialize :: RefinementInterface h => h -> Encoding (RI.Label h) (RI.H1 h) -> ST s (AlgoState s h)
initialize functor encoding = do
toSub <- VM.replicate (size encoding) []
lastW <- VM.new (length (edges encoding))
iforM_ (edges encoding) $ \i (Edge x _ _) -> do
VM.modify toSub (EdgeRef i:) x
forM_ (elements encoding) $ \x -> do
outgoingLabels <- map (label . graph encoding) <$> VM.read toSub x
px <- newSTRef $ RI.init functor (typeOf encoding x) outgoingLabels
VM.read toSub x >>= mapM_ (\(EdgeRef e) -> VM.write lastW e px)
VM.write toSub x []
-- TODO Initialize refineable partition
return AlgoState {..}
iforM_ :: Monad m => Vector a -> (Int -> a -> m b) -> m ()
iforM_ = flip V.imapM_
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
......@@ -12,6 +13,7 @@ import Data.Text (Text)
import Data.RefinementInterface
import qualified Data.MorphismEncoding as Encoding
import Data.MorphismEncoding (Edge(Edge))
data FixedProduct = FixedProduct (Vector Text)
deriving (Show)
......@@ -33,11 +35,14 @@ instance RefinementInterface FixedProduct where
return (Encoding.new structure edges)
where
parseNode :: Int -> Yaml.Value -> Yaml.Parser ((H1 FixedProduct), (Int, Label FixedProduct, Int))
parseNode :: Int -> Yaml.Value -> Yaml.Parser ((H1 FixedProduct), Edge (Label FixedProduct))
parseNode morphIdx = Yaml.withText "label" $ \txt ->
case V.elemIndex txt labels of
Nothing -> fail $ "Label" ++ T.unpack txt ++ " not defined"
Just labelIdx -> return (labelIdx, (morphIdx, (), morphIdx))
Just labelIdx -> return (labelIdx, Edge morphIdx () morphIdx)
init :: FixedProduct -> H1 FixedProduct -> [Label FixedProduct] -> Weight FixedProduct
init _ = const
fixedProduct :: RefinableFunctor
fixedProduct = RefinableFunctor
......
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
......@@ -24,7 +25,7 @@ instance RefinementInterface Powerset where
succsessors <- V.imapM parseNode arr
let structure = V.map (not . V.null . snd) succsessors
edges = V.concatMap (\(from, succs) -> fmap (from,(),) succs) succsessors
edges = V.concatMap (\(from, succs) -> fmap (Encoding.Edge from ()) succs) succsessors
return $ Encoding.new structure edges
......@@ -32,6 +33,9 @@ instance RefinementInterface Powerset where
parseNode :: Int -> Yaml.Value -> Yaml.Parser (Int, Vector Int)
parseNode nodeIdx value = (nodeIdx,) <$> Yaml.parseJSON value
init :: Powerset -> H1 Powerset -> [Label Powerset] -> Weight Powerset
init _ _ = (0, ) . length
powerset :: RefinableFunctor
powerset = RefinableFunctor
{ name = "Powerset"
......
{-# LANGUAGE RecordWildCards #-}
module Data.MorphismEncoding
( Encoding
( Encoding(edges)
, EdgeRef(..)
, Edge(..)
, new
, size
, outgoingSize
, elements
, typeOf
, graph
) where
import Data.Vector (Vector)
import Data.Vector (Vector)
import qualified Data.Vector as V
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
newtype EdgeRef = EdgeRef Int
deriving (Eq, Ord, Show)
data Edge a = Edge
{ from :: Int
, label :: a
, to :: Int
}
deriving (Show)
data Encoding a h1 = Encoding
{ structure :: Vector h1
, edges :: Vector (Int, a, Int)
, outgoingSize :: Int
, edges :: Vector (Edge a)
-- same as edges, but reverse and without label
, predecessors :: Vector [EdgeRef]
}
deriving (Show)
new :: Vector h1 -> Vector (Int, a, Int) -> Encoding a h1
new = Encoding
new :: Vector h1 -> Vector (Edge a) -> Encoding a h1
new structure edges =
let
-- FIXME Check that each outnode is mentioned
-- TODO Make efficient
outnodes :: HashMap Int [EdgeRef]
outnodes = HashMap.fromListWith (++) $
V.toList $ V.imap (\idx e -> (to e, [EdgeRef idx])) edges
outgoingSize = HashMap.size outnodes
predecessors = V.generate outgoingSize (outnodes HashMap.!)
in
Encoding {..}
size :: Encoding a h1 -> Int
size = length . structure
elements :: Encoding a h1 -> [Int]
elements self = [0..length (structure self)-1]
typeOf :: Encoding a h1 -> Int -> h1
typeOf self x = (structure self) V.! x
graph :: Encoding a h1 -> EdgeRef -> Edge a
graph self (EdgeRef e) = (edges self) V.! e
......@@ -27,3 +27,4 @@ class (Show h, Show (Label h), Show (H1 h)) => RefinementInterface h where
type H3 h :: *
parse :: h -> Yaml.Value -> Yaml.Parser (Encoding (Label h) (H1 h))
init :: h -> H1 h -> [Label h] -> Weight h
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