So this is a merge sort function I'm playing with in OCaml. The funny thing is the code delivers what I expect, which means, it sorts the list. But then raises some errors. So can someone please check my code and tell me what's going on and why these errors? And how do I eliminate them? I'm a OCaml newbie but I really want to get what's going on:
(* Merge Sort *)
(* This works but produces some extra error. Consult someone!! *)
let rec length_inner l n =
match l with
[] -> n
| h::t -> length_inner t (n + 1)
;;
let length l = length_inner l 0;;
let rec take n l =
if n = 0 then [] else
match l with
h::t -> h :: take (n - 1) t
;;
let rec drop n l =
if n = 0 then l else
match l with
h::t -> drop (n - 1) t
;;
let rec merge x y =
match x, y with
[], l -> l
| l, [] -> l
| hx::tx, hy::ty ->
if hx < hy
then hx :: merge tx (hy :: ty)
else hy :: merge (hx :: tx) ty
;;
let rec msort l =
match l with
[] -> []
| [x] -> [x]
| _ ->
let left = take (length l/2) l in
let right = drop (length l/2) l in
merge (msort left) (msort right)
;;
msort [53; 9; 2; 6; 19];;
In the terminal, I get:
OCaml version 4.00.1
# #use "prac.ml";;
val length_inner : 'a list -> int -> int = <fun>
val length : 'a list -> int = <fun>
File "prac.ml", line 13, characters 2-44:
Warning 8: this pattern-matching is not exhaustive.
Here is an example of a value that is not matched:
[]
val take : int -> 'a list -> 'a list = <fun>
File "prac.ml", line 19, characters 2-39:
Warning 8: this pattern-matching is not exhaustive.
Here is an example of a value that is not matched:
[]
val drop : int -> 'a list -> 'a list = <fun>
val merge : 'a list -> 'a list -> 'a list = <fun>
val msort : 'a list -> 'a list = <fun>
- : int list = [2; 6; 9; 19; 53]
#
The compiler is telling you that your pattern matches aren't exhaustive. In fact it's telling exactly what to try to see the problem. For example, you might try:
drop 2 []
To fix the problem you need to decide what to do with empty lists in your functions. Here's a definition of drop with exhaustive matches:
let rec drop n l =
if n = 0 then l
else
match l with
| [] -> []
| h::t -> drop (n - 1) t
If this isn't clear: your code doesn't say what to do with an empty list. Your matches only say what to do if the list has the form h :: t. But an empty list doesn't have this form. You need to add a case for [] to your matches.
Related
Here is quite a typical make a century problem.
We have a natural number list [1;2;3;4;5;6;7;8;9].
We have a list of possible operators [Some '+'; Some '*';None].
Now we create a list of operators from above possibilities and insert each operator into between each consecutive numbers in the number list and compute the value.
(Note a None b = a * 10 + b)
For example, if the operator list is [Some '+'; Some '*'; None; Some '+'; Some '+'; Some '+'; Some '+'; Some '+'], then the value is 1 + 2 * 34 + 5 + 6 + 7 + 8 + 9 = 104.
Please find all possible operator lists, so the value = 10.
The only way I can think of is brute-force.
I generate all possible operator lists.
Compute all possible values.
Then filter so I get all operator lists which produce 100.
exception Cannot_compute
let rec candidates n ops =
if n = 0 then [[]]
else
List.fold_left (fun acc op -> List.rev_append acc (List.map (fun x -> op::x) (candidates (n-1) ops))) [] ops
let glue l opl =
let rec aggr acc_l acc_opl = function
| hd::[], [] -> (List.rev (hd::acc_l), List.rev acc_opl)
| hd1::hd2::tl, None::optl -> aggr acc_l acc_opl (((hd1*10+hd2)::tl), optl)
| hd::tl, (Some c)::optl -> aggr (hd::acc_l) ((Some c)::acc_opl) (tl, optl)
| _ -> raise Cannot_glue
in
aggr [] [] (l, opl)
let compute l opl =
let new_l, new_opl = glue l opl in
let rec comp = function
| hd::[], [] -> hd
| hd::tl, (Some '+')::optl -> hd + (comp (tl, optl))
| hd1::hd2::tl, (Some '-')::optl -> hd1 + (comp ((-hd2)::tl, optl))
| hd1::hd2::tl, (Some '*')::optl -> comp (((hd1*hd2)::tl), optl)
| hd1::hd2::tl, (Some '/')::optl -> comp (((hd1/hd2)::tl), optl)
| _, _ -> raise Cannot_compute
in
comp (new_l, new_opl)
let make_century l ops =
List.filter (fun x -> fst x = 100) (
List.fold_left (fun acc x -> ((compute l x), x)::acc) [] (candidates ((List.length l)-1) ops))
let rec print_solution l opl =
match l, opl with
| hd::[], [] -> Printf.printf "%d\n" hd
| hd::tl, (Some op)::optl -> Printf.printf "%d %c " hd op; print_solution tl optl
| hd1::hd2::tl, None::optl -> print_solution ((hd1*10+hd2)::tl) optl
| _, _ -> ()
I believe my code is ugly. So I have the following questions
computer l opl is to compute using the number list and operator list. Basically it is a typical math evaluation. Is there any nicer implementation?
I have read Chapter 6 in Pearls of Functional Algorithm Design. It used some techniques to improve the performance. I found it really really obscurity and hard to understand. Anyone who read it can help?
Edit
I refined my code. Basically, I will scan the operator list first to glue all numbers where their operator is None.
Then in compute, if I meet a '-' I will simply negate the 2nd number.
A classic dynamic programming solution (which finds the = 104
solution instantly) that does not risk any problem with operators
associativity or precedence. It only returns a boolean saying whether
it's possible to come with the number; modifying it to return the
sequences of operations to get the solution is an easy but interesting
exercise, I was not motivated to go that far.
let operators = [ (+); ( * ); ]
module ISet = Set.Make(struct type t = int let compare = compare end)
let iter2 res1 res2 f =
res1 |> ISet.iter ## fun n1 ->
res2 |> ISet.iter ## fun n2 ->
f n1 n2
let can_make input target =
let has_zero = Array.fold_left (fun acc n -> acc || (n=0)) false input in
let results = Array.make_matrix (Array.length input) (Array.length input) ISet.empty in
for imax = 0 to Array.length input - 1 do
for imin = imax downto 0 do
let add n =
(* OPTIMIZATION: if the operators are known to be monotonous, we need not store
numbers above the target;
(Handling multiplication by 0 requires to be a bit more
careful, and I'm not in the mood to think hard about this
(I think one need to store the existence of a solution,
even if it is above the target), so I'll just disable the
optimization in that case)
*)
if n <= target && not has_zero then
results.(imin).(imax) <- ISet.add n results.(imin).(imax) in
let concat_numbers =
(* concatenates all number from i to j:
i=0, j=2 -> (input.(0)*10 + input.(1))*10 + input.(2)
*)
let rec concat acc k =
let acc = acc + input.(k) in
if k = imax then acc
else concat (10 * acc) (k + 1)
in concat 0 imin
in add concat_numbers;
for k = imin to imax - 1 do
let res1 = results.(imin).(k) in
let res2 = results.(k+1).(imax) in
operators |> List.iter (fun op ->
iter2 res1 res2 (fun n1 n2 -> add (op n1 n2););
);
done;
done;
done;
let result = results.(0).(Array.length input - 1) in
ISet.mem target result
Here is my solution, which evaluates according to the usual rules of precedence. It finds 303 solutions to find [1;2;3;4;5;6;7;8;9] 100 in under 1/10 second on my MacBook Pro.
Here are two interesting ones:
# 123 - 45 - 67 + 89;;
- : int = 100
# 1 * 2 * 3 - 4 * 5 + 6 * 7 + 8 * 9;;
- : int = 100
This is a brute force solution. The only slightly clever thing is that I treat concatenation of digits as simply another (high precedence) operation.
The eval function is the standard stack-based infix expression evaluation that you will find described many places. Here is an SO article about it: How to evaluate an infix expression in just one scan using stacks? The essence is to postpone evaulating by pushing operators and operands onto stacks. When you find that the next operator has lower precedence you can go back and evaluate what you pushed.
type op = Plus | Minus | Times | Divide | Concat
let prec = function
| Plus | Minus -> 0
| Times | Divide -> 1
| Concat -> 2
let succ = function
| Plus -> Minus
| Minus -> Times
| Times -> Divide
| Divide -> Concat
| Concat -> Plus
let apply op stack =
match op, stack with
| _, [] | _, [_] -> [] (* Invalid input *)
| Plus, a :: b :: tl -> (b + a) :: tl
| Minus, a :: b :: tl -> (b - a) :: tl
| Times, a :: b :: tl -> (b * a) :: tl
| Divide, a :: b :: tl -> (b / a) :: tl
| Concat, a :: b :: tl -> (b * 10 + a) :: tl
let rec eval opstack numstack ops nums =
match opstack, numstack, ops, nums with
| [], sn :: _, [], _ -> sn
| sop :: soptl, _, [], _ ->
eval soptl (apply sop numstack) ops nums
| [], _, op :: optl, n :: ntl ->
eval [op] (n :: numstack) optl ntl
| sop :: soptl, _, op :: _, _ when prec sop >= prec op ->
eval soptl (apply sop numstack) ops nums
| _, _, op :: optl, n :: ntl ->
eval (op :: opstack) (n :: numstack) optl ntl
| _ -> 0 (* Invalid input *)
let rec incr = function
| [] -> []
| Concat :: rest -> Plus :: incr rest
| x :: rest -> succ x :: rest
let find nums tot =
match nums with
| [] -> []
| numhd :: numtl ->
let rec try1 ops accum =
let accum' =
if eval [] [numhd] ops numtl = tot then
ops :: accum
else
accum
in
if List.for_all ((=) Concat) ops then
accum'
else try1 (incr ops) accum'
in
try1 (List.map (fun _ -> Plus) numtl) []
I came up with a slightly obscure implementation (for a variant of this problem) that is a bit better than brute force. It works in place, rather than generating intermediate data structures, keeping track of the combined values of the operators that have already been evaluated.
The trick is to keep track of a pending operator and value so that you can evaluate the "none" operator easily. That is, if the algorithm had just progressed though 1 + 23, the pending operator would be +, and the pending value would be 23, allowing you to easily generate either 1 + 23 + 4 or 1 + 234 as necessary.
type op = Add | Sub | Nothing
let print_ops ops =
let len = Array.length ops in
print_char '1';
for i = 1 to len - 1 do
Printf.printf "%s%d" (match ops.(i) with
| Add -> " + "
| Sub -> " - "
| Nothing -> "") (i + 1)
done;
print_newline ()
let solve k target =
let ops = Array.create k Nothing in
let rec recur i sum pending_op pending_value =
let sum' = match pending_op with
| Add -> sum + pending_value
| Sub -> if sum = 0 then pending_value else sum - pending_value
| Nothing -> pending_value in
if i = k then
if sum' = target then print_ops ops else ()
else
let digit = i + 1 in
ops.(i) <- Add;
recur (i + 1) sum' Add digit;
ops.(i) <- Sub;
recur (i + 1) sum' Sub digit;
ops.(i) <- Nothing;
recur (i + 1) sum pending_op (pending_value * 10 + digit) in
recur 0 0 Nothing 0
Note that this will generate duplicates - I didn't bother to fix that. Also, if you are doing this exercise to gain strength in functional programming, it might be beneficial to reject the imperative approach taken here and search for a similar solution that doesn't make use of assignments.
I'm looking for data structure which answer to following question ?
How many elements in lists is lower than current. And I would like to count it for every element in list. Additionally, it must be consistent subsequence of list.
For example:
[1;2;3;-3;5;3]
The correct answer is:
[0; 1; 2; 0; 4; 0]
I'm not sure if I'm exactly understanding your question right because your 'correct answer' seems inconsistent with how you described the problem, but here is a possible solution to the described problem:
let xs = [1;2;3;-3;5;3] in
let comp x y =
if (x < y) then -1
else if (x > y) then 1
else 0
in
let sorted_xs = List.sort comp xs in
let index x =
let rec helper i xs =
match xs with
| [] -> failwith "Item not in list"
| hd::tl -> (
if (hd = x) then i
else helper (i+1) tl
)
in helper 0 sorted_xs
in
List.map index xs
I'm not sure whether that is exactly the problem that you're trying to solve, but that should at least give you the general idea.
The result of this is [1;2;3;0;5;3] which is the number of other items in the list that are lower than the item at that index.
*****UPDATE*****
This is the correct code based on what you described in the comments. Let me know if this makes sense.
let xs = [1;2;3;-5;6;7;10;-1;4] in
let transfer_item xs1 xs2 =
match xs1 with
| [] -> failwith "Invalid list"
| hd::tl -> (tl,hd::xs2)
in
let find_item xs i =
let rec helper xs count =
match xs with
| [] -> count
| hd::tl -> (
if (hd > i) then count
else helper tl (count+1)
)
in helper xs 0
in
let rec new_list xs ref_list =
match xs with
| [] -> []
| hd::tl -> (
let first = find_item ref_list hd in
let (xs, ref_list) = transfer_item xs ref_list in
first::(new_list xs ref_list)
)
in new_list xs []
You can easlily solve your problem using two recursive functions: one for iterating in the list, and one for checking the predecessors in the list. The following code is a possible implementation:
let rec countElementsLessThan list value =
match list with
| [] -> 0
| head :: tail -> if head < value
then 1 + (countElementsLessThan tail value)
else countElementsLessThan tail value
;;
(*******************************)
let rec count remaining alreadySeen result =
match remaining with
| [] -> result
| head :: tail -> let elementsLessThanHead = countElementsLessThan alreadySeen head in
count tail (head :: alreadySeen) (result # [elementsLessThanHead])
;;
(*******************************)
let rec printList list =
match list with
| [] -> print_newline ()
| head :: tail -> print_int head;
printList tail
;;
(*******************************)
let result = count [1;2;3;-3;5;3] [] [];;
printList result;;
Here, method count will iterate and store the already seen elements in a list called alreadySeen. Then, for every element being checked, we call an auxiliary method countElementsLessThan that will return the number of elements lower than the current element. Finally, we store the result in the result list, until every element of the remaining list is checked.
However, I'm not completely sure of having perfectly understood your question, since for me the example you provided should have been:
[1;2;3;-3;5;3] The correct answer is: [0; 1; 2; 0; 4; 3]
instead of:
[1;2;3;-3;5;3] The correct answer is: [0; 1; 2; 0; 4; 0]
I find an example build from preorder, how about how to build binary tree from post
order ?
i edit as following, is it correct
type BinaryTree =
| Nil
| Node of NodeType * BinaryTree * BinaryTree
let rec buildBSTfromPostOrder (l:NodeType list) =
match l with
| [] -> Nil
| [a] -> Node(a, Nil, Nil)
| h::t ->
let b = Node(h, buildBSTfromPostOrder(t), buildBSTfromPostOrder(t))
let smaller =
t
|> Seq.takeWhile (fun n -> n < h)
|> Seq.toList
let bigger =
t
|> Seq.skipWhile (fun n -> n < h)
|> Seq.toList
b
let input = [10; 1; 2; 2; 1; 50]
You can't, if you want reconstruct some binary tree from streams (lists) must use at least two.
There is a Haskell version (very closed to F#)
post [] _ = []
post (x:xs) ys = post (take q xs) (take q ys) ++ -- left
post (drop q xs) (drop (q + 1) ys) ++ -- right
[x] -- node
where (Just q) = elemIndex x ys
That function reconstruct post order from pre and in order. Can be adapted to other versions.
(The keys should be uniques too)
If your tree is ordered (BST) then, simply populate tree with keys.
To populate your BST, you can write
let rec insert tree n =
match tree with
| Nil -> Node(n, Nil, Nil)
| Node(x, left, right) -> if n < x then Node(x, insert left n, right)
else Node(x, left, insert right n)
let populate xs = Seq.fold insert Nil xs
example
let rec show tree =
match tree with
| Nil -> printf ""
| Node(x, left, right) -> do printf "[%d;" x
show left
printf ";"
show right
printf "]"
do show <| populate [|1;6;4;8;2;|]
I have some Run Length Encoding code that I wrote as an exercise
let rle s =
s
|> List.map (fun x -> (x, 1))
|> List.fold (fun acc x ->
match acc with
| [] -> [(x, 1)]
| h::(x, n) -> h::(x, n+1)
| h -> h::(x, 1)
)
|> List.map (fun (x, n) ->
match n with
| 1 -> x.ToString()
| _ -> x.ToString() + n.ToString()
)
The pattern h::(x, n) -> h::(x, n+1) fails to compile.
Does anyone know why?
RLE (for grins)
let rle (s: string) =
let bldr = System.Text.StringBuilder()
let rec start = function
| [] -> ()
| c :: s -> count (1, c) s
and count (n, c) = function
| c1 :: s when c1 = c -> count (n+1, c) s
| s -> Printf.bprintf bldr "%d%c" n c; start s
start (List.ofSeq s)
bldr.ToString()
let s1 = "WWWWWWWWWWWWBWWWWWWWWWWWWBBBWWWWWWWWWWWWWWWWWWWWWWWWBWWWWWWWWWWWWWW"
let s2 = "12W1B12W3B24W1B14W"
rle s1 = s2 |> printfn "%b" //"true"
It can't compile because the second argument for :: pattern match must be a list, but here it is a tuple. In general, you seem to just misunderstand head and tail. Head is the top element while tail is a list of following elements. Essentially swapping them does the trick:
|> List.fold (fun acc x ->
match acc with
| [] -> [(x, 1)]
| (x0, n)::t when x0=x -> (x0, n+1)::t
| t -> (x, 1)::t
)
[]
Note 1: As #pad noticed, List.fold requires one more argument, a "bootstrap" accumulator to start with. Obviously, it should be just an empty list, [].
Note 2: you can't directly match x. Instead, you bind it to x0 and compare x0 with x.
Note 3: matching empty list [] is not necessary as it would happily work with the last pattern.
This doesn't answer your question, but I was bored and wrote an implementation you might find a bit more instructive -- just step through it with the debugger in Visual Studio or MonoDevelop.
let rec private rleRec encoded lastChar count charList =
match charList with
| [] ->
// No more chars left to process, but we need to
// append the current run before returning.
let encoded' = (count, lastChar) :: encoded
// Reverse the encoded list so it's in the correct
// order, then return it.
List.rev encoded'
| currentChar :: charList' ->
// Does the current character match the
// last character to be processed?
if currentChar = lastChar then
// Just increment the count and recurse.
rleRec encoded currentChar (count + 1) charList'
else
// The current character is not the same as the last.
// Append the character and run-length for the previous
// character to the 'encoded' list, then start a new run
// with the current character.
rleRec ((count, lastChar) :: encoded) currentChar 1 charList'
let rle charList =
// If the list is empty, just return an empty list
match charList with
| [] -> []
| hd :: tl ->
// Call the implementation of the RLE algorithm.
// The initial run starts with the first character in the list.
rleRec [] hd 1 tl
let rleOfString (str : string) =
rle (List.ofSeq str)
let rec printRle encoded =
match encoded with
| [] ->
printfn ""
| (length, c) :: tl ->
printf "%i%O" length c
printRle tl
let printRleOfString = rleOfString >> printRle
Pasting the code into F# interactive and using the Wikipedia example for run-length encoding:
> printRleOfString "WWWWWWWWWWWWBWWWWWWWWWWWWBBBWWWWWWWWWWWWWWWWWWWWWWWWBWWWWWWWWWWWWWW";;
12W1B12W3B24W1B14W
val it : unit = ()
Given a sequence of char what is the most efficient way to find the first non repeating char
Interested purely functional implementation haskell or F# preffered.
A fairly straightforward use of Data.Set in combination with filter will do the job in an efficient one-liner. Since this seems homeworkish, I'm declining to provide the precise line in question :-)
The complexity should, I think, be O(n log m) where m is the number of distinct characters in the string and n is the total number of characters in the string.
A simple F# solution:
let f (s: string) =
let n = Map(Seq.countBy id s)
Seq.find (fun c -> n.[c] = 1) s
Here's an F# solution in O(n log n): sort the array, then for each character in the original array, binary search for it in the sorted array: if it's the only one of its kind, that's it.
open System
open System.IO
open System.Collections.Generic
let Solve (str : string) =
let arrStr = str.ToCharArray()
let sorted = Array.sort arrStr
let len = str.Length - 1
let rec Inner i =
if i = len + 1 then
'-'
else
let index = Array.BinarySearch(sorted, arrStr.[i])
if index = 0 && sorted.[index+1] <> sorted.[index] then
arrStr.[i]
elif index = len && sorted.[index-1] <> sorted.[index] then
arrStr.[i]
elif index > 0 && index < len &&
sorted.[index+1] <> sorted.[index] &&
sorted.[index-1] <> sorted.[index] then
arrStr.[i]
else
Inner (i + 1)
Inner 0
let _ =
printfn "%c" (Solve "abcdefabcf")
A - means all characters are repeated.
Edit: ugly hack with using the - for "no solution" as you can use Options, which I keep forgetting about! An exercise for the reader, as this does look like homework.
Here's a bit longish solution, but guaranteed to be worst-case O(n log n):
import List
import Data.Ord.comparing
sortPairs :: Ord a => [(a, b)]->[(a, b)]
sortPairs = sortBy (comparing fst)
index :: Integral b => [a] -> [(a, b)]
index = flip zip [1..]
dropRepeated :: Eq a => [(a, b)]->[(a, b)]
dropRepeated [] = []
dropRepeated [x] = [x]
dropRepeated (x:xs) | fst x == fst (head xs) =
dropRepeated $ dropWhile ((==(fst x)).fst) xs
| otherwise =
x:(dropRepeated xs)
nonRepeatedPairs :: Ord a => Integral b => [a]->[(a, b)]
nonRepeatedPairs = dropRepeated . sortPairs . index
firstNonRepeating :: Ord a => [a]->a
firstNonRepeating = fst . minimumBy (comparing snd) . nonRepeatedPairs
The idea is: sort the string lexicographically, so that it's easy to remove any repeated characters in linear time and find the first character which is not repeated. But in order to find it, we need to save information about characters' positions in text.
The speed on easy cases (like [1..10000]) is not perfect, but for something harder ([1..10000] ++ [1..10000] ++ [10001]) you can see the difference between this and a naive O(n^2).
Of course this can be done in linear time, if the size of alphabet is O(1), but who knows how large the alphabet is...
An alternate Haskell O(n log n) solution using Data.Map and no sorting:
module NonRepeat (
firstNonRepeat
)
where
import Data.List (minimumBy)
import Data.Map (fromListWith, toList)
import Data.Ord (comparing)
data Occurance = Occ { first :: Int, count :: Int }
deriving (Eq, Ord)
note :: Int -> a -> (a, Occurance)
note pos a = (a, Occ pos 1)
combine :: Occurance -> Occurance -> Occurance
combine (Occ p0 c0) (Occ p1 c1) = Occ (p0 `min` p1) (c0 + c1)
firstNonRepeat :: (Ord a) => [a] -> Maybe a
firstNonRepeat = fmap fst . findMinimum . occurances
where occurances = toList . fromListWith combine . zipWith note [0..]
findMinimum = safeMinimum . filter ((== 1).count.snd)
safeMinimum [] = Nothing
safeMinimum xs = Just $ minimumBy (comparing snd) xs
let firstNonRepeating (str:string) =
let rec inner i cMap =
if i = str.Length then
cMap
|> Map.filter (fun c (count, index) -> count = 1)
|> Map.toSeq
|> Seq.minBy (fun (c, (count, index)) -> index)
|> fst
else
let c = str.[i]
let value = if cMap.ContainsKey c then
let (count, index) = cMap.[c]
(count + 1, index)
else
(1, i)
let cMap = cMap.Add(c, value)
inner (i + 1) cMap
inner 0 (Map.empty)
Here is a simpler version that sacrifices speed.
let firstNonRepeating (str:string) =
let (c, count) = str
|> Seq.countBy (fun c -> c)
|> Seq.minBy (fun (c, count) -> count)
if count = 1 then Some c else None
How about something like this:
let firstNonRepeat s =
let repeats =
((Set.empty, Set.empty), s)
||> Seq.fold (fun (one,many) c -> Set.add c one, if Set.contains c one then Set.add c many else many)
|> snd
s
|> Seq.tryFind (fun c -> not (Set.contains c repeats))
This is pure C# (so I assume there's a similar F# version), which will be efficient if GroupBy is efficient (which it ought to be):
static char FstNonRepeatedChar(string s)
{
return s.GroupBy(x => x).Where(xs => xs.Count() == 1).First().First();
}