wta: Document and clean up code

                     , megaparsec >= 7 && <8

                     , scientific >= 0.3 && <0.4

                     , containers >= 0.6 && <0.7

                     , prettyprinter >= 1.2.1

                     , prettyprinter-ansi-terminal >= 1.1.1.2

                     , prettyprinter-convert-ansi-wl-pprint

  ghc-options:         -Wall -Wno-name-shadowing

test-suite random-wta-tests

{-# LANGUAGE ScopedTypeVariables #-}

{-# LANGUAGE LambdaCase #-}

-- | Genator for random weighted tree automata.

module Generator

  ( genWTA

  , runGenerator

import           IndexedTransition              ( IndexedTransition )

import qualified IndexedTransition

data EdgeConfig = ZeroFrequency Probability | NumTransitions Int

-- | 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.

data GeneratorConfig m = GeneratorConfig

   { spec :: WTASpec m

   , zeroPolicy :: EdgeConfig

   , differentValues :: Maybe Int

   { spec :: WTASpec m -- ^ The automaton to generate.

   , zeroPolicy :: EdgeConfig -- ^ How many edges to generate.

   , differentValues :: Maybe Int -- ^ How many different monoid values to generate.

   }

type Generator m = ReaderT (GeneratorConfig m) IO

zeroFreq :: GeneratorConfig m -> Probability

zeroFreq GeneratorConfig { zeroPolicy = ZeroFrequency p } = p

zeroFreq _ = error "zeroFreq: unexpected out degree" -- TODO Ugly as hell

-- | Acutally run the generator with the given config.

runGenerator :: GeneratorConfig m -> Generator m a -> IO a

runGenerator config action = runReaderT action config

zeroFreq :: GeneratorConfig m -> Probability

zeroFreq GeneratorConfig { zeroPolicy = ZeroFrequency p } = p

zeroFreq _ = error "zeroFreq: unexpected out degree" -- Ugly as hell

genMonoidValue :: Generator m m

genMonoidValue = asks ((monoid . spec) &&& differentValues) >>= \case

  (Powerset, Nothing) -> liftIO randomIO

  n <- asks (numStates . spec)

  V.replicateM n genStateTransitions

-- TODO Implement (Random IndexedTransition)

uniqueTransitions :: Int -> IndexedTransition -> IO [IndexedTransition]

uniqueTransitions num idxMax@(IndexedTransition.Index max)

  | fromIntegral num < fromIntegral max * ((7 :: Integer) % 10) = uniqueTransitionsByGeneration

uniqueTransitionsByGeneration

  :: Int -> IndexedTransition -> IO [IndexedTransition]

uniqueTransitionsByGeneration num (IndexedTransition.Index max) = helper

uniqueTransitionsByGeneration num max = helper

  S.empty

  num

  where

    helper m 0 = return $ coerce (S.toList m)

    helper m 0 = return $ S.toList m

    helper m c = do

      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]

uniqueTransitionsByElimination num (IndexedTransition.Index max) = helper

uniqueTransitionsByElimination num max = helper

  whole

  num

  where

    helper free 0 = return $ coerce (S.toList (S.difference whole free))

    helper free 0 = return $ S.toList (S.difference whole free)

    helper free c = do

      idx <- randomRIO (0, S.size free - 1)

      let x = S.elemAt idx free

  numTransitions' <- if fromIntegral numTransitions > maxT

    then do

      let cap = IndexedTransition.fromIndexd maxT

      let cap = IndexedTransition.fromIndexdTransition maxT

      lift $ hPutStrLn

        stderr

        (  "warning: More transitions than possible requested. Capping at "

{-# LANGUAGE GADTs #-}

{-# LANGUAGE OverloadedStrings #-}

-- | Generator for the input format of the implementation of WTA bisimulation at

-- https://people.cs.umu.se/~johanna/bisimulation/

--

-- Note that to the best of my knowledge, only supports the powerset functor

-- with weights that are textually hardcoded as 1.0.

module Hoegberg (hoegbergWTA) where

import qualified Data.Vector                   as V

accepting1 :: Int -> Builder

accepting1 s = Build.decimal s <> " 1.0\n"

-- | Print a WTA. See the module level documentation for why this only accepts

-- "Bool" as monoid.

hoegbergWTA :: WTA Bool -> Builder

hoegbergWTA wta =

  declareState (spec wta) <> "\n" <> rules wta <> "%%%\n" <> accepting wta

{-# LANGUAGE DerivingStrategies #-}

{-# LANGUAGE GeneralizedNewtypeDeriving #-}

module IndexedTransition (IndexedTransition(..), maxIndex, fromIndex, index) where

-- | A bijection from transitions to integers.

--

-- This module provides functions to convert transitions to and from continuous

-- integer indices without loss of information (for a given WTA).

--

-- In particular, this allows for easy enumeration of all transitions and

-- enables choosing a small set of transitions from a potentially very large set

-- of /all/ possible transitions for a given WTA.

--

-- Transitions are ordered by

--

-- 1. Source state

-- 2. Arity

-- 3. Symbol with that arity

-- 4. Successor states in lexicographic order

--

-- Transition indices are then simply the indices into the list of all

-- transitions for the given WTA, ordered by the above criteria.

module IndexedTransition

  ( IndexedTransition(..)

  , maxIndex

  , fromIndex

  , index

  )

where

import           Data.Vector                    ( Vector )

import qualified Data.Vector                   as V

import           Data.Maybe

import           Data.Tuple

import           System.Random

import           Types

newtype IndexedTransition = Index { fromIndexd :: Integer }

  deriving newtype (Num, Eq, Ord)

-- | Index into the set of all transitions for a given WTA

newtype IndexedTransition = Index { fromIndexdTransition :: Integer }

  deriving newtype (Num, Eq, Ord, Random, Enum)

  deriving (Show)

-- | Return __one more than__ the maximum transition index for a given WTA.

maxIndex :: WTASpec m -> IndexedTransition

maxIndex spec =

  let n      = numStates spec

      (t, _) = transitionsPerState spec

  in  Index (fromIntegral n * t)

-- | Convert the given index to its corresponding transition.

fromIndex :: WTASpec m -> IndexedTransition -> (State, Transition ())

fromIndex spec (Index i) =

  let n     = numStates spec

                              }

  in  (State (fromIntegral state), trans)

-- | Convert the given transition to its corresponding index.

index :: WTASpec m1 -> State -> Transition m2 -> IndexedTransition

index spec (State state) trans =

  let (t, symbolSums) = transitionsPerState spec

-- Helpers

-- | Convert a given summand number to its arity

summandArity :: WTASpec m -> Int -> Int

summandArity spec summand = V.findIndices (/= 0) (numSymbols spec) V.! summand

-- | Convert a given arity to its summand index

aritySummand :: WTASpec m -> Int -> Int

aritySummand spec arity =

  let arities = numSymbols spec

  in  V.length (V.filter (/= 0) (V.take arity arities))

-- | Return the maximum number of transitions per state for this WTA as well as

-- a vector that contains at index @i@ the maximum number of transitions per

-- state with arity @i@ or less.

--

-- Therefore,

--

-- @

--  fst (transitionsPerState w) == last (snd (transitionsPerState w))

-- @

transitionsPerState :: WTASpec m -> (Integer, Vector Integer)

transitionsPerState spec =

  let n :: Integer = fromIntegral $ numStates spec

import           System.IO

import           System.Exit

import           Control.Applicative

import           Data.Text.Prettyprint.Doc

import           Data.Text.Prettyprint.Doc.Util

import           Data.Text.Prettyprint.Doc.Render.Terminal

import           Data.Text.Prettyprint.Convert.AnsiWlPprint

import           Types

import           Generator

          (  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"

               (  "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"

               )

    <*> parseZeroFreq

          )

    <*> parseEdgeConfig

    <*> Options.optional

          (Options.option Options.auto (Options.long "random-state"))

    <*> Options.optional

            (  Options.long "different-values"

            <> Options.metavar "NUM"

            <> Options.help

                 "Maximal number of differnt monoid values to generate"

                 ("Maximal number of differnt monoid values to generate."

                 <> "This is useful to limit the number of blocks in the initial partition."

                 )

            )

          )

    <*> Options.switch

          (Options.long "hoegberg" <> Options.help

            ("Generate output in format suiteable for Johanna Högbergs Java implementation."

            <> " See https://people.cs.umu.se/~johanna/bisimulation/"

            )

          )

    <*> Options.switch (Options.long "hoegberg" <> Options.help "Generate output in format suiteable for Hoegbergs Java implementation.")

parseZeroFreq :: Options.Parser EdgeConfig

parseZeroFreq =

parseEdgeConfig :: Options.Parser EdgeConfig

parseEdgeConfig =

  (ZeroFrequency <$> Options.option

      (Options.eitherReader readProbability)

      (  Options.long "zero-frequency"

    <|> (NumTransitions <$> Options.option

          Options.auto

          (Options.long "transitions" <> Options.metavar "NUM" <> Options.help

            "Number of transitions to generate. They will be distributed randomly over states."

            (  "Number of transitions to generate."

            <> "They will be distributed randomly over states."

            )

          )

        )

                            , numSymbols = optSymbols opts

                            }

example :: Doc AnsiStyle

example =

  "Example:"

    <> line

    <> line

    <> "    random-wta --monoid Z,max --states 3 --symbols 1,2,3"

    <> line

    <> line

    <> reflow "This generates a WTA with three states for the functor"

    <> softline

    <> "Z×X^(1 + 2×X + 3×X^2)"

    <> softline

    <> reflow "with roughly 30% of all possible edges, chosen at random."

    <> softline

    <> reflow "To control the number of edges, use --zero-frequency"

    <> softline

    <> reflow "or --transitions."

main :: IO ()

main = do

  let optSpec =

        Options.info (parseOpts Options.<**> Options.helper) Options.fullDesc

  let optSpec = Options.info

        (parseOpts Options.<**> Options.helper)

        (  Options.fullDesc

        <> Options.header "Generator for random weighted tree automata"

        <> Options.footerDoc (Just (toAnsiWlPprint example))

        )

  opts <- Options.execParser optSpec

  case optMonoid opts of

      genWTA

    putStrLn $ "# Random state for this automaton: '" <> show randGen <> "'"

    case monoid spec of

      Powerset | optHoegberg opts -> T.putStr (Build.toLazyText (hoegbergWTA wta))

      Powerset | optHoegberg opts ->

        T.putStr (Build.toLazyText (hoegbergWTA wta))

      _ | optHoegberg opts ->

        hPutStrLn stderr "error: Hoegberg output only supports powerset"

      _ -> T.putStr (Build.toLazyText (buildWTA wta))