F# How create tree from nested sets? - recursion

I have nested sets data from my db and need transform this to tree data structure:
type Item = {
Id: int
Left: int
Right: int
Level: int
}
type Items = Item list
type Tree = {Parent: Item; Childrens: Tree list}
My my failed attempt:
Get childrens items for root item and create root of tree
Search childrens for each child from step 1, build new tree
Repeat step 2 until transform all items (nested sets) to tree
let predicate p c = (c.Level = p.Level + 1) && (c.Left > p.Left) && (c.Right < p.Right)
let initLeaf item = {Parent = item; Childrens = []}
let initLeafs = List.map (fun x -> initLeaf x)
let getChildrens parent = List.filter (fun x -> predicate parent x)
let build (initList: Item list) =
let sortedList = initList |> List.sortBy (fun x -> x.Left)
let getChildrens2 parent =
let items = sortedList |> getChildrens parent
if not (List.isEmpty items) then items |> initLeafs else []
let root = initLeaf sortedList.Head
let rec loop (tree: Tree) =
let childrens =
match tree.Childrens with
| [] ->
getChildrens2 tree.Parent
| x ->
x |> List.collect (fun y -> loop y)
loop {tree with Childrens = childrens}
loop root
let res = build items

Here's my attempt at this. The example is taken from Wikipedia.
I changed the type of Item.Id to string for better output readability,
but the method is still applicable.
[<StructuredFormatDisplay("'{Id}'(L:{Left} R:{Right})")>]
type Item = {Id: string; Left: int; Right: int; Level: int}
type Tree = {Node: Item; Children: Tree list}
let lst : Item list = [
{ Id="Clothing"; Left=1; Right=22; Level=0 }
{ Id="Men's"; Left=2; Right=9; Level=1 }
{ Id="Women's"; Left=10; Right=21; Level=1 }
{ Id="Suits"; Left=3; Right=8; Level=2 }
{ Id="Slacks"; Left=4; Right=5; Level=3 }
{ Id="Jackets"; Left=6; Right=7; Level=3 }
{ Id="Dresses"; Left=11; Right=16; Level=2 }
{ Id="Skirts"; Left=17; Right=18; Level=2 }
{ Id="Blouses"; Left=19; Right=20; Level=2 }
{ Id="Evening Gowns"; Left=12; Right=13; Level=3 }
{ Id="Sun Dresses"; Left=14; Right=15; Level=3 }
]
let sorted = lst |> List.sortBy (fun x -> x.Left)
let rootItem :: unassinged = sorted
let isParentOf p c = (c.Level = p.Level + 1) && (c.Left > p.Left) && (c.Right < p.Right)
let rec buildTree (xs : Item list) (item : Item) : Tree * Item list =
let children, rest = List.partition (isParentOf item) xs
let subtrees, rest = List.mapFold buildTree rest children
let tree = {Node = item; Children = subtrees}
tree, rest
let tree, _ = buildTree unassinged rootItem
Output (truncated):
val tree : Tree =
{ Node = 'Clothing'(L:1 R:22)
Children =
[{ Node = 'Men's'(L:2 R:9)
Children =
[{ Node = 'Suits'(L:3 R:8)
Children =
[{ Node = 'Jackets'(L:6 R:7)
Children = [] };
{ Node = 'Slacks'(L:4 R:5)
Children = [] }] }] };
{ Node = 'Women's'(L:10 R:21)
...
Edit: this is the shortest tail-recursive version I could come up with.
let buildTree1 (root : Item) : Tree =
let rec go (pending : Item list) (m: Map<Item, Tree>) : Map<Item, Tree> =
match pending with
| [] -> m
| x :: xs ->
let children = List.filter (isParentOf x) unassinged
if List.isEmpty children then
let mUpd = Map.add x {Node=x; Children = []} m
go xs mUpd
else
let pendingChildren = List.filter (fun y -> not <| Map.containsKey y m) children
match pendingChildren with
| [] ->
let subtrees = List.map (fun x -> m.[x]) children
let mUpd = Map.add x {Node=x; Children = subtrees} m
go xs mUpd
| ps -> go (ps # (x :: xs)) m
go [root] Map.empty |> Map.find root
let tree = buildTree1 rootItem
Maybe it could be improved using the continuation-passing style.

Related

Better representation of a recursive polymorhphic type structure

I am implementing a tree. During the execution of my program data gets added to the node.
The code below shows my first implementation:
type 'a tree =
| Node of 'a
| Leaf
type nodata_node =
{
b: nodata_node tree;
}
type data_node =
{
a: int;
b: data_node tree;
}
The problem with this implementation is that I can't represent the value b in the following snippet:
let a = { b = Node { b = Leaf } }
let b = { b = Node { a = 1; b = Leaf } }
I need to be able to represent a node that doesn't have data but whose children all do.
So I came up with the following implementation:
type _ data =
| Unknown : unit -> unit data
| SomeInt : int -> int data
type 'a tree =
| Node of ('a, 'a) node
| Leaf
and ('a, 'b) node =
{
a: 'a data;
b: 'b tree;
}
let a = { a = Unknown (); b = Node { a = Unknown (); b = Leaf } }
let b = { a = Unknown (); b = Node { a = SomeInt 1; b = Leaf } }
That works, but it seems a bit clunky to have a field that is empty at first and gets filled later. I was wondering if there was a way to have a representation equivalent to the second but with a solution similar to the first one, in that a node with no data is not represented by a structure with en empty data field.
EDIT:
I realise now that my use of GADT is not bringing much to the question I am asking, so, here is simpler version of my second attempt:
type 'a tree =
| Node of ('a, 'a) node
| Leaf
and ('a, 'b) node =
{
a: 'a;
b: 'b tree;
}
let a = { a = (); b = Node { a = (); b = Leaf } }
let b = { a = (); b = Node { a = 1; b = Leaf } }
EDIT2: I guess there is a way to do it with functors and mutually recursive definition. I am interested in a solution that does not rely on functors.
If you wish to keep the 'a tree type constructor, you could go for:
type 'a tree =
| Node of 'a
| Leaf
type child_node = {data:int; x: child; y:child}
and child = child_node tree
type parent = child tree
let x: parent = Node (Node {data=0; x=Leaf; y = Leaf})

Most efficient way to fill a vector from back to front

I am trying to populate a vector with a sequence of values. In order to calculate the first value I need to calculate the second value, which depends on the third value etc etc.
let mut bxs = Vec::with_capacity(n);
for x in info {
let b = match bxs.last() {
Some(bx) => union(&bx, &x.bbox),
None => x.bbox.clone(),
};
bxs.push(b);
}
bxs.reverse();
Currently I just fill the vector front to back using v.push(x) and then reverse the vector using v.reverse(). Is there a way to do this in a single pass?
Is there a way to do this in a single pass?
If you don't mind adapting the vector, it's relatively easy.
struct RevVec<T> {
data: Vec<T>,
}
impl<T> RevVec<T> {
fn push_front(&mut self, t: T) { self.data.push(t); }
}
impl<T> Index<usize> for RevVec<T> {
type Output = T;
fn index(&self, index: usize) -> &T {
&self.data[self.len() - index - 1]
}
}
impl<T> IndexMut<usize> for RevVec<T> {
fn index_mut(&mut self, index: usize) -> &mut T {
let len = self.len();
&mut self.data[len - index - 1]
}
}
The solution using unsafe is below. The unsafe version is slightly more than 2x as fast as the safe version using reverse(). The idea is to use Vec::with_capacity(usize) to allocate the vector, then use ptr::write(dst: *mut T, src: T) to write the elements into the vector back to front. offset(self, count: isize) -> *const T is used to calculate the offset into the vector.
extern crate time;
use std::fmt::Debug;
use std::ptr;
use time::PreciseTime;
fn scanl<T, F>(u : &Vec<T>, f : F) -> Vec<T>
where T : Clone,
F : Fn(&T, &T) -> T {
let mut v = Vec::with_capacity(u.len());
for x in u.iter().rev() {
let b = match v.last() {
None => (*x).clone(),
Some(y) => f(x, &y),
};
v.push(b);
}
v.reverse();
return v;
}
fn unsafe_scanl<T, F>(u : &Vec<T> , f : F) -> Vec<T>
where T : Clone + Debug,
F : Fn(&T, &T) -> T {
unsafe {
let mut v : Vec<T> = Vec::with_capacity(u.len());
let cap = v.capacity();
let p = v.as_mut_ptr();
match u.last() {
None => return v,
Some(x) => ptr::write(p.offset((u.len()-1) as isize), x.clone()),
};
for i in (0..u.len()-1).rev() {
ptr::write(p.offset(i as isize), f(v.get_unchecked(i+1), u.get_unchecked(i)));
}
Vec::set_len(&mut v, cap);
return v;
}
}
pub fn bench_scanl() {
let lo : u64 = 0;
let hi : u64 = 1000000;
let v : Vec<u64> = (lo..hi).collect();
let start = PreciseTime::now();
let u = scanl(&v, |x, y| x + y);
let end= PreciseTime::now();
println!("{:?}\n in {}", u.len(), start.to(end));
let start2 = PreciseTime::now();
let u = unsafe_scanl(&v, |x, y| x + y);
let end2 = PreciseTime::now();
println!("2){:?}\n in {}", u.len(), start2.to(end2));
}

Recursively unpack list into elements

I have a list and would like to return each element from it individually. Basically like popping from a stack. For example:
let rnd = new System.Random()
let rnds = List.init 10 (fun _ -> rnd.Next(100))
List.iter (fun x -> printfn "%A"x ) rnds
However instead of iterating, I would actually like to return each integer one after the other until the list is empty. So basically something along the lines of:
List.head(rnds)
List.head(List.tail(rnds))
List.head(List.tail(List.tail(rnds)))
List.head(List.tail(List.tail(List.tail(List.tail(rnds)))))
Unfortunately my attempts at a recursive solution or even better something using fold or scan were unsuccessful. For example this just returns the list (same as map).
let pop3 (rnds:int list) =
let rec pop3' rnds acc =
match rnds with
| head :: tail -> List.tail(tail)
| [] -> acc
pop3' [] rnds
Would uncons do what you need?
let uncons = function h::t -> Some (h, t) | [] -> None
You can use it to 'pop' the head of a list:
> rnds |> uncons;;
val it : (int * int list) option =
Some (66, [17; 93; 33; 17; 21; 1; 49; 5; 96])
You can repeat this:
> rnds |> uncons |> Option.bind (snd >> uncons);;
val it : (int * int list) option = Some (17, [93; 33; 17; 21; 1; 49; 5; 96])
> rnds |> uncons |> Option.bind (snd >> uncons) |> Option.bind (snd >> uncons);;
val it : (int * int list) option = Some (93, [33; 17; 21; 1; 49; 5; 96])
This seems like a good oppurtunity for a class
type unpacker(l) =
let mutable li = l
member x.get() =
match li with
|h::t -> li<-t;h
|_ -> failwith "nothing left to return"

Pattern match against existing variables

I have a structure of nested maps:
[<RequireQualifiedAccess>]
type NestedMap =
| Object of Map<string,NestedMap>
| Value of int
I need to prune the structure.
The purpose of the code is to maintain intact the nested structure of the maps and of the map where the key value pair is found, pruning the branches where the key value pair is not found.
Here is the test NestedMap:
let l2' = NestedMap.Object ( List.zip ["C"; "S"; "D"] [NestedMap.Value(10); NestedMap.Value(20); NestedMap.Value(30)] |> Map.ofList)
let l3 = NestedMap.Object ( List.zip ["E"; "S"; "F"] [NestedMap.Value(100); NestedMap.Value(200); NestedMap.Value(300)] |> Map.ofList)
let l2'' = NestedMap.Object ( List.zip ["G"; "H"; "I"; "S"] [NestedMap.Value(30); l3; NestedMap.Value(40); NestedMap.Value(50)] |> Map.ofList)
let l1 = NestedMap.Object ( List.zip ["Y"; "A"; "B"] [NestedMap.Value(1); l2'; l2''] |> Map.ofList)
This is my code:
let rec pruneWithKeyValue (keyvalue: string * int) (json: NestedMap) =
let condition ck cv =
let tgtKey = (fst keyvalue)
let tgtVal = (snd keyvalue)
match (ck, cv) with
| (tgtKey, NestedMap.Value(tgtVal)) ->
printfn ">>> Found match : "
printfn " ck = %s " ck
printfn " tgtKey and tgtVal == %s, %i" tgtKey tgtVal
true
| _ -> false
match json with
| NestedMap.Object nmap ->
if (nmap |> Map.exists (fun k v -> condition k v)) then
json
else
printfn "Expanding w keyvalue: (%s,%i): " (fst keyvalue) (snd keyvalue)
let expanded = nmap |> Map.map (fun k v -> pruneWithKeyValue keyvalue v)
NestedMap.Object(expanded |> Map.filter (fun k v -> v <> NestedMap.Object (Map.empty)))
| _ -> NestedMap.Object (Map.empty)
let pruned = pruneWithKeyValue ("S",20) l1
let res = (pruned = l1)
The result is not what desired:
>>> Found match :
ck = Y
tgtKey and tgtVal == Y, 1
val pruneWithKeyValue : string * int -> json:NestedMap -> NestedMap
val pruned : NestedMap =
Object
(map
[("A", Object (map [("C", Value 10); ("D", Value 30); ("S", Value 20)]));
("B",
Object
(map
[("G", Value 30);
("H",
Object
(map [("E", Value 100); ("F", Value 300); ("S", Value 200)]));
("I", Value 40); ("S", Value 50)])); ("Y", Value 1)])
val remainsTheSame : bool = true
The code says that the output data structure remains unchanged (val remainsTheSame : bool = true). Even more interestingly, somehow the keyvalue tuple that contains the key-value pair the function is searching got modified:
>>> Found match :
ck = Y
tgtKey and tgtVal == Y, 1
This is the problem. In fact, if I hardcode the keyvalue tuple:
let rec pruneWithKeyValue (keyvalue: string * int) (json: NestedMap) =
let condition ck cv =
let tgtKey = (fst keyvalue)
let tgtVal = (snd keyvalue)
match (ck, cv) with
| ("S", NestedMap.Value(20)) ->
printfn ">>> Found match : "
printfn " ck = %s " ck
printfn " tgtKey and tgtVal == %s, %i" tgtKey tgtVal
true
| _ -> false
match json with
| NestedMap.Object nmap ->
if (nmap |> Map.exists (fun k v -> condition k v)) then
json
else
printfn "Expanding w keyvalue: (%s,%i): " (fst keyvalue) (snd keyvalue)
let expanded = nmap |> Map.map (fun k v -> pruneWithKeyValue keyvalue v)
NestedMap.Object(expanded |> Map.filter (fun k v -> v <> NestedMap.Object (Map.empty)))
| _ -> NestedMap.Object (Map.empty)
let pruned = pruneWithKeyValue ("S",20) l1
let remainsTheSame = (pruned = l1)
results in (yeah) the desired result:
Expanding w keyvalue: (S,20):
>>> Found match :
ck = S
tgtKey and tgtVal == S, 20
Expanding w keyvalue: (S,20):
Expanding w keyvalue: (S,20):
val pruneWithKeyValue : string * int -> json:NestedMap -> NestedMap
val pruned : NestedMap =
Object
(map
[("A", Object (map [("C", Value 10); ("D", Value 30); ("S", Value 20)]))])
val remainsTheSame : bool = false
It may be trivial but I don't understand where and how keyvalue ends up being modified, preventing me from getting the right output with parametric key-value tuple.
You can't pattern match against existing variables, in your original code tgtKey and tgtVal will be new bindings, not related to the existing ones which will be shadowed.
So change your match:
match (ck, cv) with
| (tgtKey, NestedMap.Value(tgtVal)) ->
to:
match (ck, cv) with
| (k, NestedMap.Value v) when (k, v) = (tgtKey, tgtVal) ->
or just:
match (ck, cv) with
| x when x = (tgtKey, NestedMap.Value(tgtVal)) ->

Strange error in my implementation of in-place graph BFS in OCaml

I am implementing in-place graph BFS in OCaml.
here is my code:
type graph = {s : int list array;num_v:int;mutable num_e : int};;
let bfs u g p =
let marker = Array.make g.num_v false
in
let q = Queue.create()
in
Queue.push u q;
let rec add_to_queue v = function
| [] -> ()
| hd::tl ->
if not marker.(hd) then begin
marker.(hd) <- true;
Queue.push hd q;
p.(hd) <- v
end;
add_to_queue v tl
in
**let rec bfs_go =**
if Queue.length q > 0 then begin
let v = Queue.pop q
in
print_int v;
add_to_queue v g.s.(v);
bfs_go
end
in
bfs_go;;
I thought the code is fine, but compiler gives me this error:
File "", line 20, characters 4-177: Error: This kind of expression is not allowed as right-hand side of 'let rec'
It seems my implementation of bfs_go has issues ( i have marked with ** **), but why? I can't see any errors.
Edit:
DFS in functional style
let dfs_better u g p =
let marker = Array.make g.num_v false in
let rec dfs_go current next =
match current, next with
| [], _ -> ()
| parent::[], [] -> ()
| parent::next_parent::rest, [] -> dfs_go (next_parent::rest) g.s.(next_parent)
| parent::rest, node::tl ->
if not marker.(node) then begin
print_int node;
marker.(node) <- true;
p.(node) <- parent;
dfs_go next g.s.(node)
end;
dfs_go current tl in
marker.(u) <- true;
dfs_go [u] g.s.(u);;
You probably mean
let rec bfs_go () =
...;
bfs_go ()
instead of
let rec bfs_go =
...;
bfs_go
Edit: I couldn't resist some improvements.
With your imperative style:
let bfs start graph from =
let marker = Array.make graph.num_v false in
let q = Queue.create() in
let add_to_queue parent node =
if not marker.(node) then begin
marker.(node) <- true;
Queue.push node q;
from.(node) <- parent;
end in
Queue.push start q;
while not (Queue.is_empty q) do
let node = Queue.pop q in
print_int node;
List.iter (add_to_queue node) graph.s.(node)
done
If you want something more functional:
let bfs start graph from =
let marker = Array.make graph.num_v false in
let rec bfs current next = match current, next with
| [], [] -> ()
| [], (_::_ as next) -> bfs next []
| node::current, next ->
let add parent node next =
if marker.(node) then next
else begin
marker.(node) <- true;
from.(node) <- parent;
node :: next
end in
print_int node;
bfs current (List.fold_right (add node) graph.s.(node) next)
in bfs [start] []
Edit 2:
Attempts at the DFS problem, completely untested (just compiled):
With a data-structure to handle nodes left to visit:
let dfs u g p =
let marker = Array.make g.num_v false in
let rec dfs_go = function
| [] -> ()
| node::next ->
print_int node;
let children =
List.filter (fun child -> not marker.(child)) g.s.(node) in
List.iter (fun child -> marker.(child) <- true) children;
dfs_go (children # next)
in
marker.(u) <- true;
dfs_go [u];;
Using only (non-tail) recursion:
let dfs u g p =
let marker = Array.make g.num_v false in
let rec dfs_go node =
print_int node;
let go_child child =
if not marker.(child) then begin
marker.(child) <- true;
dfs_go child;
end in
List.iter go_child g.s.(node)
in
marker.(u) <- true;
dfs_go u;;

Resources