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

Remove dummy type from RefinementInterface

The type `h` was only needed to make instance resolution unambiguous,
but type application can do that, too.
parent d738b62e
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Algorithm
( initializeAll
, finalizeStates
......@@ -36,7 +38,6 @@ import Data.Algorithm.PossibleMajorityCandidate
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)
, pred :: Vector [EdgeRef]
, partition :: RefinablePartition s
......@@ -45,8 +46,8 @@ data AlgoState s h = AlgoState
-- nextSize is the node count of the target set. All target indices in the given
-- edge set must fall into this range.
initialize :: RefinementInterface h => h -> Encoding (RI.Label h) (RI.H1 h) -> Int -> ST s (AlgoState s h)
initialize functor encoding nextSize = do
initialize :: forall h s. RefinementInterface h => Encoding (RI.Label h) (RI.H1 h) -> Int -> ST s (AlgoState s h)
initialize encoding nextSize = do
toSub <- VM.replicate (size encoding) []
lastW <- VM.new (length (edges encoding))
predMutable <- VM.replicate nextSize []
......@@ -60,7 +61,7 @@ initialize functor encoding nextSize = do
forM_ (elements encoding) $ \x -> do
outgoingLabels <- map (label . graph encoding) <$> VM.read toSub x
px <- newSTRef $ RI.init functor (typeOf encoding x) outgoingLabels
px <- newSTRef $ RI.init @h (typeOf encoding x) outgoingLabels
VM.read toSub x >>= mapM_ (\(EdgeRef e) -> VM.write lastW e px)
VM.write toSub x []
......@@ -86,14 +87,14 @@ split statesOfS = do
whenM (lift $ Partition.hasMarked (partition as) b) $
splitBlock b
updateBlock :: RefinementInterface h => Block -> RI.H3 h -> SplitM s h ()
updateBlock :: forall s h. RefinementInterface h => Block -> RI.H3 h -> SplitM s h ()
updateBlock b v0 = ask >>= \as -> lift $ do
markB <- Partition.markedStates (partition as) b
forM_ markB $ \x -> do
pc <- (fromEdgeRef . head <$> VM.read (toSub as) x)
>>= VM.read (lastW as)
labelsToS <- map (label . graph (encoding as)) <$> VM.read (toSub as) x
(wxS, vx, wxCwithoutS) <- RI.update (functor as) labelsToS <$> readSTRef pc
(wxS, vx, wxCwithoutS) <- RI.update @h labelsToS <$> readSTRef pc
writeSTRef pc wxCwithoutS
ps <- newSTRef wxS
VM.read (toSub as) x >>= \edges -> forM_ edges $ \(EdgeRef e) ->
......@@ -130,7 +131,7 @@ splitBlock b = ask >>= \as -> lift $ do
-- TODO Insert blocks except a largest into queue
undefined
collectTouchedBlocks :: RefinementInterface h => Vector State -> SplitM s h [(Block, RI.H3 h)]
collectTouchedBlocks :: forall s h. RefinementInterface h => Vector State -> SplitM s h [(Block, RI.H3 h)]
collectTouchedBlocks statesOfS = do
as <- ask
......@@ -142,7 +143,7 @@ collectTouchedBlocks statesOfS = do
unlessM (Partition.hasMarked (partition as) b) $ do
wCx <- readSTRef =<< VM.read (lastW as) (fromEdgeRef e)
let v0 = snd3 $ RI.update (functor as) [] wCx
let v0 = snd3 $ RI.update @h [] wCx
modifySTRef markedBlocks ((b, v0):)
whenM (null <$> VM.read (toSub as) x) $
......@@ -159,8 +160,8 @@ 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
forM (V.zip encodings (rotateVectorLeft sizes)) $ \(Morphism (h :: h) encoding, nextSize) ->
SomeAlgoState <$> initialize @h encoding nextSize
iforM_ :: Monad m => Vector a -> (Int -> a -> m b) -> m ()
iforM_ = flip V.imapM_
......@@ -179,7 +180,6 @@ rotateVectorLeft vec =
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
......@@ -192,8 +192,7 @@ 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
let nonSTEncoding = encoding state
nonSTPred = pred state
return $ NonSTAlgoState {..}
......
......@@ -45,12 +45,12 @@ instance RefinementInterface FixedProduct where
Nothing -> fail $ "Label" ++ T.unpack txt ++ " not defined"
Just labelIdx -> return (labelIdx, Edge morphIdx () morphIdx)
init :: FixedProduct -> H1 FixedProduct -> [Label FixedProduct] -> Weight FixedProduct
init _ tag _ = (tag, True) -- the edge points somewhere in the whole Y set => True
init :: H1 FixedProduct -> [Label FixedProduct] -> Weight FixedProduct
init tag _ = (tag, True) -- the edge points somewhere in the whole Y set => True
update :: FixedProduct -> [Label FixedProduct] -> Weight FixedProduct
update :: [Label FixedProduct] -> Weight FixedProduct
-> (Weight FixedProduct, H3 FixedProduct, Weight FixedProduct)
update _ edgesToS (tag, toC) =
update edgesToS (tag, toC) =
let
toS = not (null edgesToS)
three = case (toS, toC) of
......
......@@ -40,12 +40,12 @@ 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
init :: H1 Powerset -> [Label Powerset] -> Weight Powerset
init _ = (0, ) . length
update :: Powerset -> [Label Powerset] -> Weight Powerset
update :: [Label Powerset] -> Weight Powerset
-> (Weight Powerset, H3 Powerset, Weight Powerset)
update _ labels (toRest, toC) =
update labels (toRest, toC) =
let
toS = length labels
toCwithoutS = toC - toS
......
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE Rank2Types #-}
......@@ -29,5 +30,5 @@ class (Show h, Show (Label h), Show (H1 h), Show (Weight h), Ord (H1 h), Ord (H3
type H3 h :: *
parse :: h -> Vector Yaml.Value -> Yaml.Parser (Encoding (Label h) (H1 h))
init :: h -> H1 h -> [Label h] -> Weight h
update :: h -> [Label h] -> Weight h -> (Weight h, H3 h, Weight h)
init :: H1 h -> [Label h] -> Weight h
update :: [Label h] -> Weight h -> (Weight h, H3 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