1
Fork 0
mirror of https://github.com/Jaxan/nominal-lstar.git synced 2025-04-27 06:37:45 +02:00

Replaces all NominalType with Nominal

This commit is contained in:
Joshua Moerman 2023-05-31 15:52:17 +02:00
parent 98f9c6e295
commit eb94b82251
19 changed files with 71 additions and 69 deletions

View file

@ -24,7 +24,7 @@ data Aut = Fifo Int | Stack Int | Running Int | NFA1 | Bollig Int | NonResidual
deriving (Show, Read) deriving (Show, Read)
-- existential wrapper -- existential wrapper
data A = forall q i . (NominalType i, Contextual i, Show i, Read i, NominalType q, Show q) => A (Automaton q i) data A = forall q i . (Nominal i, Contextual i, Show i, Read i, Nominal q, Show q) => A (Automaton q i)
{- HLINT ignore "Redundant $" -} {- HLINT ignore "Redundant $" -}
mainExample :: String -> String -> String -> IO () mainExample :: String -> String -> String -> IO ()

View file

@ -13,7 +13,7 @@ import System.IO
data Learner = NomLStar | NomLStarCol | NomNLStar data Learner = NomLStar | NomLStarCol | NomNLStar
deriving (Show, Read) deriving (Show, Read)
learn :: (Read i, Contextual i, NominalType i, Show i) => Set i -> IO () learn :: (Read i, Contextual i, Nominal i, Show i) => Set i -> IO ()
learn alphSet = do learn alphSet = do
[learnerName] <- getArgs [learnerName] <- getArgs
let t = teacherWithIO2 alphSet let t = teacherWithIO2 alphSet

View file

@ -2,7 +2,7 @@ cabal-version: 2.2
name: nominal-lstar name: nominal-lstar
version: 0.1.0.0 version: 0.1.0.0
author: Joshua Moerman author: Joshua Moerman
copyright: (c) 2016 - 2020, Joshua Moerman copyright: (c) 2016 - 2023, Joshua Moerman
build-type: Simple build-type: Simple
extra-source-files: README.md extra-source-files: README.md
@ -10,7 +10,8 @@ common stuff
default-language: Haskell2010 default-language: Haskell2010
ghc-options: -O2 -Wall ghc-options: -O2 -Wall
build-depends: build-depends:
base >= 4.8 && < 5, -- at most 4.17: one transitive dependency breaks with more recent base
base >= 4.8 && < 4.17,
haskeline, haskeline,
NLambda >= 1.1 NLambda >= 1.1

View file

@ -16,7 +16,7 @@ import Prelude (Bool (..), Maybe (..), error, show, ($), (++), (.))
-- This returns all witnesses (of the form sa) for non-closedness -- This returns all witnesses (of the form sa) for non-closedness
closednessTest :: (NominalType i, _) => table -> TestResult i closednessTest :: (Nominal i, _) => table -> TestResult i
closednessTest t = case solve (isEmpty defect) of closednessTest t = case solve (isEmpty defect) of
Just True -> Succes Just True -> Succes
Just False -> trace "Not closed" $ Failed defect empty Just False -> trace "Not closed" $ Failed defect empty
@ -27,7 +27,7 @@ closednessTest t = case solve (isEmpty defect) of
defect = filter (not . hasEqRow) (rowsExt t) defect = filter (not . hasEqRow) (rowsExt t)
-- We look for inconsistencies and return columns witnessing it -- We look for inconsistencies and return columns witnessing it
consistencyTestDirect :: (NominalType i, _) => table -> TestResult i consistencyTestDirect :: (Nominal i, _) => table -> TestResult i
consistencyTestDirect t = case solve (isEmpty defect) of consistencyTestDirect t = case solve (isEmpty defect) of
Just True -> Succes Just True -> Succes
Just False -> trace "Not consistent" $ Failed empty defect Just False -> trace "Not consistent" $ Failed empty defect
@ -39,7 +39,7 @@ consistencyTestDirect t = case solve (isEmpty defect) of
-- Given a C&C table, constructs an automaton. The states are given by 2^E (not -- Given a C&C table, constructs an automaton. The states are given by 2^E (not
-- necessarily equivariant functions) -- necessarily equivariant functions)
constructHypothesis :: (NominalType i, _) => table -> Automaton (Row table) i constructHypothesis :: (Nominal i, _) => table -> Automaton (Row table) i
constructHypothesis t = simplify $ automaton q (alph t) d i f constructHypothesis t = simplify $ automaton q (alph t) d i f
where where
q = map (row t) (rows t) q = map (row t) (rows t)
@ -48,28 +48,28 @@ constructHypothesis t = simplify $ automaton q (alph t) d i f
f = filter (`contains` []) q f = filter (`contains` []) q
-- Extends the table with all prefixes of a set of counter examples. -- Extends the table with all prefixes of a set of counter examples.
useCounterExampleAngluin :: (NominalType i, _) => Teacher i -> Set [i] -> table -> table useCounterExampleAngluin :: (Nominal i, _) => Teacher i -> Set [i] -> table -> table
useCounterExampleAngluin teacher ces t = useCounterExampleAngluin teacher ces t =
let newRows = sum . map (fromList . inits) $ ces let newRows = sum . map (fromList . inits) $ ces
newRowsRed = newRows \\ rows t newRowsRed = newRows \\ rows t
in addRows (mqToBool teacher) newRowsRed t in addRows (mqToBool teacher) newRowsRed t
-- This is the variant by Maler and Pnueli: Adds all suffixes as columns -- This is the variant by Maler and Pnueli: Adds all suffixes as columns
useCounterExampleMP :: (NominalType i, _) => Teacher i -> Set [i] -> table -> table useCounterExampleMP :: (Nominal i, _) => Teacher i -> Set [i] -> table -> table
useCounterExampleMP teacher ces t = useCounterExampleMP teacher ces t =
let newColumns = sum . map (fromList . tails) $ ces let newColumns = sum . map (fromList . tails) $ ces
newColumnsRed = newColumns \\ cols t newColumnsRed = newColumns \\ cols t
in addColumns (mqToBool teacher) newColumnsRed t in addColumns (mqToBool teacher) newColumnsRed t
-- Default: use counter examples in columns, which is slightly faster -- Default: use counter examples in columns, which is slightly faster
learnAngluin :: (NominalType i, _) => Teacher i -> Automaton _ i learnAngluin :: (Nominal i, _) => Teacher i -> Automaton _ i
learnAngluin teacher = learnLoop useCounterExampleMP teacher (OT.initialBTable (mqToBool teacher) (alphabet teacher)) learnAngluin teacher = learnLoop useCounterExampleMP teacher (OT.initialBTable (mqToBool teacher) (alphabet teacher))
-- The "classical" version, where counter examples are added as rows -- The "classical" version, where counter examples are added as rows
learnAngluinRows :: (NominalType i, _) => Teacher i -> Automaton _ i learnAngluinRows :: (Nominal i, _) => Teacher i -> Automaton _ i
learnAngluinRows teacher = learnLoop useCounterExampleAngluin teacher (OT.initialBTable (mqToBool teacher) (alphabet teacher)) learnAngluinRows teacher = learnLoop useCounterExampleAngluin teacher (OT.initialBTable (mqToBool teacher) (alphabet teacher))
learnLoop :: (NominalType i, ObservationTable table i Bool, _) => _ -> Teacher i -> table -> Automaton (Row table) i learnLoop :: (Nominal i, ObservationTable table i Bool, _) => _ -> Teacher i -> table -> Automaton (Row table) i
learnLoop cexHandler teacher t = learnLoop cexHandler teacher t =
let let
-- No worry, these are computed lazily -- No worry, these are computed lazily

