Algorithm for grouping many singly linked lists - algorithm

I have a data set that consists of objects with the form:
A -> Some parent (E.g. A -> null)
B -> Some parent (E.g. B -> D)
C -> Some parent (E.g. C -> A)
D -> Some parent (E.g. D -> null)
E -> Some parent (E.g. E -> A)
F -> Some parent (E.g. F -> G)
G -> Some parent (E.g. G -> D)
H -> Some parent (E.g. H -> C)
I -> Some parent (E.g. I -> G)
J -> Some parent (E.g. J -> null)
I want all the grouped linked lists, something like the following:
A <- C <- H
^-E
J
D <- B
^- G <- F
^- I
Is there a general algorithm to solve the problem of grouping the singly-linked lists that will perform better than pure brute force?
The use case for me here is that, given G, how can I get:
D <- B
^- G <- F
^- I
in an efficient way.


Construct an array of 2-element structures, in which the first element is the destination and the second is the source:
(null, A),
( D, B),
( A, C),
(null, D),
( A, E),
( G, F),
( D, G),
( C, H),
( G, I),
(null, J)
Sort this array by the first element:
(null, A),
(null, D),
(null, J),
( A, C),
( A, E),
( C, H),
( D, B),
( D, G),
( G, F),
( G, I)
And then recursively reveal the whole graph, using the initial data and the array just created:
a.
^- G
b.
^- G <- F
^- I
c. D
^- G <- F
^- I
d. D <- B
^- G <- F
^- I

Related

Identifying duplicates in Haskell tuples

I'm trying to write a function that will Nothing a Just Int tuple if any two values in the tuple are the same. For a tuple of five values, here's what I've got. Clearly, there's room for improvement:
nothingIfMatch :: Maybe (Int, Int, Int, Int, Int) -> Maybe (Int, Int, Int, Int, Int)
nothingIfMatch Nothing = Nothing
nothingIfMatch (Just (a, b, c, d, e))
| a == b = Nothing
| a == c = Nothing
| a == d = Nothing
| a == e = Nothing
| b == c = Nothing
| b == d = Nothing
| b == e = Nothing
| c == d = Nothing
| c == e = Nothing
| d == e = Nothing
| otherwise = Just (a, b, c, d, e)
Considering there are "n choose 2" possible intersections for an n-tuple, in this case, there are only 10 options. But imagine this were an 8-tuple, with 28 possibilities, or a 10-tuple, with 45.
There has to be a more idiomatic way to do this, probably relying on non-determinism features.
How should this be done?

We can first produce a list of Ints and then perform all equality checks:
import Data.List(tails)
twoEqual :: Eq a => [a] -> Bool
twoEqual xs = any (uncurry elem) [(h, t) | (h:t) <- tails xs]
Here we first generate for every element in the list a tuple containing the element and the rest of the list. Then we perform elem functions: we call elem on the item and the rest of the list and in case any of these checks holds, then we return True, False otherwise.
So now we can construct a list from this tuple and then use a guard to perform the checks:
nothingIfMatch :: Eq a => Maybe (a, a, a, a, a) -> Maybe (a, a, a, a, a)
nothingIfMatch = (>>= f)
where f r#(a, b, c, d, e) | twoEqual [a, b, c, d, e] = Nothing
| otherwise = Just r
We can easily add one extra element to the tuple and add it to the list in the twoEqual call. Here we still perform O(n2). We can do it in O(n log n) if we can order the elements first, or we can even do it in O(n) in case the elements are hashable and no hash collisions occur.
For example:
-- O(n log n) if the elements can be ordered
import Data.List(sort, tails)
twoEqual :: Ord a => [a] -> Bool
twoEqual xs = or [h1 == h2 | (h1:h2:_) <- tails (sort xs)]
Or in case the elements can be hashed:
-- O(n) in case the elements are hashable and no hash collisions
import Data.Hashable(Hashable)
import Data.HashSet(fromList, member)
twoEqual :: (Hashable a, Ord a) => [a] -> Bool
twoEqual xs = any (flip member hs) xs
where hs = fromList xs

