1
Fork 0
mirror of https://github.com/Jaxan/ons-hs.git synced 2025-04-27 22:57:44 +02:00

Construction of Hypothesis

This commit is contained in:
Joshua Moerman 2019-01-09 12:08:07 +01:00
parent 11f57c8339
commit b414b64c1a
5 changed files with 68 additions and 8 deletions

View file

@ -7,25 +7,44 @@
module Main where module Main where
import Nominal hiding (product) import Nominal hiding (product)
import Support (Rat(..)) import Support (Rat(..), Support(..), intersect)
import OrbitList --(OrbitList(..), singleOrbit, product, productWith, filter, null, elem, rationals) import OrbitList --(OrbitList(..), singleOrbit, product, productWith, filter, null, elem, rationals)
import qualified OrbitList as List import qualified OrbitList as List
import EquivariantMap (EquivariantMap(..), lookup) import EquivariantMap (EquivariantMap(..), lookup, (!))
import qualified EquivariantMap as Map import qualified EquivariantMap as Map
import EquivariantSet (EquivariantSet(..))
import qualified EquivariantSet as Set import qualified EquivariantSet as Set
import Data.List (nub)
import Control.Monad.State import Control.Monad.State
import Prelude hiding (filter, null, elem, lookup, product, Word, map, take) import Prelude hiding (filter, null, elem, lookup, product, Word, map, take, partition)
type Word a = [a] type Word a = [a]
type Rows a = OrbitList (Word a) type Rows a = OrbitList (Word a)
type Columns a = OrbitList (Word a) type Columns a = OrbitList (Word a)
type Table a = EquivariantMap (Word a) Bool type Table a = EquivariantMap (Word a) Bool
-- states, initial state, acceptance, transition
data Automaton q a = Automaton
{ states :: OrbitList q
, initialState :: q
, acceptance :: EquivariantMap q Bool
, transition :: EquivariantMap (q, a) q
}
instance (Nominal q, Nominal a, Show q, Show a) => Show (Automaton q a) where
show Automaton{..} =
"{ states = " ++ show (toList states) ++
", initialState = " ++ show initialState ++
", acceptance = " ++ show (Map.toList acceptance) ++
", transition = " ++ show (Map.toList transition) ++
"}"
-- Utility functions -- Utility functions
exists f = not . null . filter f exists f = not . null . filter f
forAll f = null . filter (not . f) forAll f = null . filter (not . f)
ext = \p a -> p <> [a] ext p a = p <> [a]
equalRows :: (Nominal a, Ord (Orbit a)) => Word a -> Word a -> Columns a -> Table a -> Bool equalRows :: (Nominal a, Ord (Orbit a)) => Word a -> Word a -> Columns a -> Table a -> Bool
equalRows s0 t0 suffs table = equalRows s0 t0 suffs table =
@ -52,6 +71,18 @@ ask mq table (p, s) =
Just b -> return (w, b) Just b -> return (w, b)
Nothing -> (w,) <$> mq w Nothing -> (w,) <$> mq w
quotient :: _ => EquivariantSet (a, a) -> OrbitList a -> (EquivariantMap a (Int, Support), OrbitList (Int, Support))
quotient equiv ls = go 0 Map.empty OrbitList.empty (toList ls)
where
go n phi acc [] = (phi, acc)
go n phi acc (a:as) =
let (y0, r0) = partition (\p -> p `Set.member` equiv) (product (singleOrbit a) (fromList as))
y1 = filter (\p -> p `Set.member` equiv) (product (singleOrbit a) (singleOrbit a))
y2 = map (\(a1, a2) -> (a2, (n, support a1 `intersect` support a2))) (y1 <> y0)
m0 = Map.fromListWith (\(n1, s1) (n2, s2) -> (n1, s1 `intersect` s2)) . OrbitList.toList $ y2
l0 = take 1 . fromList . fmap snd $ Map.toList m0
in go (n+1) (phi <> m0) (acc <> l0) (Set.toList . Set.fromOrbitList . map snd $ r0)
-- invariants: * prefs and prefsExt disjoint, without dups -- invariants: * prefs and prefsExt disjoint, without dups
-- * prefsExt ordered -- * prefsExt ordered
@ -107,7 +138,7 @@ fillTable mq = do
} }
return () return ()
learn :: _ => (Word a -> IO Bool) -> LStar a IO () learn :: _ => (Word a -> IO Bool) -> LStar a IO (Automaton _ _)
learn mq = do learn mq = do
Observations{..} <- get Observations{..} <- get
let ncl = nonClosedness prefs prefsExt suffs table let ncl = nonClosedness prefs prefsExt suffs table
@ -123,7 +154,18 @@ learn mq = do
False -> do False -> do
addCols (take 1 (map (uncurry (:) . snd) inc)) mq addCols (take 1 (map (uncurry (:) . snd) inc)) mq
learn mq learn mq
True -> return () True -> do
let equiv = Set.fromOrbitList . filter (\(s, t) -> equalRows s t suffs table) $ product prefs prefs
(f, s) = quotient equiv prefs
trans = Map.fromList . toList . map (\(s, t) -> (s, f ! t)) . filter (\(s, t) -> equalRows s t suffs table) $ product prefsExt prefs
trans2 pa = if pa `elem` prefsExt then trans ! pa else f ! pa
lift (print (Map.toList trans))
return Automaton
{ states = s
, initialState = f ! []
, acceptance = Map.fromList . toList . map (\p -> (f ! p, table ! p)) $ prefs
, transition = Map.fromList . toList . map (\(p, a) -> ((f ! p, a), trans2 (ext p a))) $ product prefs alph
}
accept :: Show a => Word a -> IO Bool accept :: Show a => Word a -> IO Bool
@ -143,6 +185,7 @@ main = do
suffs = singleOrbit [] suffs = singleOrbit []
table = Map.empty table = Map.empty
init = Observations{..} init = Observations{..}
evalStateT (fillTable accept >> learn accept) init aut <- evalStateT (fillTable accept >> learn accept) init
print aut
return () return ()

