Generator.hs 6.11 KB
Newer Older
1 2 3 4
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE LambdaCase #-}

5
-- | Genator for random weighted tree automata.
6 7 8 9 10
module Generator
  ( genWTA
  , runGenerator
  , GeneratorConfig(..)
  , EdgeConfig(..)
11
  , uniqueTransitions
12 13
  )
where
14 15 16 17 18 19 20 21

import           Data.Vector                    ( Vector )
import qualified Data.Vector                   as V
import           System.Random
import           Control.Monad.Reader
import           Data.Coerce
import           Data.Maybe
import           Data.Foldable
Hans-Peter Deifel's avatar
Hans-Peter Deifel committed
22
import           Control.Arrow                  ( (&&&) )
23 24
import qualified Data.Map.Strict               as M
import qualified Data.Set                      as S
25
import           Data.Ratio
26
import           System.IO
27

Hans-Peter Deifel's avatar
Hans-Peter Deifel committed
28
import           Types                   hiding ( spec )
29
import           Probability
30
import           IndexedTransition              ( IndexedTransition )
31 32
import qualified IndexedTransition

33

34 35 36 37 38 39 40 41 42
-- | Decides how many non-zero transitions are generated.
data EdgeConfig
     -- | Generate zero transitions with a given probability.
     = ZeroFrequency Probability
     -- | Generate a fixed number of non-zero transitions.
     | NumTransitions Int


-- Configuration for the automaton generator.
43
data GeneratorConfig m = GeneratorConfig
44 45 46
   { spec :: WTASpec m -- ^ The automaton to generate.
   , zeroPolicy :: EdgeConfig -- ^ How many edges to generate.
   , differentValues :: Maybe Int -- ^ How many different monoid values to generate.
47 48
   }

49

50 51
type Generator m = ReaderT (GeneratorConfig m) IO

52

53
-- | Acutally run the generator with the given config.
54 55 56
runGenerator :: GeneratorConfig m -> Generator m a -> IO a
runGenerator config action = runReaderT action config

57 58 59 60 61

zeroFreq :: GeneratorConfig m -> Probability
zeroFreq GeneratorConfig { zeroPolicy = ZeroFrequency p } = p
zeroFreq _ = error "zeroFreq: unexpected out degree" -- Ugly as hell

62
genMonoidValue :: Generator m m
63
genMonoidValue = asks ((monoid . spec) &&& differentValues) >>= \case
Hans-Peter Deifel's avatar
Hans-Peter Deifel committed
64
  (Powerset, Nothing) -> liftIO randomIO
Hans-Peter Deifel's avatar
Hans-Peter Deifel committed
65 66 67 68 69 70 71
  (Powerset, Just 1 ) -> return True
  (Powerset, Just 2 ) -> liftIO randomIO
  (Powerset, _      ) -> error "differentValues >2 not supported for powerset"
  (OrWord  , Nothing) -> liftIO randomIO
  (OrWord  , Just x ) -> liftIO $ randomRIO (1, fromIntegral x)
  (MaxInt  , Nothing) -> liftIO randomIO
  (MaxInt  , Just x ) -> liftIO $ randomRIO (1, x)
72 73 74 75 76 77 78 79 80 81 82 83

genStates :: Generator m (Vector m)
genStates = do
  n <- asks (numStates . spec)
  V.replicateM n genMonoidValue

aritySummand :: Int -> Generator m Int
aritySummand arity = do
  arities <- asks (numSymbols . spec)
  return $ V.length (V.filter (/= 0) (V.take arity arities))

decideZero :: Generator m Bool
Hans-Peter Deifel's avatar
Hans-Peter Deifel committed
84
decideZero = asks zeroFreq >>= liftIO . decide
85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100

-- Generates Nothing, when it decides that a zero value would be in order
genTransition :: Int -> Int -> [State] -> Generator m (Maybe (Transition m))
genTransition arity symbol succs = decideZero >>= \case
  True -> return Nothing
  False ->
    fmap Just
      $   Transition
      <$> genMonoidValue
      <*> aritySummand arity
      <*> return symbol
      <*> return (V.fromList succs)

genForSymbol :: Int -> Int -> Generator m (Vector (Transition m))
genForSymbol arity symbol = do
  states <- asks (numStates . spec)
