Improve implementation of Variant

This reduces the exceution time of the `StringToBool` test from about 30sec to
about 13sec, so quite a dramatic improvement.

src/Test/Falsify/Reexported/Generator/Function/Perturb.hs

@@ -22,9 +22,13 @@ import Test.Falsify.Internal.Generator.ShrinkStep (Step)
 
 import qualified Test.Falsify.Internal.Generator.ShrinkStep as Step
 import qualified Test.Falsify.SampleTree                    as SampleTree
+import Data.Bits
 
 {-------------------------------------------------------------------------------
   Focus
+
+  The implementation of 'variant' is an adaptation of @integerVariant@ in
+  QuickCheck.
 -------------------------------------------------------------------------------}
 
 data Focus = FocusHere | FocusLeft Focus | FocusRight Focus
@@ -37,9 +41,39 @@ instance Semigroup Focus where
 instance Monoid Focus where
   mempty = FocusHere
 
+-- | Mark variant
+--
+-- See 'Perturb'.
 variant :: Integer -> Focus
-variant 0 = FocusLeft FocusHere
-variant n = FocusRight $ variant (n - 1)
+variant = \n ->
+    if n >= 1
+      then gamma n       $ FocusLeft  FocusHere
+      else gamma (1 - n) $ FocusRight FocusHere
+  where
+    gamma :: Integer -> Focus -> Focus
+    gamma n = encode n (ilog2 n) . zeroes k
+      where
+        k = ilog2 n
+
+    encode :: Integer -> Int -> Focus -> Focus
+    encode n = go
+      where
+        go (-1) g = g
+        go k g
+          | testBit n k = go (k - 1) $ FocusRight g
+          | otherwise   = go (k - 1) $ FocusLeft  g
+
+    -- The zeroes are effectively an encoding of the "length" of the number,
+    -- in terms of the number of bits required to encode it as a binary number.
+    -- This is used to ensure that, say, variant @0b11@ doesn't get a subtree
+    -- of the sample tree used for @0b1@.
+    zeroes :: Int -> Focus -> Focus
+    zeroes 0 g = g
+    zeroes k g = zeroes (k - 1) $ FocusLeft  g
+
+    ilog2 :: Integer -> Int
+    ilog2 1 = 0
+    ilog2 n = 1 + ilog2 (n `div` 2)
 
 {-------------------------------------------------------------------------------
   Using 'Focus'
@@ -67,6 +101,9 @@ stepAtFocus = go
   Perturbations
 -------------------------------------------------------------------------------}
 
+-- | Perturb the PRNG
+--
+-- This is the analogue of 'CoArbitrary' in QuickCheck.
 class Perturb a where
   perturb :: a -> Focus
 

test/TestSuite/Sanity/Functions.hs

@@ -75,7 +75,7 @@ test_Word8ToBool_constant = do
       show . NE.last $ Gen.shrink (not . prop) gen (SampleTree.fromSeed 0)
   where
     expected :: String
-    expected = "{254->True, _->False}"
+    expected = "{255->True, _->False}"
 
     gen :: Gen (Fun Word8 Bool)
     gen = Gen.fun (Gen.bool False)
@@ -98,7 +98,7 @@ test_IntegerToBool_constant = do
       show . NE.last $ Gen.shrink (not . prop) gen (SampleTree.fromSeed 4)
   where
     expected :: String
-    expected = "{1618->True, _->False}"
+    expected = "{3142->True, _->False}"
 
     gen :: Gen (Fun Integer Bool)
     gen = Gen.fun (Gen.bool False)
@@ -117,7 +117,7 @@ test_IntToInt_mapFilter = do
       show . NE.last $ Gen.shrink (not . prop) gen (SampleTree.fromSeed 1)
   where
     expected :: String
-    expected = "({_->0},{73->True, _->False},[73])"
+    expected = "({_->0},{59->True, _->False},[59])"
 
     gen :: Gen (Fun Int Int, Fun Int Bool, [Int])
     gen =
@@ -145,7 +145,7 @@ test_IntToInt_mapFilter = do
 test_StringToBool :: Assertion
 test_StringToBool = do
     assertEqual "" expected $
-      show . NE.last $ Gen.shrink (not . prop) gen (SampleTree.fromSeed 1)
+      show . NE.last $ Gen.shrink (not . prop) gen (SampleTree.fromSeed 2)
   where
     expected :: String
     expected = "{\"Standard ML\"->True, _->False}"