From 5fd53ea7bd81cd0506385ba95202107680a6d0c3 Mon Sep 17 00:00:00 2001 From: Egor Starikov Date: Thu, 30 Apr 2026 19:11:51 +0300 Subject: [PATCH 01/17] fix conflicts --- QuadTree.Tests/QuadTree.Tests.fsproj | 2 + QuadTree.Tests/Tests.RedBlackSet.fs | 199 ++++++++++++++++ QuadTree/QuadTree.fsproj | 1 + QuadTree/RedBlackSet.fs | 330 +++++++++++++++++++++++++++ 4 files changed, 532 insertions(+) create mode 100644 QuadTree.Tests/Tests.RedBlackSet.fs create mode 100644 QuadTree/RedBlackSet.fs diff --git a/QuadTree.Tests/QuadTree.Tests.fsproj b/QuadTree.Tests/QuadTree.Tests.fsproj index bc76cf2..022c87d 100644 --- a/QuadTree.Tests/QuadTree.Tests.fsproj +++ b/QuadTree.Tests/QuadTree.Tests.fsproj @@ -14,6 +14,8 @@ + + diff --git a/QuadTree.Tests/Tests.RedBlackSet.fs b/QuadTree.Tests/Tests.RedBlackSet.fs new file mode 100644 index 0000000..ea3a79f --- /dev/null +++ b/QuadTree.Tests/Tests.RedBlackSet.fs @@ -0,0 +1,199 @@ +module RedBlackSet.Tests + +open System +open RedBlackSet +open Xunit + +let rec blHeightInv tree = + match tree with + | Empty -> 0 + | Node(color, l, _, r) -> + let lH = blHeightInv l + let rH = blHeightInv r + if lH = -1 || rH = -1 || lH <> rH then + -1 + else if color = Red then + lH + else + lH + 1 + +let rec heightInv tree = + match tree with + | Empty -> 0 + | Node(_, l, _, r) -> + let lH = heightInv l + let rH = heightInv r + if lH > rH then + if lH = -1 || rH = -1 || (float (lH + 1) / float (rH + 1) > 2) then + -1 + else + lH + else + if lH = -1 || rH = -1 || (float (rH + 1) / float (lH + 1) > 2) then + -1 + else + rH + +let rec blackSonsOfRed tree = + match tree with + | Empty -> true + | Node(Red, Node(Red, _,_ , _) , _, _) -> false + | Node(Red, _, _, Node(Red, _, _, _)) -> false + | Node(_, l, _, r) -> + blackSonsOfRed l && blackSonsOfRed r + +let rec numOfElements tree num = + match tree with + | Empty -> 0 + | Node(_, l, _, r) -> + let lN = numOfElements l num + let rN = numOfElements r num + lN + rN + 1 + +[] +let oneElement() = + let t1 = emptySet + let t2 = insert t1 4 + let t3 = insert t2 4 + Assert.True(contains t3 4) + Assert.Equal(1, blHeightInv t3) + Assert.NotEqual(-1, heightInv t3) + Assert.True(blackSonsOfRed t3) + Assert.Equal(1, numOfElements t3 0) + +[] +let insertSomeElem() = + let t1 = emptySet + let t2 = insert t1 5 + let t3 = insert t2 9 + let t4 = insert t3 -7 + let t5 = insert t4 89 + let t6 = insert t5 -27 + let t7 = insert t6 13 + Assert.True(contains t7 -7) + Assert.Equal(2, blHeightInv t7) + Assert.NotEqual(-1, heightInv t7) + Assert.True(blackSonsOfRed t7) + Assert.Equal(6, numOfElements t7 0) + +[] +let deleteSomeElem() = + let t1 = emptySet + let t2 = insert t1 5 + let t3 = insert t2 9 + let t4 = insert t3 -7 + let t5 = insert t4 89 + let t6 = insert t5 -27 + let t7 = insert t6 13 + let t8 = delete t7 99 + let t9 = delete t8 13 + Assert.False(contains t9 13) + Assert.Equal(2, blHeightInv t9) + Assert.NotEqual(-1, heightInv t9) + Assert.True(blackSonsOfRed t9) + Assert.Equal(5, numOfElements t9 0) + +[] +let unionSets() = + let t1 = emptySet + let t2 = insert t1 5 + let t3 = insert t2 9 + let t4 = insert t3 -7 + let t5 = insert t4 89 + let t6 = insert t5 -27 + let t7 = insert t6 13 + + let t1' = emptySet + let t2' = insert t1' 2 + let t3' = insert t2' 7 + let t4' = insert t3' 21 + let t5' = insert t4' 9 + let t6' = insert t5' 5 + + let tU = union t7 t6' + Assert.NotEqual(-1, heightInv tU) + Assert.True(blackSonsOfRed tU) + Assert.Equal(9, numOfElements tU 0) + +[] +let intersectionSets() = + let t1 = emptySet + let t2 = insert t1 5 + let t3 = insert t2 9 + let t4 = insert t3 -7 + let t5 = insert t4 89 + let t6 = insert t5 -27 + let t7 = insert t6 13 + + let t1' = emptySet + let t2' = insert t1' 2 + let t3' = insert t2' 7 + let t4' = insert t3' 21 + let t5' = insert t4' 9 + let t6' = insert t5' 5 + + let tI = intersection t7 t6' + Assert.NotEqual(-1, heightInv tI) + Assert.True(blackSonsOfRed tI) + Assert.Equal(2, numOfElements tI 0) + +[] +let differenceSets() = + let t1 = emptySet + let t2 = insert t1 5 + let t3 = insert t2 9 + let t4 = insert t3 -7 + let t5 = insert t4 89 + let t6 = insert t5 -27 + let t7 = insert t6 13 + + let t1' = emptySet + let t2' = insert t1' 2 + let t3' = insert t2' 7 + let t4' = insert t3' 21 + let t5' = insert t4' 9 + let t6' = insert t5' 5 + + let tD = difference t7 t6' + Assert.NotEqual(-1, heightInv tD) + Assert.True(blackSonsOfRed tD) + Assert.Equal(4, numOfElements tD 0) + +[] +let emptySetProperties() = + let t = emptySet + Assert.False(contains t 0) + Assert.Equal(0, numOfElements t 0) + Assert.Equal(0, blHeightInv t) + Assert.True(blackSonsOfRed t) + +[] +let largeSetInsertion() = + let randomValues = [for i in 1..1000 -> Random().Next(-10000, 10000)] + let tree = Seq.fold (fun acc x -> insert acc x) emptySet randomValues + + Assert.NotEqual(-1, blHeightInv tree) + Assert.True(blackSonsOfRed tree) + + for x in randomValues do + Assert.True(contains tree x) + +[] +let deleteRoot() = + let t1 = insert emptySet 5 + let t2 = insert t1 3 + let t3 = insert t2 7 + let t4 = delete t3 5 + + Assert.False(contains t4 5) + Assert.True(contains t4 3) + Assert.True(contains t4 7) + Assert.NotEqual(-1, blHeightInv t4) + +[] +let complexRedBlackViolations() = + let values = [1..20] + let tree = Seq.fold (fun acc x -> insert acc x) emptySet values + + Assert.NotEqual(-1, blHeightInv tree) + Assert.True(blackSonsOfRed tree) diff --git a/QuadTree/QuadTree.fsproj b/QuadTree/QuadTree.fsproj index abfc6ec..acf35f1 100644 --- a/QuadTree/QuadTree.fsproj +++ b/QuadTree/QuadTree.fsproj @@ -15,6 +15,7 @@ + diff --git a/QuadTree/RedBlackSet.fs b/QuadTree/RedBlackSet.fs new file mode 100644 index 0000000..1d4ce51 --- /dev/null +++ b/QuadTree/RedBlackSet.fs @@ -0,0 +1,330 @@ +//в качестве референса использовались "Faster, Simpler Red-Black Trees" и Data/Set/RBTree.hs +module RedBlackSet + +type Color = + | Red + | Black + +type Tree<'T> = + | Empty + | Node of color: Color * left: Tree<'T> * value: 'T * right: Tree<'T> + +let emptySet = Empty + +//оболочка, чтобы понимать, надо ли вызывать балансировку на следующих шагах рекурсии +type private Result<'T> = + | Done of 'T + | ToDo of 'T + +//перекраска листа в черный +let private blacken tree = + match tree with + | Node(Red, a, x, b) -> Done(Node(Black, a, x, b)) + | _ -> ToDo tree + +//убирает оболочку +let private justTree resultTree = + match resultTree with + | Done t -> t + | ToDo t -> t + +//считает черную высоту +let rec private blackHeight tree = + match tree with + | Empty -> 0 + | Node(Red, l, _, _) -> blackHeight l + | Node(Black, l, _, _) -> 1 + (blackHeight l) + + +//проверка на наличие +let rec contains tree v = + match tree with + | Empty -> false + | Node(_, left, value, right) -> + if value > v then contains left v + elif value < v then contains right v + else true + +//балансировка +let private balance tree = + match tree with + | Node(Black, Node(Red, Node(Red, a, x, b), y, c), z, d) + | Node(Black, Node(Red, a, x, Node(Red, b, y, c)), z, d) + | Node(Black, a, x, Node(Red, Node(Red, b, y, c), z, d)) + | Node(Black, a, x, Node(Red, b, y, Node(Red, c, z, d))) -> + ToDo(Node(Red, Node(Black, a, x, b), y, Node(Black, c, z, d))) + | Node(Black, a, x, b) as n -> Done(n) + | _ -> ToDo(tree) + +//вставка +let insert tree v = + + let rec insertRec tree v = + match tree with + | Empty -> ToDo(Node(Red, Empty, v, Empty)) + | Node(color, left, value, right) -> + if value > v then + let newLeft = insertRec left v + + match newLeft with + | Done nl -> Done(Node(color, nl, value, right)) + | ToDo nl -> balance (Node(color, nl, value, right)) + elif value < v then + let newRight = insertRec right v + + match newRight with + | Done nr -> Done(Node(color, left, value, nr)) + | ToDo nr -> balance (Node(color, left, value, nr)) + else + Done(tree) + + let newTree = insertRec tree v + newTree |> justTree |> blacken |> justTree + +//удаление +let delete tree v = + + let balanceDel tree = + match tree with + | Node(color, Node(Red, Node(Red, a, x, b), y, c), z, d) + | Node(color, Node(Red, a, x, Node(Red, b, y, c)), z, d) + | Node(color, a, x, Node(Red, Node(Red, b, y, c), z, d)) + | Node(color, a, x, Node(Red, b, y, Node(Red, c, z, d))) -> + Done(Node(color, Node(Black, a, x, b), y, Node(Black, c, z, d))) + | _ -> blacken tree + + let rec eqL tree = + match tree with + | Node(color, a, x, Node(Black, b, y, c)) -> balanceDel (Node(color, a, x, Node(Red, b, y, c))) + | Node(color, a, x, Node(Red, b, y, c)) -> + let newLeft = eqL (Node(Red, a, x, b)) + + match newLeft with + | Done nl -> Done(Node(Black, nl, y, c)) + | ToDo nl -> ToDo(Node(Black, nl, y, c)) + | _ -> failwith "Impossible pattern" + + let rec eqR tree = + match tree with + | Node(color, Node(Black, a, x, b), y, c) -> balanceDel (Node(color, Node(Red, a, x, b), y, c)) + | Node(color, Node(Red, a, x, b), y, c) -> + let newRight = eqR (Node(Red, b, y, c)) + + match newRight with + | Done nr -> Done(Node(Black, a, x, nr)) + | ToDo nr -> ToDo(Node(Black, a, x, nr)) + | _ -> failwith "Impossible pattern" + + let delCur tree = + + let rec delMin tree = + match tree with + | Node(Red, Empty, x, b) -> (Done b, x) + | Node(Black, Empty, x, b) -> (blacken b, x) + | Node(color, a, x, b) -> + let (an, min) = delMin a + + match an with + | Done t -> (Done(Node(color, t, x, b)), min) + | ToDo t -> (eqL (Node(color, t, x, b)), min) + | _ -> failwith "Impossible pattern" + + match tree with + | Node(Red, a, y, Empty) -> Done a + | Node(Black, a, x, Empty) -> blacken a + | Node(color, a, x, b) -> + let (bn, min) = delMin b + + match bn with + | Done t -> Done(Node(color, a, min, t)) + | ToDo t -> eqR (Node(color, a, min, t)) + | _ -> failwith "Impossible pattern" + + let rec deleteRec tree v = + match tree with + | Empty -> Done(Empty) + | Node(color, left, value, right) -> + if value > v then + let newLeft = deleteRec left v + + match newLeft with + | Done nl -> Done(Node(color, nl, value, right)) + | ToDo nl -> eqL (Node(color, nl, value, right)) + elif value < v then + let newRight = deleteRec right v + + match newRight with + | Done nr -> Done(Node(color, left, value, nr)) + | ToDo nr -> eqR (Node(color, left, value, nr)) + else + delCur tree + + let newTree = deleteRec tree v + newTree |> justTree |> blacken |> justTree + +//join +let join t1 g t2 = + + let rec joinLT t1 g t2 targetHeight currentHeight = + if targetHeight = currentHeight then + Node(Red, t1, g, t2) + else + match t2 with + | Node(Red, l, x, r) -> + let newLeft = joinLT t1 g l targetHeight currentHeight + Node(Red, newLeft, x, r) |> balance |> justTree + | Node(Black, l, x, r) -> + let newLeft = joinLT t1 g l targetHeight (currentHeight - 1) + Node(Black, newLeft, x, r) |> balance |> justTree + | _ -> failwith "Impossible pattern" + + let rec joinRT t1 g t2 targetHeight currentHeight = + if targetHeight = currentHeight then + Node(Red, t1, g, t2) + else + match t1 with + | Node(Red, l, x, r) -> + let newRight = joinRT t2 g r targetHeight currentHeight + Node(Red, l, x, newRight) |> balance |> justTree + | Node(Black, l, x, r) -> + let newRight = joinRT t2 g r targetHeight (currentHeight - 1) + Node(Black, l, x, newRight) |> balance |> justTree + | _ -> failwith "Impossible pattern" + + let h1 = blackHeight t1 + let h2 = blackHeight t2 + + if h1 = 0 then + insert t2 g + else if h2 = 0 then + insert t1 g + else if h1 < h2 then + let t = joinLT t1 g t2 h1 h2 + + t |> blacken |> justTree + else if h1 > h2 then + let t = joinRT t1 g t2 h2 h1 + + t |> blacken |> justTree + else + Node(Black, t1, g, t2) + +//merge +let merge t1 t2 = + + let rec minimum tree = + match tree with + | Node(_, Empty, x, _) -> x + | Node(_, l, _, _) -> minimum l + | _ -> failwith "Impossible pattern" + + let mergeEQ t1 t2 = + let m = minimum t2 + let t2' = delete t2 m + let h2' = blackHeight t2' + let h1 = blackHeight t1 + + if h1 = h2' then + Node(Red, t1, m, t2') + else + match t1 with + | Node(_, Node(Red, ll, lx, lr), x, r) -> Node(Red, Node(Black, ll, lx, lr), x, Node(Black, r, m, t2')) + | Node(_, l, x, Node(Red, rl, rx, rr)) -> Node(Black, Node(Red, l, x, rl), rx, Node(Red, rr, m, t2')) + | _ -> Node(Black, (justTree (blacken t1)), m, t2') + + let rec mergeLT t1 t2 targetHeight currentHeight = + if targetHeight = currentHeight then + mergeEQ t1 t2 + else + match t2 with + | Node(Red, l, x, r) -> + let newLeft = mergeLT t1 l targetHeight currentHeight + Node(Red, newLeft, x, r) |> balance |> justTree + | Node(Black, l, x, r) -> + let newLeft = mergeLT t1 l targetHeight (currentHeight - 1) + Node(Red, newLeft, x, r) |> balance |> justTree + | _ -> failwith "Impossible pattern" + + let rec mergeRT t1 t2 targetHeight currentHeight = + if targetHeight = currentHeight then + mergeEQ t1 t2 + else + match t1 with + | Node(Red, l, x, r) -> + let newRight = mergeRT r t2 targetHeight currentHeight + Node(Red, l, x, newRight) |> balance |> justTree + | Node(Black, l, x, r) -> + let newRight = mergeRT r t2 targetHeight (currentHeight - 1) + Node(Red, l, x, newRight) |> balance |> justTree + | _ -> failwith "Impossible pattern" + + let h1 = blackHeight t1 + let h2 = blackHeight t2 + + if h1 = 0 then + t2 + else if h2 = 0 then + t1 + else if h1 < h2 then + let t = mergeLT t1 t2 h1 h2 + + t |> blacken |> justTree + else if h1 > h2 then + let t = mergeRT t1 t2 h2 h1 + + t |> blacken |> justTree + else + let t = mergeEQ t1 t2 + t |> blacken |> justTree + +//split +let rec split kx tree = + match tree with + | Empty -> (Empty, Empty) + | Node(_, l, x, r) -> + if kx < x then + let (lt, gt) = split kx l + (lt, join gt x (justTree (blacken r))) + else if kx > x then + let (lt, gt) = split kx r + (join (justTree (blacken l)) x lt, gt) + else + (justTree (blacken (l)), justTree (blacken (r))) + + +//объединение +let rec union t1 t2 = + match t1 with + | Empty -> t2 + | _ -> + match t2 with + | Empty -> t1 + | Node(_, l, x, r) -> + let (l', r') = split x t1 + join (union l' l) x (union r' r) + +//пересечение +let rec intersection t1 t2 = + match t1 with + | Empty -> Empty + | _ -> + match t2 with + | Empty -> Empty + | Node(_, l, x, r) -> + let (l', r') = split x t1 + + if contains t1 x then + join (intersection l' l) x (intersection r' r) + else + merge (intersection l' l) (intersection r' r) + +//разность +let rec difference t1 t2 = + match t1 with + | Empty -> Empty + | _ -> + match t2 with + | Empty -> t1 + | Node(_, l, x, r) -> + let (l', r') = split x t1 + merge (difference l' l) (difference r' r) From b05cd66bc617a5086825465ea43a5ce08e0e47fd Mon Sep 17 00:00:00 2001 From: Egor Starikov Date: Thu, 30 Apr 2026 19:32:27 +0300 Subject: [PATCH 02/17] formatted Tests.RedBlackSet.fs --- QuadTree.Tests/Tests.RedBlackSet.fs | 87 ++++++++++++++--------------- 1 file changed, 42 insertions(+), 45 deletions(-) diff --git a/QuadTree.Tests/Tests.RedBlackSet.fs b/QuadTree.Tests/Tests.RedBlackSet.fs index ea3a79f..ad6d4de 100644 --- a/QuadTree.Tests/Tests.RedBlackSet.fs +++ b/QuadTree.Tests/Tests.RedBlackSet.fs @@ -4,54 +4,51 @@ open System open RedBlackSet open Xunit -let rec blHeightInv tree = - match tree with +let rec blHeightInv tree = + match tree with | Empty -> 0 - | Node(color, l, _, r) -> - let lH = blHeightInv l + | Node(color, l, _, r) -> + let lH = blHeightInv l let rH = blHeightInv r - if lH = -1 || rH = -1 || lH <> rH then - -1 - else if color = Red then - lH - else - lH + 1 + + if lH = -1 || rH = -1 || lH <> rH then -1 + else if color = Red then lH + else lH + 1 let rec heightInv tree = - match tree with + match tree with | Empty -> 0 - | Node(_, l, _, r) -> + | Node(_, l, _, r) -> let lH = heightInv l let rH = heightInv r - if lH > rH then - if lH = -1 || rH = -1 || (float (lH + 1) / float (rH + 1) > 2) then + + if lH > rH then + if lH = -1 || rH = -1 || (float (lH + 1) / float (rH + 1) > 2) then -1 - else + else lH - else - if lH = -1 || rH = -1 || (float (rH + 1) / float (lH + 1) > 2) then - -1 - else - rH + else if lH = -1 || rH = -1 || (float (rH + 1) / float (lH + 1) > 2) then + -1 + else + rH let rec blackSonsOfRed tree = - match tree with + match tree with | Empty -> true - | Node(Red, Node(Red, _,_ , _) , _, _) -> false + | Node(Red, Node(Red, _, _, _), _, _) -> false | Node(Red, _, _, Node(Red, _, _, _)) -> false - | Node(_, l, _, r) -> - blackSonsOfRed l && blackSonsOfRed r + | Node(_, l, _, r) -> blackSonsOfRed l && blackSonsOfRed r -let rec numOfElements tree num = +let rec numOfElements tree num = match tree with | Empty -> 0 | Node(_, l, _, r) -> let lN = numOfElements l num let rN = numOfElements r num - lN + rN + 1 + lN + rN + 1 [] -let oneElement() = +let oneElement () = let t1 = emptySet let t2 = insert t1 4 let t3 = insert t2 4 @@ -62,7 +59,7 @@ let oneElement() = Assert.Equal(1, numOfElements t3 0) [] -let insertSomeElem() = +let insertSomeElem () = let t1 = emptySet let t2 = insert t1 5 let t3 = insert t2 9 @@ -77,7 +74,7 @@ let insertSomeElem() = Assert.Equal(6, numOfElements t7 0) [] -let deleteSomeElem() = +let deleteSomeElem () = let t1 = emptySet let t2 = insert t1 5 let t3 = insert t2 9 @@ -94,7 +91,7 @@ let deleteSomeElem() = Assert.Equal(5, numOfElements t9 0) [] -let unionSets() = +let unionSets () = let t1 = emptySet let t2 = insert t1 5 let t3 = insert t2 9 @@ -110,13 +107,13 @@ let unionSets() = let t5' = insert t4' 9 let t6' = insert t5' 5 - let tU = union t7 t6' + let tU = union t7 t6' Assert.NotEqual(-1, heightInv tU) Assert.True(blackSonsOfRed tU) Assert.Equal(9, numOfElements tU 0) [] -let intersectionSets() = +let intersectionSets () = let t1 = emptySet let t2 = insert t1 5 let t3 = insert t2 9 @@ -132,13 +129,13 @@ let intersectionSets() = let t5' = insert t4' 9 let t6' = insert t5' 5 - let tI = intersection t7 t6' + let tI = intersection t7 t6' Assert.NotEqual(-1, heightInv tI) Assert.True(blackSonsOfRed tI) Assert.Equal(2, numOfElements tI 0) [] -let differenceSets() = +let differenceSets () = let t1 = emptySet let t2 = insert t1 5 let t3 = insert t2 9 @@ -154,13 +151,13 @@ let differenceSets() = let t5' = insert t4' 9 let t6' = insert t5' 5 - let tD = difference t7 t6' + let tD = difference t7 t6' Assert.NotEqual(-1, heightInv tD) Assert.True(blackSonsOfRed tD) Assert.Equal(4, numOfElements tD 0) [] -let emptySetProperties() = +let emptySetProperties () = let t = emptySet Assert.False(contains t 0) Assert.Equal(0, numOfElements t 0) @@ -168,32 +165,32 @@ let emptySetProperties() = Assert.True(blackSonsOfRed t) [] -let largeSetInsertion() = - let randomValues = [for i in 1..1000 -> Random().Next(-10000, 10000)] +let largeSetInsertion () = + let randomValues = [ for i in 1..1000 -> Random().Next(-10000, 10000) ] let tree = Seq.fold (fun acc x -> insert acc x) emptySet randomValues - + Assert.NotEqual(-1, blHeightInv tree) Assert.True(blackSonsOfRed tree) - + for x in randomValues do Assert.True(contains tree x) [] -let deleteRoot() = +let deleteRoot () = let t1 = insert emptySet 5 let t2 = insert t1 3 let t3 = insert t2 7 let t4 = delete t3 5 - + Assert.False(contains t4 5) Assert.True(contains t4 3) Assert.True(contains t4 7) Assert.NotEqual(-1, blHeightInv t4) [] -let complexRedBlackViolations() = - let values = [1..20] +let complexRedBlackViolations () = + let values = [ 1..20 ] let tree = Seq.fold (fun acc x -> insert acc x) emptySet values - + Assert.NotEqual(-1, blHeightInv tree) Assert.True(blackSonsOfRed tree) From e736e3fd481a4b087589a61bfa2c7989e8aa4495 Mon Sep 17 00:00:00 2001 From: Egor Starikov Date: Fri, 1 May 2026 13:02:21 +0300 Subject: [PATCH 03/17] add private merge, split, join --- QuadTree/RedBlackSet.fs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/QuadTree/RedBlackSet.fs b/QuadTree/RedBlackSet.fs index 1d4ce51..7d61b4c 100644 --- a/QuadTree/RedBlackSet.fs +++ b/QuadTree/RedBlackSet.fs @@ -163,7 +163,7 @@ let delete tree v = newTree |> justTree |> blacken |> justTree //join -let join t1 g t2 = +let private join t1 g t2 = let rec joinLT t1 g t2 targetHeight currentHeight = if targetHeight = currentHeight then @@ -210,7 +210,7 @@ let join t1 g t2 = Node(Black, t1, g, t2) //merge -let merge t1 t2 = +let private merge t1 t2 = let rec minimum tree = match tree with @@ -278,7 +278,7 @@ let merge t1 t2 = t |> blacken |> justTree //split -let rec split kx tree = +let rec private split kx tree = match tree with | Empty -> (Empty, Empty) | Node(_, l, x, r) -> From 260e7e21019b752bf4b58a8f47420c7da03496d0 Mon Sep 17 00:00:00 2001 From: Egor Starikov Date: Tue, 5 May 2026 21:14:07 +0300 Subject: [PATCH 04/17] fix comments --- QuadTree/RedBlackSet.fs | 16 +--------------- 1 file changed, 1 insertion(+), 15 deletions(-) diff --git a/QuadTree/RedBlackSet.fs b/QuadTree/RedBlackSet.fs index 7d61b4c..78d1518 100644 --- a/QuadTree/RedBlackSet.fs +++ b/QuadTree/RedBlackSet.fs @@ -1,4 +1,4 @@ -//в качестве референса использовались "Faster, Simpler Red-Black Trees" и Data/Set/RBTree.hs +//The following sources were used as a reference: 'Faster, Simpler Red-Black Trees' and Data/Set/RBTree.hs. module RedBlackSet type Color = @@ -11,24 +11,20 @@ type Tree<'T> = let emptySet = Empty -//оболочка, чтобы понимать, надо ли вызывать балансировку на следующих шагах рекурсии type private Result<'T> = | Done of 'T | ToDo of 'T -//перекраска листа в черный let private blacken tree = match tree with | Node(Red, a, x, b) -> Done(Node(Black, a, x, b)) | _ -> ToDo tree -//убирает оболочку let private justTree resultTree = match resultTree with | Done t -> t | ToDo t -> t -//считает черную высоту let rec private blackHeight tree = match tree with | Empty -> 0 @@ -36,7 +32,6 @@ let rec private blackHeight tree = | Node(Black, l, _, _) -> 1 + (blackHeight l) -//проверка на наличие let rec contains tree v = match tree with | Empty -> false @@ -45,7 +40,6 @@ let rec contains tree v = elif value < v then contains right v else true -//балансировка let private balance tree = match tree with | Node(Black, Node(Red, Node(Red, a, x, b), y, c), z, d) @@ -56,7 +50,6 @@ let private balance tree = | Node(Black, a, x, b) as n -> Done(n) | _ -> ToDo(tree) -//вставка let insert tree v = let rec insertRec tree v = @@ -81,7 +74,6 @@ let insert tree v = let newTree = insertRec tree v newTree |> justTree |> blacken |> justTree -//удаление let delete tree v = let balanceDel tree = @@ -162,7 +154,6 @@ let delete tree v = let newTree = deleteRec tree v newTree |> justTree |> blacken |> justTree -//join let private join t1 g t2 = let rec joinLT t1 g t2 targetHeight currentHeight = @@ -209,7 +200,6 @@ let private join t1 g t2 = else Node(Black, t1, g, t2) -//merge let private merge t1 t2 = let rec minimum tree = @@ -277,7 +267,6 @@ let private merge t1 t2 = let t = mergeEQ t1 t2 t |> blacken |> justTree -//split let rec private split kx tree = match tree with | Empty -> (Empty, Empty) @@ -292,7 +281,6 @@ let rec private split kx tree = (justTree (blacken (l)), justTree (blacken (r))) -//объединение let rec union t1 t2 = match t1 with | Empty -> t2 @@ -303,7 +291,6 @@ let rec union t1 t2 = let (l', r') = split x t1 join (union l' l) x (union r' r) -//пересечение let rec intersection t1 t2 = match t1 with | Empty -> Empty @@ -318,7 +305,6 @@ let rec intersection t1 t2 = else merge (intersection l' l) (intersection r' r) -//разность let rec difference t1 t2 = match t1 with | Empty -> Empty From 16596d0fd04ea51e78fd5f4885105ccc5d0ff0af Mon Sep 17 00:00:00 2001 From: Egor Starikov Date: Tue, 5 May 2026 21:22:47 +0300 Subject: [PATCH 05/17] Trigger PR creation after close From a53f0ab9186669a9b8e568c5988c03b162ce7b46 Mon Sep 17 00:00:00 2001 From: Egor Starikov Date: Wed, 16 Sep 2026 20:08:21 +0300 Subject: [PATCH 06/17] refactor: use Result --- QuadTree.Tests/Tests.RedBlackSet.fs | 285 +++++++------ QuadTree/RedBlackSet.fs | 630 +++++++++++++++------------- 2 files changed, 508 insertions(+), 407 deletions(-) diff --git a/QuadTree.Tests/Tests.RedBlackSet.fs b/QuadTree.Tests/Tests.RedBlackSet.fs index ad6d4de..0244714 100644 --- a/QuadTree.Tests/Tests.RedBlackSet.fs +++ b/QuadTree.Tests/Tests.RedBlackSet.fs @@ -1,7 +1,8 @@ module RedBlackSet.Tests open System -open RedBlackSet +open RBSet.RBSet +open RBSet open Xunit let rec blHeightInv tree = @@ -22,20 +23,17 @@ let rec heightInv tree = let lH = heightInv l let rH = heightInv r - if lH > rH then - if lH = -1 || rH = -1 || (float (lH + 1) / float (rH + 1) > 2) then - -1 - else - lH - else if lH = -1 || rH = -1 || (float (rH + 1) / float (lH + 1) > 2) then + if lH = -1 || rH = -1 || (float (rH + 1) / float (lH + 1) > 2) then -1 + else if lH > rH then + lH else rH let rec blackSonsOfRed tree = match tree with | Empty -> true - | Node(Red, Node(Red, _, _, _), _, _) -> false + | Node(Red, Node(Red, _, _, _), _, _) | Node(Red, _, _, Node(Red, _, _, _)) -> false | Node(_, l, _, r) -> blackSonsOfRed l && blackSonsOfRed r @@ -49,148 +47,197 @@ let rec numOfElements tree num = [] let oneElement () = - let t1 = emptySet - let t2 = insert t1 4 - let t3 = insert t2 4 - Assert.True(contains t3 4) - Assert.Equal(1, blHeightInv t3) - Assert.NotEqual(-1, heightInv t3) - Assert.True(blackSonsOfRed t3) - Assert.Equal(1, numOfElements t3 0) + let finalTree = empty |> add 4 |> Result.bind (add 4) + + match finalTree with + | Ok t -> + Assert.True(contains 4 t) + Assert.Equal(1, blHeightInv t) + Assert.NotEqual(-1, heightInv t) + Assert.True(blackSonsOfRed t) + Assert.Equal(1, numOfElements t 0) + | Error e -> Assert.True(false, sprintf "Expect Ok, but get Error: %A" e) [] let insertSomeElem () = - let t1 = emptySet - let t2 = insert t1 5 - let t3 = insert t2 9 - let t4 = insert t3 -7 - let t5 = insert t4 89 - let t6 = insert t5 -27 - let t7 = insert t6 13 - Assert.True(contains t7 -7) - Assert.Equal(2, blHeightInv t7) - Assert.NotEqual(-1, heightInv t7) - Assert.True(blackSonsOfRed t7) - Assert.Equal(6, numOfElements t7 0) + let finalTree = + empty + |> add 5 + |> Result.bind (add 9) + |> Result.bind (add -7) + |> Result.bind (add 89) + |> Result.bind (add -27) + |> Result.bind (add 13) + + match finalTree with + | Ok t -> + Assert.True(contains -7 t) + Assert.Equal(2, blHeightInv t) + Assert.NotEqual(-1, heightInv t) + Assert.True(blackSonsOfRed t) + Assert.Equal(6, numOfElements t 0) + | Error e -> Assert.True(false, sprintf "Expect Ok, but get Error: %A" e) [] let deleteSomeElem () = - let t1 = emptySet - let t2 = insert t1 5 - let t3 = insert t2 9 - let t4 = insert t3 -7 - let t5 = insert t4 89 - let t6 = insert t5 -27 - let t7 = insert t6 13 - let t8 = delete t7 99 - let t9 = delete t8 13 - Assert.False(contains t9 13) - Assert.Equal(2, blHeightInv t9) - Assert.NotEqual(-1, heightInv t9) - Assert.True(blackSonsOfRed t9) - Assert.Equal(5, numOfElements t9 0) + let finalTree = + empty + |> add 5 + |> Result.bind (add 9) + |> Result.bind (add -7) + |> Result.bind (add 89) + |> Result.bind (add -27) + |> Result.bind (add 13) + |> Result.bind (delete 99) + |> Result.bind (delete 13) + + match finalTree with + | Ok t -> + Assert.False(contains 13 t) + Assert.Equal(2, blHeightInv t) + Assert.NotEqual(-1, heightInv t) + Assert.True(blackSonsOfRed t) + Assert.Equal(5, numOfElements t 0) + | Error e -> Assert.True(false, sprintf "Expect Ok, but get Error: %A" e) [] let unionSets () = - let t1 = emptySet - let t2 = insert t1 5 - let t3 = insert t2 9 - let t4 = insert t3 -7 - let t5 = insert t4 89 - let t6 = insert t5 -27 - let t7 = insert t6 13 - - let t1' = emptySet - let t2' = insert t1' 2 - let t3' = insert t2' 7 - let t4' = insert t3' 21 - let t5' = insert t4' 9 - let t6' = insert t5' 5 - - let tU = union t7 t6' - Assert.NotEqual(-1, heightInv tU) - Assert.True(blackSonsOfRed tU) - Assert.Equal(9, numOfElements tU 0) + let finalTree1 = + empty + |> add 5 + |> Result.bind (add 9) + |> Result.bind (add -7) + |> Result.bind (add 89) + |> Result.bind (add -27) + |> Result.bind (add 13) + + let finalTree2 = + empty + |> add 2 + |> Result.bind (add 7) + |> Result.bind (add 21) + |> Result.bind (add 9) + |> Result.bind (add 5) + + match finalTree1, finalTree2 with + | Ok t1, Ok t2 -> + match union t1 t2 with + | Ok tU -> + Assert.NotEqual(-1, heightInv tU) + Assert.True(blackSonsOfRed tU) + Assert.Equal(9, numOfElements tU 0) + | Error e -> Assert.True(false, sprintf "Error in union: %A" e) + | _ -> Assert.True(false, sprintf "Error in insert") [] let intersectionSets () = - let t1 = emptySet - let t2 = insert t1 5 - let t3 = insert t2 9 - let t4 = insert t3 -7 - let t5 = insert t4 89 - let t6 = insert t5 -27 - let t7 = insert t6 13 - - let t1' = emptySet - let t2' = insert t1' 2 - let t3' = insert t2' 7 - let t4' = insert t3' 21 - let t5' = insert t4' 9 - let t6' = insert t5' 5 - - let tI = intersection t7 t6' - Assert.NotEqual(-1, heightInv tI) - Assert.True(blackSonsOfRed tI) - Assert.Equal(2, numOfElements tI 0) + let finalTree1 = + empty + |> add 5 + |> Result.bind (add 9) + |> Result.bind (add -7) + |> Result.bind (add 89) + |> Result.bind (add -27) + |> Result.bind (add 13) + + let finalTree2 = + empty + |> add 2 + |> Result.bind (add 7) + |> Result.bind (add 21) + |> Result.bind (add 9) + |> Result.bind (add 5) + + match finalTree1, finalTree2 with + | Ok t1, Ok t2 -> + match intersection t1 t2 with + | Ok tI -> + Assert.NotEqual(-1, heightInv tI) + Assert.True(blackSonsOfRed tI) + Assert.Equal(2, numOfElements tI 0) + | Error e -> Assert.True(false, sprintf "Error in intersection: %A" e) + | _ -> Assert.True(false, sprintf "Error in insert") [] let differenceSets () = - let t1 = emptySet - let t2 = insert t1 5 - let t3 = insert t2 9 - let t4 = insert t3 -7 - let t5 = insert t4 89 - let t6 = insert t5 -27 - let t7 = insert t6 13 - - let t1' = emptySet - let t2' = insert t1' 2 - let t3' = insert t2' 7 - let t4' = insert t3' 21 - let t5' = insert t4' 9 - let t6' = insert t5' 5 - - let tD = difference t7 t6' - Assert.NotEqual(-1, heightInv tD) - Assert.True(blackSonsOfRed tD) - Assert.Equal(4, numOfElements tD 0) + let finalTree1 = + empty + |> add 5 + |> Result.bind (add 9) + |> Result.bind (add -7) + |> Result.bind (add 89) + |> Result.bind (add -27) + |> Result.bind (add 13) + + let finalTree2 = + empty + |> add 2 + |> Result.bind (add 7) + |> Result.bind (add 21) + |> Result.bind (add 9) + |> Result.bind (add 5) + + match finalTree1, finalTree2 with + | Ok t1, Ok t2 -> + match difference t1 t2 with + | Ok tD -> + Assert.NotEqual(-1, heightInv tD) + Assert.True(blackSonsOfRed tD) + Assert.Equal(4, numOfElements tD 0) + | Error e -> Assert.True(false, sprintf "Error in difference: %A" e) + | _ -> Assert.True(false, sprintf "Error in insert") [] let emptySetProperties () = - let t = emptySet - Assert.False(contains t 0) + let t = empty + Assert.False(contains 0 t) Assert.Equal(0, numOfElements t 0) Assert.Equal(0, blHeightInv t) Assert.True(blackSonsOfRed t) [] let largeSetInsertion () = - let randomValues = [ for i in 1..1000 -> Random().Next(-10000, 10000) ] - let tree = Seq.fold (fun acc x -> insert acc x) emptySet randomValues + let rng = Random() + let randomValues = [ for _ in 1..1000 -> rng.Next(-10000, 10000) ] + + let treeResult = + randomValues |> List.fold (fun acc x -> acc |> Result.bind (add x)) (Ok empty) - Assert.NotEqual(-1, blHeightInv tree) - Assert.True(blackSonsOfRed tree) + match treeResult with + | Ok tree -> + Assert.NotEqual(-1, blHeightInv tree) + Assert.True(blackSonsOfRed tree) - for x in randomValues do - Assert.True(contains tree x) + for x in randomValues do + Assert.True(contains x tree) + | Error err -> Assert.True(false, sprintf "Error in insert: %A" err) [] let deleteRoot () = - let t1 = insert emptySet 5 - let t2 = insert t1 3 - let t3 = insert t2 7 - let t4 = delete t3 5 - - Assert.False(contains t4 5) - Assert.True(contains t4 3) - Assert.True(contains t4 7) - Assert.NotEqual(-1, blHeightInv t4) + let finalTree = + empty + |> add 5 + |> Result.bind (add 3) + |> Result.bind (add 7) + |> Result.bind (delete 5) + + match finalTree with + | Ok t -> + Assert.False(contains 5 t) + Assert.True(contains 3 t) + Assert.True(contains 7 t) + Assert.NotEqual(-1, blHeightInv t) + | _ -> Assert.True(false, sprintf "Expect Ok, but get Error") [] let complexRedBlackViolations () = let values = [ 1..20 ] - let tree = Seq.fold (fun acc x -> insert acc x) emptySet values - Assert.NotEqual(-1, blHeightInv tree) - Assert.True(blackSonsOfRed tree) + let treeResult = + values |> List.fold (fun acc x -> acc |> Result.bind (add x)) (Ok empty) + + match treeResult with + | Ok tree -> + Assert.NotEqual(-1, blHeightInv tree) + Assert.True(blackSonsOfRed tree) + | Error err -> Assert.True(false, sprintf "Error in insert: %A" err) diff --git a/QuadTree/RedBlackSet.fs b/QuadTree/RedBlackSet.fs index 78d1518..673eea3 100644 --- a/QuadTree/RedBlackSet.fs +++ b/QuadTree/RedBlackSet.fs @@ -1,5 +1,9 @@ //The following sources were used as a reference: 'Faster, Simpler Red-Black Trees' and Data/Set/RBTree.hs. -module RedBlackSet +namespace RBSet + +open Result + +type RBSetError = EmptyNodeWasNotExpected type Color = | Red @@ -9,308 +13,358 @@ type Tree<'T> = | Empty | Node of color: Color * left: Tree<'T> * value: 'T * right: Tree<'T> -let emptySet = Empty - -type private Result<'T> = - | Done of 'T - | ToDo of 'T - -let private blacken tree = - match tree with - | Node(Red, a, x, b) -> Done(Node(Black, a, x, b)) - | _ -> ToDo tree - -let private justTree resultTree = - match resultTree with - | Done t -> t - | ToDo t -> t - -let rec private blackHeight tree = - match tree with - | Empty -> 0 - | Node(Red, l, _, _) -> blackHeight l - | Node(Black, l, _, _) -> 1 + (blackHeight l) - - -let rec contains tree v = - match tree with - | Empty -> false - | Node(_, left, value, right) -> - if value > v then contains left v - elif value < v then contains right v - else true - -let private balance tree = - match tree with - | Node(Black, Node(Red, Node(Red, a, x, b), y, c), z, d) - | Node(Black, Node(Red, a, x, Node(Red, b, y, c)), z, d) - | Node(Black, a, x, Node(Red, Node(Red, b, y, c), z, d)) - | Node(Black, a, x, Node(Red, b, y, Node(Red, c, z, d))) -> - ToDo(Node(Red, Node(Black, a, x, b), y, Node(Black, c, z, d))) - | Node(Black, a, x, b) as n -> Done(n) - | _ -> ToDo(tree) - -let insert tree v = - - let rec insertRec tree v = - match tree with - | Empty -> ToDo(Node(Red, Empty, v, Empty)) - | Node(color, left, value, right) -> - if value > v then - let newLeft = insertRec left v - - match newLeft with - | Done nl -> Done(Node(color, nl, value, right)) - | ToDo nl -> balance (Node(color, nl, value, right)) - elif value < v then - let newRight = insertRec right v - - match newRight with - | Done nr -> Done(Node(color, left, value, nr)) - | ToDo nr -> balance (Node(color, left, value, nr)) - else - Done(tree) +module private Tree = + type private Condition<'T> = + | Done of 'T + | ToDo of 'T - let newTree = insertRec tree v - newTree |> justTree |> blacken |> justTree + let private blacken tree = + match tree with + | Node(Red, a, x, b) -> Done(Node(Black, a, x, b)) + | _ -> ToDo tree -let delete tree v = + let private justTree resultTree = + match resultTree with + | Done t + | ToDo t -> t - let balanceDel tree = - match tree with - | Node(color, Node(Red, Node(Red, a, x, b), y, c), z, d) - | Node(color, Node(Red, a, x, Node(Red, b, y, c)), z, d) - | Node(color, a, x, Node(Red, Node(Red, b, y, c), z, d)) - | Node(color, a, x, Node(Red, b, y, Node(Red, c, z, d))) -> - Done(Node(color, Node(Black, a, x, b), y, Node(Black, c, z, d))) - | _ -> blacken tree - - let rec eqL tree = + let rec private blackHeight tree = match tree with - | Node(color, a, x, Node(Black, b, y, c)) -> balanceDel (Node(color, a, x, Node(Red, b, y, c))) - | Node(color, a, x, Node(Red, b, y, c)) -> - let newLeft = eqL (Node(Red, a, x, b)) + | Empty -> 0 + | Node(Red, l, _, _) -> blackHeight l + | Node(Black, l, _, _) -> 1 + (blackHeight l) - match newLeft with - | Done nl -> Done(Node(Black, nl, y, c)) - | ToDo nl -> ToDo(Node(Black, nl, y, c)) - | _ -> failwith "Impossible pattern" - let rec eqR tree = + let rec contains tree v = match tree with - | Node(color, Node(Black, a, x, b), y, c) -> balanceDel (Node(color, Node(Red, a, x, b), y, c)) - | Node(color, Node(Red, a, x, b), y, c) -> - let newRight = eqR (Node(Red, b, y, c)) + | Empty -> false + | Node(_, left, value, right) -> + if value > v then contains left v + elif value < v then contains right v + else true - match newRight with - | Done nr -> Done(Node(Black, a, x, nr)) - | ToDo nr -> ToDo(Node(Black, a, x, nr)) - | _ -> failwith "Impossible pattern" + let private balance tree = + match tree with + | Node(Black, Node(Red, Node(Red, a, x, b), y, c), z, d) + | Node(Black, Node(Red, a, x, Node(Red, b, y, c)), z, d) + | Node(Black, a, x, Node(Red, Node(Red, b, y, c), z, d)) + | Node(Black, a, x, Node(Red, b, y, Node(Red, c, z, d))) -> + ToDo(Node(Red, Node(Black, a, x, b), y, Node(Black, c, z, d))) + | Node(Black, a, x, b) as n -> Done(n) + | _ -> ToDo(tree) - let delCur tree = + let insert tree v = - let rec delMin tree = + let rec insertRec tree v = match tree with - | Node(Red, Empty, x, b) -> (Done b, x) - | Node(Black, Empty, x, b) -> (blacken b, x) - | Node(color, a, x, b) -> - let (an, min) = delMin a + | Empty -> ToDo(Node(Red, Empty, v, Empty)) + | Node(color, left, value, right) -> + if value > v then + let newLeft = insertRec left v - match an with - | Done t -> (Done(Node(color, t, x, b)), min) - | ToDo t -> (eqL (Node(color, t, x, b)), min) - | _ -> failwith "Impossible pattern" + match newLeft with + | Done nl -> Done(Node(color, nl, value, right)) + | ToDo nl -> balance (Node(color, nl, value, right)) + elif value < v then + let newRight = insertRec right v - match tree with - | Node(Red, a, y, Empty) -> Done a - | Node(Black, a, x, Empty) -> blacken a - | Node(color, a, x, b) -> - let (bn, min) = delMin b + match newRight with + | Done nr -> Done(Node(color, left, value, nr)) + | ToDo nr -> balance (Node(color, left, value, nr)) + else + Done(tree) - match bn with - | Done t -> Done(Node(color, a, min, t)) - | ToDo t -> eqR (Node(color, a, min, t)) - | _ -> failwith "Impossible pattern" + let newTree = insertRec tree v + newTree |> justTree |> blacken |> justTree |> Ok + + let delete tree v = + + let balanceDel tree = + match tree with + | Node(color, Node(Red, Node(Red, a, x, b), y, c), z, d) + | Node(color, Node(Red, a, x, Node(Red, b, y, c)), z, d) + | Node(color, a, x, Node(Red, Node(Red, b, y, c), z, d)) + | Node(color, a, x, Node(Red, b, y, Node(Red, c, z, d))) -> + Done(Node(color, Node(Black, a, x, b), y, Node(Black, c, z, d))) + | _ -> blacken tree + + let rec eqL tree = + resultM { + match tree with + | Node(color, a, x, Node(Black, b, y, c)) -> return balanceDel (Node(color, a, x, Node(Red, b, y, c))) + | Node(color, a, x, Node(Red, b, y, c)) -> + let! newLeft = eqL (Node(Red, a, x, b)) + + match newLeft with + | Done nl -> return Done(Node(Black, nl, y, c)) + | ToDo nl -> return ToDo(Node(Black, nl, y, c)) + | _ -> return! Error EmptyNodeWasNotExpected + } + + let rec eqR tree = + resultM { + match tree with + | Node(color, Node(Black, a, x, b), y, c) -> return balanceDel (Node(color, Node(Red, a, x, b), y, c)) + | Node(color, Node(Red, a, x, b), y, c) -> + let! newRight = eqR (Node(Red, b, y, c)) + + match newRight with + | Done nr -> return Done(Node(Black, a, x, nr)) + | ToDo nr -> return ToDo(Node(Black, a, x, nr)) + | _ -> return! Error EmptyNodeWasNotExpected + } + + let delCur tree = + resultM { + let rec delMin tree = + resultM { + match tree with + | Node(Red, Empty, x, b) -> return Done b, x + | Node(Black, Empty, x, b) -> return blacken b, x + | Node(color, a, x, b) -> + let! an, min = delMin a + + match an with + | Done t -> return Done(Node(color, t, x, b)), min + | ToDo t -> + let! t' = eqL (Node(color, t, x, b)) + return t', min + | _ -> return! Error EmptyNodeWasNotExpected + } + + match tree with + | Node(Red, a, y, Empty) -> return Done a + | Node(Black, a, x, Empty) -> return blacken a + | Node(color, a, x, b) -> + let! bn, min = delMin b + + match bn with + | Done t -> return Done(Node(color, a, min, t)) + | ToDo t -> return! eqR (Node(color, a, min, t)) + | _ -> return! Error EmptyNodeWasNotExpected + } + + let rec deleteRec tree v = + resultM { + match tree with + | Empty -> return Done(Empty) + | Node(color, left, value, right) -> + if value > v then + let! newLeft = deleteRec left v + + match newLeft with + | Done nl -> return Done(Node(color, nl, value, right)) + | ToDo nl -> return! eqL (Node(color, nl, value, right)) + elif value < v then + let! newRight = deleteRec right v + + match newRight with + | Done nr -> return Done(Node(color, left, value, nr)) + | ToDo nr -> return! eqR (Node(color, left, value, nr)) + else + return! delCur tree + } + + resultM { + let! t = deleteRec tree v + return t |> justTree |> blacken |> justTree + } + + let join t1 g t2 = + + let rec joinLT t1 g t2 targetHeight currentHeight = + resultM { + if targetHeight = currentHeight then + return Node(Red, t1, g, t2) + else + match t2 with + | Node(Red, l, x, r) -> + let! newLeft = joinLT t1 g l targetHeight currentHeight + return Node(Red, newLeft, x, r) |> balance |> justTree + | Node(Black, l, x, r) -> + let! newLeft = joinLT t1 g l targetHeight (currentHeight - 1) + return Node(Black, newLeft, x, r) |> balance |> justTree + | _ -> return! Error EmptyNodeWasNotExpected + } + + let rec joinRT t1 g t2 targetHeight currentHeight = + resultM { + if targetHeight = currentHeight then + return Node(Red, t1, g, t2) + else + match t1 with + | Node(Red, l, x, r) -> + let! newRight = joinRT t2 g r targetHeight currentHeight + return Node(Red, l, x, newRight) |> balance |> justTree + | Node(Black, l, x, r) -> + let! newRight = joinRT t2 g r targetHeight (currentHeight - 1) + return Node(Black, l, x, newRight) |> balance |> justTree + | _ -> return! Error EmptyNodeWasNotExpected + } - let rec deleteRec tree v = - match tree with - | Empty -> Done(Empty) - | Node(color, left, value, right) -> - if value > v then - let newLeft = deleteRec left v - - match newLeft with - | Done nl -> Done(Node(color, nl, value, right)) - | ToDo nl -> eqL (Node(color, nl, value, right)) - elif value < v then - let newRight = deleteRec right v - - match newRight with - | Done nr -> Done(Node(color, left, value, nr)) - | ToDo nr -> eqR (Node(color, left, value, nr)) - else - delCur tree - - let newTree = deleteRec tree v - newTree |> justTree |> blacken |> justTree - -let private join t1 g t2 = - - let rec joinLT t1 g t2 targetHeight currentHeight = - if targetHeight = currentHeight then - Node(Red, t1, g, t2) - else - match t2 with - | Node(Red, l, x, r) -> - let newLeft = joinLT t1 g l targetHeight currentHeight - Node(Red, newLeft, x, r) |> balance |> justTree - | Node(Black, l, x, r) -> - let newLeft = joinLT t1 g l targetHeight (currentHeight - 1) - Node(Black, newLeft, x, r) |> balance |> justTree - | _ -> failwith "Impossible pattern" - - let rec joinRT t1 g t2 targetHeight currentHeight = - if targetHeight = currentHeight then - Node(Red, t1, g, t2) - else - match t1 with - | Node(Red, l, x, r) -> - let newRight = joinRT t2 g r targetHeight currentHeight - Node(Red, l, x, newRight) |> balance |> justTree - | Node(Black, l, x, r) -> - let newRight = joinRT t2 g r targetHeight (currentHeight - 1) - Node(Black, l, x, newRight) |> balance |> justTree - | _ -> failwith "Impossible pattern" - - let h1 = blackHeight t1 - let h2 = blackHeight t2 - - if h1 = 0 then - insert t2 g - else if h2 = 0 then - insert t1 g - else if h1 < h2 then - let t = joinLT t1 g t2 h1 h2 - - t |> blacken |> justTree - else if h1 > h2 then - let t = joinRT t1 g t2 h2 h1 - - t |> blacken |> justTree - else - Node(Black, t1, g, t2) - -let private merge t1 t2 = - - let rec minimum tree = - match tree with - | Node(_, Empty, x, _) -> x - | Node(_, l, _, _) -> minimum l - | _ -> failwith "Impossible pattern" - - let mergeEQ t1 t2 = - let m = minimum t2 - let t2' = delete t2 m - let h2' = blackHeight t2' let h1 = blackHeight t1 + let h2 = blackHeight t2 + + resultM { + if h1 = 0 then + return! insert t2 g + elif h2 = 0 then + return! insert t1 g + elif h1 < h2 then + let! t = joinLT t1 g t2 h1 h2 + return t |> blacken |> justTree + else if h1 > h2 then + let! t = joinRT t1 g t2 h2 h1 + return t |> blacken |> justTree + else + return Node(Black, t1, g, t2) + } + + let merge t1 t2 = - if h1 = h2' then - Node(Red, t1, m, t2') - else - match t1 with - | Node(_, Node(Red, ll, lx, lr), x, r) -> Node(Red, Node(Black, ll, lx, lr), x, Node(Black, r, m, t2')) - | Node(_, l, x, Node(Red, rl, rx, rr)) -> Node(Black, Node(Red, l, x, rl), rx, Node(Red, rr, m, t2')) - | _ -> Node(Black, (justTree (blacken t1)), m, t2') - - let rec mergeLT t1 t2 targetHeight currentHeight = - if targetHeight = currentHeight then - mergeEQ t1 t2 - else - match t2 with - | Node(Red, l, x, r) -> - let newLeft = mergeLT t1 l targetHeight currentHeight - Node(Red, newLeft, x, r) |> balance |> justTree - | Node(Black, l, x, r) -> - let newLeft = mergeLT t1 l targetHeight (currentHeight - 1) - Node(Red, newLeft, x, r) |> balance |> justTree - | _ -> failwith "Impossible pattern" - - let rec mergeRT t1 t2 targetHeight currentHeight = - if targetHeight = currentHeight then - mergeEQ t1 t2 - else - match t1 with - | Node(Red, l, x, r) -> - let newRight = mergeRT r t2 targetHeight currentHeight - Node(Red, l, x, newRight) |> balance |> justTree - | Node(Black, l, x, r) -> - let newRight = mergeRT r t2 targetHeight (currentHeight - 1) - Node(Red, l, x, newRight) |> balance |> justTree - | _ -> failwith "Impossible pattern" - - let h1 = blackHeight t1 - let h2 = blackHeight t2 - - if h1 = 0 then - t2 - else if h2 = 0 then - t1 - else if h1 < h2 then - let t = mergeLT t1 t2 h1 h2 - - t |> blacken |> justTree - else if h1 > h2 then - let t = mergeRT t1 t2 h2 h1 - - t |> blacken |> justTree - else - let t = mergeEQ t1 t2 - t |> blacken |> justTree - -let rec private split kx tree = - match tree with - | Empty -> (Empty, Empty) - | Node(_, l, x, r) -> - if kx < x then - let (lt, gt) = split kx l - (lt, join gt x (justTree (blacken r))) - else if kx > x then - let (lt, gt) = split kx r - (join (justTree (blacken l)) x lt, gt) - else - (justTree (blacken (l)), justTree (blacken (r))) - - -let rec union t1 t2 = - match t1 with - | Empty -> t2 - | _ -> - match t2 with - | Empty -> t1 - | Node(_, l, x, r) -> - let (l', r') = split x t1 - join (union l' l) x (union r' r) - -let rec intersection t1 t2 = - match t1 with - | Empty -> Empty - | _ -> - match t2 with - | Empty -> Empty - | Node(_, l, x, r) -> - let (l', r') = split x t1 - - if contains t1 x then - join (intersection l' l) x (intersection r' r) + let rec minimum tree = + match tree with + | Ok(Node(_, Empty, x, _)) -> Ok x + | Ok(Node(_, l, _, _)) -> minimum (Ok l) + | _ -> Error EmptyNodeWasNotExpected + + let mergeEQ t1 t2 = + resultM { + let! m = minimum (Ok t2) + let! t2' = delete t2 m + let h2' = blackHeight t2' + let h1 = blackHeight t1 + + if h1 = h2' then + return Node(Red, t1, m, t2') + else + match t1 with + | Node(_, Node(Red, ll, lx, lr), x, r) -> + return Node(Red, Node(Black, ll, lx, lr), x, Node(Black, r, m, t2')) + | Node(_, l, x, Node(Red, rl, rx, rr)) -> + return Node(Black, Node(Red, l, x, rl), rx, Node(Red, rr, m, t2')) + | _ -> return Node(Black, (justTree (blacken t1)), m, t2') + } + + let rec mergeLT t1 t2 targetHeight currentHeight = + resultM { + if targetHeight = currentHeight then + return! mergeEQ t1 t2 + else + match t2 with + | Node(Red, l, x, r) -> + let! newLeft = mergeLT t1 l targetHeight currentHeight + return Node(Red, newLeft, x, r) |> balance |> justTree + | Node(Black, l, x, r) -> + let! newLeft = mergeLT t1 l targetHeight (currentHeight - 1) + return Node(Red, newLeft, x, r) |> balance |> justTree + | _ -> return! Error EmptyNodeWasNotExpected + } + + let rec mergeRT t1 t2 targetHeight currentHeight = + resultM { + if targetHeight = currentHeight then + return! mergeEQ t1 t2 + else + match t1 with + | Node(Red, l, x, r) -> + let! newRight = mergeRT r t2 targetHeight currentHeight + return Node(Red, l, x, newRight) |> balance |> justTree + | Node(Black, l, x, r) -> + let! newRight = mergeRT r t2 targetHeight (currentHeight - 1) + return Node(Red, l, x, newRight) |> balance |> justTree + | _ -> return! Error EmptyNodeWasNotExpected + } + + let h1 = blackHeight t1 + let h2 = blackHeight t2 + + resultM { + if h1 = 0 then + return t2 + else if h2 = 0 then + return t1 + else if h1 < h2 then + let! t = mergeLT t1 t2 h1 h2 + return t |> blacken |> justTree + else if h1 > h2 then + let! t = mergeRT t1 t2 h2 h1 + return t |> blacken |> justTree else - merge (intersection l' l) (intersection r' r) - -let rec difference t1 t2 = - match t1 with - | Empty -> Empty - | _ -> - match t2 with - | Empty -> t1 - | Node(_, l, x, r) -> - let (l', r') = split x t1 - merge (difference l' l) (difference r' r) + let! t = mergeEQ t1 t2 + return t |> blacken |> justTree + } + + let rec split kx tree = + resultM { + match tree with + | Empty -> return Empty, Empty + | Node(_, l, x, r) -> + if kx < x then + let! lt, gt = split kx l + let! t = join gt x (justTree (blacken r)) + return lt, t + else if kx > x then + let! lt, gt = split kx r + let! t = join (justTree (blacken l)) x lt + return t, gt + else + return justTree (blacken (l)), justTree (blacken (r)) + } + +module RBSet = + open Tree + + let empty = Empty + + let add value set = Tree.insert set value + + let delete value set = Tree.delete set value + + let contains value set = Tree.contains set value + + let rec union set1 set2 = + resultM { + match set1 with + | Empty -> return set2 + | _ -> + match set2 with + | Empty -> return set1 + | Node(_, l, x, r) -> + let! l', r' = Tree.split x set1 + let! tl = union l' l + let! tr = union r' r + return! Tree.join tl x tr + } + + let rec intersection set1 set2 = + resultM { + match set1 with + | Empty -> return Empty + | _ -> + match set2 with + | Empty -> return Empty + | Node(_, l, x, r) -> + let! l', r' = Tree.split x set1 + let! tl = intersection l' l + let! tr = intersection r' r + + if Tree.contains set1 x then + return! Tree.join tl x tr + else + return! Tree.merge tl tr + } + + let rec difference set1 set2 = + resultM { + match set1 with + | Empty -> return Empty + | _ -> + match set2 with + | Empty -> return set1 + | Node(_, l, x, r) -> + let! l', r' = Tree.split x set1 + let! tl = difference l' l + let! tr = difference r' r + return! Tree.merge tl tr + } From 4f341eae2d8e022874c1cfaa2f8e2787ed7065a2 Mon Sep 17 00:00:00 2001 From: Egor Starikov Date: Wed, 16 Sep 2026 22:35:41 +0300 Subject: [PATCH 07/17] fix conflicts 2 --- QuadTree.Benchmark/Main.fs | 6 +- QuadTree.Benchmark/QuadTree.Benchmark.fsproj | 1 + QuadTree.Benchmark/RedBlackSet.fs | 160 +++++++++++++++++++ 3 files changed, 166 insertions(+), 1 deletion(-) create mode 100644 QuadTree.Benchmark/RedBlackSet.fs diff --git a/QuadTree.Benchmark/Main.fs b/QuadTree.Benchmark/Main.fs index 25cfb19..39511df 100644 --- a/QuadTree.Benchmark/Main.fs +++ b/QuadTree.Benchmark/Main.fs @@ -12,7 +12,11 @@ let main argv = typeof typeof typeof - typeof |] + typeof + typeof + typeof + typeof |] + benchmarks.Run argv |> ignore 0 diff --git a/QuadTree.Benchmark/QuadTree.Benchmark.fsproj b/QuadTree.Benchmark/QuadTree.Benchmark.fsproj index 9fbd475..ba3e0b6 100644 --- a/QuadTree.Benchmark/QuadTree.Benchmark.fsproj +++ b/QuadTree.Benchmark/QuadTree.Benchmark.fsproj @@ -17,6 +17,7 @@ + diff --git a/QuadTree.Benchmark/RedBlackSet.fs b/QuadTree.Benchmark/RedBlackSet.fs new file mode 100644 index 0000000..25c9bf3 --- /dev/null +++ b/QuadTree.Benchmark/RedBlackSet.fs @@ -0,0 +1,160 @@ +namespace QuadTree.Benchmarks.RedBlackSet + +open BenchmarkDotNet.Attributes +open BenchmarkDotNet.Configs +open QuadTree.RBSet +open System.Collections.Generic + +[] +[] +[] +[] +type SingleOpsBenchmark() = + let rnd = System.Random(1234561) + + [] + [] + val mutable public A: int + + [] + val mutable public rndInt: int + + [] + val mutable public setA: RedBlackSet + + [] + member self.Setup() = + self.rndInt <- rnd.Next(self.A + 1, self.A + 1000) + + let dataA = Array.init self.A (fun _ -> rnd.Next()) + + self.setA <- + dataA + |> Array.fold + (fun (set: RedBlackSet) v -> + match RedBlackSet.add v set with + | Ok nextSet -> nextSet + | Error err -> failwithf "Benchmark setup failed: %A" err) + RedBlackSet.empty + + [] + [] + member self.AddingOneElement() = RedBlackSet.add self.rndInt self.setA + + [] + [] + member self.DeletingOneElement() = + RedBlackSet.delete self.rndInt self.setA + + +[] +[] +[] +[] +type FSSetsBenchmark() = + let rnd = System.Random(1234561) + + [] + [] + val mutable public A: int + + [] + [] + val mutable public B: int + + [] + val mutable public RedBlackSetA: RedBlackSet + + [] + val mutable public RedBlackSetB: RedBlackSet + + [] + val mutable public SetA: Set + + [] + val mutable public SetB: Set + + [] + val mutable public HashSetA: HashSet + + [] + val mutable public HashSetB: HashSet + + [] + member self.Setup() = + let dataA = Array.init self.A (fun _ -> rnd.Next()) + + let dataB = Array.init self.B (fun _ -> rnd.Next()) + + self.RedBlackSetA <- + dataA + |> Array.fold + (fun set v -> + match RedBlackSet.add v set with + | Ok s -> s + | Error e -> failwithf "%A" e) + RedBlackSet.empty + + self.RedBlackSetB <- + dataB + |> Array.fold + (fun set v -> + match RedBlackSet.add v set with + | Ok s -> s + | Error e -> failwithf "%A" e) + RedBlackSet.empty + + self.SetA <- dataA |> Array.fold (fun set v -> Set.add v set) Set.empty + + self.SetB <- dataB |> Array.fold (fun set v -> Set.add v set) Set.empty + + self.HashSetA <- HashSet() + dataA |> Array.iter (fun v -> self.HashSetA.Add(v) |> ignore) + + self.HashSetB <- HashSet() + dataB |> Array.iter (fun v -> self.HashSetB.Add(v) |> ignore) + + [] + [] + member self.UnionRB() = + RedBlackSet.union self.RedBlackSetA self.RedBlackSetB + + [] + [] + member self.UnionFS() = Set.union self.SetA self.SetB + + [] + [] + member self.UnionHashFS() = + let a = HashSet(self.HashSetA) + a.UnionWith(self.HashSetB) + + [] + [] + member self.IntersectionRB() = + RedBlackSet.intersection self.RedBlackSetA self.RedBlackSetB + + [] + [] + member self.IntersectionFS() = Set.intersect self.SetA self.SetB + + [] + [] + member self.IntersectionHashFS() = + let a = HashSet(self.HashSetA) + a.IntersectWith(self.HashSetB) + + [] + [] + member self.DifferenceRB() = + RedBlackSet.difference self.RedBlackSetA self.RedBlackSetB + + [] + [] + member self.DifferenceFS() = Set.difference self.SetA self.SetB + + [] + [] + member self.DifferenceHashFS() = + let a = HashSet(self.HashSetA) + a.ExceptWith(self.HashSetB) From 10aaa598e30d6906a7a26a48dc025329d374ecb5 Mon Sep 17 00:00:00 2001 From: Egor Starikov Date: Thu, 17 Sep 2026 00:09:18 +0300 Subject: [PATCH 08/17] refactor: change namespace --- QuadTree.Benchmark/Main.fs | 1 + QuadTree.Benchmark/RedBlackSet.fs | 33 ++++++++++++++--------------- QuadTree.Tests/Tests.RedBlackSet.fs | 4 ++-- QuadTree/RedBlackSet.fs | 24 ++++++++++----------- 4 files changed, 31 insertions(+), 31 deletions(-) diff --git a/QuadTree.Benchmark/Main.fs b/QuadTree.Benchmark/Main.fs index 39511df..b23bd49 100644 --- a/QuadTree.Benchmark/Main.fs +++ b/QuadTree.Benchmark/Main.fs @@ -15,6 +15,7 @@ let main argv = typeof typeof typeof + typeof typeof |] diff --git a/QuadTree.Benchmark/RedBlackSet.fs b/QuadTree.Benchmark/RedBlackSet.fs index 25c9bf3..8f586cb 100644 --- a/QuadTree.Benchmark/RedBlackSet.fs +++ b/QuadTree.Benchmark/RedBlackSet.fs @@ -2,7 +2,7 @@ namespace QuadTree.Benchmarks.RedBlackSet open BenchmarkDotNet.Attributes open BenchmarkDotNet.Configs -open QuadTree.RBSet +open QuadTree.RBSet open System.Collections.Generic [] @@ -20,7 +20,7 @@ type SingleOpsBenchmark() = val mutable public rndInt: int [] - val mutable public setA: RedBlackSet + val mutable public setA: RBSet [] member self.Setup() = @@ -31,20 +31,19 @@ type SingleOpsBenchmark() = self.setA <- dataA |> Array.fold - (fun (set: RedBlackSet) v -> - match RedBlackSet.add v set with + (fun (set: RBSet) v -> + match RBSet.add v set with | Ok nextSet -> nextSet | Error err -> failwithf "Benchmark setup failed: %A" err) - RedBlackSet.empty + RBSet.empty [] [] - member self.AddingOneElement() = RedBlackSet.add self.rndInt self.setA + member self.AddingOneElement() = RBSet.add self.rndInt self.setA [] [] - member self.DeletingOneElement() = - RedBlackSet.delete self.rndInt self.setA + member self.DeletingOneElement() = RBSet.delete self.rndInt self.setA [] @@ -63,10 +62,10 @@ type FSSetsBenchmark() = val mutable public B: int [] - val mutable public RedBlackSetA: RedBlackSet + val mutable public RedBlackSetA: RBSet [] - val mutable public RedBlackSetB: RedBlackSet + val mutable public RedBlackSetB: RBSet [] val mutable public SetA: Set @@ -90,19 +89,19 @@ type FSSetsBenchmark() = dataA |> Array.fold (fun set v -> - match RedBlackSet.add v set with + match RBSet.add v set with | Ok s -> s | Error e -> failwithf "%A" e) - RedBlackSet.empty + RBSet.empty self.RedBlackSetB <- dataB |> Array.fold (fun set v -> - match RedBlackSet.add v set with + match RBSet.add v set with | Ok s -> s | Error e -> failwithf "%A" e) - RedBlackSet.empty + RBSet.empty self.SetA <- dataA |> Array.fold (fun set v -> Set.add v set) Set.empty @@ -117,7 +116,7 @@ type FSSetsBenchmark() = [] [] member self.UnionRB() = - RedBlackSet.union self.RedBlackSetA self.RedBlackSetB + RBSet.union self.RedBlackSetA self.RedBlackSetB [] [] @@ -132,7 +131,7 @@ type FSSetsBenchmark() = [] [] member self.IntersectionRB() = - RedBlackSet.intersection self.RedBlackSetA self.RedBlackSetB + RBSet.intersection self.RedBlackSetA self.RedBlackSetB [] [] @@ -147,7 +146,7 @@ type FSSetsBenchmark() = [] [] member self.DifferenceRB() = - RedBlackSet.difference self.RedBlackSetA self.RedBlackSetB + RBSet.difference self.RedBlackSetA self.RedBlackSetB [] [] diff --git a/QuadTree.Tests/Tests.RedBlackSet.fs b/QuadTree.Tests/Tests.RedBlackSet.fs index 0244714..b764ab5 100644 --- a/QuadTree.Tests/Tests.RedBlackSet.fs +++ b/QuadTree.Tests/Tests.RedBlackSet.fs @@ -1,8 +1,8 @@ module RedBlackSet.Tests open System -open RBSet.RBSet -open RBSet +open QuadTree.RBSet.RBSet +open QuadTree.RBSet open Xunit let rec blHeightInv tree = diff --git a/QuadTree/RedBlackSet.fs b/QuadTree/RedBlackSet.fs index 673eea3..629ee7e 100644 --- a/QuadTree/RedBlackSet.fs +++ b/QuadTree/RedBlackSet.fs @@ -1,5 +1,5 @@ //The following sources were used as a reference: 'Faster, Simpler Red-Black Trees' and Data/Set/RBTree.hs. -namespace RBSet +namespace QuadTree.RBSet open Result @@ -9,9 +9,9 @@ type Color = | Red | Black -type Tree<'T> = +type RBSet<'T> = | Empty - | Node of color: Color * left: Tree<'T> * value: 'T * right: Tree<'T> + | Node of color: Color * left: RBSet<'T> * value: 'T * right: RBSet<'T> module private Tree = type private Condition<'T> = @@ -28,11 +28,11 @@ module private Tree = | Done t | ToDo t -> t - let rec private blackHeight tree = + let rec private getBlackHeight tree = match tree with | Empty -> 0 - | Node(Red, l, _, _) -> blackHeight l - | Node(Black, l, _, _) -> 1 + (blackHeight l) + | Node(Red, l, _, _) -> getBlackHeight l + | Node(Black, l, _, _) -> 1 + (getBlackHeight l) let rec contains tree v = @@ -202,8 +202,8 @@ module private Tree = | _ -> return! Error EmptyNodeWasNotExpected } - let h1 = blackHeight t1 - let h2 = blackHeight t2 + let h1 = getBlackHeight t1 + let h2 = getBlackHeight t2 resultM { if h1 = 0 then @@ -232,8 +232,8 @@ module private Tree = resultM { let! m = minimum (Ok t2) let! t2' = delete t2 m - let h2' = blackHeight t2' - let h1 = blackHeight t1 + let h2' = getBlackHeight t2' + let h1 = getBlackHeight t1 if h1 = h2' then return Node(Red, t1, m, t2') @@ -276,8 +276,8 @@ module private Tree = | _ -> return! Error EmptyNodeWasNotExpected } - let h1 = blackHeight t1 - let h2 = blackHeight t2 + let h1 = getBlackHeight t1 + let h2 = getBlackHeight t2 resultM { if h1 = 0 then From c4d8bc4d27efd264f90d7b429374e358ce6a1fed Mon Sep 17 00:00:00 2001 From: Egor Starikov Date: Thu, 17 Sep 2026 20:49:55 +0300 Subject: [PATCH 09/17] fix: no generic in Benchmark --- QuadTree.Benchmark/RedBlackSet.fs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/QuadTree.Benchmark/RedBlackSet.fs b/QuadTree.Benchmark/RedBlackSet.fs index 8f586cb..9810ca4 100644 --- a/QuadTree.Benchmark/RedBlackSet.fs +++ b/QuadTree.Benchmark/RedBlackSet.fs @@ -39,7 +39,7 @@ type SingleOpsBenchmark() = [] [] - member self.AddingOneElement() = RBSet.add self.rndInt self.setA + member self.AddingOneElement() : Result, RBSetError> = RBSet.add self.rndInt self.setA [] [] From 798b786262843703ef820cb9ee40ac6b5ffec058 Mon Sep 17 00:00:00 2001 From: Egor Starikov Date: Fri, 18 Sep 2026 14:24:38 +0300 Subject: [PATCH 10/17] Add: generated tests & Fix: errors with black height --- QuadTree.Benchmark/RedBlackSet.fs | 2 +- QuadTree.Tests/Tests.RedBlackSet.fs | 221 +++++++++++++++++++++++++++- QuadTree/RedBlackSet.fs | 44 +++--- 3 files changed, 246 insertions(+), 21 deletions(-) diff --git a/QuadTree.Benchmark/RedBlackSet.fs b/QuadTree.Benchmark/RedBlackSet.fs index 9810ca4..2f3c21b 100644 --- a/QuadTree.Benchmark/RedBlackSet.fs +++ b/QuadTree.Benchmark/RedBlackSet.fs @@ -39,7 +39,7 @@ type SingleOpsBenchmark() = [] [] - member self.AddingOneElement() : Result, RBSetError> = RBSet.add self.rndInt self.setA + member self.AddingOneElement() : Result, RBSetError> = RBSet.add self.rndInt self.setA [] [] diff --git a/QuadTree.Tests/Tests.RedBlackSet.fs b/QuadTree.Tests/Tests.RedBlackSet.fs index b764ab5..d775ab4 100644 --- a/QuadTree.Tests/Tests.RedBlackSet.fs +++ b/QuadTree.Tests/Tests.RedBlackSet.fs @@ -198,7 +198,7 @@ let emptySetProperties () = [] let largeSetInsertion () = let rng = Random() - let randomValues = [ for _ in 1..1000 -> rng.Next(-10000, 10000) ] + let randomValues = [ for _ in 1..1000 -> rng.Next(-5000, 5000) ] let treeResult = randomValues |> List.fold (fun acc x -> acc |> Result.bind (add x)) (Ok empty) @@ -241,3 +241,222 @@ let complexRedBlackViolations () = Assert.NotEqual(-1, blHeightInv tree) Assert.True(blackSonsOfRed tree) | Error err -> Assert.True(false, sprintf "Error in insert: %A" err) + +[] +let randomDeletions () = + let rng = Random() + let insertValues = [ for _ in 1..500 -> rng.Next(-5000, 5000) ] + let uniqueInserts = insertValues |> List.distinct + + let treeResult = + insertValues |> List.fold (fun acc x -> acc |> Result.bind (add x)) (Ok empty) + + match treeResult with + | Ok tree -> + let deleteValues = uniqueInserts |> List.filter (fun _ -> rng.Next(0, 2) = 0) + + let remaining = uniqueInserts |> List.except deleteValues + + let afterDelete = + deleteValues |> List.fold (fun acc x -> acc |> Result.bind (delete x)) (Ok tree) + + match afterDelete with + | Ok t -> + Assert.NotEqual(-1, blHeightInv t) + Assert.NotEqual(-1, heightInv t) + Assert.True(blackSonsOfRed t) + + for x in deleteValues do + Assert.False(contains x t, sprintf "Element %d should be deleted" x) + + for x in remaining do + Assert.True(contains x t, sprintf "Element %d should be present" x) + + Assert.Equal(remaining.Length, numOfElements t 0) + | Error err -> Assert.True(false, sprintf "Error in delete: %A" err) + | Error err -> Assert.True(false, sprintf "Error in insert: %A" err) + +[] +let randomDeletionsOfMissingElements () = + let rng = Random() + let insertValues = [ for _ in 1..300 -> rng.Next(-3000, 3000) ] + let deleteMissing = [ for _ in 1..300 -> rng.Next(10000, 20000) ] + + let treeResult = + insertValues |> List.fold (fun acc x -> acc |> Result.bind (add x)) (Ok empty) + + match treeResult with + | Ok tree -> + let afterDelete = + deleteMissing + |> List.fold (fun acc x -> acc |> Result.bind (delete x)) (Ok tree) + + match afterDelete with + | Ok t -> + Assert.NotEqual(-1, blHeightInv t) + Assert.NotEqual(-1, heightInv t) + Assert.True(blackSonsOfRed t) + + let expected = insertValues |> List.distinct + + for x in expected do + Assert.True(contains x t, sprintf "Element %d should still be present" x) + + for x in deleteMissing do + Assert.False(contains x t, sprintf "Element %d should not be present" x) + + Assert.Equal(expected.Length, numOfElements t 0) + | Error err -> Assert.True(false, sprintf "Error in delete: %A" err) + | Error err -> Assert.True(false, sprintf "Error in insert: %A" err) + +[] +let randomUnion () = + let rng = Random() + let vals1 = [ for _ in 1..300 -> rng.Next(-3000, 3000) ] + let vals2 = [ for _ in 1..300 -> rng.Next(-3000, 3000) ] + + let t1Result = + vals1 |> List.fold (fun acc x -> acc |> Result.bind (add x)) (Ok empty) + + let t2Result = + vals2 |> List.fold (fun acc x -> acc |> Result.bind (add x)) (Ok empty) + + match t1Result, t2Result with + | Ok t1, Ok t2 -> + match union t1 t2 with + | Ok tU -> + Assert.NotEqual(-1, blHeightInv tU) + Assert.NotEqual(-1, heightInv tU) + Assert.True(blackSonsOfRed tU) + + let expected = (vals1 @ vals2) |> List.distinct + + for x in expected do + Assert.True(contains x tU, sprintf "Element %d should be in union" x) + + Assert.Equal(expected.Length, numOfElements tU 0) + | Error e -> Assert.True(false, sprintf "Error in union: %A" e) + | _ -> Assert.True(false, "Error in insert") + +[] +let randomIntersection () = + let rng = Random() + let vals1 = [ for _ in 1..300 -> rng.Next(-3000, 3000) ] + let vals2 = [ for _ in 1..300 -> rng.Next(-3000, 3000) ] + + let t1Result = + vals1 |> List.fold (fun acc x -> acc |> Result.bind (add x)) (Ok empty) + + let t2Result = + vals2 |> List.fold (fun acc x -> acc |> Result.bind (add x)) (Ok empty) + + match t1Result, t2Result with + | Ok t1, Ok t2 -> + match intersection t1 t2 with + | Ok tI -> + Assert.NotEqual(-1, blHeightInv tI) + Assert.NotEqual(-1, heightInv tI) + Assert.True(blackSonsOfRed tI) + + let set1 = vals1 |> Set.ofList + let set2 = vals2 |> Set.ofList + let expected = Set.intersect set1 set2 + let allVals = Set.union set1 set2 + let notExpected = Set.difference allVals expected + + for x in expected do + Assert.True(contains x tI, sprintf "Element %d should be in intersection" x) + + for x in notExpected do + Assert.False(contains x tI, sprintf "Element %d should not be in intersection" x) + + Assert.Equal(expected.Count, numOfElements tI 0) + | Error e -> Assert.True(false, sprintf "Error in intersection: %A" e) + | _ -> Assert.True(false, "Error in insert") + +[] +let randomDifference () = + let rng = Random() + let vals1 = [ for _ in 1..300 -> rng.Next(-3000, 3000) ] + let vals2 = [ for _ in 1..300 -> rng.Next(-3000, 3000) ] + + let t1Result = + vals1 |> List.fold (fun acc x -> acc |> Result.bind (add x)) (Ok empty) + + let t2Result = + vals2 |> List.fold (fun acc x -> acc |> Result.bind (add x)) (Ok empty) + + match t1Result, t2Result with + | Ok t1, Ok t2 -> + match difference t1 t2 with + | Ok tD -> + Assert.NotEqual(-1, blHeightInv tD) + Assert.NotEqual(-1, heightInv tD) + Assert.True(blackSonsOfRed tD) + + let set1 = vals1 |> Set.ofList + let set2 = vals2 |> Set.ofList + let expected = Set.difference set1 set2 + + for x in expected do + Assert.True(contains x tD, sprintf "Element %d should be in difference" x) + + for x in set2 do + Assert.False(contains x tD, sprintf "Element %d should not be in difference" x) + + Assert.Equal(expected.Count, numOfElements tD 0) + | Error e -> Assert.True(false, sprintf "Error in difference: %A" e) + | _ -> Assert.True(false, "Error in insert") + +[] +let randomMixedOperations () = + let rng = Random() + + let buildRandomSet size = + let values = [ for _ in 1..size -> rng.Next(-5000, 5000) ] + + values + |> List.fold (fun acc x -> acc |> Result.bind (add x)) (Ok empty) + |> function + | Ok t -> t + | Error e -> failwithf "Insert failed: %A" e + + let t1 = buildRandomSet 400 + let t2 = buildRandomSet 400 + + let combined = + match union t1 t2 with + | Ok u -> u + | Error e -> failwithf "Union failed: %A" e + + let combinedList = + let rec toList tree acc = + match tree with + | Empty -> acc + | Node(_, l, v, r) -> toList l (v :: toList r acc) + + toList combined [] + + let toDelete = combinedList |> List.filter (fun _ -> rng.Next(0, 2) = 0) + + let afterDelete = + toDelete |> List.fold (fun acc x -> acc |> Result.bind (delete x)) (Ok combined) + + match afterDelete with + | Ok final -> + Assert.NotEqual(-1, blHeightInv final) + Assert.NotEqual(-1, heightInv final) + Assert.True(blackSonsOfRed t1) + Assert.True(blackSonsOfRed t2) + Assert.True(blackSonsOfRed final) + + for x in toDelete do + Assert.False(contains x final, sprintf "Deleted element %d found" x) + + let expectedRemaining = combinedList |> List.except toDelete + + for x in expectedRemaining do + Assert.True(contains x final, sprintf "Element %d should be present" x) + + Assert.Equal(expectedRemaining.Length, numOfElements final 0) + | Error e -> Assert.True(false, sprintf "Error in mixed ops: %A" e) diff --git a/QuadTree/RedBlackSet.fs b/QuadTree/RedBlackSet.fs index 629ee7e..af170df 100644 --- a/QuadTree/RedBlackSet.fs +++ b/QuadTree/RedBlackSet.fs @@ -18,23 +18,25 @@ module private Tree = | Done of 'T | ToDo of 'T + // Для delete: возвращает ToDo для signal о уменьшении высоты let private blacken tree = match tree with | Node(Red, a, x, b) -> Done(Node(Black, a, x, b)) | _ -> ToDo tree + let private justTree resultTree = match resultTree with | Done t | ToDo t -> t + // Фактическая чёрная высота (только чёрные узлы) let rec private getBlackHeight tree = match tree with | Empty -> 0 | Node(Red, l, _, _) -> getBlackHeight l | Node(Black, l, _, _) -> 1 + (getBlackHeight l) - let rec contains tree v = match tree with | Empty -> false @@ -53,8 +55,13 @@ module private Tree = | Node(Black, a, x, b) as n -> Done(n) | _ -> ToDo(tree) - let insert tree v = + let blackenRoot tree = + match tree with + | Node(_, l, x, r) -> Node(Black, l, x, r) + | Empty -> Empty + + let insert tree v = let rec insertRec tree v = match tree with | Empty -> ToDo(Node(Red, Empty, v, Empty)) @@ -78,7 +85,6 @@ module private Tree = newTree |> justTree |> blacken |> justTree |> Ok let delete tree v = - let balanceDel tree = match tree with | Node(color, Node(Red, Node(Red, a, x, b), y, c), z, d) @@ -171,7 +177,6 @@ module private Tree = } let join t1 g t2 = - let rec joinLT t1 g t2 targetHeight currentHeight = resultM { if targetHeight = currentHeight then @@ -194,10 +199,10 @@ module private Tree = else match t1 with | Node(Red, l, x, r) -> - let! newRight = joinRT t2 g r targetHeight currentHeight + let! newRight = joinRT r g t2 targetHeight currentHeight return Node(Red, l, x, newRight) |> balance |> justTree | Node(Black, l, x, r) -> - let! newRight = joinRT t2 g r targetHeight (currentHeight - 1) + let! newRight = joinRT r g t2 targetHeight (currentHeight - 1) return Node(Black, l, x, newRight) |> balance |> justTree | _ -> return! Error EmptyNodeWasNotExpected } @@ -212,16 +217,15 @@ module private Tree = return! insert t1 g elif h1 < h2 then let! t = joinLT t1 g t2 h1 h2 - return t |> blacken |> justTree + return blackenRoot t else if h1 > h2 then let! t = joinRT t1 g t2 h2 h1 - return t |> blacken |> justTree + return blackenRoot t else return Node(Black, t1, g, t2) } let merge t1 t2 = - let rec minimum tree = match tree with | Ok(Node(_, Empty, x, _)) -> Ok x @@ -243,7 +247,8 @@ module private Tree = return Node(Red, Node(Black, ll, lx, lr), x, Node(Black, r, m, t2')) | Node(_, l, x, Node(Red, rl, rx, rr)) -> return Node(Black, Node(Red, l, x, rl), rx, Node(Red, rr, m, t2')) - | _ -> return Node(Black, (justTree (blacken t1)), m, t2') + | Node(_, l, x, r) -> return Node(Black, Node(Red, l, x, r), m, t2') + | _ -> return! Error EmptyNodeWasNotExpected } let rec mergeLT t1 t2 targetHeight currentHeight = @@ -257,7 +262,7 @@ module private Tree = return Node(Red, newLeft, x, r) |> balance |> justTree | Node(Black, l, x, r) -> let! newLeft = mergeLT t1 l targetHeight (currentHeight - 1) - return Node(Red, newLeft, x, r) |> balance |> justTree + return Node(Black, newLeft, x, r) |> balance |> justTree | _ -> return! Error EmptyNodeWasNotExpected } @@ -272,7 +277,7 @@ module private Tree = return Node(Red, l, x, newRight) |> balance |> justTree | Node(Black, l, x, r) -> let! newRight = mergeRT r t2 targetHeight (currentHeight - 1) - return Node(Red, l, x, newRight) |> balance |> justTree + return Node(Black, l, x, newRight) |> balance |> justTree | _ -> return! Error EmptyNodeWasNotExpected } @@ -286,15 +291,16 @@ module private Tree = return t1 else if h1 < h2 then let! t = mergeLT t1 t2 h1 h2 - return t |> blacken |> justTree + return blackenRoot t else if h1 > h2 then let! t = mergeRT t1 t2 h2 h1 - return t |> blacken |> justTree + return blackenRoot t else let! t = mergeEQ t1 t2 - return t |> blacken |> justTree + return blackenRoot t } + // БЕЗ blacken - передаём поддеревья как есть let rec split kx tree = resultM { match tree with @@ -309,7 +315,7 @@ module private Tree = let! t = join (justTree (blacken l)) x lt return t, gt else - return justTree (blacken (l)), justTree (blacken (r)) + return justTree (blacken l), justTree (blacken r) } module RBSet = @@ -326,10 +332,10 @@ module RBSet = let rec union set1 set2 = resultM { match set1 with - | Empty -> return set2 + | Empty -> return Tree.blackenRoot set2 | _ -> match set2 with - | Empty -> return set1 + | Empty -> return Tree.blackenRoot set1 | Node(_, l, x, r) -> let! l', r' = Tree.split x set1 let! tl = union l' l @@ -361,7 +367,7 @@ module RBSet = | Empty -> return Empty | _ -> match set2 with - | Empty -> return set1 + | Empty -> return Tree.blackenRoot set1 | Node(_, l, x, r) -> let! l', r' = Tree.split x set1 let! tl = difference l' l From 5832b2bc7cb0e287637c578e2013442ba52057ad Mon Sep 17 00:00:00 2001 From: Egor Starikov Date: Tue, 22 Sep 2026 21:34:48 +0300 Subject: [PATCH 11/17] fix: merge --- QuadTree.Benchmark/RedBlackSet.fs | 1 + QuadTree.Tests/Tests.RedBlackSet.fs | 5 +- QuadTree/RedBlackSet.fs | 150 ++++++++-------------------- 3 files changed, 48 insertions(+), 108 deletions(-) diff --git a/QuadTree.Benchmark/RedBlackSet.fs b/QuadTree.Benchmark/RedBlackSet.fs index 2f3c21b..d4ed6b4 100644 --- a/QuadTree.Benchmark/RedBlackSet.fs +++ b/QuadTree.Benchmark/RedBlackSet.fs @@ -2,6 +2,7 @@ namespace QuadTree.Benchmarks.RedBlackSet open BenchmarkDotNet.Attributes open BenchmarkDotNet.Configs +open QuadTree.RBSet.RBSet open QuadTree.RBSet open System.Collections.Generic diff --git a/QuadTree.Tests/Tests.RedBlackSet.fs b/QuadTree.Tests/Tests.RedBlackSet.fs index d775ab4..ba799b3 100644 --- a/QuadTree.Tests/Tests.RedBlackSet.fs +++ b/QuadTree.Tests/Tests.RedBlackSet.fs @@ -1,6 +1,7 @@ module RedBlackSet.Tests open System +open QuadTree.RBSet.Tree open QuadTree.RBSet.RBSet open QuadTree.RBSet open Xunit @@ -26,9 +27,9 @@ let rec heightInv tree = if lH = -1 || rH = -1 || (float (rH + 1) / float (lH + 1) > 2) then -1 else if lH > rH then - lH + lH + 1 else - rH + rH + 1 let rec blackSonsOfRed tree = match tree with diff --git a/QuadTree/RedBlackSet.fs b/QuadTree/RedBlackSet.fs index af170df..685e579 100644 --- a/QuadTree/RedBlackSet.fs +++ b/QuadTree/RedBlackSet.fs @@ -5,32 +5,29 @@ open Result type RBSetError = EmptyNodeWasNotExpected -type Color = +module Tree = + type Color = | Red | Black -type RBSet<'T> = - | Empty - | Node of color: Color * left: RBSet<'T> * value: 'T * right: RBSet<'T> + type Tree<'T> = + | Empty + | Node of color: Color * left: Tree<'T> * value: 'T * right: Tree<'T> -module private Tree = type private Condition<'T> = | Done of 'T | ToDo of 'T - // Для delete: возвращает ToDo для signal о уменьшении высоты - let private blacken tree = - match tree with - | Node(Red, a, x, b) -> Done(Node(Black, a, x, b)) - | _ -> ToDo tree - - let private justTree resultTree = match resultTree with | Done t | ToDo t -> t - // Фактическая чёрная высота (только чёрные узлы) + let blackenRoot tree = + match tree with + | Node(Red, a, x, b) -> Node(Black, a, x, b) + | _ -> tree + let rec private getBlackHeight tree = match tree with | Empty -> 0 @@ -55,12 +52,6 @@ module private Tree = | Node(Black, a, x, b) as n -> Done(n) | _ -> ToDo(tree) - - let blackenRoot tree = - match tree with - | Node(_, l, x, r) -> Node(Black, l, x, r) - | Empty -> Empty - let insert tree v = let rec insertRec tree v = match tree with @@ -82,9 +73,14 @@ module private Tree = Done(tree) let newTree = insertRec tree v - newTree |> justTree |> blacken |> justTree |> Ok + newTree |> justTree |> blackenRoot |> Ok let delete tree v = + let blacken tree = + match tree with + | Node(Red, a, x, b) -> Done(Node(Black, a, x, b)) + | _ -> ToDo tree + let balanceDel tree = match tree with | Node(color, Node(Red, Node(Red, a, x, b), y, c), z, d) @@ -173,7 +169,7 @@ module private Tree = resultM { let! t = deleteRec tree v - return t |> justTree |> blacken |> justTree + return t |> justTree |> blackenRoot } let join t1 g t2 = @@ -226,81 +222,22 @@ module private Tree = } let merge t1 t2 = - let rec minimum tree = - match tree with - | Ok(Node(_, Empty, x, _)) -> Ok x - | Ok(Node(_, l, _, _)) -> minimum (Ok l) - | _ -> Error EmptyNodeWasNotExpected - - let mergeEQ t1 t2 = - resultM { - let! m = minimum (Ok t2) - let! t2' = delete t2 m - let h2' = getBlackHeight t2' - let h1 = getBlackHeight t1 - - if h1 = h2' then - return Node(Red, t1, m, t2') - else - match t1 with - | Node(_, Node(Red, ll, lx, lr), x, r) -> - return Node(Red, Node(Black, ll, lx, lr), x, Node(Black, r, m, t2')) - | Node(_, l, x, Node(Red, rl, rx, rr)) -> - return Node(Black, Node(Red, l, x, rl), rx, Node(Red, rr, m, t2')) - | Node(_, l, x, r) -> return Node(Black, Node(Red, l, x, r), m, t2') - | _ -> return! Error EmptyNodeWasNotExpected - } - - let rec mergeLT t1 t2 targetHeight currentHeight = - resultM { - if targetHeight = currentHeight then - return! mergeEQ t1 t2 - else - match t2 with - | Node(Red, l, x, r) -> - let! newLeft = mergeLT t1 l targetHeight currentHeight - return Node(Red, newLeft, x, r) |> balance |> justTree - | Node(Black, l, x, r) -> - let! newLeft = mergeLT t1 l targetHeight (currentHeight - 1) - return Node(Black, newLeft, x, r) |> balance |> justTree - | _ -> return! Error EmptyNodeWasNotExpected - } - - let rec mergeRT t1 t2 targetHeight currentHeight = - resultM { - if targetHeight = currentHeight then - return! mergeEQ t1 t2 - else - match t1 with - | Node(Red, l, x, r) -> - let! newRight = mergeRT r t2 targetHeight currentHeight - return Node(Red, l, x, newRight) |> balance |> justTree - | Node(Black, l, x, r) -> - let! newRight = mergeRT r t2 targetHeight (currentHeight - 1) - return Node(Black, l, x, newRight) |> balance |> justTree - | _ -> return! Error EmptyNodeWasNotExpected - } - - let h1 = getBlackHeight t1 - let h2 = getBlackHeight t2 - resultM { - if h1 = 0 then - return t2 - else if h2 = 0 then - return t1 - else if h1 < h2 then - let! t = mergeLT t1 t2 h1 h2 - return blackenRoot t - else if h1 > h2 then - let! t = mergeRT t1 t2 h2 h1 - return blackenRoot t - else - let! t = mergeEQ t1 t2 - return blackenRoot t + match t1, t2 with + | Empty, t -> return t + | t, Empty -> return t + | _, _ -> + let rec extractMin tree = + match tree with + | Node(_, Empty, x, _) -> x + | Node(_, l, _, _) -> extractMin l + | Empty -> failwith "extractMin: empty tree" + + let minVal = extractMin t2 + let! t2Rest = delete t2 minVal + return! join (blackenRoot t1) minVal (blackenRoot t2Rest) } - // БЕЗ blacken - передаём поддеревья как есть let rec split kx tree = resultM { match tree with @@ -308,19 +245,20 @@ module private Tree = | Node(_, l, x, r) -> if kx < x then let! lt, gt = split kx l - let! t = join gt x (justTree (blacken r)) + let! t = join gt x (blackenRoot r) return lt, t else if kx > x then let! lt, gt = split kx r - let! t = join (justTree (blacken l)) x lt + let! t = join (blackenRoot l) x lt return t, gt else - return justTree (blacken l), justTree (blacken r) + return blackenRoot l, blackenRoot r } module RBSet = open Tree + type RBSet<'T> = Tree<'T> let empty = Empty let add value set = Tree.insert set value @@ -332,15 +270,15 @@ module RBSet = let rec union set1 set2 = resultM { match set1 with - | Empty -> return Tree.blackenRoot set2 + | Empty -> return blackenRoot set2 | _ -> match set2 with - | Empty -> return Tree.blackenRoot set1 + | Empty -> return blackenRoot set1 | Node(_, l, x, r) -> - let! l', r' = Tree.split x set1 + let! l', r' = split x set1 let! tl = union l' l let! tr = union r' r - return! Tree.join tl x tr + return! join (blackenRoot tl) x (blackenRoot tr) } let rec intersection set1 set2 = @@ -351,14 +289,14 @@ module RBSet = match set2 with | Empty -> return Empty | Node(_, l, x, r) -> - let! l', r' = Tree.split x set1 + let! l', r' = split x set1 let! tl = intersection l' l let! tr = intersection r' r if Tree.contains set1 x then - return! Tree.join tl x tr + return! join (blackenRoot tl) x (blackenRoot tr) else - return! Tree.merge tl tr + return! merge (blackenRoot tl) (blackenRoot tr) } let rec difference set1 set2 = @@ -367,10 +305,10 @@ module RBSet = | Empty -> return Empty | _ -> match set2 with - | Empty -> return Tree.blackenRoot set1 + | Empty -> return blackenRoot set1 | Node(_, l, x, r) -> - let! l', r' = Tree.split x set1 + let! l', r' = split x set1 let! tl = difference l' l let! tr = difference r' r - return! Tree.merge tl tr + return! merge (blackenRoot tl) (blackenRoot tr) } From 0f4c2919f14e8dae31165cf6992cd39b475833f9 Mon Sep 17 00:00:00 2001 From: Egor Starikov Date: Wed, 23 Sep 2026 14:38:18 +0300 Subject: [PATCH 12/17] Add: patch operations in Benchmark --- QuadTree.Benchmark/Main.fs | 7 +- QuadTree.Benchmark/RedBlackSet.fs | 150 +++++++++++++++++++++--------- QuadTree/RedBlackSet.fs | 6 +- 3 files changed, 114 insertions(+), 49 deletions(-) diff --git a/QuadTree.Benchmark/Main.fs b/QuadTree.Benchmark/Main.fs index b23bd49..ec4e2b4 100644 --- a/QuadTree.Benchmark/Main.fs +++ b/QuadTree.Benchmark/Main.fs @@ -13,10 +13,9 @@ let main argv = typeof typeof typeof - typeof - typeof - typeof - typeof |] + typeof + typeof + typeof |] benchmarks.Run argv |> ignore diff --git a/QuadTree.Benchmark/RedBlackSet.fs b/QuadTree.Benchmark/RedBlackSet.fs index d4ed6b4..2f296ef 100644 --- a/QuadTree.Benchmark/RedBlackSet.fs +++ b/QuadTree.Benchmark/RedBlackSet.fs @@ -10,48 +10,144 @@ open System.Collections.Generic [] [] [] -type SingleOpsBenchmark() = +type BatchOpsBenchmark() = let rnd = System.Random(1234561) [] [] val mutable public A: int + [] + [] + val mutable public N: int + + [] + val mutable public data: int[] + + [] + val mutable public toInsert: int[] + + [] + val mutable public existingToDelete: int[] + + [] + val mutable public missingToDelete: int[] + [] val mutable public rndInt: int [] val mutable public setA: RBSet + [] + val mutable public fsSet: Set + + [] + val mutable public initialRB: RBSet + + [] + val mutable public initialFS: Set + [] member self.Setup() = - self.rndInt <- rnd.Next(self.A + 1, self.A + 1000) + self.data <- Array.init self.A (fun _ -> rnd.Next()) - let dataA = Array.init self.A (fun _ -> rnd.Next()) - - self.setA <- - dataA + self.initialRB <- + self.data |> Array.fold (fun (set: RBSet) v -> match RBSet.add v set with | Ok nextSet -> nextSet - | Error err -> failwithf "Benchmark setup failed: %A" err) + | Error err -> failwithf "Setup failed: %A" err) RBSet.empty + self.initialFS <- self.data |> Array.fold (fun s v -> Set.add v s) Set.empty + + let maxData = if self.data.Length > 0 then Array.max self.data else 0 + let minData = if self.data.Length > 0 then Array.min self.data else 0 + + let insertCount = min self.N self.A + self.toInsert <- Array.init insertCount (fun i -> maxData + 1000 + i) + + let uniqueExisting = + self.data |> Array.distinct |> Array.truncate (min self.N self.A) + + let shuffleRnd = System.Random(42) + let shuffled = Array.copy uniqueExisting + + for i in shuffled.Length - 1 .. -1 .. 1 do + let j = shuffleRnd.Next(i + 1) + let tmp = shuffled.[i] + shuffled.[i] <- shuffled.[j] + shuffled.[j] <- tmp + + self.existingToDelete <- shuffled + + let missingCount = min self.N self.A + self.missingToDelete <- Array.init missingCount (fun i -> minData - 1000 - i) + + self.setA <- self.initialRB + self.fsSet <- self.initialFS + + [] + member self.IterationSetup() = + self.setA <- self.initialRB + self.fsSet <- self.initialFS + + [] + [] + member self.InsertBatchRB() = + self.toInsert + |> Array.fold + (fun s v -> + match RBSet.add v s with + | Ok s' -> s' + | Error _ -> s) + self.setA + [] - [] - member self.AddingOneElement() : Result, RBSetError> = RBSet.add self.rndInt self.setA + [] + member self.InsertBatchFS() = + self.toInsert |> Array.fold (fun s v -> Set.add v s) self.fsSet + + [] + [] + member self.DeleteExistingBatchRB() = + self.existingToDelete + |> Array.fold + (fun s v -> + match RBSet.delete v s with + | Ok s' -> s' + | Error _ -> s) + self.setA [] - [] - member self.DeletingOneElement() = RBSet.delete self.rndInt self.setA + [] + member self.DeleteExistingBatchFS() = + self.existingToDelete |> Array.fold (fun s v -> Set.remove v s) self.fsSet + + [] + [] + member self.DeleteMissingBatchRB() = + self.missingToDelete + |> Array.fold + (fun s v -> + match RBSet.delete v s with + | Ok s' -> s' + | Error _ -> s) + self.setA + + [] + [] + member self.DeleteMissingBatchFS() = + self.missingToDelete |> Array.fold (fun s v -> Set.remove v s) self.fsSet [] [] [] [] -type FSSetsBenchmark() = +type SetsBenchmark() = let rnd = System.Random(1234561) [] @@ -74,12 +170,6 @@ type FSSetsBenchmark() = [] val mutable public SetB: Set - [] - val mutable public HashSetA: HashSet - - [] - val mutable public HashSetB: HashSet - [] member self.Setup() = let dataA = Array.init self.A (fun _ -> rnd.Next()) @@ -108,12 +198,6 @@ type FSSetsBenchmark() = self.SetB <- dataB |> Array.fold (fun set v -> Set.add v set) Set.empty - self.HashSetA <- HashSet() - dataA |> Array.iter (fun v -> self.HashSetA.Add(v) |> ignore) - - self.HashSetB <- HashSet() - dataB |> Array.iter (fun v -> self.HashSetB.Add(v) |> ignore) - [] [] member self.UnionRB() = @@ -123,12 +207,6 @@ type FSSetsBenchmark() = [] member self.UnionFS() = Set.union self.SetA self.SetB - [] - [] - member self.UnionHashFS() = - let a = HashSet(self.HashSetA) - a.UnionWith(self.HashSetB) - [] [] member self.IntersectionRB() = @@ -138,12 +216,6 @@ type FSSetsBenchmark() = [] member self.IntersectionFS() = Set.intersect self.SetA self.SetB - [] - [] - member self.IntersectionHashFS() = - let a = HashSet(self.HashSetA) - a.IntersectWith(self.HashSetB) - [] [] member self.DifferenceRB() = @@ -152,9 +224,3 @@ type FSSetsBenchmark() = [] [] member self.DifferenceFS() = Set.difference self.SetA self.SetB - - [] - [] - member self.DifferenceHashFS() = - let a = HashSet(self.HashSetA) - a.ExceptWith(self.HashSetB) diff --git a/QuadTree/RedBlackSet.fs b/QuadTree/RedBlackSet.fs index 685e579..05fe14c 100644 --- a/QuadTree/RedBlackSet.fs +++ b/QuadTree/RedBlackSet.fs @@ -7,8 +7,8 @@ type RBSetError = EmptyNodeWasNotExpected module Tree = type Color = - | Red - | Black + | Red + | Black type Tree<'T> = | Empty @@ -258,7 +258,7 @@ module Tree = module RBSet = open Tree - type RBSet<'T> = Tree<'T> + type RBSet<'T> = Tree<'T> let empty = Empty let add value set = Tree.insert set value From e2478bad11db363f9c88f049e992abd539f36df0 Mon Sep 17 00:00:00 2001 From: Egor Starikov Date: Wed, 23 Sep 2026 17:49:51 +0300 Subject: [PATCH 13/17] Add: tests for intesetion and differnce with empty result --- QuadTree.Tests/Tests.RedBlackSet.fs | 31 +++++++++++++++++++++++++++++ 1 file changed, 31 insertions(+) diff --git a/QuadTree.Tests/Tests.RedBlackSet.fs b/QuadTree.Tests/Tests.RedBlackSet.fs index ba799b3..cea9dab 100644 --- a/QuadTree.Tests/Tests.RedBlackSet.fs +++ b/QuadTree.Tests/Tests.RedBlackSet.fs @@ -196,6 +196,37 @@ let emptySetProperties () = Assert.Equal(0, blHeightInv t) Assert.True(blackSonsOfRed t) +[] +let emptyResultOfIntersection () = + let finalTree1 = empty |> add 4 |> Result.bind (add 7) |> Result.bind (add 14) + + let finalTree2 = empty |> add 8 |> Result.bind (add 10) |> Result.bind (add 13) + + match finalTree1, finalTree2 with + | Ok t1, Ok t2 -> + match intersection t1 t2 with + | Ok empty -> Assert.True(true) + | _ -> Assert.False(true) + | _ -> Assert.False(true) + + match finalTree1 with + | Ok t -> + match intersection empty t with + | Ok empty -> Assert.True(true) + | _ -> Assert.False(true) + | _ -> Assert.False(true) + +[] +let emptyResultOfDifference () = + let finalTree1 = empty |> add 4 |> Result.bind (add 7) |> Result.bind (add 14) + + match finalTree1 with + | Ok t -> + match difference empty t with + | Ok empty -> Assert.True(true) + | _ -> Assert.False(true) + | _ -> Assert.False(true) + [] let largeSetInsertion () = let rng = Random() From 166b7fa6b3fae6fb59a28d417677d8ed70f7f86a Mon Sep 17 00:00:00 2001 From: Egor Starikov Date: Sun, 27 Sep 2026 12:40:33 +0300 Subject: [PATCH 14/17] refactor tests --- QuadTree.Tests/Tests.RedBlackSet.fs | 96 ++++++++++++++--------------- 1 file changed, 48 insertions(+), 48 deletions(-) diff --git a/QuadTree.Tests/Tests.RedBlackSet.fs b/QuadTree.Tests/Tests.RedBlackSet.fs index cea9dab..9bca590 100644 --- a/QuadTree.Tests/Tests.RedBlackSet.fs +++ b/QuadTree.Tests/Tests.RedBlackSet.fs @@ -31,12 +31,12 @@ let rec heightInv tree = else rH + 1 -let rec blackSonsOfRed tree = +let rec blackChildrenOfRed tree = match tree with | Empty -> true | Node(Red, Node(Red, _, _, _), _, _) | Node(Red, _, _, Node(Red, _, _, _)) -> false - | Node(_, l, _, r) -> blackSonsOfRed l && blackSonsOfRed r + | Node(_, l, _, r) -> blackChildrenOfRed l && blackChildrenOfRed r let rec numOfElements tree num = match tree with @@ -55,9 +55,9 @@ let oneElement () = Assert.True(contains 4 t) Assert.Equal(1, blHeightInv t) Assert.NotEqual(-1, heightInv t) - Assert.True(blackSonsOfRed t) + Assert.True(blackChildrenOfRed t) Assert.Equal(1, numOfElements t 0) - | Error e -> Assert.True(false, sprintf "Expect Ok, but get Error: %A" e) + | Error e -> Assert.Fail $"Expect Ok, but get Error: {e}" [] let insertSomeElem () = @@ -75,9 +75,9 @@ let insertSomeElem () = Assert.True(contains -7 t) Assert.Equal(2, blHeightInv t) Assert.NotEqual(-1, heightInv t) - Assert.True(blackSonsOfRed t) + Assert.True(blackChildrenOfRed t) Assert.Equal(6, numOfElements t 0) - | Error e -> Assert.True(false, sprintf "Expect Ok, but get Error: %A" e) + | Error e -> Assert.Fail $"Expect Ok, but get Error: {e}" [] let deleteSomeElem () = @@ -97,9 +97,9 @@ let deleteSomeElem () = Assert.False(contains 13 t) Assert.Equal(2, blHeightInv t) Assert.NotEqual(-1, heightInv t) - Assert.True(blackSonsOfRed t) + Assert.True(blackChildrenOfRed t) Assert.Equal(5, numOfElements t 0) - | Error e -> Assert.True(false, sprintf "Expect Ok, but get Error: %A" e) + | Error e -> Assert.Fail $"Expect Ok, but get Error: {e}" [] let unionSets () = @@ -125,10 +125,10 @@ let unionSets () = match union t1 t2 with | Ok tU -> Assert.NotEqual(-1, heightInv tU) - Assert.True(blackSonsOfRed tU) + Assert.True(blackChildrenOfRed tU) Assert.Equal(9, numOfElements tU 0) - | Error e -> Assert.True(false, sprintf "Error in union: %A" e) - | _ -> Assert.True(false, sprintf "Error in insert") + | Error e -> Assert.Fail $"Error in union: {e}" + | _ -> Assert.Fail $"Error in insert" [] let intersectionSets () = @@ -154,10 +154,10 @@ let intersectionSets () = match intersection t1 t2 with | Ok tI -> Assert.NotEqual(-1, heightInv tI) - Assert.True(blackSonsOfRed tI) + Assert.True(blackChildrenOfRed tI) Assert.Equal(2, numOfElements tI 0) - | Error e -> Assert.True(false, sprintf "Error in intersection: %A" e) - | _ -> Assert.True(false, sprintf "Error in insert") + | Error e -> Assert.Fail $"Error in intersection: {e}" + | _ -> Assert.Fail $"Error in insert" [] let differenceSets () = @@ -183,10 +183,10 @@ let differenceSets () = match difference t1 t2 with | Ok tD -> Assert.NotEqual(-1, heightInv tD) - Assert.True(blackSonsOfRed tD) + Assert.True(blackChildrenOfRed tD) Assert.Equal(4, numOfElements tD 0) - | Error e -> Assert.True(false, sprintf "Error in difference: %A" e) - | _ -> Assert.True(false, sprintf "Error in insert") + | Error e -> Assert.Fail $"Error in difference: {e}" + | _ -> Assert.Fail $"Error in insert" [] let emptySetProperties () = @@ -194,7 +194,7 @@ let emptySetProperties () = Assert.False(contains 0 t) Assert.Equal(0, numOfElements t 0) Assert.Equal(0, blHeightInv t) - Assert.True(blackSonsOfRed t) + Assert.True(blackChildrenOfRed t) [] let emptyResultOfIntersection () = @@ -206,15 +206,15 @@ let emptyResultOfIntersection () = | Ok t1, Ok t2 -> match intersection t1 t2 with | Ok empty -> Assert.True(true) - | _ -> Assert.False(true) - | _ -> Assert.False(true) + | _ -> Assert.Fail $"expected Ok empty" + | _ -> Assert.Fail $"expexcted Ok" match finalTree1 with | Ok t -> match intersection empty t with | Ok empty -> Assert.True(true) - | _ -> Assert.False(true) - | _ -> Assert.False(true) + | _ -> Assert.Fail $"expected Ok empty" + | _ -> Assert.Fail $"expexcted Ok" [] let emptyResultOfDifference () = @@ -224,8 +224,8 @@ let emptyResultOfDifference () = | Ok t -> match difference empty t with | Ok empty -> Assert.True(true) - | _ -> Assert.False(true) - | _ -> Assert.False(true) + | _ -> Assert.Fail $"expected Ok empty" + | _ -> Assert.Fail $"expexcted Ok" [] let largeSetInsertion () = @@ -238,11 +238,11 @@ let largeSetInsertion () = match treeResult with | Ok tree -> Assert.NotEqual(-1, blHeightInv tree) - Assert.True(blackSonsOfRed tree) + Assert.True(blackChildrenOfRed tree) for x in randomValues do Assert.True(contains x tree) - | Error err -> Assert.True(false, sprintf "Error in insert: %A" err) + | Error e -> Assert.Fail $"Error in insert: {e}" [] let deleteRoot () = @@ -259,7 +259,7 @@ let deleteRoot () = Assert.True(contains 3 t) Assert.True(contains 7 t) Assert.NotEqual(-1, blHeightInv t) - | _ -> Assert.True(false, sprintf "Expect Ok, but get Error") + | _ -> Assert.Fail $"Expect Ok, but get Error" [] let complexRedBlackViolations () = @@ -271,8 +271,8 @@ let complexRedBlackViolations () = match treeResult with | Ok tree -> Assert.NotEqual(-1, blHeightInv tree) - Assert.True(blackSonsOfRed tree) - | Error err -> Assert.True(false, sprintf "Error in insert: %A" err) + Assert.True(blackChildrenOfRed tree) + | Error e -> Assert.Fail $"Error in insert: {e}" [] let randomDeletions () = @@ -296,7 +296,7 @@ let randomDeletions () = | Ok t -> Assert.NotEqual(-1, blHeightInv t) Assert.NotEqual(-1, heightInv t) - Assert.True(blackSonsOfRed t) + Assert.True(blackChildrenOfRed t) for x in deleteValues do Assert.False(contains x t, sprintf "Element %d should be deleted" x) @@ -305,8 +305,8 @@ let randomDeletions () = Assert.True(contains x t, sprintf "Element %d should be present" x) Assert.Equal(remaining.Length, numOfElements t 0) - | Error err -> Assert.True(false, sprintf "Error in delete: %A" err) - | Error err -> Assert.True(false, sprintf "Error in insert: %A" err) + | Error e -> Assert.Fail $"Error in delete: {e}" + | Error e -> Assert.Fail $"Error in insert: {e}" [] let randomDeletionsOfMissingElements () = @@ -327,7 +327,7 @@ let randomDeletionsOfMissingElements () = | Ok t -> Assert.NotEqual(-1, blHeightInv t) Assert.NotEqual(-1, heightInv t) - Assert.True(blackSonsOfRed t) + Assert.True(blackChildrenOfRed t) let expected = insertValues |> List.distinct @@ -338,8 +338,8 @@ let randomDeletionsOfMissingElements () = Assert.False(contains x t, sprintf "Element %d should not be present" x) Assert.Equal(expected.Length, numOfElements t 0) - | Error err -> Assert.True(false, sprintf "Error in delete: %A" err) - | Error err -> Assert.True(false, sprintf "Error in insert: %A" err) + | Error e -> Assert.Fail $"Error in delete: {e}" + | Error e -> Assert.Fail $"Error in insert: {e}" [] let randomUnion () = @@ -359,7 +359,7 @@ let randomUnion () = | Ok tU -> Assert.NotEqual(-1, blHeightInv tU) Assert.NotEqual(-1, heightInv tU) - Assert.True(blackSonsOfRed tU) + Assert.True(blackChildrenOfRed tU) let expected = (vals1 @ vals2) |> List.distinct @@ -367,8 +367,8 @@ let randomUnion () = Assert.True(contains x tU, sprintf "Element %d should be in union" x) Assert.Equal(expected.Length, numOfElements tU 0) - | Error e -> Assert.True(false, sprintf "Error in union: %A" e) - | _ -> Assert.True(false, "Error in insert") + | Error e -> Assert.Fail $"Error in union: {e}" + | _ -> Assert.Fail $"Error in insert" [] let randomIntersection () = @@ -388,7 +388,7 @@ let randomIntersection () = | Ok tI -> Assert.NotEqual(-1, blHeightInv tI) Assert.NotEqual(-1, heightInv tI) - Assert.True(blackSonsOfRed tI) + Assert.True(blackChildrenOfRed tI) let set1 = vals1 |> Set.ofList let set2 = vals2 |> Set.ofList @@ -403,8 +403,8 @@ let randomIntersection () = Assert.False(contains x tI, sprintf "Element %d should not be in intersection" x) Assert.Equal(expected.Count, numOfElements tI 0) - | Error e -> Assert.True(false, sprintf "Error in intersection: %A" e) - | _ -> Assert.True(false, "Error in insert") + | Error e -> Assert.Fail $"Error in intersection: {e}" + | _ -> Assert.Fail $"Error in insert" [] let randomDifference () = @@ -424,7 +424,7 @@ let randomDifference () = | Ok tD -> Assert.NotEqual(-1, blHeightInv tD) Assert.NotEqual(-1, heightInv tD) - Assert.True(blackSonsOfRed tD) + Assert.True(blackChildrenOfRed tD) let set1 = vals1 |> Set.ofList let set2 = vals2 |> Set.ofList @@ -437,8 +437,8 @@ let randomDifference () = Assert.False(contains x tD, sprintf "Element %d should not be in difference" x) Assert.Equal(expected.Count, numOfElements tD 0) - | Error e -> Assert.True(false, sprintf "Error in difference: %A" e) - | _ -> Assert.True(false, "Error in insert") + | Error e -> Assert.Fail $"Error in difference: {e}" + | _ -> Assert.Fail $"Error in insert" [] let randomMixedOperations () = @@ -478,9 +478,9 @@ let randomMixedOperations () = | Ok final -> Assert.NotEqual(-1, blHeightInv final) Assert.NotEqual(-1, heightInv final) - Assert.True(blackSonsOfRed t1) - Assert.True(blackSonsOfRed t2) - Assert.True(blackSonsOfRed final) + Assert.True(blackChildrenOfRed t1) + Assert.True(blackChildrenOfRed t2) + Assert.True(blackChildrenOfRed final) for x in toDelete do Assert.False(contains x final, sprintf "Deleted element %d found" x) @@ -491,4 +491,4 @@ let randomMixedOperations () = Assert.True(contains x final, sprintf "Element %d should be present" x) Assert.Equal(expectedRemaining.Length, numOfElements final 0) - | Error e -> Assert.True(false, sprintf "Error in mixed ops: %A" e) + | Error e -> Assert.Fail $"Error in mixed ops: {e}" From 2e2b9776c390072ee3dd00515fef26eff7eed304 Mon Sep 17 00:00:00 2001 From: Egor Starikov Date: Sun, 27 Sep 2026 18:41:14 +0300 Subject: [PATCH 15/17] fix: generate sets with not empty intersection --- QuadTree.Benchmark/RedBlackSet.fs | 15 +++++++++++++-- 1 file changed, 13 insertions(+), 2 deletions(-) diff --git a/QuadTree.Benchmark/RedBlackSet.fs b/QuadTree.Benchmark/RedBlackSet.fs index 2f296ef..87cf438 100644 --- a/QuadTree.Benchmark/RedBlackSet.fs +++ b/QuadTree.Benchmark/RedBlackSet.fs @@ -172,9 +172,20 @@ type SetsBenchmark() = [] member self.Setup() = - let dataA = Array.init self.A (fun _ -> rnd.Next()) + let smaller = min self.A self.B + let commonCount = int (float smaller * 0.25) - let dataB = Array.init self.B (fun _ -> rnd.Next()) + let common = Array.init commonCount (fun _ -> rnd.Next()) + + let uniqueACount = self.A - commonCount + let uniqueBCount = self.B - commonCount + + let uniqueA = Array.init uniqueACount (fun _ -> rnd.Next()) + + let uniqueB = Array.init uniqueBCount (fun _ -> rnd.Next()) + + let dataA = Array.append common uniqueA + let dataB = Array.append common uniqueB self.RedBlackSetA <- dataA From 016d692e3a86757d348c11abdc86c8fbde90aeeb Mon Sep 17 00:00:00 2001 From: Egor Starikov Date: Wed, 30 Sep 2026 11:29:32 +0300 Subject: [PATCH 16/17] formatted --- QuadTree.Tests/Tests.RedBlackSet.fs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/QuadTree.Tests/Tests.RedBlackSet.fs b/QuadTree.Tests/Tests.RedBlackSet.fs index 9bca590..13478b9 100644 --- a/QuadTree.Tests/Tests.RedBlackSet.fs +++ b/QuadTree.Tests/Tests.RedBlackSet.fs @@ -57,7 +57,7 @@ let oneElement () = Assert.NotEqual(-1, heightInv t) Assert.True(blackChildrenOfRed t) Assert.Equal(1, numOfElements t 0) - | Error e -> Assert.Fail $"Expect Ok, but get Error: {e}" + | Error e -> Assert.Fail $"Expect Ok, but get Error: {e}" [] let insertSomeElem () = @@ -157,7 +157,7 @@ let intersectionSets () = Assert.True(blackChildrenOfRed tI) Assert.Equal(2, numOfElements tI 0) | Error e -> Assert.Fail $"Error in intersection: {e}" - | _ -> Assert.Fail $"Error in insert" + | _ -> Assert.Fail $"Error in insert" [] let differenceSets () = From b24a875e91ad066fe1297226caa7556ee2c6f3b3 Mon Sep 17 00:00:00 2001 From: Egor Starikov Date: Wed, 30 Sep 2026 21:57:04 +0300 Subject: [PATCH 17/17] fix Tests.fsproj --- QuadTree.Tests/QuadTree.Tests.fsproj | 1 - 1 file changed, 1 deletion(-) diff --git a/QuadTree.Tests/QuadTree.Tests.fsproj b/QuadTree.Tests/QuadTree.Tests.fsproj index 022c87d..a8a29ca 100644 --- a/QuadTree.Tests/QuadTree.Tests.fsproj +++ b/QuadTree.Tests/QuadTree.Tests.fsproj @@ -14,7 +14,6 @@ -