From 46ae60eaca841b554ba20c6a2b7a15b43c12b4df Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gkleen@yggdrasil.li>
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 ++++++++++++++++++++++++++++++++
3 files changed, 323 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
(limited to 'edit-lens/test/Control')
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
--
cgit v1.2.3