Cleaned up a little bit

README.md

@@ -3,15 +3,49 @@ monoid-learner
 
 Learns the minimal monoid accepting an unknown language through an orcale.
 Similar to Lstar, but for monoids instead of automata. The output is a monoid
-representation which is furthermore minimised by the Knuth-Bendix completion.
+presentation which is furthermore minimised by the Knuth-Bendix completion.
+Only works for regular languages.
 
 [Original](https://gist.github.com/Jaxan/d9bb9e3223e8fe8266fe4fe84d357088)
 
-Output for the example in `app/Main.hs`:
+This algorithm is made more precise and generalised to bimonoids (in the
+sense of a finite set with two binary operations) in
+[this paper.](https://doi.org/10.1007/978-3-030-71995-1_26)
+
+
+## To run
+
+Install Haskell and its cabal tool and clone this repo. Then run:
 
 ```
-Inferred rules: (generators are a, b and the unit)
+cabal run monoid-learner
-[(fromList "aaa",fromList "a"),(fromList "aaaa",fromList "aa"),(fromList "aaab",fromList "ab"),(fromList "aaabb",fromList "abb"),(fromList "aab",fromList "b"),(fromList "aabb",fromList "bb"),(fromList "aba",fromList "b"),(fromList "abaa",fromList "ab"),(fromList "abab",fromList "bb"),(fromList "ababb",fromList "aa"),(fromList "abba",fromList "bb"),(fromList "abbaa",fromList "abb"),(fromList "abbab",fromList "aa"),(fromList "abbabb",fromList "b"),(fromList "abbb",fromList "a"),(fromList "abbbb",fromList "ab"),(fromList "ba",fromList "ab"),(fromList "baa",fromList "b"),(fromList "bab",fromList "abb"),(fromList "babb",fromList "a"),(fromList "bba",fromList "abb"),(fromList "bbaa",fromList "bb"),(fromList "bbab",fromList "a"),(fromList "bbabb",fromList "ab"),(fromList "bbb",fromList "aa"),(fromList "bbbb",fromList "b")]
+```
-After KB:
+
-[(fromList "ba",fromList "ab"),(fromList "aaa",fromList "a"),(fromList "aab",fromList "b"),(fromList "bbb",fromList "aa")]
+
+## Example output for the example in `app/Main.hs`:
+
+For the language of non-empty words with an even number of as and a triple
+number of bs. Note that the equations tell us that the language is
+commutative.
+
+```
+Monoid on the generators:
+    fromList "ab"
+with equations:
+    [(fromList "ba",fromList "ab"),(fromList "aaa",fromList "a"),(fromList "aab",fromList "b"),(fromList "bbb",fromList "aa")]
+and accepting strings:
+    fromList [fromList "aa"]
+```
+
+For the language where a occurs on position 3 on the right and the empty
+word.
+
+```
+... (many membership queries) ...
+Monoid on the generators:
+    fromList "ab"
+with equations:
+    [(fromList "bbbb",fromList "bbb"),(fromList "bbba",fromList "bba"),(fromList "bbab",fromList "bab"),(fromList "bbaa",fromList "baa"),(fromList "babb",fromList "abb"),(fromList "baba",fromList "aba"),(fromList "baab",fromList "aab"),(fromList "baaa",fromList "aaa"),(fromList "abbb",fromList "bbb"),(fromList "abba",fromList "bba"),(fromList "abab",fromList "bab"),(fromList "abaa",fromList "baa"),(fromList "aabb",fromList "abb"),(fromList "aaba",fromList "aba"),(fromList "aaab",fromList "aab"),(fromList "aaaa",fromList "aaa")]
+and accepting strings:
+    fromList [fromList "",fromList "aaa",fromList "aab",fromList "aba",fromList "abb"]
 ```

app/Main.hs

@@ -1,5 +1,7 @@
 module Main where
 
+import Data.Foldable (Foldable (toList))
+import Data.IORef
 import qualified Data.Map as Map
 import qualified Data.Sequence as Seq
 import qualified Data.Set as Set
@@ -7,8 +9,8 @@ import KnuthBendix
 import MStar
 
 -- We use the alphabet {a, b} as always
-alphabet :: Set.Set Char
+symbols :: Set.Set Char
-alphabet = Set.fromList "ab"
+symbols = Set.fromList "ab"
 
 -- Example language L = { w | nonempty && even number of as && triple numbers of bs }
 language :: MStar.Word Char -> Bool
@@ -16,26 +18,64 @@ language w = not (null w) && length aa `mod` 2 == 0 && length bb `mod` 3 == 0
   where
     (aa, bb) = Seq.partition (== 'a') w
 
+-- Let's count the number of membership queries
+-- and print all the queries
+languageM :: IORef Int -> MStar.Word Char -> IO Bool
+languageM count w = do
+  modifyIORef' count succ
+  n <- readIORef count
+  let nstr = show n
+  putStr nstr
+  putStr (replicate (8 - length nstr) ' ')
+  putStrLn $ toList w
+  return $ language w
+
 main :: IO ()
 main = do
-  let -- Initialise
+  putStrLn "Welcome to the monoid learner"
-      s = initialState alphabet language
+  count <- newIORef 0
-      -- make closed, consistent and associative
+  let lang = languageM count
-      (_, s2) = learn language s
+
-      -- The corresponding hypothesis is wrong on the string bbb
+  -- Initialise
-      -- So we add a row bb
+  s <- initialState symbols lang
-      s3 = addRow (Seq.fromList "bb") language s2
+  -- make closed, consistent and associative
-      -- Make closed, consistent and associative again
+  s2 <- learn lang s
-      (_, s4) = learn language s3
+
-      -- Extract the rewrite rules from the table
+  -- Above hypothesis is trivial (accepts nothing)
+  -- Let's add a column so that aa can be reached
+  putStrLn "Adding counterexample aa"
+  s3 <- addContext (Seq.empty, Seq.singleton 'a') lang s2
+  -- Make closed, consistent and associative again
+  s5 <- learn lang s3
+
+  -- Still wrong, on bbb
+  -- Let's add a column to reach it
+  putStrLn "Adding counterexample bbb"
+  s6 <- addContext (Seq.singleton 'b', Seq.singleton 'b') lang s5
+  -- Make closed, consistent and associative again
+  s7 <- learn lang s6
+
+  -- Hypothesis is now correct
+  let sFinal = s7
+  let -- Extract the rewrite rules from the table
       -- For this we simply look at products r1 r2 and see which row is equivalent to it
-      rowPairs = Set.filter (\w -> not (w `Set.member` rows s4)) . Set.map (uncurry (<>)) $ Set.cartesianProduct (rows s4) (rows s4)
+      rowPairs = Set.filter (\w -> not (w `Set.member` rows sFinal)) . Set.map (uncurry (<>)) $ Set.cartesianProduct (rows sFinal) (rows sFinal)
-      representatives = Map.fromList (fmap (\w -> (row s4 w, w)) (Set.toList (rows s4)))
+      representatives = Map.fromList (fmap (\w -> (row sFinal w, w)) (Set.toList (rows sFinal)))
-      rules0 = Map.fromSet (\w -> representatives Map.! row s4 w) rowPairs
+      rules0 = Map.fromSet (\w -> representatives Map.! row sFinal w) rowPairs
       rules = Map.toList rules0
+      kbRules = knuthBendix rules
+      -- Also extract final set
+      accRows0 = Set.filter (\m -> row sFinal m Map.! (Seq.empty, Seq.empty)) $ rows sFinal
+      accRows = Set.map (rewrite kbRules) accRows0
 
-  putStrLn "Inferred rules: (generators are a, b and the unit)"
+  putStrLn "Monoid on the generators:"
-  print rules
+  putStr "    "
+  print symbols
 
-  putStrLn "After KB:"
+  putStrLn "with equations:"
-  print (knuthBendix rules)
+  putStr "    "
+  print kbRules
+
+  putStrLn "and accepting strings:"
+  putStr "    "
+  print accRows

monoid-learner.cabal

@@ -7,7 +7,6 @@ build-type:          Simple
 
 common stuff
   default-language: Haskell2010
-  ghc-options: -Wall -O2
   build-depends:
     base >=4.12 && <5,
     containers,
@@ -24,4 +23,15 @@ executable monoid-learner
   import: stuff
   hs-source-dirs: app
   main-is: Main.hs
-  build-depends: monoid-learner
+  ghc-options: -Wall -O2
+  build-depends:
+    monoid-learner
+
+test-suite test
+  import: stuff
+  hs-source-dirs: test
+  main-is: test.hs
+  type: exitcode-stdio-1.0
+  build-depends:
+    monoid-learner,
+    hedgehog

src/KnuthBendix.hs

@@ -1,9 +1,12 @@
 module KnuthBendix where
 
-import Data.Sequence (Seq, fromList)
-import Data.Foldable (Foldable (toList))
 import Data.Bifunctor (Bifunctor (bimap))
+import Data.Foldable (Foldable (toList))
+import Data.Sequence (Seq, fromList)
 import qualified Math.Algebra.Group.StringRewriting as Rew
 
 knuthBendix :: Ord a => [(Seq a, Seq a)] -> [(Seq a, Seq a)]
 knuthBendix = fmap (bimap fromList fromList) . Rew.knuthBendix . fmap (bimap toList toList)
+
+rewrite :: Ord a => [(Seq a, Seq a)] -> Seq a -> Seq a
+rewrite system = fromList . Rew.rewrite (fmap (bimap toList toList) system) . toList

src/MStar.hs

@@ -1,112 +1,114 @@
 {-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE PartialTypeSignatures #-}
 {-# LANGUAGE RecordWildCards #-}
-{-# OPTIONS_GHC -Wno-partial-type-signatures #-}
 
 module MStar where
 
--- Copyright Joshua Moerman 2020
+-- Copyright Joshua Moerman 2020, 2021
 -- M*: an algorithm to query learn the syntactic monoid
 -- for a regular language. I hope it works correctly.
 -- This is a rough sketch, and definitely not cleaned up.
 
-import Control.Applicative (Applicative ((<*>)), (<$>))
+import qualified Data.List as List
 import Data.Map (Map)
 import qualified Data.Map as Map
-import Data.Sequence (Seq, empty, singleton)
+import Data.Maybe (listToMaybe)
+import Data.Sequence (Seq)
+import qualified Data.Sequence as Seq
 import Data.Set (Set)
 import qualified Data.Set as Set
 import Prelude hiding (Word)
 
 type Word a = Seq a
 type Alphabet a = Set a
+type MembershipQuery m a = Word a -> m Bool
 
-type MembershipQuery a = Word a -> Bool
+squares :: Ord a => Set (Word a) -> Set (Word a)
-
--- If l includes the empty word, then this set also includes l
-squares :: _ => Set (Word a) -> Set (Word a)
 squares l = Set.map (uncurry (<>)) (Set.cartesianProduct l l)
 
+setPlus :: Ord a => Set a -> Set (Word a) -> Set (Word a)
+setPlus alph rows = Set.map pure alph `Set.union` squares rows
+
 -- Left and Right concats, these are like columns, but they act
 -- both left and right. Maybe a better word would be "tests".
 type Context a = (Word a, Word a)
-type Contexts a = Set (Context a)
 
-initialContexts :: Contexts a
+type Index a = Word a
-initialContexts = Set.singleton (empty, empty)
-
-type Row a = Word a
-type Rows a = Set (Row a)
-
-initialRows :: Ord a => Alphabet a -> Rows a
-initialRows alphabet = Set.singleton empty `Set.union` Set.map singleton alphabet
 
 -- State of the M* algorithm
 data State a = State
-  { rows :: Rows a,
+  { rows :: Set (Index a),
-    contexts :: Contexts a,
+    contexts :: Set (Context a),
-    cache :: Map (Word a) Bool
+    cache :: Map (Word a) Bool,
+    alphabet :: Set a
   }
   deriving (Show, Eq)
 
 -- Row data for an index
-row :: _ => State a -> Row a -> Map (Context a) Bool
+row :: Ord a => State a -> Index a -> Map (Context a) Bool
 row State {..} m = Map.fromSet (\(l, r) -> cache Map.! (l <> m <> r)) contexts
 
 -- Difference of two rows (i.e., all contexts in which they differ)
-difference :: _ => State a -> Row a -> Row a -> [Context a]
+difference :: Ord a => State a -> Index a -> Index a -> [Context a]
 difference State {..} m1 m2 = [(l, r) | (l, r) <- Set.toList contexts, cache Map.! (l <> m1 <> r) /= cache Map.! (l <> m2 <> r)]
 
 -- Initial state of the algorithm
-initialState :: Ord a => Alphabet a -> MembershipQuery a -> State a
+initialState :: (Monad m, Ord a) => Alphabet a -> MembershipQuery m a -> m (State a)
-initialState alphabet mq =
+initialState alphabet mq = do
-  State
+  let rows = Set.singleton Seq.empty
-    { rows = rows,
+      contexts = Set.singleton (Seq.empty, Seq.empty)
-      contexts = contexts,
+      initialQueries = Set.map (\(m, (l, r)) -> l <> m <> r) $ Set.cartesianProduct (setPlus alphabet rows) contexts
-      cache = cache
+      initialQueriesL = Set.toList initialQueries
-    }
+  results <- mapM mq initialQueriesL
-  where
+  let cache = Map.fromList (zip initialQueriesL results)
-    rows = initialRows alphabet
+  return $
-    contexts = initialContexts
+    State
-    initialQueries =
+      { rows = rows,
-      Set.map (\(m, (l, r)) -> l <> m <> r) $
+        contexts = contexts,
-        Set.cartesianProduct (squares rows) contexts
+        cache = cache,
-    cache = Map.fromSet mq initialQueries
+        alphabet = alphabet
+      }
 
 
 -- CLOSED --
 -- Returns all pairs which are not closed
-closed :: _ => State a -> [(Row a, Row a)]
+closed :: Ord a => State a -> Set (Index a)
-closed s@State {..} = [(m1, m2) | (m1, m2) <- Set.toList rowPairs, notExists (row s (m1 <> m2))]
+closed s@State {..} = Set.filter notExists (setPlus alphabet rows `Set.difference` rows)
   where
-    rowPairs = Set.cartesianProduct rows rows
     allRows = Set.map (row s) rows
-    notExists m = not (m `Set.member` allRows)
+    notExists m = not (row s m `Set.member` allRows)
 
--- Returns a fix for the non-closedness.
+-- Returns a fix for the non-closedness. (Some element)
-fixClosed :: _ => _ -> Maybe (Word a)
+fixClosed1 :: Set (Index a) -> Maybe (Word a)
-fixClosed [] = Nothing
+fixClosed1 = listToMaybe . Set.toList
-fixClosed ((a, b) : _) = Just (a <> b)
+
+-- Returns a fix for the non-closedness. (Shortest element)
+fixClosed2 :: Set (Index a) -> Maybe (Word a)
+fixClosed2 = listToMaybe . List.sortOn Seq.length . Set.toList
 
 -- Adds a new element
-addRow :: Ord a => Row a -> MembershipQuery a -> State a -> State a
+addRow :: (Monad m, Ord a) => Index a -> MembershipQuery m a -> State a -> m (State a)
-addRow m mq s@State {..} = s {rows = newRows, cache = cache <> dCache}
+addRow m mq s@State {..} = do
-  where
+  let newRows = Set.insert m rows
-    newRows = Set.insert m rows
+      queries = Set.map (\(mi, (l, r)) -> l <> mi <> r) $ Set.cartesianProduct (setPlus alphabet newRows) contexts
-    queries = Set.map (\(mi, (l, r)) -> l <> mi <> r) $ Set.cartesianProduct (squares newRows) contexts
+      queriesRed = queries `Set.difference` Map.keysSet cache
-    queriesRed = queries `Set.difference` Map.keysSet cache
+      queriesRedL = Set.toList queriesRed
-    dCache = Map.fromSet mq queriesRed
+  results <- mapM mq queriesRedL
+  let dCache = Map.fromList (zip queriesRedL results)
+  return $ s {rows = newRows, cache = cache <> dCache}
 
 
 -- CONSISTENT --
+-- Not needed when counterexamples are added as columns, the table
+-- then remains sharp. There is a more efficient way of testing this
+-- property, see https://doi.org/10.1007/978-3-030-71995-1_26
 -- Returns all inconsistencies
-consistent :: _ => State a -> _
+consistent :: Ord a => State a -> [(Index a, Index a, Index a, Index a, [Context a])]
 consistent s@State {..} = [(m1, m2, n1, n2, d) | (m1, m2) <- equalRowPairs, (n1, n2) <- equalRowPairs, let d = difference s (m1 <> n1) (m2 <> n2), not (Prelude.null d)]
   where
-    equalRowPairs = Prelude.filter (\(m1, m2) -> row s m1 == row s m2) $ (,) <$> Set.toList rows <*> Set.toList rows
+    equalRowPairs = Set.toList . Set.filter (\(m1, m2) -> row s m1 == row s m2) $ Set.cartesianProduct rows rows
 
 -- Returns a fix for consistency.
-fixConsistent :: _ => State a -> _ -> Maybe (Context a)
+fixConsistent :: Ord a => State a -> [(Index a, Index a, Index a, Index a, [Context a])] -> Maybe (Context a)
 fixConsistent _ [] = Nothing
 fixConsistent _ ((_, _, _, _, []) : _) = error "Cannot happen cons"
 fixConsistent s ((m1, m2, n1, n2, (l, r) : _) : _) = Just . head . Prelude.filter valid $ [(l <> m1, r), (l <> m2, r), (l, n1 <> r), (l, n2 <> r)] -- Many choices here
@@ -114,30 +116,37 @@ fixConsistent s ((m1, m2, n1, n2, (l, r) : _) : _) = Just . head . Prelude.filte
     valid c = not (Set.member c (contexts s))
 
 -- Adds a test
-addContext :: Ord a => Context a -> MembershipQuery a -> State a -> State a
+addContext :: (Monad m, Ord a) => Context a -> MembershipQuery m a -> State a -> m (State a)
-addContext lr mq s@State {..} = s {contexts = newContexts, cache = cache <> dCache}
+addContext lr mq s@State {..} = do
-  where
+  let newContexts = Set.insert lr contexts
-    newContexts = Set.insert lr contexts
+      queries = Set.map (\(m, (l, r)) -> l <> m <> r) $ Set.cartesianProduct (setPlus alphabet rows) newContexts
-    queries = Set.map (\(m, (l, r)) -> l <> m <> r) $ Set.cartesianProduct (squares rows) newContexts
+      queriesRed = queries `Set.difference` Map.keysSet cache
-    queriesRed = queries `Set.difference` Map.keysSet cache
+      queriesRedL = Set.toList queriesRed
-    dCache = Map.fromSet mq queriesRed
+  results <- mapM mq queriesRedL
+  let dCache = Map.fromList (zip queriesRedL results)
+  return $ s {contexts = newContexts, cache = cache <> dCache}
 
 
 -- ASSOCIATIVITY --
 -- Returns non-associativity results. Implemented in a brute force way
 -- This is something new in M*, it's obviously not needed in L*
-associative :: _ => State a -> _
+associative :: Ord a => State a -> [(Index a, Index a, Index a, Index a, Index a, [Context a])]
 associative s@State {..} = [(m1, m2, m3, m12, m23, d) | (m1, m2, m3, m12, m23) <- allCandidates, let d = difference s (m12 <> m3) (m1 <> m23), not (Prelude.null d)]
   where
     rs = Set.toList rows
     allTriples = [(m1, m2, m3) | m1 <- rs, m2 <- rs, m3 <- rs]
     allCandidates = [(m1, m2, m3, m12, m23) | (m1, m2, m3) <- allTriples, m12 <- rs, row s m12 == row s (m1 <> m2), m23 <- rs, row s m23 == row s (m2 <> m3)]
 
--- Fix for associativity (hopefully)
+-- Fix for associativity, needs a membership query
-fixAssociative :: _ => _ -> Maybe (Context a)
+-- See https://doi.org/10.1007/978-3-030-71995-1_26
-fixAssociative [] = Nothing
+fixAssociative :: (Monad m, Ord a) => [(Index a, Index a, Index a, Index a, Index a, [Context a])] -> MembershipQuery m a -> State a -> m (Maybe (Context a))
-fixAssociative ((_, _, _, _, _, []) : _) = error "Cannot happen assoc"
+fixAssociative [] _ _ = return Nothing
-fixAssociative ((_, _, m3, _, _, (l, r) : _) : _) = Just (l, m3 <> r) -- TODO: many choices
+fixAssociative ((_, _, _, _, _, []) : _) _ _ = error "Cannot happen assoc"
+fixAssociative ((m1, m2, m3, m12, m23, e@(l, r) : _) : _) mq table = do
+  b <- mq (l <> m1 <> m2 <> m3 <> r)
+  if row table (m12 <> m3) Map.! e /= b
+    then return (Just (l, m3 <> r))
+    else return (Just (l <> m1, r))
 
 
 -- Abstract data type for a monoid. The map from the alphabet
@@ -154,38 +163,50 @@ data MonoidAcceptor a q = MonoidAcceptor
 acceptMonoid :: MonoidAcceptor a q -> Word a -> Bool
 acceptMonoid MonoidAcceptor {..} w = accept (foldr multiplication unit (fmap alph w))
 
-
 -- HYPOTHESIS --
 -- Syntactic monoid construction
-constructMonoid :: _ => State a -> MonoidAcceptor a Int
+constructMonoid :: Ord a => State a -> MonoidAcceptor a Int
 constructMonoid s@State {..} =
   MonoidAcceptor
     { elements = [0 .. Set.size allRows - 1],
       unit = unit,
       multiplication = curry (multMap Map.!),
       accept = (accMap Map.!),
-      alph = rowToInt . singleton
+      alph = rowToInt . Seq.singleton -- incorrect if symbols behave trivially
     }
   where
     allRows = Set.map (row s) rows
     rowMap = Map.fromList (zip (Set.toList allRows) [0 ..])
     rowToInt m = rowMap Map.! row s m
-    unit = rowToInt empty
+    unit = rowToInt Seq.empty
-    accMap = Map.fromList [(rowMap Map.! r, r Map.! (empty, empty)) | r <- Set.toList allRows]
+    accMap = Map.fromList [(rowMap Map.! r, r Map.! (Seq.empty, Seq.empty)) | r <- Set.toList allRows]
     multList = [((rowToInt m1, rowToInt m2), rowToInt (m1 <> m2)) | m1 <- Set.toList rows, m2 <- Set.toList rows]
     multMap = Map.fromList multList
 
 
 -- Learns until it can construct a monoid
 -- Please do counterexample handling yourself
-learn :: _ => MembershipQuery a -> State a -> (MonoidAcceptor a _, State a)
+learn :: (Monad m, Ord a) => MembershipQuery m a -> State a -> m (State a)
-learn mq s =
+learn mq = makeClosedAndConsistentAndAssoc
-  case fixClosed $ closed s of
+  where
-    Just m -> learn mq (addRow m mq s)
+    makeClosed s = do
-    Nothing ->
+      case fixClosed2 $ closed s of
-      case fixConsistent s $ consistent s of
+        Just m -> do
-        Just c -> learn mq (addContext c mq s)
+          s2 <- addRow m mq s
-        Nothing ->
+          makeClosed s2
-          case fixAssociative $ associative s of
+        Nothing -> return s
-            Just c -> learn mq (addContext c mq s)
+    makeClosedAndConsistent s = do
-            Nothing -> (constructMonoid s, s)
+      s2 <- makeClosed s
+      case fixConsistent s2 $ consistent s2 of
+        Just c -> do
+          s3 <- addContext c mq s2
+          makeClosedAndConsistent s3
+        Nothing -> return s2
+    makeClosedAndConsistentAndAssoc s = do
+      s2 <- makeClosedAndConsistent s
+      result <- fixAssociative (associative s2) mq s2
+      case result of
+        Just a -> do
+          s3 <- addContext a mq s2
+          makeClosedAndConsistentAndAssoc s3
+        Nothing -> return s2

test/test.hs

@@ -0,0 +1,4 @@
+import Hedgehog.Main
+
+main :: IO ()
+main = defaultMain []