Commit fcf35573 authored by Hans-Peter Deifel's avatar Hans-Peter Deifel 🐢

Implement random WTA generator

parent b3c8c9e9
......@@ -282,3 +282,23 @@ executable random-dfa
, random
, text
, optparse-applicative
executable random-wta
hs-source-dirs: src/random-wta
main-is: Main.hs
other-modules: Types
, Generator
, Output
default-language: Haskell2010
default-extensions: OverloadedStrings
, LambdaCase
, MultiParamTypeClasses
, FlexibleInstances
, FunctionalDependencies
build-depends: base >= 4.11
, optparse-applicative
, vector
, text
, random >= 1.1 && <1.2
, mtl >= 2.2 && <2.3
, megaparsec >= 7
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE LambdaCase #-}
module Generator (genWTA, runGenerator, GeneratorConfig(..)) where
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
import Types hiding (spec)
data GeneratorConfig m = GeneratorConfig
{ spec :: WTASpec m
, zeroFreq :: Double
}
type Generator m = ReaderT (GeneratorConfig m) IO
runGenerator :: GeneratorConfig m -> Generator m a -> IO a
runGenerator config action = runReaderT action config
genMonoidValue :: Generator m m
genMonoidValue = asks (monoid . spec) >>= \case
Powerset -> liftIO $ randomIO
OrWord -> liftIO $ randomIO
MaxInt -> liftIO $ randomIO
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
decideZero = do
freq <- asks zeroFreq
randomValue :: Double <- liftIO (randomRIO (0.0, 1.0))
return $ randomValue < freq
-- 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)
fmap (V.fromList . catMaybes) $ traverse
(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)
fold <$> (traverse genForArity (V.findIndices (/= 0) arities))
genTransitions :: Generator m (Vector (Vector (Transition m)))
genTransitions = do
n <- asks (numStates . spec)
V.replicateM n genStateTransitions
genWTA :: Generator m (WTA m)
genWTA = WTA <$> asks spec <*> genStates <*> genTransitions
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ExistentialQuantification #-}
module Main (main) where
import Data.Vector ( Vector )
import qualified Data.Vector as V
import qualified Data.Text.Lazy.IO as T
import Data.Text ( Text )
import qualified Data.Text.Lazy.Builder as Build
import qualified Options.Applicative as Options
import qualified Text.Megaparsec as Mega
import qualified Text.Megaparsec.Char as Mega
import qualified Text.Megaparsec.Char.Lexer as Mega
import Data.Void
import System.Random
import System.IO
import Types
import Generator
import Output
data SomeMonoid = forall m. SomeMonoid (MonoidType m)
data Opts = Opts
{ optMonoid :: SomeMonoid
, optStates :: Int
, optSymbols :: SymbolSpec
, optZeroFrequency :: Double
, optRandomState :: Maybe StdGen
}
readMonoid :: Options.ReadM SomeMonoid
readMonoid = Options.eitherReader $ \case
"Z,max" -> Right (SomeMonoid MaxInt)
"N,or" -> Right (SomeMonoid OrWord)
"powerset" -> Right (SomeMonoid Powerset)
_ ->
Left
$ "Unknown monoid type. Valid values are '"
<> "Z,max"
<> "', '"
<> "N,or"
<> "' and '"
<> "powerset"
<> "'"
readSymbols :: Options.ReadM SymbolSpec
readSymbols = Options.maybeReader (Mega.parseMaybe parser)
where
parser :: Mega.Parsec Void String (Vector Int)
parser = V.fromList <$> Mega.decimal `Mega.sepBy` (Mega.string ",")
parseOpts :: Options.Parser Opts
parseOpts =
Opts
<$> Options.option
readMonoid
(Options.long "monoid" <> Options.metavar "MONOID" <> Options.help
( "Monoid to use. Valid valies are '"
<> "Z,max"
<> "', '"
<> "N,or"
<> "' and '"
<> "powerset"
<> "'"
)
)
<*> Options.option
Options.auto
(Options.long "states" <> Options.metavar "NUM" <> Options.help
"Number of states to generate"
)
<*> Options.option
readSymbols
( Options.long "symbols"
<> Options.metavar "NUM,NUM,..."
<> Options.help
"Comma separated list of symbols per arity. E.g. 2,0,1 means two symbols with arity 0, non with arity 1 and one with arity two"
)
<*> Options.option
Options.auto
( Options.long "zero-frequency"
<> Options.showDefault
<> Options.value 0.7
<> Options.metavar "FREQ"
)
<*> Options.optional
(Options.option Options.auto (Options.long "random-state"))
withSpec :: Opts -> (forall m . WTASpec m -> x) -> x
withSpec opts f = case optMonoid opts of
SomeMonoid m -> f WTASpec { monoid = m
, numStates = optStates opts
, numSymbols = optSymbols opts
}
main :: IO ()
main = do
let optSpec =
Options.info (parseOpts Options.<**> Options.helper) (Options.fullDesc)
opts <- Options.execParser optSpec
case optRandomState opts of
Nothing -> return ()
Just x -> setStdGen x
withSpec opts $ \spec -> do
getStdGen >>= hPutStrLn stderr . ("Random state: " <>) . show
wta <- runGenerator (GeneratorConfig spec (optZeroFrequency opts)) genWTA
T.putStr (Build.toLazyText (buildWTA wta))
{-# LANGUAGE GADTs #-}
module Output (buildWTA) where
import qualified Data.Vector as V
import Data.Vector ( Vector )
import Data.Text.Lazy.Builder ( Builder )
import qualified Data.Text.Lazy.Builder as Build
import qualified Data.Text.Lazy.Builder.Int as Build
import Data.Foldable
import Data.List
import Data.String
import Data.Maybe
import Types
wtaFunctor :: (WTASpec m) -> Builder
wtaFunctor wta = monoidForStates (monoid wta) <> " × " <> withMonoidForWeights
(monoid wta)
(polynomial (numSymbols wta))
monoidForStates :: (MonoidType m) -> Builder
monoidForStates MaxInt = "Z"
monoidForStates OrWord = "N"
monoidForStates Powerset = "2"
withMonoidForWeights :: (MonoidType m) -> Builder -> Builder
withMonoidForWeights MaxInt inner = "(Z, max)^(" <> inner <> ")"
withMonoidForWeights OrWord inner = "(N, or)^(" <> inner <> ")"
withMonoidForWeights Powerset inner = "P(" <> inner <> ")"
polynomial :: SymbolSpec -> Builder
polynomial = sepList " + " id . catMaybes . toList . V.imap summand
where
summand :: Int -> Int -> Maybe Builder
summand arity 0 = Nothing
summand 0 syms = Just (Build.decimal syms)
summand arity syms = Just $
fold (intersperse "×" (Build.decimal syms : replicate arity "X"))
data ValueUse = Weight | StateVal
buildValue :: ValueUse -> MonoidType m -> m -> Builder
buildValue _ MaxInt i = Build.decimal i
buildValue Weight OrWord w = "0x" <> Build.hexadecimal w
buildValue StateVal OrWord w = Build.decimal w
buildValue _ Powerset b = case b of
False -> "0"
True -> "1"
buildTransition :: MonoidType m -> Transition m -> Builder
buildTransition mon trans =
"inj"
<> Build.decimal (summand trans)
<> " "
<> buildSuccs (successors trans)
<> buildWeight mon (weight trans)
where
buildSuccs succs = if V.null succs
then Build.decimal (symbol trans)
else "(" <> Build.decimal (symbol trans) <> ", " <> (sepList ", " buildStateName (successors trans)) <> ")"
buildWeight :: MonoidType m -> m -> Builder
buildWeight Powerset _ = ""
buildWeight mon val = ": " <> buildValue Weight mon val
buildTransitions :: MonoidType m -> Vector (Transition m) -> Builder
buildTransitions mon trans =
"{ " <> sepList ", " (buildTransition mon) trans <> " }"
buildState :: WTASpec m -> (Int, m, Vector (Transition m)) -> Builder
buildState wtaSpec (state, value, trans) =
buildStateName (State state)
<> ": ("
<> buildValue StateVal (monoid wtaSpec) value
<> ", "
<> buildTransitions (monoid wtaSpec) trans
<> ")\n"
buildStateName :: State -> Builder
buildStateName = ("s" <>) . Build.decimal
buildStates :: WTA m -> Builder
buildStates wta = foldMap
(buildState (spec wta))
(V.zip3 (V.fromList indices) (stateValue wta) (stateTransitions wta))
where indices = [0 .. V.length (stateValue wta) - 1]
buildWTA :: WTA m -> Builder
buildWTA a = (wtaFunctor (spec a)) <> "\n" <> buildStates a
-- helpers
sepList :: (Foldable f, Monoid m, IsString m) => m -> (a -> m) -> f a -> m
sepList m action = fold . intersperse m . map action . toList
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Types
( MonoidType(..)
, WTASpec(..)
, Transition(..)
, WTA(..)
, SymbolSpec
, State(..)
)
where
import Data.Vector ( Vector )
-- Powerset is not the monoid, it's ({True,False}, or)^X
data MonoidType m where
MaxInt ::MonoidType Int
OrWord ::MonoidType Word
Powerset ::MonoidType Bool
-- | For each arity, the number of symbols
type SymbolSpec = Vector Int
data WTASpec m = WTASpec
{ monoid :: MonoidType m
, numStates :: Int
, numSymbols :: SymbolSpec
}
newtype State = State { fromState :: Int}
deriving (Num,Show,Eq,Integral,Enum,Real,Ord)
data Transition m = Transition
{ weight :: m
, summand :: Int
, symbol :: Int
, successors :: Vector State
} deriving (Show)
data WTA m = WTA
{ spec :: WTASpec m
, stateValue :: Vector m
, stateTransitions :: Vector (Vector (Transition m))
}
Markdown is supported
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