View file

@ -23,7 +23,7 @@ import Prelude (Bool (..), Int, Maybe (..), Show (..), ($), (++), (.))
-- This does hinder generalisations to other nominal join semi- -- This does hinder generalisations to other nominal join semi-
-- lattices than the Booleans. -- lattices than the Booleans.
rfsaClosednessTest :: (NominalType i, _) => Set (Row table) -> table -> TestResult i rfsaClosednessTest :: (Nominal i, _) => Set (Row table) -> table -> TestResult i
rfsaClosednessTest primesUpp t = case solve (isEmpty defect) of rfsaClosednessTest primesUpp t = case solve (isEmpty defect) of
Just True -> Succes Just True -> Succes
Just False -> trace "Not closed" $ Failed defect empty Just False -> trace "Not closed" $ Failed defect empty
@ -32,7 +32,7 @@ rfsaClosednessTest primesUpp t = case solve (isEmpty defect) of
where where
defect = filter (\ua -> row t ua `neq` sum (filter (`isSubsetOf` row t ua) primesUpp)) (rowsExt t) defect = filter (\ua -> row t ua `neq` sum (filter (`isSubsetOf` row t ua) primesUpp)) (rowsExt t)
rfsaConsistencyTest :: (NominalType i, _) => table -> TestResult i rfsaConsistencyTest :: (Nominal i, _) => table -> TestResult i
rfsaConsistencyTest t = case solve (isEmpty defect) of rfsaConsistencyTest t = case solve (isEmpty defect) of
Just True -> Succes Just True -> Succes
Just False -> trace "Not consistent" $ Failed empty defect Just False -> trace "Not consistent" $ Failed empty defect
@ -43,7 +43,7 @@ rfsaConsistencyTest t = case solve (isEmpty defect) of
defect = triplesWithFilter (\(u1, u2) a v -> maybeIf (not (tableAt2 (u1 ++ [a]) v) /\ tableAt2 (u2 ++ [a]) v) (a:v)) candidates (alph t) (cols t) defect = triplesWithFilter (\(u1, u2) a v -> maybeIf (not (tableAt2 (u1 ++ [a]) v) /\ tableAt2 (u2 ++ [a]) v) (a:v)) candidates (alph t) (cols t)
tableAt2 s e = singleton True `eq` tableAt t s e tableAt2 s e = singleton True `eq` tableAt t s e
constructHypothesisBollig :: (NominalType i, _) => Set (Row table) -> table -> Automaton (Row table) i constructHypothesisBollig :: (Nominal i, _) => Set (Row table) -> table -> Automaton (Row table) i
constructHypothesisBollig primesUpp t = automaton q (alph t) d i f constructHypothesisBollig primesUpp t = automaton q (alph t) d i f
where where
q = primesUpp q = primesUpp
@ -55,20 +55,20 @@ constructHypothesisBollig primesUpp t = automaton q (alph t) d i f
-- Adds all suffixes as columns -- Adds all suffixes as columns
-- TODO: do actual Rivest and Schapire -- TODO: do actual Rivest and Schapire
addCounterExample :: (NominalType i, _) => MQ i Bool -> Set [i] -> table -> table addCounterExample :: (Nominal i, _) => MQ i Bool -> Set [i] -> table -> table
addCounterExample mq ces t = addCounterExample mq ces t =
let newColumns = sum . map (fromList . tails) $ ces let newColumns = sum . map (fromList . tails) $ ces
newColumnsRed = newColumns \\ cols t newColumnsRed = newColumns \\ cols t
in addColumns mq newColumnsRed t in addColumns mq newColumnsRed t
learnBollig :: (NominalType i, _) => Int -> Int -> Teacher i -> Automaton _ i learnBollig :: (Nominal i, _) => Int -> Int -> Teacher i -> Automaton _ i
learnBollig k n teacher = learnBolligLoop teacher (BOT.initialBTableSize (mqToBool teacher) (alphabet teacher) k n) learnBollig k n teacher = learnBolligLoop teacher (BOT.initialBTableSize (mqToBool teacher) (alphabet teacher) k n)
-- Slow version -- Slow version
learnBolligOld :: (NominalType i, _) => Int -> Int -> Teacher i -> Automaton _ i learnBolligOld :: (Nominal i, _) => Int -> Int -> Teacher i -> Automaton _ i
learnBolligOld k n teacher = learnBolligLoop teacher (SOT.initialBTableSize (mqToBool teacher) (alphabet teacher) k n) learnBolligOld k n teacher = learnBolligLoop teacher (SOT.initialBTableSize (mqToBool teacher) (alphabet teacher) k n)
learnBolligLoop :: (NominalType i, _) => Teacher i -> table -> Automaton (Row table) i learnBolligLoop :: (Nominal i, _) => Teacher i -> table -> Automaton (Row table) i
learnBolligLoop teacher t = learnBolligLoop teacher t =
let let
-- These simplify's do speed up -- These simplify's do speed up