Hans-Peter Deifel's avatar
Hans-Peter Deifel committed
101
  V.fromList . catMaybes <$> traverse
102 103 104 105 106 107 108 109 110 111 112
    (genTransition arity symbol)
    (replicateM arity (coerce [0 .. states - 1]))

genForArity :: Int -> Generator m (Vector (Transition m))
genForArity arity = do
  n <- asks ((V.! arity) . numSymbols . spec)
  fold <$> V.generateM n (genForSymbol arity)

genStateTransitions :: Generator m (Vector (Transition m))
genStateTransitions = do
  arities <- asks (numSymbols . spec)
Hans-Peter Deifel's avatar
Hans-Peter Deifel committed
113
  fold <$> traverse genForArity (V.findIndices (/= 0) arities)
114

115 116
genTransitionsZeroFreq :: Generator m (Vector (Vector (Transition m)))
genTransitionsZeroFreq = do
117 118 119
  n <- asks (numStates . spec)
  V.replicateM n genStateTransitions

120
uniqueTransitions :: Int -> IndexedTransition -> IO [IndexedTransition]
121
uniqueTransitions num idxMax@(IndexedTransition.Index max)
Hans-Peter Deifel's avatar
Hans-Peter Deifel committed
122
  | fromIntegral num < fromIntegral max * ((7 :: Integer) % 10) = uniqueTransitionsByGeneration
123 124 125 126 127 128
    num
    idxMax
  | otherwise = uniqueTransitionsByElimination num idxMax

uniqueTransitionsByGeneration
  :: Int -> IndexedTransition -> IO [IndexedTransition]
129
uniqueTransitionsByGeneration num max = helper
130 131
  S.empty
  num
132
  where
133
    helper m 0 = return $ S.toList m
134
    helper m c = do
135 136 137 138 139
      x <- randomRIO (0, max - 1)
      if x `S.member` m then helper m c else helper (S.insert x m) (c - 1)

uniqueTransitionsByElimination
  :: Int -> IndexedTransition -> IO [IndexedTransition]
140
uniqueTransitionsByElimination num max = helper
141 142
  whole
  num
143
  where
144
    helper free 0 = return $ S.toList (S.difference whole free)
145 146 147
    helper free c = do
      idx <- randomRIO (0, S.size free - 1)
      let x = S.elemAt idx free
148
      helper (S.delete x free) (c - 1)
149

150
    whole = S.fromList [0 .. max - 1]
151

152 153
genTransitionsNumTrans :: Int -> Generator m (Vector (Vector (Transition m)))
genTransitionsNumTrans numTransitions = do
154
  wtaSpec <- asks spec
155
  let n    = numStates wtaSpec
156
      maxT = IndexedTransition.maxIndex wtaSpec
157

Hans-Peter Deifel's avatar
Hans-Peter Deifel committed
158
  numTransitions' <- if fromIntegral numTransitions > maxT
159
    then do
160
      let cap = IndexedTransition.fromIndexdTransition maxT
161 162 163 164 165
      lift $ hPutStrLn
        stderr
        (  "warning: More transitions than possible requested. Capping at "
        <> show cap
        )
166
      return (fromIntegral cap)
Hans-Peter Deifel's avatar
Hans-Peter Deifel committed
167
    else return numTransitions
168

169 170 171 172 173 174 175
  transitions <-
    lift
    $   map (IndexedTransition.fromIndex wtaSpec)
    <$> uniqueTransitions numTransitions' maxT
  weightedTransitions <- (traverse . traverse . traverse)
    (const genMonoidValue)
    transitions
176

177 178 179
  let byState = foldl' (\m (State s, t) -> M.insertWith (++) s [t] m)
                       M.empty
                       weightedTransitions
180 181

  let stateVec = V.generate n $ \i -> case M.lookup i byState of
182
        Nothing  -> V.empty
183 184 185 186
        Just lst -> V.fromList lst

  return stateVec

187
genWTA :: Generator m (WTA m)
188
genWTA = asks zeroPolicy >>= \case
189
  NumTransitions d ->
Hans-Peter Deifel's avatar
Hans-Peter Deifel committed
190
    WTA <$> asks spec <*> genStates <*> genTransitionsNumTrans d
191
  ZeroFrequency _ -> WTA <$> asks spec <*> genStates <*> genTransitionsZeroFreq