Powerset.hs 2.14 KB
Newer Older
1
{-# LANGUAGE DeriveFunctor #-}
2
{-# LANGUAGE InstanceSigs #-}
Hans-Peter Deifel's avatar
Hans-Peter Deifel committed
3
4
5
6
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}

7
module Data.Functors.Powerset (Powerset(..), powerset, Powerset') where
Hans-Peter Deifel's avatar
Hans-Peter Deifel committed
8
9
10
11
12
13
14

import           Data.Vector (Vector)
import qualified Data.Vector as V
import qualified Data.Yaml as Yaml

import           Data.RefinementInterface
import qualified Data.MorphismEncoding as Encoding
15
import           Text.Parser.Functor
16
import           Text.Parser.FunctorNew
17
import qualified Text.Parser.Lexer as L
Hans-Peter Deifel's avatar
Hans-Peter Deifel committed
18

19
20
21
-- New interface

data Powerset' a = Powerset' a
22
23
24
25
26
  deriving (Functor)

instance ParseFunctor Powerset' where
  precedence = 5
  parseFunctor = Prefix' (L.symbol "P" >> pure Powerset')
27
28
29

-- Old interface

Hans-Peter Deifel's avatar
Hans-Peter Deifel committed
30
31
32
data Powerset = Powerset
  deriving (Show)

33
34
35
powerset :: FunctorParser Powerset
powerset = Prefix (L.symbol "P" >> pure Powerset)

Hans-Peter Deifel's avatar
Hans-Peter Deifel committed
36
instance RefinementInterface Powerset where
37
  -- | No edge labels
Hans-Peter Deifel's avatar
Hans-Peter Deifel committed
38
  type Label Powerset = ()
39
  -- | Tuple of (|edgesToC\S|, |edgesToS|)
Hans-Peter Deifel's avatar
Hans-Peter Deifel committed
40
  type Weight Powerset = (Int, Int)
41
  -- | Does this state have at least one successor?
Hans-Peter Deifel's avatar
Hans-Peter Deifel committed
42
  type H1 Powerset = Bool
43
44
45
46
  -- | Tuple of:
  --    - do we have edges to the rest?
  --    - do we have edges to C\S?
  --    - do we have edges to S?
Hans-Peter Deifel's avatar
Hans-Peter Deifel committed
47
48
  type H3 Powerset = (Bool, Bool, Bool)

49
  parse _ arr = do
50
    successors <- V.imapM parseNode arr
Hans-Peter Deifel's avatar
Hans-Peter Deifel committed
51

52
53
    let structure = V.map (not . V.null . snd) successors
        edges = V.concatMap (\(from, succs) -> fmap (Encoding.Edge from ()) succs) successors
Hans-Peter Deifel's avatar
Hans-Peter Deifel committed
54
55
56
57
58
59
60

    return $ Encoding.new structure edges

    where
      parseNode :: Int -> Yaml.Value -> Yaml.Parser (Int, Vector Int)
      parseNode nodeIdx value = (nodeIdx,) <$> Yaml.parseJSON value

61
62
  init :: H1 Powerset -> [Label Powerset] -> Weight Powerset
  init _ = (0, ) . length
63

64
  update :: [Label Powerset] -> Weight Powerset
65
         -> (Weight Powerset, H3 Powerset, Weight Powerset)
66
  update labels (toRest, toC) =
67
68
69
70
71
72
73
74
    let
      toS = length labels
      toCwithoutS = toC - toS
      weightToS = (toRest + toCwithoutS, toS)
      h3 = (toRest > 0, toCwithoutS > 0, toS > 0)
      weightToCwithoutS = (toRest + toS, toCwithoutS)
    in
      (weightToS, h3, weightToCwithoutS)