Related
I have made this following function :
let rec arbre_vers_bits_rec arb l =
match arb with
| Feuille f -> (match f with
| Blanc -> 0 :: 0 :: l;
| Noir -> 0 :: 1 :: l;)
| Noeud(a,b,c,d) -> (
1 ::
arbre_vers_bits_rec a (
arbre_vers_bits_rec b (
arbre_vers_bits_rec c (
arbre_vers_bits_rec d (l))));
);;
let arbre_vers_bits arb =
arbre_vers_bits_rec arb [];;
Which give me a bits list like : [1;0;0;0;1;0;1;0;0]
Now I'm trying to make the reverse function : tree to bits list
So I have made this :
let rec bits_vers_arbres_aux lb res =
match lb with
| [] -> res;
| 1 :: tl -> (Noeud((bits_vers_arbres_aux (sublist 1 9 tl) res),
(bits_vers_arbres_aux (sublist 10 18 tl) res),
(bits_vers_arbres_aux (sublist 19 27 tl) res),
(bits_vers_arbres_aux (sublist 28 35 tl) res)));
| 0 :: a :: 0 :: b :: 0 :: c :: 0 :: d :: tl -> (bits_vers_feuille a b c d);
| _ -> failwith "error";;
let bits_vers_arbres lb =
let a = Noeud(Feuille Blanc, Feuille Blanc, Feuille Blanc, Feuille Blanc) in
bits_vers_arbres_aux lb a;;
with bits_vers_feuille which return me a tree with 4 node a b c d.
I understand how I need to do but I can't figure out how to split the list without using sublist ( it works with bits list like [1;1;...] but not bigger.
sublist :
let rec sublist b e l =
match l with
[] -> failwith "sublist"
| h :: t ->
let tail =
if e = 0 then []
else sublist (b-1) (e-1) t
in
if b > 0 then tail
else h :: tail
My tree type:
type arbre =
Feuille of couleur
| Noeud of arbre * arbre * arbre * arbre
couleur type:
type couleur = Noir | Blanc
What should I try ?
The intuition is that you want to work through the string of bits with the rule that if you see 1 you have a subtree at that point and if you see 0 you have a leaf. This seems pretty close to the definition of a recursive function. The only problem (it seems to me) is in tracking the remainder of the list of bits after you extract a subtree. Hence your function needs to return not only a tree, but also the remaining undecoded bits:
let rec bits_vers_arbres lb =
match lb with
| [] -> failwith "Ill-formed bit string"
| 0 :: bn :: rest -> (Feuille (if bn = 0 then Blanc else Noir), rest)
| 1 :: rest ->
let (a, rest') = bits_vers_arbres rest in
let (b, rest'') = bits_vers_arbres rest' in
. . .
I think this will work, but I haven't finished coding it myself.
I have translated a lot of this to English, because I can read the French, and I can reason out coding problems, but doing both at the same time is really taxing.
type color = White | Black
type tree =
| Leaf of color
| Node of tree * tree * tree * tree
let tree_to_bits t =
let rec aux t bit_list =
match t with
| Leaf White -> 0 :: 0 :: bit_list
| Leaf Black -> 0 :: 1 :: bit_list
| Node (a, b, c, d) ->
1 :: aux a (aux b (aux c (aux d bit_list)))
in
aux t []
let rec bits_to_tree bit_list =
let rec consume_leaves bit_list leaves_acc =
if List.length leaves_acc >= 4 then
(List.rev leaves_acc, bit_list)
else
match bit_list with
| [] | 1 :: _ -> (List.rev leaves_acc, bit_list)
| 0 :: 0 :: rest -> consume_leaves rest (Leaf White :: leaves_acc)
| 0 :: 1 :: rest -> consume_leaves rest (Leaf Black :: leaves_acc)
in
match bit_list with
| [] -> failwith "ill formed"
| 0 :: 0 :: rest -> (Leaf White, rest)
| 0 :: 1 :: rest -> (Leaf Black, rest)
(* A node with at least one leaf! *)
| 1 :: (0 :: _ as rest) ->
print_endline "Found node";
let leaves, rest = consume_leaves rest [] in
Printf.printf "Consumed %d leaves\n" (List.length leaves);
(match leaves with
| [a] ->
let (b, rest') = bits_to_tree rest in
let (c, rest'') = bits_to_tree rest' in
let (d, rest''') = bits_to_tree rest'' in
Node (a, b, c, d), rest'''
| [a; b] ->
let (c, rest') = bits_to_tree rest in
let (d, rest'') = bits_to_tree rest' in
Node (a, b, c, d), rest''
| [a; b; c] ->
let (d, rest') = bits_to_tree rest in
Node (a, b, c, d), rest'
| [a; b; c; d] ->
Node (a, b, c, d), rest)
(* A node that contains a node immediately *)
| 1 :: (1 :: _ as rest) ->
let (a, rest') = bits_to_tree rest in
let (b, rest'') = bits_to_tree rest' in
let (c, rest''') = bits_to_tree rest'' in
let (d, rest'''') = bits_to_tree rest''' in
Node (a, b, c, d), rest''''
It throws all kinds of non-exhaustive pattern matching warnings, and I am as certain that there is a more elegant way to do this as I am that water is wet, but...
─( 12:40:54 )─< command 65 >───────────────────────────────────────────────────────────────────────────────────────────────────────────────{ counter: 0 }─
utop # t;;
- : tree =
Node (Leaf White, Node (Leaf White, Leaf Black, Leaf White, Leaf Black),
Leaf White, Leaf White)
─( 12:41:22 )─< command 66 >───────────────────────────────────────────────────────────────────────────────────────────────────────────────{ counter: 0 }─
utop # tree_to_bits t;;
- : int list = [1; 0; 0; 1; 0; 0; 0; 1; 0; 0; 0; 1; 0; 0; 0; 0]
─( 12:44:39 )─< command 67 >───────────────────────────────────────────────────────────────────────────────────────────────────────────────{ counter: 0 }─
utop # tree_to_bits t |> bits_to_tree;;
Found node
Consumed 1 leaves
Found node
Consumed 4 leaves
- : tree * int list =
(Node (Leaf White, Node (Leaf White, Leaf Black, Leaf White, Leaf Black),
Leaf White, Leaf White),
[])
─( 12:44:47 )─< command 68 >───────────────────────────────────────────────────────────────────────────────────────────────────────────────{ counter: 0 }─
utop # tree_to_bits t |> bits_to_tree |> fst |> tree_to_bits;;
Found node
Consumed 1 leaves
Found node
Consumed 4 leaves
- : int list = [1; 0; 0; 1; 0; 0; 0; 1; 0; 0; 0; 1; 0; 0; 0; 0]
─( 13:38:17 )─< command 79 >───────────────────────────────────────────────────────────────────────────────────────────────────────────────{ counter: 0 }─
utop # let t =
let w = Leaf White
and b = Leaf Black
in
Node (Node (w, b, w, b), Node (b, w, b, w),
Node (w, w, b, b), Node (b, b, w, w));;
val t : tree =
Node (Node (Leaf White, Leaf Black, Leaf White, Leaf Black),
Node (Leaf Black, Leaf White, Leaf Black, Leaf White),
Node (Leaf White, Leaf White, Leaf Black, Leaf Black),
Node (Leaf Black, Leaf Black, Leaf White, Leaf White))
─( 13:38:52 )─< command 80 >───────────────────────────────────────────────────────────────────────────────────────────────────────────────{ counter: 0 }─
utop # tree_to_bits t ;;
- : int list =
[1; 1; 0; 0; 0; 1; 0; 0; 0; 1; 1; 0; 1; 0; 0; 0; 1; 0; 0; 1; 0; 0; 0; 0; 0; 1;
0; 1; 1; 0; 1; 0; 1; 0; 0; 0; 0]
─( 13:39:06 )─< command 81 >───────────────────────────────────────────────────────────────────────────────────────────────────────────────{ counter: 0 }─
utop # tree_to_bits t |> bits_to_tree;;
Found node
Consumed 4 leaves
Found node
Consumed 4 leaves
Found node
Consumed 4 leaves
Found node
Consumed 4 leaves
- : tree * int list =
(Node (Node (Leaf White, Leaf Black, Leaf White, Leaf Black),
Node (Leaf Black, Leaf White, Leaf Black, Leaf White),
Node (Leaf White, Leaf White, Leaf Black, Leaf Black),
Node (Leaf Black, Leaf Black, Leaf White, Leaf White)),
[])
More Elegant
Having more time to think about this while out on a walk, we end up with a more elegant approach that still passes the same tests as before.
let rec bits_to_tree' = function
| 0 :: 0 :: rest -> Leaf White, rest
| 0 :: 1 :: rest -> Leaf Black, rest
| 1 :: rest ->
let (a, rest' ) = bits_to_tree' rest in
let (b, rest'' ) = bits_to_tree' rest' in
let (c, rest''' ) = bits_to_tree' rest'' in
let (d, rest'''') = bits_to_tree' rest''' in
Node (a, b, c, d), rest''''
| _ -> failwith "Ill-formed bit list"
If the first two elements in the bit list are 0 and 0, this indicates a Leaf White. If 0 and 1, then this indicates a Leaf Black. Either way, we return the rest of the bit list as well.
If the first number is 1, then it indicates a Node. We know a Node contains four trees, so we use a chain of let bindings to recursively call the function on the rest. Each time we get the tree, but also the remaining bit list. Doing this ensures we "consume" the bit list.
If the bit list doesn't start with 0 followed by 0 or 1; or a 1, then the bit list is ill-formed.
The ' suffixes on rest are not necessary, but they demonstrate how we're changing this value. We could just call all of these rest because we don't access previous rest values.
As a further exercise, this could be a locally scoped function, that hides the passing of rest.
let bits_to_tree bit_list =
let rec bits_to_tree' = function
| 0 :: 0 :: rest -> Leaf White, rest
| 0 :: 1 :: rest -> Leaf Black, rest
| 1 :: rest ->
let (a, rest) = bits_to_tree' rest in
let (b, rest) = bits_to_tree' rest in
let (c, rest) = bits_to_tree' rest in
let (d, rest) = bits_to_tree' rest in
Node (a, b, c, d), rest
| _ -> failwith "Ill-formed bit list"
in
bits_to_tree' bit_list |> fst
I have a quadTree type defined by that :
type 'a quadtree =
| Empty
| Leaf of 'a
| Node of 'a quadtree * 'a quadtree * 'a quadtree * 'a quadtree;;
Rooms defined by
type room = {
n : bool;
e : bool;
s : bool;
w : bool;
ps : coord;
exit : bool
}
Coordinates defined by
type coord = {
x : int;
y : int;
}
So TLDR of all that, I have a Quadtree of rooms that have or don't have exits up, down, left and right.
The objective now is to create a function that will find a way (if it exists) from one room to another (from its coordinates), the problem is that I don't see how to do it in OCaml...
Anyway, thanks for your time, have a good day.
Edit :
To clarify, I am the one defining the types and can alter them if needed.
Also, I tried implementing Dijkstra's algorithm (from Wikipedia's pseudo code), but being quite unfamiliar with both graphs, and OCaml's arrays and lists. To be precise, my problem -I think- comes from the fact that I'm not able to modify variables in a function, so for instance in Wikipedia's pseudo code, in this line:
u ← Q.extract_min() // Remove and return best vertex
I see how to remove the best vertex, and I see how to return it, but not both at the same time.
Or, here:
for each neighbor v of u: // where v is still in Q.
alt ← dist[u] + length(u, v)
if alt < dist[v]: // A shorter path to v has been found
dist[v] ← alt
prev[v] ← u
How do I modify dist and prev outside of the 'for' loop? Can I use a for loop or is it simpler / better to use a recursive function?
Also I should make clear that the maze is "directional", meaning that being able to go from room A to room B does not mean you'll be able to go from room B to room A.
Edit 2 :
I should have clarified this in the beginning, sorry :
The quadtree follows this rule :
| Node of North West * North East * South West * South East
Edit 3 :
Okay change of plan, turns out I was doing things very stupidly. I don't need to find the way to a certain room, just to an exit. So I tried this :
let rec contains_exit = function
| [] -> false
| e::l' when (getCell e.x e.y maze).exit -> true
| e::l' when (getCell e.x e.y maze).exit = false -> contains_exit l'
;;
let rec find_exit start way =
if is_exit start then
way
else
(let a = find_exit (northp start) way#[start] in
if contains_exit a then
way
else
(
let b = find_exit (eastp start) way#[start] in
if contains_exit b then
way
else
(
let c = find_exit (southp start) way#[start] in
if contains_exit c then
way
else
(
let d = find_exit (westp start) way#[start] in
if contains_exit d then
way
else
way
)
)
)
)
;;
But it gives me a stack overflow. After a bit of research, it seems that the line "contains_exit a" is never true, so the way is never returned and it loops !
Any idea why that is ? Is the problem my contains_exit function ?
Edit 4 :
Ended up doing this function :
let rec find_exit start way =
sleep 50000000;
let r = (Random.int 180) in
set_color (rgb r r r);
fill_rect (start.x * sizeCell + doorWidth * 2) (start.y * sizeCell + doorWidth * 2) (sizeCell - 4 * doorWidth) (sizeCell - 4 * doorWidth);
if is_exit start then
way#[start]
else
(let a = if (getCell start.x start.y maze).n && ((mem (northp start) way) = false) then find_exit (northp start) way#[start] else [] in
if a != [] then
a
else
(
let b = if (getCell start.x start.y maze).e && ((mem (eastp start) way) = false) then find_exit (eastp start) way#[start] else [] in
if b != [] then
b
else
(
let c = if (getCell start.x start.y maze).w && ((mem (westp start) way) = false) then find_exit (westp start) way#[start] else [] in
if c != [] then
c
else
(
let d = if (getCell start.x start.y maze).s && ((mem (southp start) way) = false) then find_exit (southp start) way#[start] else [] in
if d != [] then
d
else
[]
)
)
)
)
;;
it sometimes works... But other times it blocks and it goes from one room to the one below then up again then down again... I don't understand why !?
If you want to try the whole program, here it is : link
Then you can go for some thing like this:
type 'a quadtree =
| Empty
| Leaf of 'a
| Node of 'a * 'a quadtree * 'a quadtree * 'a quadtree * 'a quadtree;;
type room = {
n : bool;
e : bool;
s : bool;
w : bool;
ps : coord;
exit : bool
};;
type coord = {
x : int;
y : int;
};;
let rec treeForRoom(tree, room) =
match tree with
| Empty -> Empty
| Leaf l -> if l.ps == room.ps then l else Empty
| Node (r, n, e, s, w) as node ->
if r == room
then node
else
match ((r.ps.x - room.ps.x), (r.ps.y - room.ps.y)) with
| (0, n) -> if n > 0 then treeForRoom(w) else treeForRoom(e)
| (n, 0) -> if n > 0 then treeForRoom(s) else treeForRoom(n)
(* Assuming the root of the tree is the room we start from *)
let rec searchPath(tree, r) =
match tree with
| Empty -> (false, 0, [])
| Leaf l -> if l == r then (true, 0) else (false, 0, [])
| Node (r, n, e, s, w) as node ->
let pn = searchPath(n, r)
and pe = searchPath(e, r)
and ps = searchPath(s, r)
and pw = searchPath(w, r)
in
find_best_path(p1, p2, p3, p4)
let find_best_path(p1, p2, p3, p4) =
match (p1, p2, p3, p4) with
| ((false,_,_), (false,_,_), (false,_,_), (false,_,_)) -> (false, -1, [])
| ((true, w, p), (false,_,_), (false,_,_), (false,_,_)) -> (true, w, p)
| ((false,_,_), (true, w, p)), (false,_,_), (false,_,_)) -> (true, w, p)
| ((false,_,_), (false,_,_), (true, w, p)), (false,_,_)) -> (true, w, p)
| ((false,_,_), (false,_,_), (false,_,_),(true, w, p)) -> (true, w, p)
| ((p1ok, p1w, p1p), (p2ok, p2w, p2p),(p3ok, p3w, p3p),(p4ok, p4w, p4p)) ->
if p1ok && p2ok && p3ok && p4ok
then
min_weight([(p1ok, p1w, p1p), (p2ok, p2w, p2p),(p3ok, p3w, p3p),(p4ok, p4w, p4p)])
else
....
let rec min_weight(l) =
match l with
| [] -> (false, -1, [])
| [t] -> t
| [(to, tw, tp) as t::q] -> let (mo, mw, mp) as minw = min_weight(q) in
if tw < mw
then
t
else
minw
I added the root to the type definition ('a* ...) so I can make a function to find the good tree to go through. I also assume that the tree respect the following rule: (root, north room, east room, south room, west room) for each node (you can make an add function to ensure this property).
Then you go through the tree exploring from the end and getting the minimal weight path for then end to the start point. (It is the same weight as it goes through the same paths under the same conditions (cause you explore the tree from the start but compute the path from then end)).
This code does not take into account the possibility to pass through doors but it is a just a check to add as the way of going through the tree is already correctly oriented.
I let you complete and correct the code.
Hope it will help you.
When I compile my code is ok, but when I call and execute the function Quicksort, the program seems to be in infinite loop. What Can I do ?
I tested all the functions, but it seems the problem is in tQuicksort function.
I'm a beginner.
let h l =
match l with
| [] -> raise (Failure "head")
| x::xs -> x;;
let t l =
match l with
| [] -> raise (Failure "tail")
| x::xs -> xs;;
let rec trev l r =
match l with
| [] -> r
| x::xs -> trev xs (x::r);;
let rev l = trev l [];;
let rec tunir l1 l2 r =
match l1 with
| [] -> if l2 == [] then
rev r
else
tunir [] (t l2) ((h l2)::r)
| x1::xs1 -> tunir xs1 l2 (x1::r);;
let unir l1 l2 = tunir l1 l2 [];;
let rec tpart x l l1 l2 =
match l with
| [] -> if l1 == [] then
((x::[]), l2)
else
(l1, (x::l2))
| (lx:: lxs) -> if (h l) <= x then
tpart x (t l) ((h l)::l1) l2
else
tpart x (t l) l1 ((h l)::l2);;
let part x l = tpart x l [] [];;
let rec tnroelem l n =
match l with
| [] -> n
| x::xs -> tnroelem (t l) (n+1);;
let nroelem l = tnroelem l 0;;
let rec tunirL l r =
match l with
| [] -> rev r
| lx::lxs -> if lx == [] then tunirL lxs r
else tunirL((t lx)::lxs) ((h lx)::r);;
let unirL l = tunirL l [];;
let rec tquicksort lm l lM =
match l with
| [] -> unirL (unir (rev lm) lM)
| lx::lxs -> let (la, lb) = part (h l) (t l) in
if (nroelem la < nroelem lb) then tquicksort ((quicksort la)::lm) lb lM
else tquicksort lm la ((quicksort lb)::lM)
and quicksort l = tquicksort [] l [];;
let rec geraListaT n l =
if n == 0 then l
else geraListaT (n-1) (n::l);;
let geraLista n = geraListaT n [];;
let lista : int list = geraLista 9;;
List.iter (fun x->print_int x) (quicksort lista)
You are missing a case when you're attempting to quicksort lm l lM and l only has one element. In that case the branch taken is
| lx::lxs -> let (la, lb) = part (h l) (t l) in
if (nroelem la < nroelem lb)
then tquicksort ((quicksort la)::lm) lb lM
else tquicksort lm la ((quicksort lb)::lM)
And then no matter what the result of the if is, you perform a recursive call quicksort lm' l' lM' where l' also has only one element. This can be fixed by adding an extra case after the one for the empty list:
| lx::[] -> unirL (unir (rev (l :: lm)) lM)
first, this is my code :
module Problem1 = struct
type aexp =
| Const of int
| Var of string
| Power of string * int
| Times of aexp list
| Sum of aexp list
let diff : aexp * string -> aexp
= fun (exp, var) ->
match exp with
|Const a -> Const 0
|Var x -> if x = var then Const 1 else Var x
|Power (s, i) ->
if s = var then Times[Const i;Power (s, i - 1)] else Power (s, i)
|Times l ->
match l with
|h::t -> Sum[Times[diff (h, var);t];diff (t, var)]
|Sum m ->
match m with
|h::t -> Sum[diff(h, var); diff(t, var)];;
end
The interpretor says,
Error: This variant pattern is expected to have type aexp list
The constructor Sum does not belong to type list
But I intended the symbol m to be an aexp list.
Can't find what is wrong.
Actually your problem is simple and you would have seen it by using a tool that knows how to indent OCaml code ;-)
Look at how your last lines are indented with an OCaml indenter :
|Times l ->
match l with
|h::t -> Sum[Times[diff (h, var);t];diff (t, var)]
|Sum m ->
match m with
|h::t -> Sum[diff(h, var); diff(t, var)];;
Yes, that's right, since you created a new pattern matching in Times l, Sum m is included in it. You should write
|Times l -> begin
match l with
|h::t -> Sum[Times[diff (h, var);t];diff (t, var)]
end
|Sum m ->
match m with
|h::t -> Sum[diff(h, var); diff(t, var)];;
And it will work just fine.
By the way, you'll have another problem because you didn't write let rec diff ... but let diff and you're calling diff recursively.
To me, this part looks off: Times[diff (h, var);t]. Since t is an aexp list, you should use the other list constructor, ::, to make it `Times (diff (h, var) :: t).
If you put match .. with .. inside a case of another match .. with, you need wrap the internal one with begin .. end:
(* I do not check the code is correct *)
let diff : aexp * string -> aexp
= fun (exp, var) ->
match exp with
|Const a -> Const 0
|Var x -> if x = var then Const 1 else Var x
|Power (s, i) ->
if s = var then Times[Const i;Power (s, i - 1)] else Power (s, i)
|Times l ->
begin match l with
|h::t -> Sum[Times[diff (h, var);t];diff (t, var)]
end
|Sum m ->
match m with
|h::t -> Sum[diff(h, var); diff(t, var)]
Please install a proper auto-indentation tool such as tuareg or ocp-indent, since they can tell the proper program structure. Hand indentation often fools your eyes.
According to AVL tree wiki
The balance factor is calculated as follows: balanceFactor = height(left-subtree) - height(right-subtree). For each node checked, if the balance factor remains −1, 0, or +1 then no rotations are necessary.
However, in OCaml, it seems it uses balance factor of 2
let bal l x d r =
let hl = match l with Empty -> 0 | Node(_,_,_,_,h) -> h in
let hr = match r with Empty -> 0 | Node(_,_,_,_,h) -> h in
if hl > hr + 2 then begin
match l with
Empty -> invalid_arg "Map.bal"
| Node(ll, lv, ld, lr, _) ->
if height ll >= height lr then
create ll lv ld (create lr x d r)
else begin
match lr with
Empty -> invalid_arg "Map.bal"
| Node(lrl, lrv, lrd, lrr, _)->
create (create ll lv ld lrl) lrv lrd (create lrr x d r)
end
end else if hr > hl + 2 then begin
match r with
Empty -> invalid_arg "Map.bal"
| Node(rl, rv, rd, rr, _) ->
if height rr >= height rl then
create (create l x d rl) rv rd rr
else begin
match rl with
Empty -> invalid_arg "Map.bal"
| Node(rll, rlv, rld, rlr, _) ->
create (create l x d rll) rlv rld (create rlr rv rd rr)
end
end else
Node(l, x, d, r, (if hl >= hr then hl + 1 else hr + 1))
Why?
In AVL trees you can see the maximal height difference as a tweakable parameter. They must have chosen 2 to tradeoff between the rebalancing cost on insertion/removal and the lookup cost.
Since you seem to be interested in these things I suggest you have a look at this this paper that has formal proof of correctness of OCaml's Set's module which uses the same AVL tree, by doing do so they actually did find an error in the rebalancing scheme... Also while not strictly equivalent implementation wise, I learned quite a lot from this this paper.