haal 0.4.1.0 → 0.5.0.0
raw patch · 11 files changed
+367/−20 lines, 11 filesdep +deepseqdep +tastydep +tasty-benchdep ~basedep ~containersdep ~mtlPVP ok
version bump matches the API change (PVP)
Dependencies added: deepseq, tasty, tasty-bench
Dependency ranges changed: base, containers, mtl, random
API changes (from Hackage documentation)
- Haal.Experiment: experiment :: forall sul (m :: Type -> Type) aut s learner oracle i o. (SUL sul m, Automaton aut s, Learner learner aut s, EquivalenceOracle oracle, FiniteOrd i, FiniteOrd s, FiniteEq o) => learner i o -> oracle -> ExperimentT (sul i o) m (aut s i o, Statistics aut s i o)
+ Haal.Experiment: experiment :: forall sul (m :: Type -> Type) aut s learner oracle i o. (SUL sul m, Automaton aut s, Learner learner aut s, EquivalenceOracle oracle, FiniteOrd i, FiniteOrd s, FiniteOrd o) => learner i o -> oracle -> ExperimentT (sul i o) m (aut s i o, Statistics aut s i o)
- Haal.Experiment: learn :: forall sul (m :: Type -> Type) i o. (Learner l aut s, SUL sul m, Automaton aut s, FiniteOrd i, FiniteOrd s, FiniteEq o) => l i o -> ExperimentT (sul i o) m (l i o, aut s i o)
+ Haal.Experiment: learn :: forall sul (m :: Type -> Type) i o. (Learner l aut s, SUL sul m, Automaton aut s, FiniteOrd i, FiniteOrd s, FiniteOrd o) => l i o -> ExperimentT (sul i o) m (l i o, aut s i o)
- Haal.Learning.LMstar: lmstar :: forall sul i o (m :: Type -> Type). (SUL sul m, FiniteOrd i, Eq o, Monad m) => LMstar i o -> ExperimentT (sul i o) m (LMstar i o, MealyAutomaton StateID i o)
+ Haal.Learning.LMstar: lmstar :: forall sul i o (m :: Type -> Type). (SUL sul m, FiniteOrd i, Ord o, Monad m) => LMstar i o -> ExperimentT (sul i o) m (LMstar i o, MealyAutomaton StateID i o)
Files
- CHANGELOG.md +26/−0
- README.md +12/−4
- bench/Bench/BlackBox.hs +55/−0
- bench/Bench/Dot.hs +60/−0
- bench/Bench/EndToEnd.hs +70/−0
- bench/Bench/EquivalenceOracle.hs +79/−0
- bench/Main.hs +16/−0
- haal.cabal +27/−2
- src/Haal/Dot.hs +6/−7
- src/Haal/Experiment.hs +2/−2
- src/Haal/Learning/LMstar.hs +14/−5
CHANGELOG.md view
@@ -8,6 +8,32 @@ ## Unreleased +## 0.5.0.0 - 2026-04-22++### Fixed+- `Haal.Learning.LMstar.equivalenceClasses` now iterates over `Sm` only,+ matching Definition 2 of Shahbaz & Groz, "Inferring Mealy Machines".+ Previously it iterated over `Sm ∪ Sm·I`, which could pick a representative+ from `Sm·I` whose `rep++[i]` was not in the observation table, causing+ `makeHypothesis` to fail on many real protocol models (DTLS, medium MQTT)+ with `"invariant violation — makeHypothesis failed on closed consistent table"`.++### Changed (breaking)+- `Haal.Learning.LMstar.otIsConsistent` tightens its output constraint+ from `Eq o` to `Ord o` to support Map-based row grouping.++### Changed+- `Haal.Learning.LMstar.otIsConsistent` groups prefixes by row signature+ before pairwise comparison, reducing the worst-case pair enumeration.+- `Haal.Dot.parseDot` uses `Set.fromList` instead of `nub` for deduplication+ (O(n²) → O(n log n)).++### Added+- `tasty-bench`-based benchmark suite in `bench/` covering BlackBox+ operations, W-method / Wp-method test-suite generation, DOT+ serialize/parse/roundtrip, and end-to-end learning experiments.+ Run with `stack bench haal`.+ ## 0.4.1.0 - 2026-03-21 ### Added
README.md view
@@ -74,16 +74,24 @@ ## Installing -The project is still in its early stages and has not yet been published. For now, you can clone the repository, build, and install it locally using:+The project is available on Hackage. You can check the available version with the command: ```bash-stack install+stack list haal # cabal list haal ``` -Moreover, I try to add haddock comments as much as possible. Therefore, documentation can be built using:+Given that the project is still in its early stages, you probably always want to see the latest version listed. +You can clone the repo and build the library yourself with:++```bash +stack build haal:lib+```++Moreover, given that the library makes use of LiquidHaskell annotations from v0.4.0.1 onwards, you can build with verification turned on:+ ```bash-stack haddock+stack build haal:lib --flag haal:liquid ``` ## Example
+ bench/Bench/BlackBox.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE DeriveGeneric #-}++module Bench.BlackBox (blackBoxBenchmarks) where++import Control.DeepSeq (NFData)+import GHC.Generics (Generic)+import qualified Data.Map as Map+import qualified Data.Set as Set+import Test.Tasty.Bench (Benchmark, bench, bgroup, nf)++import Haal.Automaton.MealyAutomaton (MealyAutomaton, mkMealyAutomaton)+import Haal.BlackBox (accessSequences, distinguish, globalCharacterizingSet, localCharacterizingSet, reachable)++-- | Input alphabet for benchmark automata.+data In = IA | IB | IC | ID deriving (Show, Eq, Ord, Enum, Bounded, Generic)+instance NFData In++-- | Output alphabet for benchmark automata.+data Out = OX | OY | OZ | OW deriving (Show, Eq, Ord, Enum, Bounded, Generic)+instance NFData Out++-- | States for benchmark automata.+data St = S0 | S1 | S2 | S3 | S4 | S5 | S6 | S7 deriving (Show, Eq, Ord, Enum, Bounded, Generic)+instance NFData St++-- | A deterministic 8-state Mealy automaton with fixed transitions.+benchAutomaton :: MealyAutomaton St In Out+benchAutomaton = mkMealyAutomaton delta lambda (Set.fromList [S0 .. S7]) S0+ where+ transMap :: Map.Map (St, In) (St, Out)+ transMap = Map.fromList+ [ ((S0, IA), (S1, OX)), ((S0, IB), (S2, OY)), ((S0, IC), (S3, OZ)), ((S0, ID), (S4, OW))+ , ((S1, IA), (S5, OY)), ((S1, IB), (S0, OX)), ((S1, IC), (S6, OW)), ((S1, ID), (S7, OZ))+ , ((S2, IA), (S3, OZ)), ((S2, IB), (S4, OX)), ((S2, IC), (S7, OY)), ((S2, ID), (S1, OW))+ , ((S3, IA), (S6, OW)), ((S3, IB), (S5, OZ)), ((S3, IC), (S0, OX)), ((S3, ID), (S2, OY))+ , ((S4, IA), (S7, OX)), ((S4, IB), (S6, OW)), ((S4, IC), (S1, OY)), ((S4, ID), (S0, OZ))+ , ((S5, IA), (S2, OZ)), ((S5, IB), (S7, OY)), ((S5, IC), (S4, OX)), ((S5, ID), (S3, OW))+ , ((S6, IA), (S4, OY)), ((S6, IB), (S1, OX)), ((S6, IC), (S5, OZ)), ((S6, ID), (S0, OW))+ , ((S7, IA), (S0, OW)), ((S7, IB), (S3, OZ)), ((S7, IC), (S2, OY)), ((S7, ID), (S6, OX))+ ]++ delta s i = fst (transMap Map.! (s, i))+ lambda s i = snd (transMap Map.! (s, i))++blackBoxBenchmarks :: Benchmark+blackBoxBenchmarks = bgroup "BlackBox"+ [ bgroup "8-state"+ [ bench "reachable" $ nf reachable benchAutomaton+ , bench "accessSequences" $ nf accessSequences benchAutomaton+ , bench "globalCharacterizingSet" $ nf globalCharacterizingSet benchAutomaton+ , bench "localCharacterizingSet/S0" $ nf (localCharacterizingSet benchAutomaton) S0+ , bench "distinguish/S0-S1" $ nf (distinguish benchAutomaton S0) S1+ , bench "distinguish/S0-S7" $ nf (distinguish benchAutomaton S0) S7+ ]+ ]
+ bench/Bench/Dot.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE DeriveGeneric #-}+{-# OPTIONS_GHC -Wno-orphans #-}++module Bench.Dot (dotBenchmarks) where++import Control.DeepSeq (NFData (rnf))+import GHC.Generics (Generic)+import qualified Data.Map as Map+import qualified Data.Set as Set+import Test.Tasty.Bench (Benchmark, bench, bgroup, nf)++import Haal.Automaton.MealyAutomaton (MealyAutomaton, mkMealyAutomaton)+import Haal.Dot (ParsedMealy (..), mealyToDot, parseDot)++-- | Input alphabet for benchmark automata.+data In = IA | IB | IC | ID deriving (Show, Eq, Ord, Enum, Bounded, Generic)+instance NFData In++-- | Output alphabet for benchmark automata.+data Out = OX | OY | OZ | OW deriving (Show, Eq, Ord, Enum, Bounded, Generic)+instance NFData Out++-- | States for benchmark automata.+data St = S0 | S1 | S2 | S3 | S4 | S5 | S6 | S7 deriving (Show, Eq, Ord, Enum, Bounded, Generic)+instance NFData St++instance NFData ParsedMealy where+ rnf (ParsedMealy a b c d e f) = rnf a `seq` rnf b `seq` rnf c `seq` rnf d `seq` rnf e `seq` rnf f++-- | A deterministic 8-state Mealy automaton with fixed transitions.+benchAutomaton :: MealyAutomaton St In Out+benchAutomaton = mkMealyAutomaton delta lambda (Set.fromList [S0 .. S7]) S0+ where+ transMap :: Map.Map (St, In) (St, Out)+ transMap = Map.fromList+ [ ((S0, IA), (S1, OX)), ((S0, IB), (S2, OY)), ((S0, IC), (S3, OZ)), ((S0, ID), (S4, OW))+ , ((S1, IA), (S5, OY)), ((S1, IB), (S0, OX)), ((S1, IC), (S6, OW)), ((S1, ID), (S7, OZ))+ , ((S2, IA), (S3, OZ)), ((S2, IB), (S4, OX)), ((S2, IC), (S7, OY)), ((S2, ID), (S1, OW))+ , ((S3, IA), (S6, OW)), ((S3, IB), (S5, OZ)), ((S3, IC), (S0, OX)), ((S3, ID), (S2, OY))+ , ((S4, IA), (S7, OX)), ((S4, IB), (S6, OW)), ((S4, IC), (S1, OY)), ((S4, ID), (S0, OZ))+ , ((S5, IA), (S2, OZ)), ((S5, IB), (S7, OY)), ((S5, IC), (S4, OX)), ((S5, ID), (S3, OW))+ , ((S6, IA), (S4, OY)), ((S6, IB), (S1, OX)), ((S6, IC), (S5, OZ)), ((S6, ID), (S0, OW))+ , ((S7, IA), (S0, OW)), ((S7, IB), (S3, OZ)), ((S7, IC), (S2, OY)), ((S7, ID), (S6, OX))+ ]++ delta s i = fst (transMap Map.! (s, i))+ lambda s i = snd (transMap Map.! (s, i))++-- | Pre-generated DOT string for parsing benchmarks.+benchDotString :: String+benchDotString = case mealyToDot benchAutomaton of+ Right s -> s+ Left err -> error ("benchDotString: " ++ err)++dotBenchmarks :: Benchmark+dotBenchmarks = bgroup "Dot"+ [ bench "mealyToDot/8-state" $ nf mealyToDot benchAutomaton+ , bench "parseDot/8-state" $ nf parseDot benchDotString+ , bench "roundtrip/8-state" $ nf (parseDot . either error id . mealyToDot) benchAutomaton+ ]
+ bench/Bench/EndToEnd.hs view
@@ -0,0 +1,70 @@+{-# LANGUAGE DeriveGeneric #-}++module Bench.EndToEnd (endToEndBenchmarks) where++import Control.DeepSeq (NFData)+import GHC.Generics (Generic)+import qualified Data.Map as Map+import qualified Data.Set as Set+import Test.Tasty.Bench (Benchmark, bench, bgroup, whnf)++import Haal.Automaton.MealyAutomaton (MealyAutomaton, mkMealyAutomaton)+import Haal.EquivalenceOracle.WMethod (WMethod, WMethodConfig (..), mkWMethod)+import Haal.EquivalenceOracle.WpMethod (WpMethod, WpMethodConfig (..), mkWpMethod)+import Haal.Experiment (experiment, runExperiment)+import Haal.Learning.LMstar (LMstarConfig (..), mkLMstar)++-- | Input alphabet for benchmark automata.+data In = IA | IB | IC | ID deriving (Show, Eq, Ord, Enum, Bounded, Generic)+instance NFData In++-- | Output alphabet for benchmark automata.+data Out = OX | OY | OZ | OW deriving (Show, Eq, Ord, Enum, Bounded, Generic)+instance NFData Out++-- | States for the SUL (target automaton).+data St = S0 | S1 | S2 | S3 | S4 | S5 | S6 | S7 deriving (Show, Eq, Ord, Enum, Bounded, Generic)+instance NFData St++-- | A deterministic 8-state Mealy automaton used as the SUL.+benchAutomaton :: MealyAutomaton St In Out+benchAutomaton = mkMealyAutomaton delta lambda (Set.fromList [S0 .. S7]) S0+ where+ transMap :: Map.Map (St, In) (St, Out)+ transMap = Map.fromList+ [ ((S0, IA), (S1, OX)), ((S0, IB), (S2, OY)), ((S0, IC), (S3, OZ)), ((S0, ID), (S4, OW))+ , ((S1, IA), (S5, OY)), ((S1, IB), (S0, OX)), ((S1, IC), (S6, OW)), ((S1, ID), (S7, OZ))+ , ((S2, IA), (S3, OZ)), ((S2, IB), (S4, OX)), ((S2, IC), (S7, OY)), ((S2, ID), (S1, OW))+ , ((S3, IA), (S6, OW)), ((S3, IB), (S5, OZ)), ((S3, IC), (S0, OX)), ((S3, ID), (S2, OY))+ , ((S4, IA), (S7, OX)), ((S4, IB), (S6, OW)), ((S4, IC), (S1, OY)), ((S4, ID), (S0, OZ))+ , ((S5, IA), (S2, OZ)), ((S5, IB), (S7, OY)), ((S5, IC), (S4, OX)), ((S5, ID), (S3, OW))+ , ((S6, IA), (S4, OY)), ((S6, IB), (S1, OX)), ((S6, IC), (S5, OZ)), ((S6, ID), (S0, OW))+ , ((S7, IA), (S0, OW)), ((S7, IB), (S3, OZ)), ((S7, IC), (S2, OY)), ((S7, ID), (S6, OX))+ ]++ delta s i = fst (transMap Map.! (s, i))+ lambda s i = snd (transMap Map.! (s, i))++wmethod :: Int -> WMethod+wmethod d = either error id (mkWMethod (WMethodConfig d))++wpmethod :: Int -> WpMethod+wpmethod d = either error id (mkWpMethod (WpMethodConfig d))++-- | Run a full learning experiment (init -> learn -> test -> refine -> converge).+-- Uses whnf since MealyAutomaton contains functions that cannot be NFData.+endToEndBenchmarks :: Benchmark+endToEndBenchmarks = bgroup "EndToEnd"+ [ bgroup "LMstar"+ [ bench "WMethod/depth=1" $+ whnf (runExperiment (experiment (mkLMstar Star) (wmethod 1))) benchAutomaton+ , bench "WpMethod/depth=1" $+ whnf (runExperiment (experiment (mkLMstar Star) (wpmethod 1))) benchAutomaton+ ]+ , bgroup "LMplus"+ [ bench "WMethod/depth=1" $+ whnf (runExperiment (experiment (mkLMstar Plus) (wmethod 1))) benchAutomaton+ , bench "WpMethod/depth=1" $+ whnf (runExperiment (experiment (mkLMstar Plus) (wpmethod 1))) benchAutomaton+ ]+ ]
+ bench/Bench/EquivalenceOracle.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE DeriveGeneric #-}++module Bench.EquivalenceOracle (equivalenceOracleBenchmarks) where++import Control.DeepSeq (NFData)+import GHC.Generics (Generic)+import qualified Data.Map as Map+import qualified Data.Set as Set+import Test.Tasty.Bench (Benchmark, bench, bgroup, nf)++import Haal.Automaton.MealyAutomaton (MealyAutomaton, mkMealyAutomaton)+import Haal.EquivalenceOracle.WMethod (WMethod, WMethodConfig (..), mkWMethod, wmethodSuiteSize)+import Haal.EquivalenceOracle.WpMethod (WpMethod, WpMethodConfig (..), mkWpMethod, wpmethodSuiteSize)+import Haal.Experiment (EquivalenceOracle (testSuite))++-- | Input alphabet for benchmark automata.+data In = IA | IB | IC | ID deriving (Show, Eq, Ord, Enum, Bounded, Generic)+instance NFData In++-- | Output alphabet for benchmark automata.+data Out = OX | OY | OZ | OW deriving (Show, Eq, Ord, Enum, Bounded, Generic)+instance NFData Out++-- | States for benchmark automata.+data St = S0 | S1 | S2 | S3 | S4 | S5 | S6 | S7 deriving (Show, Eq, Ord, Enum, Bounded, Generic)+instance NFData St++-- | A deterministic 8-state Mealy automaton with fixed transitions.+benchAutomaton :: MealyAutomaton St In Out+benchAutomaton = mkMealyAutomaton delta lambda (Set.fromList [S0 .. S7]) S0+ where+ transMap :: Map.Map (St, In) (St, Out)+ transMap = Map.fromList+ [ ((S0, IA), (S1, OX)), ((S0, IB), (S2, OY)), ((S0, IC), (S3, OZ)), ((S0, ID), (S4, OW))+ , ((S1, IA), (S5, OY)), ((S1, IB), (S0, OX)), ((S1, IC), (S6, OW)), ((S1, ID), (S7, OZ))+ , ((S2, IA), (S3, OZ)), ((S2, IB), (S4, OX)), ((S2, IC), (S7, OY)), ((S2, ID), (S1, OW))+ , ((S3, IA), (S6, OW)), ((S3, IB), (S5, OZ)), ((S3, IC), (S0, OX)), ((S3, ID), (S2, OY))+ , ((S4, IA), (S7, OX)), ((S4, IB), (S6, OW)), ((S4, IC), (S1, OY)), ((S4, ID), (S0, OZ))+ , ((S5, IA), (S2, OZ)), ((S5, IB), (S7, OY)), ((S5, IC), (S4, OX)), ((S5, ID), (S3, OW))+ , ((S6, IA), (S4, OY)), ((S6, IB), (S1, OX)), ((S6, IC), (S5, OZ)), ((S6, ID), (S0, OW))+ , ((S7, IA), (S0, OW)), ((S7, IB), (S3, OZ)), ((S7, IC), (S2, OY)), ((S7, ID), (S6, OX))+ ]++ delta s i = fst (transMap Map.! (s, i))+ lambda s i = snd (transMap Map.! (s, i))++wmethod :: Int -> WMethod+wmethod d = either error id (mkWMethod (WMethodConfig d))++wpmethod :: Int -> WpMethod+wpmethod d = either error id (mkWpMethod (WpMethodConfig d))++equivalenceOracleBenchmarks :: Benchmark+equivalenceOracleBenchmarks = bgroup "EquivalenceOracle"+ [ bgroup "WMethod"+ [ bgroup "testSuite"+ [ bench "depth=1" $ nf (\w -> snd (testSuite w benchAutomaton)) (wmethod 1)+ , bench "depth=2" $ nf (\w -> snd (testSuite w benchAutomaton)) (wmethod 2)+ , bench "depth=3" $ nf (\w -> snd (testSuite w benchAutomaton)) (wmethod 3)+ ]+ , bgroup "suiteSize"+ [ bench "depth=1" $ nf (\w -> wmethodSuiteSize w benchAutomaton) (wmethod 1)+ , bench "depth=2" $ nf (\w -> wmethodSuiteSize w benchAutomaton) (wmethod 2)+ , bench "depth=3" $ nf (\w -> wmethodSuiteSize w benchAutomaton) (wmethod 3)+ ]+ ]+ , bgroup "WpMethod"+ [ bgroup "testSuite"+ [ bench "depth=1" $ nf (\w -> snd (testSuite w benchAutomaton)) (wpmethod 1)+ , bench "depth=2" $ nf (\w -> snd (testSuite w benchAutomaton)) (wpmethod 2)+ , bench "depth=3" $ nf (\w -> snd (testSuite w benchAutomaton)) (wpmethod 3)+ ]+ , bgroup "suiteSize"+ [ bench "depth=1" $ nf (\w -> wpmethodSuiteSize w benchAutomaton) (wpmethod 1)+ , bench "depth=2" $ nf (\w -> wpmethodSuiteSize w benchAutomaton) (wpmethod 2)+ , bench "depth=3" $ nf (\w -> wpmethodSuiteSize w benchAutomaton) (wpmethod 3)+ ]+ ]+ ]
+ bench/Main.hs view
@@ -0,0 +1,16 @@+module Main (main) where++import Test.Tasty.Bench (defaultMain)++import Bench.BlackBox (blackBoxBenchmarks)+import Bench.Dot (dotBenchmarks)+import Bench.EndToEnd (endToEndBenchmarks)+import Bench.EquivalenceOracle (equivalenceOracleBenchmarks)++main :: IO ()+main = defaultMain+ [ blackBoxBenchmarks+ , equivalenceOracleBenchmarks+ , dotBenchmarks+ , endToEndBenchmarks+ ]
haal.cabal view
@@ -1,11 +1,11 @@ cabal-version: 2.2 --- This file has been generated from package.yaml by hpack version 0.37.0.+-- This file has been generated from package.yaml by hpack version 0.38.1. -- -- see: https://github.com/sol/hpack name: haal-version: 0.4.1.0+version: 0.5.0.0 synopsis: A Haskell library for Active Automata Learning. description: Please see the README on GitHub at <https://github.com/steve-anunknown/haal#readme> category: Model Learning@@ -160,4 +160,29 @@ , hspec , mtl , random+ default-language: Haskell2010++benchmark haal-bench+ type: exitcode-stdio-1.0+ main-is: Main.hs+ other-modules:+ Bench.BlackBox+ Bench.Dot+ Bench.EndToEnd+ Bench.EquivalenceOracle+ Paths_haal+ autogen-modules:+ Paths_haal+ hs-source-dirs:+ bench+ ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N -O2+ build-depends:+ base >=4.18.3 && <5+ , containers+ , deepseq+ , haal+ , mtl+ , random+ , tasty+ , tasty-bench default-language: Haskell2010
src/Haal/Dot.hs view
@@ -9,7 +9,7 @@ ) where import Data.Char (isAlphaNum, isDigit, isLower, isSpace, toUpper)-import Data.List (intercalate, isInfixOf, isPrefixOf, nub)+import Data.List (intercalate, isInfixOf, isPrefixOf) import qualified Data.Map.Strict as Map import Data.Maybe (mapMaybe) import qualified Data.Set as Set@@ -111,14 +111,13 @@ let ls = lines src initSt <- findInit ls trans <- collectTrans ls- let allStates = nub $ concatMap (\(s, _, d, _) -> [s, d]) trans- if initSt `notElem` allStates+ let allStateSet = Set.fromList $ concatMap (\(s, _, d, _) -> [s, d]) trans+ if initSt `Set.notMember` allStateSet then Left ("Initial state '" ++ initSt ++ "' does not appear in any transition") else do- let otherStates = filter (/= initSt) allStates- stateOrder = initSt : otherStates- inputSyms = nub $ map (\(_, i, _, _) -> i) trans- outputSyms = nub $ map (\(_, _, _, o) -> o) trans+ let stateOrder = initSt : Set.toList (Set.delete initSt allStateSet)+ inputSyms = Set.toList . Set.fromList $ map (\(_, i, _, _) -> i) trans+ outputSyms = Set.toList . Set.fromList $ map (\(_, _, _, o) -> o) trans warnings = slashWarnings inputSyms outputSyms return ParsedMealy
src/Haal/Experiment.hs view
@@ -70,7 +70,7 @@ , Automaton aut s , FiniteOrd i , FiniteOrd s- , FiniteEq o+ , FiniteOrd o ) => l i o -> ExperimentT (sul i o) m (l i o, aut s i o)@@ -126,7 +126,7 @@ , EquivalenceOracle oracle , FiniteOrd i , FiniteOrd s- , FiniteEq o+ , FiniteOrd o ) => learner i o -> oracle ->
src/Haal/Learning/LMstar.hs view
@@ -150,7 +150,7 @@ (FiniteOrd i, Eq o) => ObservationTable i o -> Map.Map [i] [[i]]-equivalenceClasses ot = go Map.empty (sm `Set.union` sm_I)+equivalenceClasses ot = go Map.empty sm where sm = prefixSetS ot sm_I = prefixSetSI ot@@ -165,7 +165,7 @@ -- | The 'lmstar' function implements one iteration of the LM* algorithm. lmstar :: forall sul i o m.- (SUL sul m, FiniteOrd i, Eq o, Monad m) =>+ (SUL sul m, FiniteOrd i, Ord o, Monad m) => LMstar i o -> ExperimentT (sul i o) m (LMstar i o, MealyAutomaton StateID i o) lmstar (LMstar (Init ot)) = case otIsClosed ot of@@ -209,14 +209,23 @@ distinguishing letter and @e@ is an existing suffix witnessing the inconsistency, so that @[a] ++ e@ can be added to E. -}-otIsConsistent :: forall i o. (FiniteOrd i, Eq o) => ObservationTable i o -> ([i], [i])+otIsConsistent :: forall i o. (FiniteOrd i, Ord o) => ObservationTable i o -> ([i], [i]) otIsConsistent ot = Maybe.fromMaybe ([], []) condition where alph = [minBound .. maxBound] :: [i] sm = Set.toList $ prefixSetS ot em = Set.toList $ suffixSetE ot+ tm = mappingT ot - equivalentPairs = [(r1, r2) | r1 <- sm, r2 <- sm, r1 <= r2, equivalentRows ot r1 r2]+ -- Group prefixes by their row signature (the sequence of outputs+ -- for each suffix in E). Prefixes with identical signatures are+ -- equivalent, so only pairs within the same group need checking+ -- for consistency violations.+ rowSig s = map (\e -> Map.lookup (s, e) tm) em+ groups = Map.elems $ Map.fromListWith (++) [(rowSig s, [s]) | s <- sm]+ equivalentPairs = [pair | group <- groups, pair <- uniquePairs group]+ uniquePairs [] = []+ uniquePairs (x : xs) = [(x, y) | y <- xs] ++ uniquePairs xs condition = do (s1, s2) <-@@ -231,7 +240,7 @@ alph e <- find- (\e -> Map.lookup (s1 ++ [x], e) (mappingT ot) /= Map.lookup (s2 ++ [x], e) (mappingT ot))+ (\e -> Map.lookup (s1 ++ [x], e) tm /= Map.lookup (s2 ++ [x], e) tm) em return ([x], e)