From 1ef7403159c3fa495e42ef707ecc657d196c59ea Mon Sep 17 00:00:00 2001 From: Tyson Williams Date: Tue, 10 Nov 2020 09:12:09 -0600 Subject: [PATCH 1/9] improved integral shrink trees to match behavior of binary search --- src/Hedgehog/Gen.fs | 26 +++++++++++++++++++++----- 1 file changed, 21 insertions(+), 5 deletions(-) diff --git a/src/Hedgehog/Gen.fs b/src/Hedgehog/Gen.fs index a4e9995e..195cc36c 100644 --- a/src/Hedgehog/Gen.fs +++ b/src/Hedgehog/Gen.fs @@ -163,11 +163,27 @@ 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 + let mapFirstDifferently f g = function + | [] -> [] + | x :: xs -> (f x) :: (xs |> List.map g) + let rec createTree (destination : ^a) (x : ^a) = + let childrenValues = + match Shrink.towards destination x |> Seq.toList with + | [] -> [] + | x :: [] -> List.singleton x + | _ :: xs -> xs + let xs = + childrenValues + |> Seq.cons destination + |> Seq.pairwise + |> Seq.toList + |> mapFirstDifferently id (fun (d, x) -> (d + LanguagePrimitives.GenericOne, x)) + |> Seq.map (fun (d, x) -> createTree d x) + Node (x, xs) + range + |> Random.integral + |> Random.map (range |> Range.origin |> createTree) + |> ofRandom // // Combinators - Choice From abbd5f8a0e5d42c4875340cfcca165c85cf0bcf7 Mon Sep 17 00:00:00 2001 From: Tyson Williams Date: Sat, 6 Feb 2021 21:05:46 -0600 Subject: [PATCH 2/9] moved createTree --- src/Hedgehog/Gen.fs | 19 +------------------ src/Hedgehog/Shrink.fs | 18 +++++++++++++++++- 2 files changed, 18 insertions(+), 19 deletions(-) diff --git a/src/Hedgehog/Gen.fs b/src/Hedgehog/Gen.fs index 195cc36c..1b82e9de 100644 --- a/src/Hedgehog/Gen.fs +++ b/src/Hedgehog/Gen.fs @@ -163,26 +163,9 @@ module Gen = /// Generates a random number in the given inclusive range. let inline integral (range : Range<'a>) : Gen<'a> = - let mapFirstDifferently f g = function - | [] -> [] - | x :: xs -> (f x) :: (xs |> List.map g) - let rec createTree (destination : ^a) (x : ^a) = - let childrenValues = - match Shrink.towards destination x |> Seq.toList with - | [] -> [] - | x :: [] -> List.singleton x - | _ :: xs -> xs - let xs = - childrenValues - |> Seq.cons destination - |> Seq.pairwise - |> Seq.toList - |> mapFirstDifferently id (fun (d, x) -> (d + LanguagePrimitives.GenericOne, x)) - |> Seq.map (fun (d, x) -> createTree d x) - Node (x, xs) range |> Random.integral - |> Random.map (range |> Range.origin |> createTree) + |> Random.map (range |> Range.origin |> Shrink.createTree) |> ofRandom // diff --git a/src/Hedgehog/Shrink.fs b/src/Hedgehog/Shrink.fs index 66be69b2..a8608853 100644 --- a/src/Hedgehog/Shrink.fs +++ b/src/Hedgehog/Shrink.fs @@ -1,4 +1,4 @@ -namespace Hedgehog +namespace Hedgehog module Shrink = @@ -98,3 +98,19 @@ module Shrink = None Seq.unfold go diff + + + let inline createTree (destination : ^a) (x : ^a) = + let mapFirstDifferently f g = function + | [] -> [] + | x :: xs -> (f x) :: (xs |> List.map g) + let rec binarySearchTree (destination : ^a) (x : ^a) = + let xs = + towards destination x + |> Seq.cons destination + |> Seq.pairwise + |> Seq.toList + |> mapFirstDifferently id (fun (d, x) -> (d + LanguagePrimitives.GenericOne, x)) + |> Seq.map (fun (d, x) -> binarySearchTree d x) + Node (x, xs) + binarySearchTree destination x From 06f96f5dbcac28cbe6899267f22772fdac9dd312 Mon Sep 17 00:00:00 2001 From: Tyson Williams Date: Sat, 6 Feb 2021 21:00:35 -0600 Subject: [PATCH 3/9] added characterization tests for Shrink.createTree for parameters 0 to 7 --- tests/Hedgehog.Tests/ShrinkTests.fs | 75 +++++++++++++++++++++++++++++ 1 file changed, 75 insertions(+) diff --git a/tests/Hedgehog.Tests/ShrinkTests.fs b/tests/Hedgehog.Tests/ShrinkTests.fs index 53fcb091..45f78e56 100644 --- a/tests/Hedgehog.Tests/ShrinkTests.fs +++ b/tests/Hedgehog.Tests/ShrinkTests.fs @@ -205,4 +205,79 @@ 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" + "└-1" + " └-0" ] + expected =! actual + + testCase "createTree correct for 0,3" <| fun _ -> + let actual = Shrink.createTree 0 3 |> Tree.map (sprintf "%A") |> Tree.renderList + let expected = + [ "3" + "└-2" + " └-1" + " └-0" ] + expected =! actual + + testCase "createTree correct for 0,4" <| fun _ -> + let actual = Shrink.createTree 0 4 |> Tree.map (sprintf "%A") |> Tree.renderList + let expected = + [ "4" + "├-2" + "| └-1" + "| └-0" + "└-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" + "├-3" + "| └-2" + "| └-1" + "| └-0" + "└-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" + "├-3" + "| └-2" + "| └-1" + "| └-0" + "└-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" + "├-4" + "| ├-2" + "| | └-1" + "| | └-0" + "| └-3" + "└-6" + " └-5" ] + expected =! actual ] From e24227466c2f12f230c374eccaf8709974d32ef7 Mon Sep 17 00:00:00 2001 From: Tyson Williams Date: Sun, 7 Feb 2021 22:57:12 -0600 Subject: [PATCH 4/9] now using binary search tree with shrinking with origin-first heuristic --- src/Hedgehog/Seq.fs | 3 ++ src/Hedgehog/Shrink.fs | 32 +++++++++----------- src/Hedgehog/Tree.fs | 13 ++++++++ tests/Hedgehog.Tests/ShrinkTests.fs | 47 ++++++++++++++++++++--------- 4 files changed, 64 insertions(+), 31 deletions(-) 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 a8608853..2686a928 100644 --- a/src/Hedgehog/Shrink.fs +++ b/src/Hedgehog/Shrink.fs @@ -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. @@ -101,16 +99,16 @@ module Shrink = let inline createTree (destination : ^a) (x : ^a) = - let mapFirstDifferently f g = function - | [] -> [] - | x :: xs -> (f x) :: (xs |> List.map g) + let one = LanguagePrimitives.GenericOne let rec binarySearchTree (destination : ^a) (x : ^a) = let xs = towards destination x - |> Seq.cons destination + |> Seq.cons (destination - one) |> Seq.pairwise - |> Seq.toList - |> mapFirstDifferently id (fun (d, x) -> (d + LanguagePrimitives.GenericOne, x)) - |> Seq.map (fun (d, x) -> binarySearchTree d x) + |> Seq.map (fun (d, x) -> binarySearchTree (d + one) x) Node (x, xs) - binarySearchTree destination x + if destination = x then + Node (x, Seq.empty) + else + binarySearchTree (destination + one) 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 45f78e56..72615897 100644 --- a/tests/Hedgehog.Tests/ShrinkTests.fs +++ b/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 = @@ -222,26 +228,26 @@ let shrinkTests = testList "Shrink tests" [ let actual = Shrink.createTree 0 2 |> Tree.map (sprintf "%A") |> Tree.renderList let expected = [ "2" - "└-1" - " └-0" ] + "├-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" - " └-0" ] + " └-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" - "| └-0" "└-3" ] expected =! actual @@ -249,10 +255,10 @@ let shrinkTests = testList "Shrink tests" [ let actual = Shrink.createTree 0 5 |> Tree.map (sprintf "%A") |> Tree.renderList let expected = [ "5" + "├-0" "├-3" "| └-2" "| └-1" - "| └-0" "└-4" ] expected =! actual @@ -260,10 +266,10 @@ let shrinkTests = testList "Shrink tests" [ let actual = Shrink.createTree 0 6 |> Tree.map (sprintf "%A") |> Tree.renderList let expected = [ "6" + "├-0" "├-3" "| └-2" "| └-1" - "| └-0" "└-5" " └-4" ] expected =! actual @@ -272,12 +278,25 @@ let shrinkTests = testList "Shrink tests" [ let actual = Shrink.createTree 0 7 |> Tree.map (sprintf "%A") |> Tree.renderList let expected = [ "7" + "├-0" "├-4" "| ├-2" "| | └-1" - "| | └-0" "| └-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 ] From a8430fcc1299cf5cec8436b543dc94facb94f736 Mon Sep 17 00:00:00 2001 From: Tyson Williams <34664007+TysonMN@users.noreply.github.com> Date: Mon, 8 Feb 2021 09:59:09 -0600 Subject: [PATCH 5/9] Update src/Hedgehog/Gen.fs Co-authored-by: Nikos Baxevanis --- src/Hedgehog/Gen.fs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Hedgehog/Gen.fs b/src/Hedgehog/Gen.fs index 1b82e9de..2780f105 100644 --- a/src/Hedgehog/Gen.fs +++ b/src/Hedgehog/Gen.fs @@ -163,6 +163,7 @@ module Gen = /// Generates a random number in the given inclusive range. let inline integral (range : Range<'a>) : Gen<'a> = + // https://github.com/hedgehogqa/fsharp-hedgehog/pull/239 range |> Random.integral |> Random.map (range |> Range.origin |> Shrink.createTree) From 4ae71069cbf740207002dc487ca2e13c95adabb2 Mon Sep 17 00:00:00 2001 From: Tyson Williams Date: Wed, 10 Feb 2021 19:55:37 -0600 Subject: [PATCH 6/9] simplified use of plus/minus one --- src/Hedgehog/Shrink.fs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Hedgehog/Shrink.fs b/src/Hedgehog/Shrink.fs index 2686a928..a8922869 100644 --- a/src/Hedgehog/Shrink.fs +++ b/src/Hedgehog/Shrink.fs @@ -102,13 +102,13 @@ module Shrink = let one = LanguagePrimitives.GenericOne let rec binarySearchTree (destination : ^a) (x : ^a) = let xs = - towards destination x - |> Seq.cons (destination - one) + towards (destination + one) x + |> Seq.cons destination |> Seq.pairwise - |> Seq.map (fun (d, x) -> binarySearchTree (d + one) x) + |> Seq.map (fun (d, x) -> binarySearchTree d x) Node (x, xs) if destination = x then Node (x, Seq.empty) else - binarySearchTree (destination + one) x + binarySearchTree destination x |> Tree.addChildValue destination From f9288d80771fa85585a2b1d714d4e0c62692c0e2 Mon Sep 17 00:00:00 2001 From: Tyson Williams Date: Wed, 10 Feb 2021 19:56:26 -0600 Subject: [PATCH 7/9] uncurried function --- src/Hedgehog/Shrink.fs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Hedgehog/Shrink.fs b/src/Hedgehog/Shrink.fs index a8922869..e9758eae 100644 --- a/src/Hedgehog/Shrink.fs +++ b/src/Hedgehog/Shrink.fs @@ -100,15 +100,15 @@ module Shrink = let inline createTree (destination : ^a) (x : ^a) = let one = LanguagePrimitives.GenericOne - let rec binarySearchTree (destination : ^a) (x : ^a) = + let rec binarySearchTree ((destination : ^a), (x : ^a)) = let xs = towards (destination + one) x |> Seq.cons destination |> Seq.pairwise - |> Seq.map (fun (d, x) -> binarySearchTree d x) + |> Seq.map binarySearchTree Node (x, xs) if destination = x then Node (x, Seq.empty) else - binarySearchTree destination x + binarySearchTree (destination, x) |> Tree.addChildValue destination From bc0a86c23538826fa0fe24541acdc87ce8aca198 Mon Sep 17 00:00:00 2001 From: Tyson Williams Date: Wed, 10 Feb 2021 20:34:31 -0600 Subject: [PATCH 8/9] revert all changes to Shrink.towards --- src/Hedgehog/Shrink.fs | 9 +++++---- tests/Hedgehog.Tests/ShrinkTests.fs | 6 +++--- 2 files changed, 8 insertions(+), 7 deletions(-) diff --git a/src/Hedgehog/Shrink.fs b/src/Hedgehog/Shrink.fs index e9758eae..741b22f1 100644 --- a/src/Hedgehog/Shrink.fs +++ b/src/Hedgehog/Shrink.fs @@ -66,18 +66,19 @@ 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. diff --git a/tests/Hedgehog.Tests/ShrinkTests.fs b/tests/Hedgehog.Tests/ShrinkTests.fs index 72615897..3dfbab79 100644 --- a/tests/Hedgehog.Tests/ShrinkTests.fs +++ b/tests/Hedgehog.Tests/ShrinkTests.fs @@ -73,19 +73,19 @@ let shrinkTests = testList "Shrink tests" [ let actual = Shrink.towards 0 100 |> Seq.toList - [50; 75; 88; 94; 97; 99] =! actual + [0; 50; 75; 88; 94; 97; 99] =! actual testCase "towards correct on input 500, 1000" <| fun _ -> let actual = Shrink.towards 500 1000 |> Seq.toList - [750; 875; 938; 969; 985; 993; 997; 999] =! actual + [500; 750; 875; 938; 969; 985; 993; 997; 999] =! actual testCase "towards correct on input -50, -26" <| fun _ -> let actual = Shrink.towards -50 -26 |> Seq.toList - [-38; -32; -29; -27] =! actual + [-50; -38; -32; -29; -27] =! actual testCase "towards correct on input 4, 5" <| fun _ -> let actual = From d2944906837ab899a4dd19bec85df12129b9cfcd Mon Sep 17 00:00:00 2001 From: Tyson Williams Date: Wed, 10 Feb 2021 20:35:14 -0600 Subject: [PATCH 9/9] makes createTree tests pass again while also simplifying --- src/Hedgehog/Shrink.fs | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/src/Hedgehog/Shrink.fs b/src/Hedgehog/Shrink.fs index 741b22f1..8bff8511 100644 --- a/src/Hedgehog/Shrink.fs +++ b/src/Hedgehog/Shrink.fs @@ -100,11 +100,9 @@ module Shrink = let inline createTree (destination : ^a) (x : ^a) = - let one = LanguagePrimitives.GenericOne let rec binarySearchTree ((destination : ^a), (x : ^a)) = let xs = - towards (destination + one) x - |> Seq.cons destination + towards destination x |> Seq.pairwise |> Seq.map binarySearchTree Node (x, xs)