Improved integral shrink trees to match behavior of binary search

src/Hedgehog/Gen.fs

@@ -163,11 +163,11 @@ module Gen =
 
     /// Generates a random number in the given inclusive range.
     let inline integral (range : Range<'a>) : Gen<'a> =
-        let shrink =
-            Shrink.towards (Range.origin range)
-
-        Random.integral range
-        |> create shrink
+        // https://github.com/hedgehogqa/fsharp-hedgehog/pull/239
+        range
+        |> Random.integral
+        |> Random.map (range |> Range.origin |> Shrink.createTree)
+        |> ofRandom
 
     //
     // Combinators - Choice

src/Hedgehog/Seq.fs

@@ -15,3 +15,6 @@ let inline consNub (x : 'a) (ys0 : seq<'a>) : seq<'a> =
             ys0
         else
             cons x ys0
+
+let inline join (xss: 'a seq seq) : seq<'a> =
+    Seq.collect id xss

src/Hedgehog/Shrink.fs

@@ -1,4 +1,4 @@
-namespace Hedgehog
+namespace Hedgehog
 
 
 module Shrink =
@@ -18,15 +18,14 @@ module Shrink =
 
     /// Produce a list containing the progressive halving of an integral.
     let inline halves (n : ^a) : seq<'a> =
+        let one : ^a = LanguagePrimitives.GenericOne
+        let two : ^a = one + one
         let go x =
             let zero : ^a = LanguagePrimitives.GenericZero
             if x = zero then
                 None
             else
-                let one : ^a = LanguagePrimitives.GenericOne
-                let two : ^a = one + one
-                let x' = x / two
-                Some (x, x')
+                Some (x, x / two)
         Seq.unfold go n
 
     /// Shrink a list by edging towards the empty list.
@@ -67,19 +66,18 @@ module Shrink =
 
     /// Shrink an integral number by edging towards a destination.
     let inline towards (destination : ^a) (x : ^a) : seq<'a> =
+        let one : ^a = LanguagePrimitives.GenericOne
+        let two : ^a = one + one
         if destination = x then
             Seq.empty
+        elif destination = x - one then
+            Seq.singleton destination
         else
-            let one : ^a = LanguagePrimitives.GenericOne
-            let two : ^a = one + one
-
             /// We need to halve our operands before subtracting them as they may be using
             /// the full range of the type (i.e. 'MinValue' and 'MaxValue' for 'Int32')
             let diff : ^a = (x / two) - (destination / two)
-
             halves diff
             |> Seq.map (fun y -> x - y)
-            |> Seq.consNub destination
 
     /// Shrink a floating-point number by edging towards a destination.
     /// Note we always try the destination first, as that is the optimal shrink.
@@ -98,3 +96,19 @@ module Shrink =
                     None
 
             Seq.unfold go diff
+
+
+    let inline createTree (destination : ^a) (x : ^a) =
+        let one = LanguagePrimitives.GenericOne
+        let rec binarySearchTree (destination : ^a) (x : ^a) =
+            let xs =
+                towards destination x
+                |> Seq.cons (destination - one)
+                |> Seq.pairwise
+                |> Seq.map (fun (d, x) -> binarySearchTree (d + one) x)
+            Node (x, xs)
+        if destination = x then
+            Node (x, Seq.empty)
+        else
+            binarySearchTree (destination + one) x
+            |> Tree.addChildValue destination

src/Hedgehog/Tree.fs

@@ -21,6 +21,19 @@ module Tree =
     let singleton (x : 'a) : Tree<'a> =
         Node (x, Seq.empty)
 
+    let addChild (child: Tree<'a>) (parent: Tree<'a>) : Tree<'a> =
+        let (Node (x, xs)) = parent
+        Node (x, Seq.cons child xs)
+
+    let addChildValue (a: 'a) (tree: Tree<'a>) : Tree<'a> =
+        tree |> addChild (singleton a)
+
+    let rec cata (f: 'a -> 'b seq -> 'b) (Node (x, xs): Tree<'a>) : 'b =
+        f x (Seq.map (cata f) xs)
+
+    let toSeq (tree: Tree<'a>) : 'a seq =
+        tree |> cata (fun a -> Seq.join >> Seq.cons a)
+
     /// Map over a tree.
     let rec map (f : 'a -> 'b) (Node (x, xs) : Tree<'a>) : Tree<'b> =
         Node (f x, Seq.map (map f) xs)

tests/Hedgehog.Tests/ShrinkTests.fs

@@ -69,23 +69,29 @@ let shrinkTests = testList "Shrink tests" [
           [ "a"; "b"; "c" ] ]
         =! actual
 
-    testCase "towards shrinks an integral number by edging towards a destination - exmaple 1" <| fun _ ->
+    testCase "towards correct on input 0, 100" <| fun _ ->
         let actual =
             Shrink.towards 0 100
             |> Seq.toList
-        [0; 50; 75; 88; 94; 97; 99] =! actual
+        [50; 75; 88; 94; 97; 99] =! actual
 
-    testCase "towards shrinks an integral number by edging towards a destination - exmaple 2" <| fun _ ->
+    testCase "towards correct on input 500, 1000" <| fun _ ->
         let actual =
             Shrink.towards 500 1000
             |> Seq.toList
-        [500; 750; 875; 938; 969; 985; 993; 997; 999] =! actual
+        [750; 875; 938; 969; 985; 993; 997; 999] =! actual
 
-    testCase "towards shrinks an integral number by edging towards a destination - exmaple 3" <| fun _ ->
+    testCase "towards correct on input -50, -26" <| fun _ ->
         let actual =
             Shrink.towards -50 -26
             |> Seq.toList
-        [-50; -38; -32; -29; -27] =! actual
+        [-38; -32; -29; -27] =! actual
+
+    testCase "towards correct on input 4, 5" <| fun _ ->
+        let actual =
+            Shrink.towards 4 5
+            |> Seq.toList
+        [4] =! actual
 
     testCase "towardsDouble shrinks a floating-point number by edging towards a destination - example 1" <| fun _ ->
         let actual =
@@ -205,4 +211,92 @@ let shrinkTests = testList "Shrink tests" [
         | Failed failureData ->
             failureData.Shrinks =! shrinkLimit
         | _ -> failwith "impossible"
+
+    testCase "createTree correct for 0,0" <| fun _ ->
+        let actual = Shrink.createTree 0 0 |> Tree.map (sprintf "%A") |> Tree.render
+        let expected = "0"
+        expected =! actual
+
+    testCase "createTree correct for 0,1" <| fun _ ->
+        let actual = Shrink.createTree 0 1 |> Tree.map (sprintf "%A") |> Tree.renderList
+        let expected =
+          [ "1"
+            "└-0" ]
+        expected =! actual
+
+    testCase "createTree correct for 0,2" <| fun _ ->
+        let actual = Shrink.createTree 0 2 |> Tree.map (sprintf "%A") |> Tree.renderList
+        let expected =
+          [ "2"
+            "├-0"
+            "└-1" ]
+        expected =! actual
+
+    testCase "createTree correct for 0,3" <| fun _ ->
+        let actual = Shrink.createTree 0 3 |> Tree.map (sprintf "%A") |> Tree.renderList
+        let expected =
+            [ "3"
+              "├-0"
+              "└-2"
+              "  └-1" ]
+        expected =! actual
+
+    testCase "createTree correct for 0,4" <| fun _ ->
+        let actual = Shrink.createTree 0 4 |> Tree.map (sprintf "%A") |> Tree.renderList
+        let expected =
+            [ "4"
+              "├-0"
+              "├-2"
+              "| └-1"
+              "└-3" ]
+        expected =! actual
+
+    testCase "createTree correct for 0,5" <| fun _ ->
+        let actual = Shrink.createTree 0 5 |> Tree.map (sprintf "%A") |> Tree.renderList
+        let expected =
+            [ "5"
+              "├-0"
+              "├-3"
+              "| └-2"
+              "|   └-1"
+              "└-4" ]
+        expected =! actual
+
+    testCase "createTree correct for 0,6" <| fun _ ->
+        let actual = Shrink.createTree 0 6 |> Tree.map (sprintf "%A") |> Tree.renderList
+        let expected =
+            [ "6"
+              "├-0"
+              "├-3"
+              "| └-2"
+              "|   └-1"
+              "└-5"
+              "  └-4" ]
+        expected =! actual
+
+    testCase "createTree correct for 0,7" <| fun _ ->
+        let actual = Shrink.createTree 0 7 |> Tree.map (sprintf "%A") |> Tree.renderList
+        let expected =
+            [ "7"
+              "├-0"
+              "├-4"
+              "| ├-2"
+              "| | └-1"
+              "| └-3"
+              "└-6"
+              "  └-5" ]
+        expected =! actual
+
+    testCase "createTree correct for 4,5" <| fun _ ->
+        let actual = Shrink.createTree 4 5 |> Tree.map (sprintf "%A") |> Tree.renderList
+        let expected =
+            [ "5"
+              "└-4" ]
+        expected =! actual
+
+    testCase "createTree 0,n creates a tree containing each value in [0,n] exactly once" <| fun _ ->
+        for n in [0..100] do
+            let actual = Shrink.createTree 0 n |> Tree.toSeq |> Seq.sort |> Seq.toList
+            let expected = [0..n]
+            expected =! actual
 ]