mirror of
https://github.com/Jaxan/monoid-learner.git
synced 2025-04-27 06:57:44 +02:00
62 lines
2.7 KiB
Haskell
62 lines
2.7 KiB
Haskell
{-# LANGUAGE ExistentialQuantification #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
|
|
import qualified Data.Sequence as Seq
|
|
import qualified Data.Set as Set
|
|
import Equivalence
|
|
import Examples.Examples
|
|
import Monoid
|
|
import Test.Tasty
|
|
import Test.Tasty.HUnit
|
|
|
|
main :: IO ()
|
|
main = defaultMain tests
|
|
|
|
data ExMonoid a = forall q. Ord q => ExMonoid {monoid :: MonoidAcceptor a q}
|
|
|
|
tests :: TestTree
|
|
tests =
|
|
testGroup
|
|
"unit tests"
|
|
[ equivalences,
|
|
languages
|
|
]
|
|
|
|
equivalences :: TestTree
|
|
equivalences =
|
|
testGroup
|
|
"equivalences"
|
|
[ testCase "0 == 0" $ emptyLanguage `shouldBeEquivalentTo` emptyLanguage,
|
|
testCase "0 == 0" $ emptyLanguage `shouldBeEquivalentTo` emptyLanguageConvoluted,
|
|
testCase "0 /= 1" $ emptyLanguage `shouldNotBeEquivalentTo` fullLanguage,
|
|
testCase "upto is union n=0" $ lengthUptoN 0 `shouldBeEquivalentToE` uptoAsUnion 0,
|
|
testCase "upto is union n=1" $ lengthUptoN 1 `shouldBeEquivalentToE` uptoAsUnion 1,
|
|
testCase "upto is union n=2" $ lengthUptoN 2 `shouldBeEquivalentToE` uptoAsUnion 2,
|
|
testCase "upto is union n=3" $ lengthUptoN 3 `shouldBeEquivalentToE` uptoAsUnion 3,
|
|
testCase "intersection" $ (lengthIsN 4 `intersection` lengthIsN 5) `shouldBeEquivalentTo` emptyLanguage,
|
|
testCase "upto and union" $ (lengthUptoN 4 `intersection` lengthUptoN 7) `shouldBeEquivalentTo` lengthUptoN 4,
|
|
testCase "empty word" $ lengthIsN 0 `shouldBeEquivalentTo` singletonLanguage Seq.empty,
|
|
testCase "empty lang" $ emptyLanguage `shouldBeEquivalentTo` finiteLanguage Set.empty
|
|
]
|
|
where
|
|
shouldBeEquivalentTo x y = equivalent (Set.fromList "ab") x y @?= True
|
|
shouldNotBeEquivalentTo x y = equivalent (Set.fromList "ab") x y @?= False
|
|
shouldBeEquivalentToE x (ExMonoid y) = equivalent (Set.fromList "ab") x y @?= True
|
|
|
|
uptoAsUnion 0 = ExMonoid (lengthIsN 0)
|
|
uptoAsUnion n = case uptoAsUnion (n -1) of
|
|
ExMonoid m -> ExMonoid (lengthIsN n `union` m)
|
|
|
|
languages :: TestTree
|
|
languages =
|
|
testGroup
|
|
"languages"
|
|
[ shouldReject "fin lang empty" (finiteLanguage (Set.fromList [])) ["", "a", "b", "abba"],
|
|
shouldAccept "fin lang 1" (finiteLanguage (Set.fromList ["abba"])) ["abba"],
|
|
shouldReject "fin lang 1" (finiteLanguage (Set.fromList ["abba"])) ["aba", "abbab", "babba", ""],
|
|
shouldAccept "fin lang 2" (finiteLanguage (Set.fromList ["abba", "b", "aaa"])) ["abba", "b", "aaa"],
|
|
shouldReject "fin lang 2" (finiteLanguage (Set.fromList ["abba", "b", "aaa"])) ["aba", "abbab", "babba", "", "a", "aa", "aaaa"]
|
|
]
|
|
where
|
|
shouldAccept name m ls = testGroup (name <> " accepts") [testCase (show w) $ acceptMonoid m w @?= True | w <- ls]
|
|
shouldReject name m ls = testGroup (name <> " rejects") [testCase (show w) $ acceptMonoid m w @?= False | w <- ls]
|