View file

@ -15,7 +15,7 @@ import Prelude (Bool (..), Eq, Int, Ord, Show (..), (++), (.))
import qualified Prelude () import qualified Prelude ()
-- Helper function -- Helper function
mqToSubset :: NominalType i => (Set [i] -> Set ([i], Bool)) -> Set [i] -> Set [i] mqToSubset :: Nominal i => (Set [i] -> Set ([i], Bool)) -> Set [i] -> Set [i]
mqToSubset mq = mapFilter (\(i, o) -> maybeIf (fromBool o) i) . mq mqToSubset mq = mapFilter (\(i, o) -> maybeIf (fromBool o) i) . mq
-- A table is nothing more than a part of the language. -- A table is nothing more than a part of the language.
@ -28,9 +28,9 @@ data Table i = Table
, colIndices :: Set (ColumnIndex i) , colIndices :: Set (ColumnIndex i)
, aa :: Set i , aa :: Set i
} }
deriving (Show, Ord, Eq, Generic, NominalType, Conditional, Contextual) deriving (Show, Ord, Eq, Generic, Nominal, Conditional, Contextual)
instance (NominalType i, Contextual i) => ObservationTable (Table i) i Bool where instance (Nominal i, Contextual i) => ObservationTable (Table i) i Bool where
type Row (Table i) = Set [i] type Row (Table i) = Set [i]
rows = rowIndices rows = rowIndices
cols = colIndices cols = colIndices
@ -62,7 +62,7 @@ instance (NominalType i, Contextual i) => ObservationTable (Table i) i Bool wher
newContent = mqToSubset mq newPartRed newContent = mqToSubset mq newPartRed
initialBTableWith :: NominalType i => MQ i Bool -> Set i -> Set (RowIndex i) -> Set (ColumnIndex i) -> Table i initialBTableWith :: Nominal i => MQ i Bool -> Set i -> Set (RowIndex i) -> Set (ColumnIndex i) -> Table i
initialBTableWith mq alphabet newRows newColumns = Table initialBTableWith mq alphabet newRows newColumns = Table
{ content = content { content = content
, domain = domain , domain = domain
@ -75,8 +75,8 @@ initialBTableWith mq alphabet newRows newColumns = Table
domain = pairsWith (++) newRows (newColumns `union` newColumnsExt) domain = pairsWith (++) newRows (newColumns `union` newColumnsExt)
content = mqToSubset mq domain content = mqToSubset mq domain
initialBTable :: NominalType i => MQ i Bool -> Set i -> Table i initialBTable :: Nominal i => MQ i Bool -> Set i -> Table i
initialBTable mq alphabet = initialBTableWith mq alphabet (singleton []) (singleton []) initialBTable mq alphabet = initialBTableWith mq alphabet (singleton []) (singleton [])
initialBTableSize :: NominalType i => MQ i Bool -> Set i -> Int -> Int -> Table i initialBTableSize :: Nominal i => MQ i Bool -> Set i -> Int -> Int -> Table i
initialBTableSize mq alphabet rs cs = initialBTableWith mq alphabet (replicateSetUntil rs alphabet) (replicateSetUntil cs alphabet) initialBTableSize mq alphabet rs cs = initialBTableWith mq alphabet (replicateSetUntil rs alphabet) (replicateSetUntil cs alphabet)

View file

@ -12,7 +12,7 @@ import qualified Prelude ()
-- Example automaton from the whiteboard. Three orbits with 0, 1 and 2 -- Example automaton from the whiteboard. Three orbits with 0, 1 and 2
-- registers. The third orbit has a local symmetry (S2). -- registers. The third orbit has a local symmetry (S2).
data Example1 = Initial | S1 Atom | S2 (Atom, Atom) data Example1 = Initial | S1 Atom | S2 (Atom, Atom)
deriving (Show, Eq, Ord, Generic, NominalType, Contextual) deriving (Show, Eq, Ord, Generic, Nominal, Contextual)
example1 :: Automaton Example1 Atom example1 :: Automaton Example1 Atom
example1 = automaton example1 = automaton
@ -37,7 +37,7 @@ example1 = automaton
-- Accepts all even words (ignores the alphabet). Two orbits, with a -- Accepts all even words (ignores the alphabet). Two orbits, with a
-- trivial action. No registers. -- trivial action. No registers.
data Aut2 = Even | Odd data Aut2 = Even | Odd
deriving (Eq, Ord, Show, Generic, NominalType, Contextual) deriving (Eq, Ord, Show, Generic, Nominal, Contextual)
example2 :: Automaton Aut2 Atom example2 :: Automaton Aut2 Atom
example2 = automaton example2 = automaton
@ -57,7 +57,7 @@ example2 = automaton
-- Accepts all non-empty words with the same symbol. Three orbits: the initial -- Accepts all non-empty words with the same symbol. Three orbits: the initial
-- state, a state with a register and a sink state. -- state, a state with a register and a sink state.
data Aut3 = Empty | Stored Atom | Sink data Aut3 = Empty | Stored Atom | Sink
deriving (Eq, Ord, Show, Generic, NominalType, Contextual) deriving (Eq, Ord, Show, Generic, Nominal, Contextual)
example3 :: Automaton Aut3 Atom example3 :: Automaton Aut3 Atom
example3 = automaton example3 = automaton
@ -86,7 +86,7 @@ data Aut4 = Aut4Init -- Initial state
| Second Atom Atom -- After reading two different symbols | Second Atom Atom -- After reading two different symbols
| Symm Atom Atom Atom -- Accepting state with C3 symmetry | Symm Atom Atom Atom -- Accepting state with C3 symmetry
| Sorted Atom Atom Atom -- State without symmetry | Sorted Atom Atom Atom -- State without symmetry
deriving (Eq, Ord, Show, Generic, NominalType, Contextual) deriving (Eq, Ord, Show, Generic, Nominal, Contextual)
example4 :: Automaton Aut4 Atom example4 :: Automaton Aut4 Atom
example4 = automaton example4 = automaton
@ -125,7 +125,7 @@ example4 = automaton
-- Accepts all two-symbols words with different atoms -- Accepts all two-symbols words with different atoms
data Aut5 = Aut5Init | Aut5Store Atom | Aut5T | Aut5F data Aut5 = Aut5Init | Aut5Store Atom | Aut5T | Aut5F
deriving (Eq, Ord, Show, Generic, NominalType, Contextual) deriving (Eq, Ord, Show, Generic, Nominal, Contextual)
example5 :: Automaton Aut5 Atom example5 :: Automaton Aut5 Atom
example5 = automaton example5 = automaton

View file

@ -14,7 +14,7 @@ import qualified Prelude ()
-- The complement of 'all distinct atoms' -- The complement of 'all distinct atoms'
-- Not determinizable -- Not determinizable
data NFA1 = Initial1 | Guessed1 Atom | Final1 data NFA1 = Initial1 | Guessed1 Atom | Final1
deriving (Show, Eq, Ord, Generic, NominalType, Contextual) deriving (Show, Eq, Ord, Generic, Nominal, Contextual)
exampleNFA1 :: Automaton NFA1 Atom exampleNFA1 :: Automaton NFA1 Atom
exampleNFA1 = automaton exampleNFA1 = automaton
@ -43,7 +43,7 @@ exampleNFA1 = automaton
-- So this one *is* determinizable. -- So this one *is* determinizable.
-- Also used in the Bollig et al paper. -- Also used in the Bollig et al paper.
data NFA2 = Initial2 | Distinguished Atom | Count Int data NFA2 = Initial2 | Distinguished Atom | Count Int
deriving (Show, Eq, Ord, Generic, NominalType, Contextual) deriving (Show, Eq, Ord, Generic, Nominal, Contextual)
exampleNFA2 :: Int -> Automaton NFA2 Atom exampleNFA2 :: Int -> Automaton NFA2 Atom
exampleNFA2 n = automaton exampleNFA2 n = automaton

View file

@ -14,7 +14,7 @@ import qualified Prelude ()
-- second list is to pop. If the second list is empty, it will reverse -- second list is to pop. If the second list is empty, it will reverse
-- the first. -- the first.
data Fifo a = Fifo [a] [a] data Fifo a = Fifo [a] [a]
deriving (Eq, Ord, Show, Generic, NominalType, Contextual) deriving (Eq, Ord, Show, Generic, Nominal, Contextual)
push :: a -> Fifo a -> Fifo a push :: a -> Fifo a -> Fifo a
push x (Fifo l1 l2) = Fifo (x:l1) l2 push x (Fifo l1 l2) = Fifo (x:l1) l2
@ -38,7 +38,7 @@ sizeFifo (Fifo l1 l2) = length l1 + length l2
-- The alphabet: -- The alphabet:
data DataInput = Put Atom | Get Atom data DataInput = Put Atom | Get Atom
deriving (Eq, Ord, Show, Read, Generic, NominalType, Contextual) deriving (Eq, Ord, Show, Read, Generic, Nominal, Contextual)
-- The automaton: States consist of fifo queues and a sink state. -- The automaton: States consist of fifo queues and a sink state.
-- This representation is not minimal at all, but that's OK, since the -- This representation is not minimal at all, but that's OK, since the

View file

@ -18,7 +18,7 @@ import qualified Prelude ()
-- Parametric in the alphabet, because why not? -- Parametric in the alphabet, because why not?
data NonResidual a = Q1 | Q2 a | Q3 a a | Q4 a | Q5 data NonResidual a = Q1 | Q2 a | Q3 a a | Q4 a | Q5
deriving (Eq, Ord, Show, Generic, NominalType, Contextual) deriving (Eq, Ord, Show, Generic, Nominal, Contextual)
exampleNonResidual :: Automaton (NonResidual Atom) Atom exampleNonResidual :: Automaton (NonResidual Atom) Atom
exampleNonResidual = automaton exampleNonResidual = automaton

View file

@ -13,7 +13,7 @@ import Prelude (Eq, Ord, Read, Show)
import qualified Prelude () import qualified Prelude ()
data Res1 a = QR1 a | QR2 | QEmpty data Res1 a = QR1 a | QR2 | QEmpty
deriving (Eq, Ord, Show, Generic, NominalType, Contextual) deriving (Eq, Ord, Show, Generic, Nominal, Contextual)
-- Language L = { w a | a fresh for w } + {eps}, but anchored with a new symbol -- Language L = { w a | a fresh for w } + {eps}, but anchored with a new symbol
exampleResidual1 :: Automaton (Res1 Atom) DataInput exampleResidual1 :: Automaton (Res1 Atom) DataInput
@ -35,10 +35,10 @@ exampleResidual1 = automaton
-- Example when learning breaks -- Example when learning breaks
data Res2 a = Guess a | GuessConfused a | Accept data Res2 a = Guess a | GuessConfused a | Accept
deriving (Eq, Ord, Show, Generic, NominalType, Contextual) deriving (Eq, Ord, Show, Generic, Nominal, Contextual)
data AlphabetR a = A a | Anc a data AlphabetR a = A a | Anc a
deriving (Eq, Ord, Show, Read, Generic, NominalType, Contextual) deriving (Eq, Ord, Show, Read, Generic, Nominal, Contextual)
exampleResidual2 :: Automaton (Res2 Atom) (AlphabetR Atom) exampleResidual2 :: Automaton (Res2 Atom) (AlphabetR Atom)
exampleResidual2 = automaton exampleResidual2 = automaton

View file

@ -18,9 +18,9 @@ import qualified Prelude ()
data RunningExample a = Store [a] | Check [a] | Accept | Reject data RunningExample a = Store [a] | Check [a] | Accept | Reject
deriving (Eq, Ord, Show, Generic, NominalType, Contextual) deriving (Eq, Ord, Show, Generic, Nominal, Contextual)
runningExample :: NominalType a => Set a -> Int -> Automaton (RunningExample a) a runningExample :: Nominal a => Set a -> Int -> Automaton (RunningExample a) a
runningExample alphabet 0 = automaton runningExample alphabet 0 = automaton
(fromList [Accept, Reject]) (fromList [Accept, Reject])
alphabet alphabet

View file

@ -12,7 +12,7 @@ import qualified Prelude ()
-- Functional stack data type is simply a list. -- Functional stack data type is simply a list.
newtype Stack a = Stack [a] newtype Stack a = Stack [a]
deriving (Eq, Ord, Show, Generic, NominalType, Contextual) deriving (Eq, Ord, Show, Generic, Nominal, Contextual)
push :: a -> Stack a -> Stack a push :: a -> Stack a -> Stack a
push x (Stack l1) = Stack (x:l1) push x (Stack l1) = Stack (x:l1)

View file

@ -3,7 +3,8 @@
module ObservationTableClass where module ObservationTableClass where
import NLambda (NominalType, Set, pairsWith) import Data.Kind (Type)
import NLambda (Nominal, Set, pairsWith)
import Prelude ((++)) import Prelude ((++))
-- Words are indices to our table -- Words are indices to our table
@ -14,9 +15,9 @@ type ColumnIndex i = [i]
type MQ i o = Set [i] -> Set ([i], o) type MQ i o = Set [i] -> Set ([i], o)
-- This is a fat class, so that instances could give more efficient implementations -- This is a fat class, so that instances could give more efficient implementations
class (NominalType table, NominalType i, NominalType o) => ObservationTable table i o | table -> i o where class (Nominal table, Nominal i, Nominal o) => ObservationTable table i o | table -> i o where
-- The type of data in a row is determined by the table -- The type of data in a row is determined by the table
type Row table :: * type Row table :: Type
-- getters -- getters
rows :: table -> Set (RowIndex i) rows :: table -> Set (RowIndex i)

View file

@ -22,7 +22,7 @@ import qualified Prelude ()
-- Except when o = Bool, more on that later -- Except when o = Bool, more on that later
type Fun i o = Set (i, o) type Fun i o = Set (i, o)
dom :: (NominalType i, NominalType o) => Fun i o -> Set i dom :: (Nominal i, Nominal o) => Fun i o -> Set i
dom = map fst dom = map fst
-- A table is nothing more than a part of the language. -- A table is nothing more than a part of the language.
@ -34,9 +34,9 @@ data Table i o = Table
, colIndices :: Set (ColumnIndex i) , colIndices :: Set (ColumnIndex i)
, aa :: Set i , aa :: Set i
} }
deriving (Show, Ord, Eq, Generic, NominalType, Conditional, Contextual) deriving (Show, Ord, Eq, Generic, Nominal, Conditional, Contextual)
instance (NominalType i, NominalType o) => ObservationTable (Table i o) i o where instance (Nominal i, Nominal o) => ObservationTable (Table i o) i o where
type Row (Table i o) = Fun [i] o type Row (Table i o) = Fun [i] o
rows = rowIndices rows = rowIndices
cols = colIndices cols = colIndices
@ -70,11 +70,11 @@ instance (NominalType i, NominalType o) => ObservationTable (Table i o) i o wher
-- We can reuse the above tables for the Boolean case and -- We can reuse the above tables for the Boolean case and
-- perform some minor optimisations. -- perform some minor optimisations.
newtype Boolean table = B { unB :: table } newtype Boolean table = B { unB :: table }
deriving (Show, Ord, Eq, Generic, NominalType, Conditional, Contextual) deriving (Show, Ord, Eq, Generic, Nominal, Conditional, Contextual)
type BTable i = Boolean (Table i Bool) type BTable i = Boolean (Table i Bool)
instance (NominalType i) => ObservationTable (BTable i) i Bool where instance (Nominal i) => ObservationTable (BTable i) i Bool where
-- Special case of a boolean: functions to Booleans are subsets -- Special case of a boolean: functions to Booleans are subsets
type Row (BTable i) = Set [i] type Row (BTable i) = Set [i]
@ -94,7 +94,7 @@ instance (NominalType i) => ObservationTable (BTable i) i Bool where
rowEps (B Table{..}) = mapFilter (\(i, o) -> maybeIf (fromBool o /\ i `member` colIndices) i) content rowEps (B Table{..}) = mapFilter (\(i, o) -> maybeIf (fromBool o /\ i `member` colIndices) i) content
initialTableWith :: (NominalType i, NominalType o) => MQ i o -> Set i -> Set (RowIndex i) -> Set (ColumnIndex i) -> Table i o initialTableWith :: (Nominal i, Nominal o) => MQ i o -> Set i -> Set (RowIndex i) -> Set (ColumnIndex i) -> Table i o
initialTableWith mq alphabet newRows newColumns = Table initialTableWith mq alphabet newRows newColumns = Table
{ content = content { content = content
, rowIndices = newRows , rowIndices = newRows
@ -106,17 +106,17 @@ initialTableWith mq alphabet newRows newColumns = Table
domain = pairsWith (++) newRows (newColumns `union` newColumnsExt) domain = pairsWith (++) newRows (newColumns `union` newColumnsExt)
content = mq domain content = mq domain
initialTable :: (NominalType i, NominalType o) => MQ i o -> Set i -> Table i o initialTable :: (Nominal i, Nominal o) => MQ i o -> Set i -> Table i o
initialTable mq alphabet = initialTableWith mq alphabet (singleton []) (singleton []) initialTable mq alphabet = initialTableWith mq alphabet (singleton []) (singleton [])
initialTableSize :: (NominalType i, NominalType o) => MQ i o -> Set i -> Int -> Int -> Table i o initialTableSize :: (Nominal i, Nominal o) => MQ i o -> Set i -> Int -> Int -> Table i o
initialTableSize mq alphabet rs cs = initialTableWith mq alphabet (replicateSetUntil rs alphabet) (replicateSetUntil cs alphabet) initialTableSize mq alphabet rs cs = initialTableWith mq alphabet (replicateSetUntil rs alphabet) (replicateSetUntil cs alphabet)
initialBTableWith :: NominalType i => MQ i Bool -> Set i -> Set (RowIndex i) -> Set (ColumnIndex i) -> BTable i initialBTableWith :: Nominal i => MQ i Bool -> Set i -> Set (RowIndex i) -> Set (ColumnIndex i) -> BTable i
initialBTableWith = coerce initialTableWith initialBTableWith = coerce initialTableWith
initialBTable :: NominalType i => MQ i Bool -> Set i -> BTable i initialBTable :: Nominal i => MQ i Bool -> Set i -> BTable i
initialBTable = coerce initialTable initialBTable = coerce initialTable
initialBTableSize :: NominalType i => MQ i Bool -> Set i -> Int -> Int -> BTable i initialBTableSize :: Nominal i => MQ i Bool -> Set i -> Int -> Int -> BTable i
initialBTableSize = coerce initialTableSize initialBTableSize = coerce initialTableSize

View file

@ -23,7 +23,7 @@ import Prelude hiding (map)
-- The teacher interface is slightly inconvenient -- The teacher interface is slightly inconvenient
-- But this is for a good reason. The type [i] -> o -- But this is for a good reason. The type [i] -> o
-- doesn't work well in nlambda -- doesn't work well in nlambda
mqToBool :: NominalType i => Teacher i -> Set [i] -> Set ([i], Bool) mqToBool :: Nominal i => Teacher i -> Set [i] -> Set ([i], Bool)
mqToBool teacher qs = answer mqToBool teacher qs = answer
where where
realQ = membership teacher qs realQ = membership teacher qs
@ -41,7 +41,7 @@ mqToBool teacher qs = answer
-- 1. This is a fully automatic teacher, which has an internal automaton -- 1. This is a fully automatic teacher, which has an internal automaton
-- Only works for DFAs for now, as those can be checked for equivalence -- Only works for DFAs for now, as those can be checked for equivalence
teacherWithTarget :: (NominalType i, NominalType q) => Automaton q i -> Teacher i teacherWithTarget :: (Nominal i, Nominal q) => Automaton q i -> Teacher i
teacherWithTarget aut = Teacher teacherWithTarget aut = Teacher
{ membership = foreachQuery $ accepts aut { membership = foreachQuery $ accepts aut
, equivalent = automaticEquivalent bisim aut , equivalent = automaticEquivalent bisim aut
@ -50,7 +50,7 @@ teacherWithTarget aut = Teacher
-- 1b. This is a fully automatic teacher, which has an internal automaton -- 1b. This is a fully automatic teacher, which has an internal automaton
-- NFA have undecidable equivalence, n is a bound on deoth of bisimulation. -- NFA have undecidable equivalence, n is a bound on deoth of bisimulation.
teacherWithTargetNonDet :: (Show i, Show q, NominalType i, NominalType q) => Int -> Automaton q i -> Teacher i teacherWithTargetNonDet :: (Show i, Show q, Nominal i, Nominal q) => Int -> Automaton q i -> Teacher i
teacherWithTargetNonDet n aut = Teacher teacherWithTargetNonDet n aut = Teacher
{ membership = foreachQuery $ accepts aut { membership = foreachQuery $ accepts aut
, equivalent = automaticEquivalent (bisimNonDet n) aut , equivalent = automaticEquivalent (bisimNonDet n) aut
@ -62,7 +62,7 @@ teacherWithTargetNonDet n aut = Teacher
-- Note that parsing is very unforgiving, one mistake, and there is no way back -- Note that parsing is very unforgiving, one mistake, and there is no way back
-- Atoms are referenced by Ints. When the user provides a counter example, we -- Atoms are referenced by Ints. When the user provides a counter example, we
-- consider the whole orbit generated by it. -- consider the whole orbit generated by it.
teacherWithIO :: (Show i, Read i, NominalType i, Contextual i) => Set i -> Teacher i teacherWithIO :: (Show i, Read i, Nominal i, Contextual i) => Set i -> Teacher i
teacherWithIO alph = Teacher teacherWithIO alph = Teacher
{ membership = ioMembership { membership = ioMembership
, equivalent = ioEquivalent , equivalent = ioEquivalent
@ -70,7 +70,7 @@ teacherWithIO alph = Teacher
} }
-- 2b. Same as above. But with machine readable queries (except for EQs maybe) -- 2b. Same as above. But with machine readable queries (except for EQs maybe)
teacherWithIO2 :: (Show i, Read i, NominalType i, Contextual i) => Set i -> Teacher i teacherWithIO2 :: (Show i, Read i, Nominal i, Contextual i) => Set i -> Teacher i
teacherWithIO2 alph = Teacher teacherWithIO2 alph = Teacher
{ membership = ioMembership2 { membership = ioMembership2
, equivalent = ioEquivalent2 , equivalent = ioEquivalent2
@ -80,7 +80,7 @@ teacherWithIO2 alph = Teacher
-- 3. A teacher uses a target for the mebership queries, but you for equivalence -- 3. A teacher uses a target for the mebership queries, but you for equivalence
-- Useful as long as you don't have an equivalence check -- Useful as long as you don't have an equivalence check
-- used for NFAs when there was no bounded bisimulation yet -- used for NFAs when there was no bounded bisimulation yet
teacherWithTargetAndIO :: (Show i, Read i, NominalType i, Contextual i, NominalType q) => Automaton q i -> Teacher i teacherWithTargetAndIO :: (Show i, Read i, Nominal i, Contextual i, Nominal q) => Automaton q i -> Teacher i
teacherWithTargetAndIO aut = Teacher teacherWithTargetAndIO aut = Teacher
{ membership = foreachQuery $ accepts aut { membership = foreachQuery $ accepts aut
, equivalent = ioEquivalent , equivalent = ioEquivalent

View file

@ -17,12 +17,12 @@ data Teacher i = Teacher
-- Given a hypothesis, returns Nothing when equivalence or a (equivariant) -- Given a hypothesis, returns Nothing when equivalence or a (equivariant)
-- set of counter examples. Needs to be quantified over q, because the -- set of counter examples. Needs to be quantified over q, because the
-- learner may choose the type of the state space. -- learner may choose the type of the state space.
, equivalent :: forall q. (Show q, NominalType q) => Automaton q i -> Maybe (Set [i]) , equivalent :: forall q. (Show q, Nominal q) => Automaton q i -> Maybe (Set [i])
-- Returns the alphabet to the learner -- Returns the alphabet to the learner
, alphabet :: Set i , alphabet :: Set i
} }
-- Often a membership query is defined by a function [i] -> Formula. This wraps -- Often a membership query is defined by a function [i] -> Formula. This wraps
-- such a function to the required type for a membership query (see above). -- such a function to the required type for a membership query (see above).
foreachQuery :: NominalType i => ([i] -> Formula) -> Set[i] -> Set ([i], Formula) foreachQuery :: Nominal i => ([i] -> Formula) -> Set[i] -> Set ([i], Formula)
foreachQuery f = map (\q -> (q, f q)) foreachQuery f = map (\q -> (q, f q))

View file

@ -9,7 +9,7 @@ import System.IO.Unsafe (unsafePerformIO)
import Text.Read (readMaybe) import Text.Read (readMaybe)
-- Posing a membership query to the terminal and waits for used to input a formula -- Posing a membership query to the terminal and waits for used to input a formula
ioMembership :: (Show i, NominalType i, Contextual i) => Set [i] -> Set ([i], Formula) ioMembership :: (Show i, Nominal i, Contextual i) => Set [i] -> Set ([i], Formula)
ioMembership queries = unsafePerformIO $ do ioMembership queries = unsafePerformIO $ do
cache <- readIORef mqCache cache <- readIORef mqCache
let cachedAnswers = filter (\(a, _) -> a `member` queries) cache let cachedAnswers = filter (\(a, _) -> a `member` queries) cache
@ -41,7 +41,7 @@ ioMembership queries = unsafePerformIO $ do
-- Same as above, but with a machine-readable format -- Same as above, but with a machine-readable format
ioMembership2 :: (Show i, NominalType i, Contextual i) => Set [i] -> Set ([i], Formula) ioMembership2 :: (Show i, Nominal i, Contextual i) => Set [i] -> Set ([i], Formula)
ioMembership2 queries = unsafePerformIO $ do ioMembership2 queries = unsafePerformIO $ do
cache <- readIORef mqCache cache <- readIORef mqCache
let cachedAnswers = filter (\(a, _) -> a `member` queries) cache let cachedAnswers = filter (\(a, _) -> a `member` queries) cache
@ -73,7 +73,7 @@ newtype TestIO i = T [i]
-- Poses a query to the terminal, waiting for the user to provide a counter example -- Poses a query to the terminal, waiting for the user to provide a counter example
-- User can pose a "test query" which is evaluated on the hypothesis -- User can pose a "test query" which is evaluated on the hypothesis
ioEquivalent :: (Show q, NominalType q, Show i, Read i, NominalType i) => Automaton q i -> Maybe (Set [i]) ioEquivalent :: (Show q, Nominal q, Show i, Read i, Nominal i) => Automaton q i -> Maybe (Set [i])
ioEquivalent hypothesis = unsafePerformIO $ do ioEquivalent hypothesis = unsafePerformIO $ do
putStrLn "\n# Is the following automaton correct?" putStrLn "\n# Is the following automaton correct?"
putStr "# " putStr "# "
@ -102,7 +102,7 @@ ioEquivalent hypothesis = unsafePerformIO $ do
-- Same as above but in different format. -- Same as above but in different format.
-- This is used for automation and benchmarking different nominal tools -- This is used for automation and benchmarking different nominal tools
ioEquivalent2 :: (Show q, NominalType q, Show i, Read i, NominalType i) => Automaton q i -> Maybe (Set [i]) ioEquivalent2 :: (Show q, Nominal q, Show i, Read i, Nominal i) => Automaton q i -> Maybe (Set [i])
ioEquivalent2 hypothesis = unsafePerformIO $ do ioEquivalent2 hypothesis = unsafePerformIO $ do
putStrLn "EQ\n\"Is the following automaton correct?" putStrLn "EQ\n\"Is the following automaton correct?"
print hypothesis print hypothesis

View file

@ -8,7 +8,7 @@ import Prelude hiding (filter, map, not, sum)
-- Checks bisimulation of initial states (only for DFAs) -- Checks bisimulation of initial states (only for DFAs)
-- returns some counterexamples if not bisimilar -- returns some counterexamples if not bisimilar
-- returns empty set iff bisimilar -- returns empty set iff bisimilar
bisim :: (NominalType i, NominalType q1, NominalType q2) => Automaton q1 i -> Automaton q2 i -> Set [i] bisim :: (Nominal i, Nominal q1, Nominal q2) => Automaton q1 i -> Automaton q2 i -> Set [i]
bisim aut1 aut2 = go empty (pairsWith addEmptyWord (initialStates aut1) (initialStates aut2)) bisim aut1 aut2 = go empty (pairsWith addEmptyWord (initialStates aut1) (initialStates aut2))
where where
go rel todo = go rel todo =
@ -37,7 +37,7 @@ bisim aut1 aut2 = go empty (pairsWith addEmptyWord (initialStates aut1) (initial
-- I am not sure about correctness, but that is not really an issue for our -- I am not sure about correctness, but that is not really an issue for our
-- use-case. Note that deciding equivalence of NFAs is undecidable, so we -- use-case. Note that deciding equivalence of NFAs is undecidable, so we
-- bound the bisimulation depth. -- bound the bisimulation depth.
bisimNonDet :: (Show i, Show q1, Show q2, NominalType i, NominalType q1, NominalType q2) => Int -> Automaton q1 i -> Automaton q2 i -> Set [i] bisimNonDet :: (Show i, Show q1, Show q2, Nominal i, Nominal q1, Nominal q2) => Int -> Automaton q1 i -> Automaton q2 i -> Set [i]
bisimNonDet n aut1 aut2 = go empty (singleton ([], initialStates aut1, initialStates aut2)) bisimNonDet n aut1 aut2 = go empty (singleton ([], initialStates aut1, initialStates aut2))
where where
go rel todo0 = go rel todo0 =