Generating First Set from the grammar

Algorithm for Finding first set:
Given a grammar with the rules A1 → w1, ..., An → wn, we can compute the Fi(wi) and Fi(Ai) for every rule as follows:
initialize every Fi(Ai) with the empty set
set Fi(wi) to Fi(wi) for every rule Ai → wi, where Fi is defined as follows:
Fi(a w' ) = { a } for every terminal a
Fi(A w' ) = Fi(A) for every nonterminal A with ε not in Fi(A)
Fi(A w' ) = Fi(A) \ { ε } ∪ Fi(w' ) for every nonterminal A with ε in Fi(A)
Fi(ε) = { ε }
add Fi(wi) to Fi(Ai) for every rule Ai → wi
do steps 2 and 3 until all Fi sets stay the same.
Grammar:
A -> B C c
A -> g D B
B -> EPSILON | b C D E
C -> D a B | c a
D -> EPSILON | d D
E -> g A f | c
This website generates the first set as follows:
Non-Terminal Symbol First Set
A g, ε, b, a, c, d
B ε, b
C a, c, ε, d
D ε, d
E g, c
But the algorithm says Fi(A w' ) = Fi(A) for every nonterminal A with ε not in Fi(A) so the First(A) according to this algorithm should not contain ε. First(A) = {g, b, a, c, d}.
Q: First(A) for the above grammar is = First(B) - ε U First(C) U {g} ?
This video also follows the above algorithm and do not choose ε.

First(B) = {ε, b}
First(D) = {ε, d}
First(E) = {g, c}
First(C) = {c, d, a}
First(A) = {b, g, c, d, a}
Example:
X -> Y a | b
Y -> c | ε
First(X) = {c, a, b}
First(Y) = {c, ε}
First(X) doesn't have ε because if you replace Y by ε, then First(Y a) is equal to First(ε a) = {a}
First set implementation on my github.
Edit: Updated link
https://github.com/amirbawab/EasyCC-CPP/blob/master/src/syntax/grammar/Grammar.cpp#L229
Computing the first and follow sets are both available on the new link above.

Red Black Tree contains too many black nodes and too few red nodes

This is further to the question I had asked here
Difficulty in writing Red Black Tree in F#
Based on previous inputs, I have created this program.
open System;
type Color = | R | B
type tree =
| Node of int * Color * tree * tree
| Leaf
let blackHeight tree =
let rec innerBlackHeight accm = function
| Leaf -> accm + 1
| Node(_, B, l, r) -> List.max [(innerBlackHeight (accm + 1) l); (innerBlackHeight (accm + 1) r)]
| Node(_, R, l, r) -> List.max [(innerBlackHeight accm l); (innerBlackHeight accm r)]
innerBlackHeight 0 tree
let isTreeBalanced tree =
let rec isBlackHeightSame = function
| Node(n, c, l, r) ->
if (blackHeight l) = (blackHeight r) then
true && (isBlackHeightSame l) && (isBlackHeightSame r)
else
false
| Leaf -> true
let isRootBlack = function
| Node(n, c, _, _) ->
if c = B then
true
else
false
| _ -> false
let rec twoConsequtiveReds = function
| Leaf -> true
| Node(_, R, Node(_, R, _, _), _) -> false
| Node(_, R, _, Node(_, R, _, _)) -> false
| Node(_, _, l, r) -> (twoConsequtiveReds l) && (twoConsequtiveReds r)
((isBlackHeightSame tree) && (isRootBlack tree) && (twoConsequtiveReds tree))
let balance = function
| Node (gpn, B, Node(pn, R, Node(cn, R, a, b), c), d) -> Node(pn, R, Node(cn, B, a, b), Node(gpn, B, c, d))
| Node (gpn, B, a, Node(pn, R, b, Node(cn, R, c, d))) -> Node(pn, R, Node(gpn, B, a, b), Node(cn, B, c, d))
| Node (gpn, B, Node(pn, R, a, Node(cn, R, b, c)), d) -> Node(cn, R, Node(pn, B, a, b), Node(gpn, B, c, d))
| Node (gpn, B, a, Node(pn, R, Node(cn, R, b, c), d)) -> Node(cn, R, Node(gpn, B, a, b), Node(pn, B, c, d))
| Node (n, c, l, r) -> Node(n, c, l, r)
| _ -> failwith "unknown pattern"
let rec insert x tree =
let rec insertInner = function
| Node(n, c, l, r) when x < n -> balance (Node(n, c, insertInner l, r))
| Node(n, c, l, r) when x > n -> balance (Node(n, c, l, insertInner r))
| Node(n, c, l, r) as node when x = n -> node
| Leaf -> Node(x, R, Leaf, Leaf)
| _ -> failwith "unknown pattern"
match (insertInner tree) with
| Node(n, _, l, r) -> Node(n, B, l, r)
| t -> t
let rec findLowest = function
| Node(n, _, Leaf, _) -> n
| Node(_, _, l, _) -> findLowest l
| _ -> failwith "Unknown pattern"
let rec countNodes = function
| Node(_, c, l, r) ->
let (x1, y1, z1) = countNodes l
let (x2, y2, z2) = countNodes r
if c = B then
(1 + x1 + x2, y1 + y2, z1 + z2)
else
(x1 + x2, 1 + y1 + y2, z1 + z2)
| Leaf -> (0, 0, 1)
let rec delete x tree =
let rec innerDelete = function
| Node(n, c, l, r) when x < n -> balance (Node(n, c, innerDelete l, r))
| Node(n, c, l, r) when x > n -> balance (Node(n, c, l, innerDelete r))
| Node(n, c, Leaf, Leaf) when x = n -> Leaf
| Node(n, c, l, Leaf) when x = n -> balance l
| Node(n, c, Leaf, r) when x = n -> balance r
| Node(n, c, l, r) when x = n -> balance (Node((findLowest r), c, l, r))
| _ -> failwith "unexpected pattern"
match (innerDelete tree) with
| Node(n, _, l, r) -> Node(n, B, l, r)
| t -> t
let generateNums n =
seq {for i in 0 .. n - 1 -> i}
[<EntryPoint>]
let main args =
let mutable tree = Leaf
for i in generateNums 100000 do
tree <-insert i tree
printfn "%A" tree
printfn "%i" (blackHeight tree)
printfn "%b" (isTreeBalanced tree)
let (bc, rc, lc) = countNodes tree
printfn "black nodes %i red nodes %i leaf nodes %i" bc rc lc
0
The problems which I am facing is
For a tree of 0 to 99999 it produces a tree with 99994 black nodes 6 red nodes and 100001 leaf nodes.
Is this normal? that the tree has so few red nodes?
I have written a function to validate if the tree is valid based on the 3 rules (root is always black, black height is same for all branches and red nodes don't have red children) and my method says that the generated tree is indeed valid.
the problem with too many black nodes is that is that certain branches are full of black nodes and if i try to delete a node, then rotations don't help in balancing the tree and the black height of that branch is always less than the other branches of the tree.
So my questions are... is it normal for a red black tree to have too few red nodes? in that case how do you keep the tree balanced in case of deletions?

There's no such thing as "too many black nodes". No red nodes at all means the tree is the most balanced. Introducing new red nodes into an all-black tree increases its imbalance (at first).
When deleting a black node in an all-black tree you follow the deletion algorithm, which ensures that the properties are preserved.

Difficulty in writing Red Black Tree in F#

I am writing a red black tree in F#.
the code which I have written is below. I am facing 2 problems with this code
The rules of balancing the tree state that when the tree has a XYr or rXY type of imbalance I must recolor the 2 parent nodes and IF the grand parent node is not ROOT of the tree then it should be recolored as well.
The difficulty here is that in the recursive approach I only get the next node to work on.. so its hard to know what is the root node.
IN order to solve the above, I added another integer called height to my Node type (type node = Node of int * int * color). That made my pattern matching code in balanceTree function pretty long... but the problem is that when I recolor the grandparent the tree becomes imbalanced because the grand-grand-parent and grand-parent can be red in color which is not allowed.
Can someone recommend a clean way of resolving the issue.
type Color =
| R
| B
type tree =
| Node of int * Color * tree * tree
| Empty
let countNodes tree =
let rec incrCount = function
| Empty -> 0
| Node(_, _, n1, n2) -> 1 + (incrCount n1) + (incrCount n2)
incrCount tree
let isTreeValid tree =
let getTreeBlackNodeHeight tree =
let rec getNodeHeight acc = function
| Empty -> acc + 1
| Node(_, R, n1, _) -> getNodeHeight acc n1
| Node(_, B, n1, _) -> getNodeHeight (acc + 1) n1
getNodeHeight 0 tree
let isRootNodeBlack = function
| Empty -> true
| Node(_, B, _, _) -> true
| Node(_, R, _, _) -> false
let rec areAllBlackHeightsSame height acc = function
| Empty ->
if (acc + 1) = height then true else false
| Node(_, R, n1, n2) -> areAllBlackHeightsSame height acc n1 && areAllBlackHeightsSame height acc n2
| Node(_, B, n1, n2) -> areAllBlackHeightsSame height (acc + 1) n1 && areAllBlackHeightsSame height (acc + 1) n2
let allRedsMustHaveBlackChildren tree =
let getRootNodeColor = function
| Empty -> Color.B
| Node(_, y, _, _) -> y
let rec checkChildColor = function
| Empty -> true
| Node(_, R, n1, n2) -> getRootNodeColor n1 = Color.B && getRootNodeColor n2 = Color.B && checkChildColor n1 && checkChildColor n2
| Node(_, B, n1, n2) -> (checkChildColor n1) && (checkChildColor n2)
checkChildColor tree
(areAllBlackHeightsSame (getTreeBlackNodeHeight tree) 0 tree) && (isRootNodeBlack tree) && (allRedsMustHaveBlackChildren tree)
let insert x tree =
let rec createNode = function
| Empty -> if (countNodes tree) = 0 then Node(x, B, Empty, Empty) else Node(x, R, Empty, Empty)
| Node(i, c, n1, n2) when x > i -> Node(i, c, n1, (createNode n2))
| Node(i, c, n1, n2) when x < i -> Node(i, c, (createNode n1), n2)
| Node(i, _, _, _) when x = i -> failwith "Node already exists"
| _ -> failwith "unknown"
createNode tree
let colorToggle = function
| (i, B) -> (i, R)
| (i, R) -> (i, B)
let balanceTree tree =
let rec balance = function
| Node(gpv, B, Node(p1v, R, Node(c1v, R, a, b), c), Node(p2v, R, d, e)) -> balance (Node(gpv, B, Node(p1v, B, Node(c1v, R, a, b), c), Node(p2v, B, d, e)))
| Node(gpv, B, Node(p1v, R, a, Node(c2v, R, b, c)), Node(p2v, R, d, e)) -> balance (Node(gpv, B, Node(p1v, B, a, Node(c2v, R, b, c)), Node(p2v, B, e, e)))
| Node(gpv, B, Node(p1v, R, a, b), Node(p2v, R, Node(c1v, R, c, d), e)) -> balance (Node(gpv, B, Node(p1v, B, a, b), Node(p2v, B, Node(c1v, R, c, d), e)))
| Node(gpv, B, Node(p1v, R, a, b), Node(p2v, R, c, Node(c2v, R, d, e))) -> balance (Node(gpv, B, Node(p1v, B, a, b), Node(p2v, B, c, Node(c2v, R, d, e))))
| Node(gpv, B, x4, Node(pv, R, x1, Node(cv, R, x2, x3))) -> balance (Node(pv, B, Node(gpv, R, x4, x1), Node(cv, R, x2, x3)))
| Node(gpv, B, x4, Node(pv, R, Node(cv, R, x1, x2), x3)) -> balance (Node(pv, B, Node(gpv, R, x4, Node(cv, B, x1, x2)), x3))
| Node(gpv, B, Node(pv, R, x1, Node(cv, R, x2, x3)), x4) -> balance (Node(pv, B, x1, Node(gpv, R, Node(cv, R, x2, x3), x4)))
| Node(gpv, B, Node(pv, R, Node(cv, R, x1, x2), x3), x4) -> balance (Node(pv, B, (Node(cv, R, x1, x2)), Node(gpv, R, x3, x4)))
| Node(i, x, n1, n2) -> Node(i, x, (balance n1), (balance n2))
| Empty -> Empty
balance tree
[<EntryPoint>]
let main args =
//let t1 = Node((35, B), Node((20, R), Node((10, B), Node((5, R), Empty, Empty), Empty), Node((25, B), Empty, Empty)), Node((85, R), Node((55, B), Node((40, R), Empty, Empty), Node((70, R), Empty, Empty)), Node((100, B), Empty, Empty)))
let t2 = [1 .. 6] |> List.fold (fun acc i-> insert i acc) Empty
printfn "Is Tree Valid : %b" (isTreeValid t2)
let t3 = balanceTree t2
printfn "is Tree Valid : %b" (isTreeValid t3)
0

Standard ML-style implementation in F# looks like this:
type color = R | B
type 'a tree = E | T of color * 'a tree * 'a * 'a tree
let balance = function
| B, T (R, T (R,a,x,b), y, c), z, d
| B, T (R, a, x, T (R,b,y,c)), z, d
| B, a, x, T (R, T (R,b,y,c), z, d)
| B, a, x, T (R, b, y, T (R,c,z,d)) -> T (R, T (B,a,x,b), y, T (B,c,z,d))
| col, a, x, b -> T (col, a, x, b)
let insert x s =
let rec ins = function
| E -> T (R,E,x,E)
| T (col,a,y,b) as s ->
if x < y then
balance (col, ins a, y, b)
elif x > y then
balance (col, a, y, ins b)
else
s
match ins s with
| T (_,a,y,b) -> T (B,a,y,b)
| t -> t

Topological sort, but with a certain kind of grouping

It seems this must be a common scheduling problem, but I don't see the solution or even what to call the problem. It's like a topological sort, but different....
Given some dependencies, say
A -> B -> D -- that is, A must come before B, which must come before D
A -> C -> D
there might be multiple solutions to a topological sort:
A, B, C, D
and A, C, B, D
are both solutions.
I need an algorithm that returns this:
(A) -> (B,C) -> (D)
That is, do A, then all of B and C, then you can do D. All the ambiguities or don't-cares are grouped.
I think algorithms such as those at Topological Sort with Grouping won't correctly handle cases like the following.
A -> B -> C -> D -> E
A - - - > M - - - > E
For this, the algorithm should return
(A) -> (B, C, D, M) -> (E)
This
A -> B -> D -> F
A -> C -> E -> F
should return
(A) -> (B, D, C, E) -> (F)
While this
A -> B -> D -> F
A -> C -> E -> F
C -> D
B -> E
should return
(A) -> (B, C) -> (D, E) -> (F)
And this
A -> B -> D -> F
A -> C -> E -> F
A -> L -> M -> F
C -> D
C -> M
B -> E
B -> M
L -> D
L -> E
should return
(A) -> (B, C, L) -> (D, E, M) -> (F)
Is there a name and a conventional solution to this problem? (And do the algorithms posted at Topological Sort with Grouping correctly handle this?)
Edit to answer requests for more examples:
A->B->C
A->C
should return
(A) -> (B) -> (C). That would be a straight topological sort.
And
A->B->D
A->C->D
A->D
should return
(A) -> (B, C) -> (D)
And
A->B->C
A->C
A->D
should return
(A) -> (B,C,D)

Let G be the transitive closure of the graph. Let G' be the undirected graph that results from removing the orientation from G and taking the complement. The connected components of the G' are the sets you are looking for.

Resources