Simplified a bit

app/LStar.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE PartialTypeSignatures #-}
 {-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TupleSections #-}
 {-# OPTIONS_GHC -Wno-partial-type-signatures #-}
 
 module Main where
@@ -17,70 +18,79 @@ import Control.Monad.State
 import Prelude hiding (filter, null, elem, lookup, product, Word, map, take)
 
 type Word a    = [a]
-type Alph a    = OrbitList a
 type Rows a    = OrbitList (Word a)
 type Columns a = OrbitList (Word a)
-type Table a   = EquivariantMap (Word a, Word a) Bool -- TODO: Just make it Word a -> Bool
+type Table a   = EquivariantMap (Word a) Bool
 
-data Observations a = Observations
-  { alph     :: OrbitList a
-  , prefs    :: OrbitList (Word a)
-  , prefsExt :: OrbitList (Word a)
-  , suffs    :: OrbitList (Word a)
-  , table    :: Table a
-  }
-
-ext = \p a -> p ++ [a]
-
-unequalRows :: (Nominal a, Ord (Orbit a)) => Word a -> Word a -> Columns a -> Table a -> Bool
-unequalRows s0 t0 suffs table =
-  False `elem` ( productWith (\(s, t) e -> lookup (s, e) table == lookup (t, e) table) (singleOrbit (s0, t0)) suffs )
+-- Utility functions
+exists f = not . null . filter f 
+forAll f = null . filter (not . f)
+ext = \p a -> p <> [a]
 
 equalRows :: (Nominal a, Ord (Orbit a)) => Word a -> Word a -> Columns a -> Table a -> Bool
-equalRows s0 t0 suffs table = not (unequalRows s0 t0 suffs table)
+equalRows s0 t0 suffs table =
+  forAll (\((s, t), e) -> lookup (s ++ e) table == lookup (t ++ e) table) $ product (singleOrbit (s0, t0)) suffs
 
-notClosed :: (Nominal a, Ord (Orbit a)) => Word a -> Rows a -> Columns a -> Table a -> Bool
-notClosed t prefs suffs table =
-  null (filter (\(t, s) -> equalRows t s suffs table) (product (singleOrbit t) prefs))
+closed :: (Nominal a, Ord (Orbit a)) => Word a -> Rows a -> Columns a -> Table a -> Bool
+closed t prefs suffs table =
+  exists (\(t, s) -> equalRows t s suffs table) (product (singleOrbit t) prefs)
 
 nonClosedness :: (Nominal a, Ord (Orbit a)) => Rows a -> Rows a -> Columns a -> Table a -> Rows a
 nonClosedness prefs prefsExt suffs table =
-  filter (\t -> notClosed t prefs suffs table) prefsExt
+  filter (\t -> not $ closed t prefs suffs table) prefsExt
 
-inconsistencies :: (Nominal a, Ord a, Ord (Orbit a)) => Rows a -> Columns a -> Table a -> Alph a -> OrbitList ((Word a, Word a), (a, Word a))
+inconsistencies :: (Nominal a, Ord a, Ord (Orbit a)) => Rows a -> Columns a -> Table a -> OrbitList a -> OrbitList ((Word a, Word a), (a, Word a))
 inconsistencies prefs suffs table alph =
-  filter (\((s, t), (a, e)) -> lookup (s ++ [a], e) table /= lookup (t ++ [a], e) table) candidatesExt
+  filter (\((s, t), (a, e)) -> lookup (s ++ (a:e)) table /= lookup (t ++ (a:e)) table) candidatesExt
   where
     candidates = filter (\(s, t) -> s < t && equalRows s t suffs table) (product prefs prefs)
     candidatesExt = product candidates (product alph suffs)
 
+-- First lookup, then membership query
+ask mq table (p, s) =
+  let w = p ++ s in case lookup w table of
+                        Just b -> return (w, b)
+                        Nothing -> (w,) <$> mq w
+
+
+-- invariants: * prefs and prefsExt disjoint, without dups
+--             * prefsExt ordered
+--             * prefs and (prefs `union` prefsExt) prefix-closed
+--             * table defined on (prefs `union` prefsExt) * suffs
+data Observations a = Observations
+  { alph     :: OrbitList a
+  , prefs    :: Rows a
+  , prefsExt :: Rows a
+  , suffs    :: Columns a
+  , table    :: Table a
+  }
+
 -- input alphabet, inner monad, return value
 type LStar i m a = StateT (Observations i) m a
 
 -- precondition: newPrefs is subset of prefExts
--- postcondition: things are prefix-closed and disjoint
 addRows :: (Nominal a, Ord (Orbit a), Monad m) => Rows a -> (Word a -> m Bool) -> LStar a m ()
 addRows newPrefs mq = do
   Observations{..} <- get
   let newPrefsExt = productWith ext newPrefs alph
       rect = product newPrefsExt suffs
-  ans <- lift $ mapM (\(p, s) -> do b <- mq (p ++ s); return ((p, s), b)) (List.toList rect)
+  ans <- lift $ mapM (ask mq table) (List.toList rect)
   put $ Observations
-          { prefs = prefs `union` newPrefs
+          { prefs = prefs <> newPrefs
           , prefsExt = (prefsExt `minus` newPrefs) `union` newPrefsExt
           , table = table <> Map.fromList ans
           , ..
           }
   return ()
 
--- precondition: things are disjoint
+-- precondition: newSuffs disjoint from suffs
 addCols :: (Nominal a, Ord (Orbit a), Monad m) => Columns a -> (Word a -> m Bool) -> LStar a m ()
 addCols newSuffs mq = do
   Observations{..} <- get
   let rect = product (prefs `union` prefsExt) newSuffs
-  ans <- lift $ mapM (\(p, s) -> do b <- mq (p ++ s); return ((p, s), b)) (List.toList rect)
+  ans <- lift $ mapM (ask mq table) (List.toList rect)
   put $ Observations
-          { suffs = suffs `union` newSuffs
+          { suffs = suffs <> newSuffs
           , table = table <> Map.fromList ans
           , ..
           }
@@ -90,23 +100,13 @@ fillTable :: (Nominal a, Ord (Orbit a), Monad m) => (Word a -> m Bool) -> LStar
 fillTable mq = do
   Observations{..} <- get
   let rect = product (prefs `union` prefsExt) suffs
-  ans <- lift $ mapM (\(p, s) -> do b <- mq (p ++ s); return ((p, s), b)) (List.toList rect)
+  ans <- lift $ mapM (ask mq table) (List.toList rect)
   put $ Observations
           { table = Map.fromList ans
           , ..
           }
   return ()
 
-
-accept :: Show a => Word a -> IO Bool
-accept w = do
-  print w
-  a <- getLine
-  case a of
-    "Y" -> return True
-    "N" -> return False
-    _   -> accept w
-
 learn :: _ => (Word a -> IO Bool) -> LStar a IO ()
 learn mq = do
   Observations{..} <- get
@@ -125,6 +125,16 @@ learn mq = do
           learn mq
         True -> return ()
 
+
+accept :: Show a => Word a -> IO Bool
+accept w = do
+  print w
+  a <- getLine
+  case a of
+    "Y" -> return True
+    "N" -> return False
+    _   -> accept w
+
 main :: IO ()
 main = do
   let alph = rationals

src/OrbitList.hs

@@ -65,6 +65,9 @@ product (OrbitList as) (OrbitList bs) = OrbitList . concat $ (Nominal.product (P
 productWith :: (Nominal a, Nominal b, Nominal c) => (a -> b -> c) -> OrbitList a -> OrbitList b -> OrbitList c
 productWith f as bs = map (uncurry f) (OrbitList.product as bs)
 
+instance Semigroup (OrbitList a) where (OrbitList as) <> (OrbitList bs) = OrbitList (as <> bs)
+instance Monoid (OrbitList a) where mempty = empty
+
 
 -- Sorted Lists