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

Not much

Browse source
This commit is contained in:
Joshua Moerman 2019-01-09 15:54:47 +01:00
parent b414b64c1a
commit 01319327af
1 changed files with 23 additions and 9 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

32
app/LStar.hs
View file

@ -8,14 +8,13 @@ module Main where
import Nominal hiding (product) import Nominal hiding (product)
import Support (Rat(..), Support(..), intersect) import Support (Rat(..), Support(..), intersect)
import OrbitList --(OrbitList(..), singleOrbit, product, productWith, filter, null, elem, rationals) import OrbitList
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 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, partition) import Prelude hiding (filter, null, elem, lookup, product, Word, map, take, partition)
@ -71,6 +70,7 @@ ask mq table (p, s) =
Just b -> return (w, b) Just b -> return (w, b)
Nothing -> (w,) <$> mq w Nothing -> (w,) <$> mq w
-- Non trivial, should be made more efficient
quotient :: _ => EquivariantSet (a, a) -> OrbitList a -> (EquivariantMap a (Int, Support), OrbitList (Int, Support)) quotient :: _ => EquivariantSet (a, a) -> OrbitList a -> (EquivariantMap a (Int, Support), OrbitList (Int, Support))
quotient equiv ls = go 0 Map.empty OrbitList.empty (toList ls) quotient equiv ls = go 0 Map.empty OrbitList.empty (toList ls)
where where
@ -160,23 +160,37 @@ learn mq = do
trans = Map.fromList . toList . map (\(s, t) -> (s, f ! t)) . filter (\(s, t) -> equalRows s t suffs table) $ product prefsExt 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 trans2 pa = if pa `elem` prefsExt then trans ! pa else f ! pa
lift (print (Map.toList trans)) lift (print (Map.toList trans))
return Automaton let hypothesis = Automaton
{ states = s { states = s
, initialState = f ! [] , initialState = f ! []
, acceptance = Map.fromList . toList . map (\p -> (f ! p, table ! p)) $ prefs , 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 , transition = Map.fromList . toList . map (\(p, a) -> ((f ! p, a), trans2 (ext p a))) $ product prefs alph
} }
eq <- lift (askEquiv hypothesis)
case eq of
Nothing -> return hypothesis
Just w -> error "No counterexample handling yet"
accept :: Show a => Word a -> IO Bool accept :: Show a => Word a -> IO Bool
accept w = do accept w = do
print w putStr "MQ \""
putStr (show w)
putStrLn "\""
a <- getLine a <- getLine
case a of case a of
"Y" -> return True "Y" -> return True
"N" -> return False "N" -> return False
_ -> accept w _ -> accept w
askEquiv :: _ => Automaton q a -> IO (Maybe (Word a))
askEquiv aut = do
putStr "EQ \""
putStr (show aut)
putStrLn "\""
a <- getLine
return Nothing
main :: IO () main :: IO ()
main = do main = do
let alph = rationals let alph = rationals