Adds the main L* loop, no hypotheses yet

app/LStar.hs

@@ -1,56 +1,138 @@
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE PartialTypeSignatures #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# OPTIONS_GHC -Wno-partial-type-signatures #-}
 
 module Main where
 
 import Nominal hiding (product)
 import Support (Rat(..))
-import OrbitList
+import OrbitList --(OrbitList(..), singleOrbit, product, productWith, filter, null, elem, rationals)
-import EquivariantMap (EquivariantMap, lookup, fromSet)
+import qualified OrbitList as List
-import EquivariantSet (fromOrbitList, toList)
+import EquivariantMap (EquivariantMap(..), lookup)
+import qualified EquivariantMap as Map
+import qualified EquivariantSet as Set
 
-import Prelude hiding (filter, null, elem, lookup, product, Word, map)
+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
+type Table a   = EquivariantMap (Word a, Word a) Bool -- TODO: Just make it 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 )
 
-
 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)
 
-closed :: (Nominal a, Ord (Orbit a)) => Word a -> Rows a -> Columns a -> Table a -> Bool
+notClosed :: (Nominal a, Ord (Orbit a)) => Word a -> Rows a -> Columns a -> Table a -> Bool
-closed t prefs suffs table =
+notClosed t prefs suffs table =
-  null (filter (\(t, s) -> unequalRows t s suffs table) (product (singleOrbit t) prefs))
+  null (filter (\(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 -> not (closed t prefs suffs table)) prefsExt 
+  filter (\t -> notClosed t prefs suffs table) prefsExt
 
-inconsistencies :: (Nominal a, Ord a, Ord (Orbit a)) => Rows a -> Columns a -> Table a -> Alph a -> OrbitList (([a], [a]), (a, Word a))
+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 prefs suffs table alph =
   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)
 
+-- input alphabet, inner monad, return value
+type LStar i m a = StateT (Observations i) m a
 
--- Example to test
+-- precondition: newPrefs is subset of prefExts
-accept [Rat a, Rat b] = a == b
+-- postcondition: things are prefix-closed and disjoint
-accept _ = False
+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)
+  put $ Observations
+          { prefs = prefs `union` newPrefs
+          , prefsExt = (prefsExt `minus` newPrefs) `union` newPrefsExt
+          , table = table <> Map.fromList ans
+          , ..
+          }
+  return ()
+
+-- precondition: things are disjoint
+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)
+  put $ Observations
+          { suffs = suffs `union` newSuffs
+          , table = table <> Map.fromList ans
+          , ..
+          }
+  return ()
+
+fillTable :: (Nominal a, Ord (Orbit a), Monad m) => (Word a -> m Bool) -> LStar a m ()
+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)
+  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
+  let ncl = nonClosedness prefs prefsExt suffs table
+      inc = inconsistencies prefs suffs table alph
+  lift (print (toList ncl))
+  lift (print (toList inc))
+  case null ncl of
+    False -> do
+      addRows (take 1 ncl) mq
+      learn mq
+    True -> do
+      case null inc of
+        False -> do
+          addCols (take 1 (map (uncurry (:) . snd) inc)) mq
+          learn mq
+        True -> return ()
 
 main :: IO ()
 main = do
   let alph = rationals
-      prefs = singleOrbit [] `union` map (\r -> [r]) alph
+      prefs = singleOrbit []
-      prefsExt = productWith (\p a -> p ++ [a]) prefs alph
+      prefsExt = productWith ext prefs alph
       suffs = singleOrbit []
-      table = fromSet (\(a, b) -> accept (a ++ b)) . fromOrbitList $ product (prefs `union` prefsExt) (suffs)
+      table = Map.empty
-  print (toList . fromOrbitList $ (nonClosedness prefs prefsExt suffs table))
+      init = Observations{..}
-  print (toList . fromOrbitList $ (inconsistencies prefs suffs table alph))
+  evalStateT (fillTable accept >> learn accept) init
+  return ()
 

ons-hs.cabal

@@ -45,6 +45,7 @@ executable ons-hs-lstar
   main-is:             LStar.hs
   ghc-options:         -threaded -rtsopts -with-rtsopts=-N
   build-depends:       base
+                     , mtl
                      , ons-hs
   ghc-options:         -threaded -rtsopts -with-rtsopts=-N -O2
   default-language:    Haskell2010

src/EquivariantMap.hs

@@ -106,6 +106,13 @@ fromSet :: (Nominal k, Nominal v) => (k -> v) -> EquivariantSet k -> Equivariant
 fromSet f (EqSet s) = EqMap (Map.fromSet f2 s)
   where f2 ko = let k = getElementE ko in mapel k (f k)
 
+toList :: (Nominal k, Nominal v) => EquivariantMap k v -> [(k, v)]
+toList (EqMap l) = [(k, mapelInv k vob) | (ko, vob) <- Map.toList l, let k = getElementE ko]
+
+fromList :: (Nominal k, Nominal v, Ord (Orbit k)) => [(k, v)] -> EquivariantMap k v
+fromList l = EqMap . Map.fromList $ [(toOrbit k, mapel k v) | (k, v) <- l]
+
+
 
 -- Filter
 

src/OrbitList.hs

@@ -54,6 +54,8 @@ map f (OrbitList as) = OrbitList $ L.map (omap f) as
 filter :: Nominal a => (a -> Bool) -> OrbitList a -> OrbitList a
 filter f = OrbitList . L.filter (f . getElementE) . unOrbitList
 
+take :: Int -> OrbitList a -> OrbitList a
+take n = OrbitList . L.take n . unOrbitList
 
 -- Combinations
 
@@ -89,3 +91,12 @@ projectWith f = unionAll . fmap OrbitList . groupOnFst . splitOrbs . unOrbitList
   where
     splitOrbs = fmap (\o -> (omap fst o, omap snd o))
     groupOnFst = fmap (fmap snd) . L.groupBy (\x y -> fst x == fst y)
+
+
+-- Conversions
+
+toList :: Nominal a => OrbitList a -> [a]
+toList = fmap getElementE . unOrbitList
+
+fromList :: Nominal a => [a] -> OrbitList a
+fromList = OrbitList . fmap toOrbit

src/Support/Rat.hs

@@ -10,4 +10,7 @@ import GHC.Generics (Generic)
 -- Ord instances, and because it's not very nice to work with type synonyms.
 -- Show instance included for debugging.
 newtype Rat = Rat { unRat :: Rational }
-  deriving (Eq, Ord, Show, Generic)
+  deriving (Eq, Ord, Generic)
+
+instance Show Rat where
+  show (Rat x) = show x