View file

@ -10,6 +10,7 @@ module EquivariantMap where
import Data.Semigroup (Semigroup) import Data.Semigroup (Semigroup)
import Data.Map (Map) import Data.Map (Map)
import qualified Data.Map as Map import qualified Data.Map as Map
import Data.Maybe (fromMaybe)
import EquivariantSet (EquivariantSet(..)) import EquivariantSet (EquivariantSet(..))
import Nominal import Nominal
@ -55,6 +56,8 @@ member x (EqMap m) = Map.member (toOrbit x) m
lookup :: (Nominal k, Ord (Orbit k), Nominal v) => k -> EquivariantMap k v -> Maybe v lookup :: (Nominal k, Ord (Orbit k), Nominal v) => k -> EquivariantMap k v -> Maybe v
lookup x (EqMap m) = mapelInv x <$> Map.lookup (toOrbit x) m lookup x (EqMap m) = mapelInv x <$> Map.lookup (toOrbit x) m
(!) :: (Nominal k, Ord (Orbit k), Nominal v) => EquivariantMap k v -> k -> v
(!) m k = fromMaybe undefined (EquivariantMap.lookup k m)
-- Construction -- Construction
@ -112,6 +115,9 @@ toList (EqMap l) = [(k, mapelInv k vob) | (ko, vob) <- Map.toList l, let k = get
fromList :: (Nominal k, Nominal v, Ord (Orbit k)) => [(k, v)] -> EquivariantMap k v 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] fromList l = EqMap . Map.fromList $ [(toOrbit k, mapel k v) | (k, v) <- l]
fromListWith :: forall k v. (Nominal k, Nominal v, Ord (Orbit k)) => (v -> v -> v) -> [(k, v)] -> EquivariantMap k v
fromListWith f l = EqMap . Map.fromListWithKey opf $ [(toOrbit k, mapel k v) | (k, v) <- l]
where opf ko p1 p2 = let k = getElementE ko :: k in mapel k (mapelInv k p1 `f` mapelInv k p2)
-- Filter -- Filter

View file

@ -91,6 +91,7 @@ deriving via (Trivial Void) instance Nominal Void
deriving via (Trivial ()) instance Nominal () deriving via (Trivial ()) instance Nominal ()
deriving via (Trivial Bool) instance Nominal Bool deriving via (Trivial Bool) instance Nominal Bool
deriving via (Trivial Char) instance Nominal Char deriving via (Trivial Char) instance Nominal Char
deriving via (Trivial Int) instance Nominal Int -- NB: Trivial instance!
deriving via (Trivial Ordering) instance Nominal Ordering deriving via (Trivial Ordering) instance Nominal Ordering

View file

@ -54,6 +54,10 @@ map f (OrbitList as) = OrbitList $ L.map (omap f) as
filter :: Nominal a => (a -> Bool) -> OrbitList a -> OrbitList a filter :: Nominal a => (a -> Bool) -> OrbitList a -> OrbitList a
filter f = OrbitList . L.filter (f . getElementE) . unOrbitList filter f = OrbitList . L.filter (f . getElementE) . unOrbitList
partition :: Nominal a => (a -> Bool) -> OrbitList a -> (OrbitList a, OrbitList a)
partition f (OrbitList s) = both OrbitList . L.partition (f . getElementE) $ s
where both g (a, b) = (g a, g b)
take :: Int -> OrbitList a -> OrbitList a take :: Int -> OrbitList a -> OrbitList a
take n = OrbitList . L.take n . unOrbitList take n = OrbitList . L.take n . unOrbitList

View file

@ -7,7 +7,10 @@ import Support.Rat
-- always sorted -- always sorted
newtype Support = Support { unSupport :: [Rat] } newtype Support = Support { unSupport :: [Rat] }
deriving (Show, Eq, Ord) deriving (Eq, Ord)
instance Show Support where
show = show . unSupport
size :: Support -> Int size :: Support -> Int
size = List.length . unSupport size = List.length . unSupport
@ -24,6 +27,9 @@ empty = Support []
union :: Support -> Support -> Support union :: Support -> Support -> Support
union (Support x) (Support y) = Support (OrdList.union x y) union (Support x) (Support y) = Support (OrdList.union x y)
intersect :: Support -> Support -> Support
intersect (Support x) (Support y) = Support (OrdList.isect x y)
singleton :: Rat -> Support singleton :: Rat -> Support
singleton r = Support [r] singleton r = Support [r]