mirror of
https://github.com/Jaxan/nominal-lstar.git
synced 2025-04-27 14:47:45 +02:00
Faster version of the nominal NL* algorithm by specialising the observation table to Booleans
This commit is contained in:
parent
c2b2907555
commit
7b41e7d97c
7 changed files with 110 additions and 22 deletions
2
.gitignore
vendored
2
.gitignore
vendored
|
@ -4,5 +4,7 @@ dist/
|
||||||
*.hi
|
*.hi
|
||||||
*.prof
|
*.prof
|
||||||
*.code-workspace
|
*.code-workspace
|
||||||
|
.stack-work
|
||||||
|
.vscode
|
||||||
bench.csv
|
bench.csv
|
||||||
|
|
||||||
|
|
|
@ -24,6 +24,7 @@ import NLambda
|
||||||
Examples.example4 is not used, because it takes a bit too long.
|
Examples.example4 is not used, because it takes a bit too long.
|
||||||
-}
|
-}
|
||||||
|
|
||||||
|
myConfig :: Config
|
||||||
myConfig = defaultConfig
|
myConfig = defaultConfig
|
||||||
{ quickMode = True
|
{ quickMode = True
|
||||||
, includeFirstIter = True
|
, includeFirstIter = True
|
||||||
|
@ -36,6 +37,7 @@ stackBound = 4
|
||||||
doublewordBound = 3
|
doublewordBound = 3
|
||||||
nlastpositionBound = 4
|
nlastpositionBound = 4
|
||||||
|
|
||||||
|
main :: IO ()
|
||||||
main = defaultMainWith myConfig
|
main = defaultMainWith myConfig
|
||||||
[ bgroup "NomLStarR"
|
[ bgroup "NomLStarR"
|
||||||
[ bgroup "Fifo" $
|
[ bgroup "Fifo" $
|
||||||
|
|
|
@ -21,6 +21,7 @@ library
|
||||||
AbstractLStar,
|
AbstractLStar,
|
||||||
Angluin,
|
Angluin,
|
||||||
Bollig,
|
Bollig,
|
||||||
|
BooleanObservationTable,
|
||||||
Examples,
|
Examples,
|
||||||
Examples.Contrived,
|
Examples.Contrived,
|
||||||
Examples.ContrivedNFAs,
|
Examples.ContrivedNFAs,
|
||||||
|
|
|
@ -1,14 +1,17 @@
|
||||||
|
{-# language FlexibleContexts #-}
|
||||||
{-# language PartialTypeSignatures #-}
|
{-# language PartialTypeSignatures #-}
|
||||||
|
{-# language TypeFamilies #-}
|
||||||
{-# OPTIONS_GHC -Wno-partial-type-signatures #-}
|
{-# OPTIONS_GHC -Wno-partial-type-signatures #-}
|
||||||
module Bollig where
|
module Bollig where
|
||||||
|
|
||||||
import AbstractLStar
|
import AbstractLStar
|
||||||
|
import qualified BooleanObservationTable as BOT
|
||||||
import ObservationTableClass
|
import ObservationTableClass
|
||||||
import SimpleObservationTable
|
import qualified SimpleObservationTable as SOT
|
||||||
import Teacher
|
import Teacher
|
||||||
|
|
||||||
import Data.List (tails)
|
import Data.List (tails)
|
||||||
import Debug.Trace
|
import Debug.Trace (trace, traceShow)
|
||||||
import NLambda hiding (alphabet)
|
import NLambda hiding (alphabet)
|
||||||
import Prelude (Bool (..), Int, Maybe (..), Show (..), snd, ($), (++), (.))
|
import Prelude (Bool (..), Int, Maybe (..), Show (..), snd, ($), (++), (.))
|
||||||
|
|
||||||
|
@ -31,7 +34,7 @@ mqToBool teacher words = answer
|
||||||
answer = map (setB True) inw `union` map (setB False) outw
|
answer = map (setB True) inw `union` map (setB False) outw
|
||||||
setB b (w, _) = (w, b)
|
setB b (w, _) = (w, b)
|
||||||
|
|
||||||
rfsaClosednessTest :: NominalType i => Set (BRow i) -> BTable i -> TestResult i
|
rfsaClosednessTest :: (NominalType 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
|
||||||
|
@ -40,7 +43,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 => BTable i -> TestResult i
|
rfsaConsistencyTest :: (NominalType 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
|
||||||
|
@ -51,7 +54,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 (BRow i) -> BTable i -> Automaton (BRow i) i
|
constructHypothesisBollig :: (NominalType 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
|
||||||
|
@ -63,16 +66,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] -> BTable i -> BTable i
|
addCounterExample :: (NominalType 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 (BRow i) i
|
-- Slow version
|
||||||
learnBollig k n teacher = learnBolligLoop teacher (initialBTableSize (mqToBool teacher) (alphabet teacher) k n)
|
learnBolligOld :: (NominalType i, _) => Int -> Int -> Teacher i -> Automaton (Row (SOT.BTable i)) i
|
||||||
|
learnBolligOld k n teacher = learnBolligLoop teacher (SOT.initialBTableSize (mqToBool teacher) (alphabet teacher) k n)
|
||||||
|
|
||||||
learnBolligLoop :: (NominalType i, _) => Teacher i -> BTable i -> Automaton (BRow i) i
|
learnBollig :: (NominalType i, _) => Int -> Int -> Teacher i -> Automaton (Row (BOT.Table i)) i
|
||||||
|
learnBollig k n teacher = learnBolligLoop teacher (BOT.initialBTableSize (mqToBool teacher) (alphabet teacher) k n)
|
||||||
|
|
||||||
|
learnBolligLoop :: (NominalType 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
|
||||||
|
|
77
src/BooleanObservationTable.hs
Normal file
77
src/BooleanObservationTable.hs
Normal file
|
@ -0,0 +1,77 @@
|
||||||
|
{-# language DeriveAnyClass #-}
|
||||||
|
{-# language DeriveGeneric #-}
|
||||||
|
{-# language FlexibleInstances #-}
|
||||||
|
{-# language MultiParamTypeClasses #-}
|
||||||
|
{-# language RecordWildCards #-}
|
||||||
|
{-# language TypeFamilies #-}
|
||||||
|
|
||||||
|
module BooleanObservationTable where
|
||||||
|
|
||||||
|
import ObservationTableClass
|
||||||
|
|
||||||
|
import GHC.Generics (Generic)
|
||||||
|
import NLambda
|
||||||
|
import Prelude (Bool (..), Eq, Int, Ord, Show (..), (++), (.))
|
||||||
|
import qualified Prelude ()
|
||||||
|
|
||||||
|
-- Helper function
|
||||||
|
mqToSubset :: NominalType i => (Set [i] -> Set ([i], Bool)) -> Set [i] -> Set [i]
|
||||||
|
mqToSubset mq = mapFilter (\(i, o) -> maybeIf (fromBool o) i) . mq
|
||||||
|
|
||||||
|
-- A table is nothing more than a part of the language.
|
||||||
|
-- Invariant: content is always a subset of
|
||||||
|
-- `rows * columns` union `rows * alph * columns`.
|
||||||
|
data Table i = Table
|
||||||
|
{ content :: Set [i]
|
||||||
|
, rowIndices :: Set (RowIndex i)
|
||||||
|
, colIndices :: Set (ColumnIndex i)
|
||||||
|
, aa :: Set i
|
||||||
|
}
|
||||||
|
deriving (Show, Ord, Eq, Generic, NominalType, Conditional, Contextual)
|
||||||
|
|
||||||
|
-- Currently, it may ask redundant membership queries
|
||||||
|
instance (NominalType i, Contextual i) => ObservationTable (Table i) i Bool where
|
||||||
|
type Row (Table i) = Set [i]
|
||||||
|
rows = rowIndices
|
||||||
|
cols = colIndices
|
||||||
|
alph = aa
|
||||||
|
row Table{..} r = filter (\e -> (r ++ e) `member` content) colIndices
|
||||||
|
rowEps Table{..} = intersection content colIndices
|
||||||
|
tableAt Table{..} r c = ite ((r ++ c) `member` content) (singleton True) (singleton False)
|
||||||
|
|
||||||
|
addRows mq newRows t@Table{..} =
|
||||||
|
t { content = content `union` newContent
|
||||||
|
, rowIndices = rowIndices `union` newRows
|
||||||
|
}
|
||||||
|
where
|
||||||
|
newRowsExt = pairsWith (\r a -> r ++ [a]) newRows aa
|
||||||
|
newPart = pairsWith (++) (newRows `union` newRowsExt) colIndices
|
||||||
|
newContent = mqToSubset mq newPart
|
||||||
|
|
||||||
|
addColumns mq newColumns t@Table{..} =
|
||||||
|
t { content = content `union` newContent
|
||||||
|
, colIndices = colIndices `union` newColumns
|
||||||
|
}
|
||||||
|
where
|
||||||
|
newColumnsExt = pairsWith (:) aa newColumns
|
||||||
|
newPart = pairsWith (++) rowIndices (newColumns `union` newColumnsExt)
|
||||||
|
newContent = mqToSubset mq newPart
|
||||||
|
|
||||||
|
|
||||||
|
initialBTableWith :: NominalType i => MQ i Bool -> Set i -> Set (RowIndex i) -> Set (ColumnIndex i) -> Table i
|
||||||
|
initialBTableWith mq alphabet newRows newColumns = Table
|
||||||
|
{ content = content
|
||||||
|
, rowIndices = newRows
|
||||||
|
, colIndices = newColumns
|
||||||
|
, aa = alphabet
|
||||||
|
}
|
||||||
|
where
|
||||||
|
newColumnsExt = pairsWith (:) alphabet newColumns
|
||||||
|
domain = pairsWith (++) newRows (newColumns `union` newColumnsExt)
|
||||||
|
content = mqToSubset mq domain
|
||||||
|
|
||||||
|
initialBTable :: NominalType i => MQ i Bool -> Set i -> Table i
|
||||||
|
initialBTable mq alphabet = initialBTableWith mq alphabet (singleton []) (singleton [])
|
||||||
|
|
||||||
|
initialBTableSize :: NominalType i => MQ i Bool -> Set i -> Int -> Int -> Table i
|
||||||
|
initialBTableSize mq alphabet rs cs = initialBTableWith mq alphabet (replicateSetUntil rs alphabet) (replicateSetUntil cs alphabet)
|
|
@ -1,9 +1,9 @@
|
||||||
{-# language TypeFamilies #-}
|
|
||||||
{-# language FunctionalDependencies #-}
|
{-# language FunctionalDependencies #-}
|
||||||
|
{-# language TypeFamilies #-}
|
||||||
|
|
||||||
module ObservationTableClass where
|
module ObservationTableClass where
|
||||||
|
|
||||||
import NLambda
|
import NLambda (NominalType, Set, pairsWith)
|
||||||
import Prelude ((++))
|
import Prelude ((++))
|
||||||
|
|
||||||
-- Words are indices to our table
|
-- Words are indices to our table
|
||||||
|
|
|
@ -1,22 +1,21 @@
|
||||||
{-# language DeriveAnyClass #-}
|
{-# language DeriveAnyClass #-}
|
||||||
{-# language DeriveGeneric #-}
|
{-# language DeriveGeneric #-}
|
||||||
{-# language RecordWildCards #-}
|
|
||||||
{-# language FlexibleInstances #-}
|
{-# language FlexibleInstances #-}
|
||||||
{-# language MultiParamTypeClasses #-}
|
{-# language MultiParamTypeClasses #-}
|
||||||
{-# language TypeFamilies #-}
|
|
||||||
{-# language PartialTypeSignatures #-}
|
{-# language PartialTypeSignatures #-}
|
||||||
|
{-# language RecordWildCards #-}
|
||||||
|
{-# language TypeFamilies #-}
|
||||||
{-# OPTIONS_GHC -Wno-partial-type-signatures #-}
|
{-# OPTIONS_GHC -Wno-partial-type-signatures #-}
|
||||||
|
|
||||||
module SimpleObservationTable where
|
module SimpleObservationTable where
|
||||||
|
|
||||||
import ObservationTableClass
|
import ObservationTableClass
|
||||||
|
|
||||||
import NLambda hiding (fromJust)
|
|
||||||
|
|
||||||
import GHC.Generics (Generic)
|
|
||||||
import Prelude (Bool (..), Eq, Int, Ord, Show (..), fst, (++), (.))
|
|
||||||
import qualified Prelude ()
|
|
||||||
import Data.Coerce (coerce)
|
import Data.Coerce (coerce)
|
||||||
|
import GHC.Generics (Generic)
|
||||||
|
import NLambda
|
||||||
|
import Prelude (Bool (..), Eq, Int, Ord, Show (..), fst, (++))
|
||||||
|
import qualified Prelude ()
|
||||||
|
|
||||||
|
|
||||||
-- We represent functions as their graphs
|
-- We represent functions as their graphs
|
||||||
|
@ -30,10 +29,10 @@ dom = map fst
|
||||||
-- Invariant: content is always defined for elements in
|
-- Invariant: content is always defined for elements in
|
||||||
-- `rows * columns` and `rows * alph * columns`.
|
-- `rows * columns` and `rows * alph * columns`.
|
||||||
data Table i o = Table
|
data Table i o = Table
|
||||||
{ content :: Fun [i] o
|
{ content :: Fun [i] o
|
||||||
, rowIndices :: Set (RowIndex i)
|
, rowIndices :: Set (RowIndex i)
|
||||||
, 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, NominalType, Conditional, Contextual)
|
||||||
|
|
||||||
|
|
Loading…
Add table
Reference in a new issue