diff --git a/src/Hedgehog/Gen.fs b/src/Hedgehog/Gen.fs index a4e9995e..2780f105 100644 --- a/src/Hedgehog/Gen.fs +++ b/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 diff --git a/src/Hedgehog/Seq.fs b/src/Hedgehog/Seq.fs index 0f32b822..9999c5cc 100644 --- a/src/Hedgehog/Seq.fs +++ b/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 diff --git a/src/Hedgehog/Shrink.fs b/src/Hedgehog/Shrink.fs index 66be69b2..8bff8511 100644 --- a/src/Hedgehog/Shrink.fs +++ b/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. @@ -98,3 +97,17 @@ module Shrink = None Seq.unfold go diff + + + let inline createTree (destination : ^a) (x : ^a) = + let rec binarySearchTree ((destination : ^a), (x : ^a)) = + let xs = + towards destination x + |> Seq.pairwise + |> Seq.map binarySearchTree + Node (x, xs) + if destination = x then + Node (x, Seq.empty) + else + binarySearchTree (destination, x) + |> Tree.addChildValue destination diff --git a/src/Hedgehog/Tree.fs b/src/Hedgehog/Tree.fs index c6bf04ed..be1e3d7e 100644 --- a/src/Hedgehog/Tree.fs +++ b/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) diff --git a/tests/Hedgehog.Tests/ShrinkTests.fs b/tests/Hedgehog.Tests/ShrinkTests.fs index 53fcb091..3dfbab79 100644 --- a/tests/Hedgehog.Tests/ShrinkTests.fs +++ b/tests/Hedgehog.Tests/ShrinkTests.fs @@ -69,24 +69,30 @@ 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 - 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 - 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 + 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 = Shrink.towardsDouble 0.0 100.0 @@ -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 ]