diff --git a/src/AbstractLStar.hs b/src/AbstractLStar.hs index 39f3494..d693990 100644 --- a/src/AbstractLStar.hs +++ b/src/AbstractLStar.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RecordWildCards #-} +{-# language RecordWildCards #-} module AbstractLStar where import ObservationTable @@ -59,19 +59,21 @@ learn makeComplete handleCounterExample constructHypothesis teacher s = eqloop s2 h = case equivalent teacher h of Nothing -> trace "Yes" $ h Just ces -> trace "No" $ - case isTrue . isEmpty $ realces h ces of - True -> eqloop s2 h - False -> + if isTrue . isEmpty $ realces h ces + then eqloop s2 h + else let s3 = handleCounterExample teacher s2 ces in learn makeComplete handleCounterExample constructHypothesis teacher s3 realces h ces = NLambda.filter (\(ce, a) -> a `neq` accepts h ce) $ membership teacher ces --- Initial state is always the same in our case -constructEmptyState :: LearnableAlphabet i => Teacher i -> State i -constructEmptyState teacher = +-- Initialise with the trivial table +-- We allow to initialise with all words of length <= k,n for rows and columns +-- Normally one should take k = n = 0 +constructEmptyState :: LearnableAlphabet i => Int -> Int -> Teacher i -> State i +constructEmptyState k n teacher = let aa = Teacher.alphabet teacher in - let ss = singleton [] in + let ss = replicateSetUntil k aa in let ssa = pairsWith (\s a -> s ++ [a]) ss aa in - let ee = singleton [] in + let ee = replicateSetUntil n aa in let t = fillTable teacher (ss `union` ssa) ee in State{..} diff --git a/src/Angluin.hs b/src/Angluin.hs index e120eb2..833852d 100644 --- a/src/Angluin.hs +++ b/src/Angluin.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RecordWildCards #-} +{-# language RecordWildCards #-} module Angluin where import AbstractLStar @@ -8,8 +8,8 @@ import Teacher import Data.List (inits, tails) import Debug.Trace import NLambda +import Prelude (Bool (..), Maybe (..), fst, id, show, ($), (++), (.)) import qualified Prelude hiding () -import Prelude (Bool(..), Maybe(..), id, ($), (.), (++), fst, show) justOne :: (Contextual a, NominalType a) => Set a -> Set a justOne s = mapFilter id . orbit [] . element $ s @@ -70,12 +70,12 @@ makeCompleteAngluin = makeCompleteWith [closednessTest, consistencyTestDirect] -- Default: use counter examples in columns, which is slightly faster learnAngluin :: LearnableAlphabet i => Teacher i -> Automaton (BRow i) i learnAngluin teacher = learn makeCompleteAngluin useCounterExampleMP constructHypothesis teacher initial - where initial = constructEmptyState teacher + where initial = constructEmptyState 0 0 teacher -- The "classical" version, where counter examples are added as rows learnAngluinRows :: LearnableAlphabet i => Teacher i -> Automaton (BRow i) i learnAngluinRows teacher = learn makeCompleteAngluin useCounterExampleAngluin constructHypothesis teacher initial - where initial = constructEmptyState teacher + where initial = constructEmptyState 0 0 teacher -- Below are some variations of the above functions with different diff --git a/src/Bollig.hs b/src/Bollig.hs index 9752cc9..c2b1fe7 100644 --- a/src/Bollig.hs +++ b/src/Bollig.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RecordWildCards #-} +{-# language RecordWildCards #-} module Bollig where import AbstractLStar @@ -9,11 +9,11 @@ import Teacher import Data.List (tails) import Debug.Trace import NLambda +import Prelude (Bool (..), Int, Maybe (..), fst, show, ($), (++), (.)) import qualified Prelude hiding () -import Prelude (Bool(..), Maybe(..), ($), (.), (++), fst, show) rowUnion :: NominalType i => Set (BRow i) -> BRow i -rowUnion set = Prelude.uncurry union . setTrueFalse . partition (\(_, f) -> f) $ map (\is -> (is, exists fromBool (mapFilter (\(is2, b) -> maybeIf (is `eq` is2) b) flatSet))) allIs +rowUnion set = Prelude.uncurry union . setTrueFalse . partition snd $ map (\is -> (is, exists fromBool (mapFilter (\(is2, b) -> maybeIf (is `eq` is2) b) flatSet))) allIs where flatSet = sum set allIs = map fst flatSet @@ -28,7 +28,7 @@ sublang :: NominalType i => BRow i -> BRow i -> Formula sublang r1 r2 = forAll fromBool $ pairsWithFilter (\(i1, f1) (i2, f2) -> maybeIf (i1 `eq` i2) (f1 `boolImplies` f2)) r1 r2 sublangs :: NominalType i => BRow i -> Set (BRow i) -> Set (BRow i) -sublangs r set = filter (\r2 -> r2 `sublang` r) set +sublangs r = filter (`sublang` r) rfsaClosednessTest2 :: LearnableAlphabet i => State i -> TestResult i rfsaClosednessTest2 State{..} = case solve (isEmpty defect) of @@ -69,6 +69,6 @@ constructHypothesisBollig State{..} = automaton q a d i f makeCompleteBollig :: LearnableAlphabet i => TableCompletionHandler i makeCompleteBollig = makeCompleteWith [rfsaClosednessTest2, rfsaConsistencyTest] -learnBollig :: LearnableAlphabet i => Teacher i -> Automaton (BRow i) i -learnBollig teacher = learn makeCompleteBollig useCounterExampleMP constructHypothesisBollig teacher initial - where initial = constructEmptyState teacher +learnBollig :: LearnableAlphabet i => Int -> Int -> Teacher i -> Automaton (BRow i) i +learnBollig k n teacher = learn makeCompleteBollig useCounterExampleMP constructHypothesisBollig teacher initial + where initial = constructEmptyState k n teacher diff --git a/src/Main.hs b/src/Main.hs index 63385d0..bcd590c 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -38,7 +38,7 @@ mainExample learnerName teacherName autName = do let h = case read learnerName of NomLStar -> learnAngluinRows teacher NomLStarCol -> learnAngluin teacher - NomNLStar -> learnBollig teacher + NomNLStar -> learnBollig 1 1 teacher print h mainWithIO :: String -> IO () @@ -47,7 +47,7 @@ mainWithIO learnerName = do let h = case read learnerName of NomLStar -> learnAngluinRows t NomLStarCol -> learnAngluin t - NomNLStar -> learnBollig t + NomNLStar -> learnBollig 0 0 t print h main :: IO () diff --git a/src/Main2.hs b/src/Main2.hs index 27d6c41..2896c3b 100644 --- a/src/Main2.hs +++ b/src/Main2.hs @@ -18,7 +18,7 @@ learn alphSet = do let h = case read learnerName of NomLStar -> learnAngluinRows t NomLStarCol -> learnAngluin t - NomNLStar -> learnBollig t + NomNLStar -> learnBollig 0 0 t hPrint stderr h main :: IO () diff --git a/src/NLStar.hs b/src/NLStar.hs index 293806b..08f7ba2 100644 --- a/src/NLStar.hs +++ b/src/NLStar.hs @@ -57,4 +57,4 @@ makeCompleteNonDet = makeCompleteWith [nonDetClosednessTest] -- Default: use counter examples in columns, which is slightly faster learnNonDet :: LearnableAlphabet i => Teacher i -> Automaton (BRow i) i learnNonDet teacher = learn makeCompleteNonDet useCounterExampleMP constructHypothesisNonDet teacher initial - where initial = constructEmptyState teacher + where initial = constructEmptyState 0 0 teacher