From 46ae60eaca841b554ba20c6a2b7a15b43c12b4df Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Tue, 18 Dec 2018 13:51:16 +0100 Subject: Much ado about nothing --- edit-lens/test/Control/DFST/LensTest.hs | 35 ++++++ edit-lens/test/Control/DFSTTest.hs | 101 +++++++++++++++++ edit-lens/test/Control/FSTTest.hs | 187 ++++++++++++++++++++++++++++++++ edit-lens/test/Driver.hs | 1 + 4 files changed, 324 insertions(+) create mode 100644 edit-lens/test/Control/DFST/LensTest.hs create mode 100644 edit-lens/test/Control/DFSTTest.hs create mode 100644 edit-lens/test/Control/FSTTest.hs create mode 100644 edit-lens/test/Driver.hs (limited to 'edit-lens/test') diff --git a/edit-lens/test/Control/DFST/LensTest.hs b/edit-lens/test/Control/DFST/LensTest.hs new file mode 100644 index 0000000..46a1896 --- /dev/null +++ b/edit-lens/test/Control/DFST/LensTest.hs @@ -0,0 +1,35 @@ +module Control.DFST.LensTest where + +import Prelude hiding (init) + +import Control.DFST +import Control.DFST.Lens +import Control.FST hiding (stInitial, stTransition, stAccept) + +import Data.Set (Set) +import qualified Data.Set as Set + +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map + +import Data.Sequence (Seq) +import qualified Data.Sequence as Seq + +import Data.Maybe (maybeToList) + +import Test.Tasty +import Test.Tasty.Hedgehog +import Test.Tasty.HUnit hiding (assert) + +import Hedgehog +import qualified Hedgehog.Gen as G +import qualified Hedgehog.Range as R + +import Numeric.Natural + +import Control.DFSTTest + +hprop_applyDivInit :: Property +hprop_applyDivInit = property $ do + word <- Seq.fromList <$> forAll genWord + init @(StringEdits Natural) `apply` (divInit word :: StringEdits Natural) === Just word diff --git a/edit-lens/test/Control/DFSTTest.hs b/edit-lens/test/Control/DFSTTest.hs new file mode 100644 index 0000000..4d91a03 --- /dev/null +++ b/edit-lens/test/Control/DFSTTest.hs @@ -0,0 +1,101 @@ +module Control.DFSTTest where + +import Control.DFST +import Control.FST hiding (stInitial, stTransition, stAccept) + +import Data.Set (Set) +import qualified Data.Set as Set + +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map + +import Data.Sequence (Seq) +import qualified Data.Sequence as Seq + +import Data.Maybe (maybeToList) + +import Test.Tasty +import Test.Tasty.Hedgehog +import Test.Tasty.HUnit hiding (assert) + +import Hedgehog +import qualified Hedgehog.Gen as G +import qualified Hedgehog.Range as R + +import Numeric.Natural + +import Text.PrettyPrint.Leijen (Pretty(..)) + + +dfstId :: Ord a => Set a -> DFST () a a +dfstId syms = DFST + { stInitial = () + , stTransition = Map.fromList + [(((), sym), ((), Seq.singleton sym)) | sym <- Set.toList syms] + , stAccept = Set.singleton () + } + +dfstDouble :: Ord a => Set a -> DFST () a a +dfstDouble syms = DFST + { stInitial = () + , stTransition = Map.fromList + [(((), sym), ((), Seq.fromList [sym, sym])) | sym <- Set.toList syms] + , stAccept = Set.singleton () + } + +dfstRunLengthDecode :: Ord a + => Set a + -> Natural + -> DFST (Maybe Natural) (Either Natural a) a +dfstRunLengthDecode syms lim = DFST + { stInitial = Nothing + , stTransition = Map.fromList . concat $ + [ [((Nothing, Left n), (Just n, Seq.empty)) | n <- [0..lim]] + , [((Just n, Right sym), (Nothing, Seq.replicate (fromIntegral n) sym)) | n <- [0..lim], sym <- Set.toList syms] + ] + , stAccept = Set.singleton Nothing + } + +genWord :: Gen [Natural] +genWord = G.list (R.linear 0 1000) . G.integral $ R.linear 0 100 + +genDFST :: (Ord input, Ord output) => Set input -> Set output -> Gen (DFST Natural input output) +genDFST inA outA = do + states <- G.set (R.linear 1 1000) . G.integral $ R.linear 0 100 + stInitial <- G.element $ Set.toList states + stAccept <- Set.fromList <$> G.subsequence (Set.toList states) + stTransition <- fmap Map.fromList . G.list (R.linear 0 1000) . G.small $ do + st <- G.element $ Set.toList states + input <- G.element $ Set.toList inA + st' <- G.element $ Set.toList states + output <- fmap Seq.fromList . G.list (R.linear 0 20) . G.element $ Set.toList outA + return ((st, input), (st', output)) + return DFST{..} + + +testDFST :: (Show output, Ord output, Show state, Ord state) => (Set Natural -> DFST state Natural output) -> (Seq Natural -> Seq output) -> Property +testDFST mkDfst f = property $ do + input <- forAll genWord + let fst = mkDfst $ Set.fromList input + Just (f $ Seq.fromList input) === runDFST fst (Seq.fromList input) + +hprop_runDFSTId, hprop_runDFSTDouble :: Property +hprop_runDFSTId = testDFST dfstId id +hprop_runDFSTDouble = testDFST dfstDouble double + where + double :: Seq a -> Seq a + double Seq.Empty = Seq.Empty + double (a Seq.:<| as) = a Seq.:<| a Seq.:<| double as + +unit_runLengthDecode :: Assertion +unit_runLengthDecode = runDFST dfst input @?= Just (Seq.fromList "aaacc") + where + input = Seq.fromList [Left 3, Right 'a', Left 0, Right 'b', Left 2, Right 'c'] + dfst = dfstRunLengthDecode (Set.fromList "abc") 3 + +hprop_toFST :: Property +hprop_toFST = property $ do + input <- forAll genWord + dfst <- forAllWith (show . pretty . toFST) $ genDFST (Set.fromList $ input ++ [0..20]) (Set.fromList [0..20] :: Set Natural) + + runFST (toFST dfst) (Seq.fromList input) === maybeToList (runDFST dfst $ Seq.fromList input) diff --git a/edit-lens/test/Control/FSTTest.hs b/edit-lens/test/Control/FSTTest.hs new file mode 100644 index 0000000..f5e02c2 --- /dev/null +++ b/edit-lens/test/Control/FSTTest.hs @@ -0,0 +1,187 @@ +module Control.FSTTest where + +import Control.FST + +import Data.Set (Set) +import qualified Data.Set as Set + +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map + +import Data.Sequence (Seq) +import qualified Data.Sequence as Seq + +import Data.Maybe (fromMaybe) +import Data.Foldable (Foldable(..)) + +import Control.Monad (when) + +import Data.Void + +import Test.Tasty +import Test.Tasty.Hedgehog +import Test.Tasty.HUnit hiding (assert) + +import Hedgehog +import qualified Hedgehog.Gen as G +import qualified Hedgehog.Range as R + +import Numeric.Natural + +import Text.PrettyPrint.Leijen (Pretty(..)) + +import Control.DeepSeq (force) + + +fstId :: Ord a => Set a -> FST () a a +fstId syms = FST + { stInitial = Set.singleton () + , stTransition = Map.fromList [(((), Just sym), Set.singleton ((), Just sym)) | sym <- Set.toList syms] + , stAccept = Set.singleton () + } + +fstDouble :: Ord a => Set a -> FST (Maybe a) a a +fstDouble syms = FST + { stInitial = Set.singleton Nothing + , stTransition = Map.fromListWith Set.union . concat $ + [ [((Nothing, Just sym), Set.singleton (Just sym, Just sym)) | sym <- Set.toList syms] + , [((Just sym, Nothing), Set.singleton (Nothing, Just sym)) | sym <- Set.toList syms] + ] + , stAccept = Set.singleton Nothing + } + +fstRunLengthDecode :: Ord a + => Set a -- ^ Alphabet + -> Natural -- ^ Upper limit to run length + -> FST (Maybe (Natural, Maybe a)) (Either Natural a) a +fstRunLengthDecode syms lim = FST + { stInitial = Set.singleton Nothing + , stTransition = Map.fromListWith Set.union . concat $ + [ [((Nothing, Just (Left n)), Set.singleton (Just (n, Nothing), Nothing)) | n <- [0..lim]] + , [((Just (n, Nothing), Just (Right sym)), Set.singleton (Just (n, Just sym), Nothing)) | n <- [0..lim], sym <- Set.toList syms] + , [((Just (n, Just sym), Nothing), Set.singleton (Just (pred n, Just sym), Just sym)) | n <- [1..lim], sym <- Set.toList syms] + , [((Just (0, Just sym), Nothing), Set.singleton (Nothing, Nothing)) | sym <- Set.toList syms] + ] + , stAccept = Set.singleton Nothing + } + +data StRunLengthEncode a = STREInitial + | STRECountUp a Natural + | STRESwitch (Maybe a) a + | STREFinish + deriving (Show, Eq, Ord) + +fstRunLengthEncode :: Ord a + => Bool -- ^ Generate /all/ run length encodings instead of the best + -> Set a -- ^ Alphabet + -> Natural -- ^ Upper limit to run length + -> FST (StRunLengthEncode a) a (Either Natural a) +fstRunLengthEncode genAll syms lim = FST + { stInitial = Set.singleton STREInitial + , stTransition = Map.fromListWith Set.union . concat $ + [ [((STREInitial, Just sym), Set.singleton (STRECountUp sym 1, Nothing)) | sym <- Set.toList syms] + , [((STRECountUp sym n, Just sym), Set.singleton (STRECountUp sym (succ n), Nothing)) | sym <- Set.toList syms, n <- [1..pred lim]] + , [((STRECountUp sym n, Just sym'), Set.singleton (STRESwitch (Just sym') sym, Just $ Left n)) | n <- [1..lim], sym <- Set.toList syms, sym' <- Set.toList syms, sym /= sym'] + , [((STRECountUp sym lim, Just sym), Set.singleton (STRESwitch (Just sym) sym, Just $ Left lim)) | sym <- Set.toList syms] + , [((STRECountUp sym n, Nothing), Set.singleton (STRESwitch Nothing sym, Just $ Left n)) | sym <- Set.toList syms, n <- [1..lim]] + , [((STRESwitch (Just sym') sym, Nothing), Set.singleton (STRECountUp sym' 1, Just $ Right sym)) | sym <- Set.toList syms, sym' <- Set.toList syms] + , [((STRESwitch Nothing sym, Nothing), Set.singleton (STREFinish, Just $ Right sym)) | sym <- Set.toList syms] + , [((STRECountUp sym n, Just sym), Set.singleton (STRESwitch (Just sym) sym, Just $ Left n)) | n <- [1..lim], sym <- Set.toList syms, genAll] + ] + , stAccept = Set.fromList [STREInitial, STREFinish] + } + + +genWord :: Gen [Natural] +genWord = G.list (R.linear 0 1000) . G.integral $ R.linear 0 100 + + +runFSTDet :: (Show output, Ord output, Show state, Ord state) => (Set Natural -> FST state Natural output) -> (Seq Natural -> Seq output) -> Property +runFSTDet mkFst f = property $ do + input <- forAll genWord + let fst = mkFst $ Set.fromList input + annotateShow $ pretty fst + [f $ Seq.fromList input] === runFST fst (Seq.fromList input) + + +hprop_runFSTId, hprop_runFSTDouble :: Property +hprop_runFSTId = runFSTDet fstId id +hprop_runFSTDouble = runFSTDet fstDouble double + where + double :: Seq a -> Seq a + double Seq.Empty = Seq.Empty + double (a Seq.:<| as) = a Seq.:<| a Seq.:<| double as + +hprop_runWordFST :: Property +hprop_runWordFST = property $ do + input <- forAll genWord + let fst = wordFST $ Seq.fromList input + annotateShow $ pretty fst + [Seq.fromList input] === runFST fst (Seq.empty :: Seq Void) + +unit_runLengthDecode, unit_runLengthEncode :: Assertion +unit_runLengthDecode = runFST fst input @?= [Seq.fromList "aaacc"] + where + input = Seq.fromList [Left 3, Right 'a', Left 0, Right 'b', Left 2, Right 'c'] + fst = fstRunLengthDecode (Set.fromList "abc") 3 +unit_runLengthEncode = runFST fst input @?= [Seq.fromList [Left 3, Right 'a', Left 2, Right 'c']] + where + input = Seq.fromList "aaacc" + fst = fstRunLengthEncode False (Set.fromList "abc") 3 + +hprop_runLength :: Property +hprop_runLength = property $ do + input <- forAll genWord + let maxRun = fromMaybe 1 $ countMaxRun input + alphabet = Set.fromList input + encode = fstRunLengthEncode False alphabet maxRun + decode = fstRunLengthDecode alphabet maxRun + annotateShow $ countMaxRun input + annotateShow $ pretty encode + annotateShow $ pretty decode + [encoded] <- return . runFST encode $ Seq.fromList input + annotateShow $ toList encoded + [Seq.fromList input] === runFST decode encoded + +hprop_runLength' :: Property +hprop_runLength' = property $ do + input <- forAll genWord + + let maxRun = fromMaybe 1 $ countMaxRun input + alphabet = Set.fromList input + encode = fstRunLengthEncode True alphabet maxRun + decode = fstRunLengthDecode alphabet maxRun + annotateShow $ countMaxRun input + annotateShow $ pretty encode + annotateShow $ pretty decode + + let encoded = runFST encode $ Seq.fromList input + annotateShow encoded + when (maxRun > 1) $ + assert $ encoded `longerThan` 1 + + encoded' <- forAll $ G.element encoded + [Seq.fromList input] === runFST decode encoded' + where + longerThan :: [a] -> Natural -> Bool + longerThan [] _ = False + longerThan _ 0 = True + longerThan (_:xs) n = longerThan xs $ pred n + +countMaxRun :: (Eq a, Foldable f) => f a -> Maybe Natural +countMaxRun = goMaxRun Nothing Nothing . toList + where + goMaxRun :: Eq a + => Maybe (a, Natural) -- ^ Maximum + -> Maybe (a, Natural) -- ^ Current + -> [a] + -> Maybe Natural + goMaxRun Nothing Nothing [] = Nothing + goMaxRun (Just (_, n)) (Just (_, n')) [] + | n' > n = Just n' + | otherwise = Just n + goMaxRun Nothing Nothing (a:as) = goMaxRun (Just (a, 1)) (Just (a, 1)) as + goMaxRun (Just (a, n)) (Just (a', n')) (x:xs) + | x == a' = goMaxRun (Just (a, n)) (Just (a', succ n')) xs + | n' > n = goMaxRun (Just (a', n')) (Just (x, 1)) xs + | otherwise = goMaxRun (Just (a, n)) (Just (x, 1)) xs diff --git a/edit-lens/test/Driver.hs b/edit-lens/test/Driver.hs new file mode 100644 index 0000000..327adf4 --- /dev/null +++ b/edit-lens/test/Driver.hs @@ -0,0 +1 @@ +{-# OPTIONS_GHC -F -pgmF tasty-discover -optF --tree-display #-} -- cgit v1.2.3