Related
I'm writing a function called after which takes a list of integers and two integers as parameters. after list num1 num2 should return True if num1 occurs in the list and num2 occurs in list afternum1. (Not necessarily immediately after).
after::[Int]->Int->Int->Bool
after [] _ _=False
after [x:xs] b c
|x==b && c `elem` xs =True
|x/=b && b `elem` xs && b `elem` xs=True
This is what I have so far,my biggest problem is that I don't know how to force num2 to be after num1.
There's a few different ways to approach this one; while it's tempting to go straight for recursion on this, it's nice to
avoid using recursion explicitly if there's another option.
Here's a simple version using some list utilities. Note that it's a Haskell idiom that the object we're operating over is usually the last argument. In this case switching the arguments lets us write it as a pipeline with it's third argument (the list) passed implicitly:
after :: Int -> Int -> [Int] -> Bool
after a b = elem b . dropWhile (/= a)
Hopefully this is pretty easy to understand; we drop elements of the list until we hit an a, assuming we find one we check if there's a b in the remaining list. If there was no a, this list is [] and obviously there's no b there, so it returns False as expected.
You haven't specified what happens if 'a' and 'b' are equal, so I'll leave it up to you to adapt it for that case. HINT: add a tail somewhere ;)
Here are a couple of other approaches if you're interested:
This is pretty easily handled using a fold;
We have three states to model. Either we're looking for the first elem, or
we're looking for the second elem, or we've found them (in the right order).
data State =
FindA | FindB | Found
deriving Eq
Then we can 'fold' (aka reduce) the list down to the result of whether it matches or not.
after :: Int -> Int -> [Int] -> Bool
after a b xs = foldl go FindA xs == Found
where
go FindA x = if x == a then FindB else FindA
go FindB x = if x == b then Found else FindB
go Found _ = Found
You can also do it recursively if you like:
after :: Int -> Int -> [Int] -> Bool
after _ _ [] = False
after a b (x:xs)
| x == a = b `elem` xs
| otherwise = after a b xs
Cheers!
You can split it into two parts: the first one will find the first occurrence of num1. After that, you just need to drop all elements before it and just check that num2 is in the remaining part of the list.
There's a standard function elemIndex for the first part. The second one is just elem.
import Data.List (elemIndex)
after xs x y =
case x `elemIndex` xs of
Just i -> y `elem` (drop (i + 1) xs)
Nothing -> False
If you'd like to implement it without elem or elemIndex, you could include a subroutine. Something like:
after xs b c = go xs False
where go (x:xs) bFound
| x == b && not (null xs) = go xs True
| bFound && x == c = True
| null xs = False
| otherwise = go xs bFound
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.
How can I efficiently represent the list [0..] \\ [t+0*p, t+1*p ..]?
I have defined:
Prelude> let factors p t = [t+0*p, t+1*p ..]
I want to efficiently represent an infinite list that is the difference of [0..] and factors p t, but using \\ from Data.List requires too much memory for even medium-sized lists:
Prelude Data.List> [0..10000] \\ (factors 5 0)
<interactive>: out of memory
I know that I can represent the values between t+0*p and t+1*p with:
Prelude> let innerList p1 p2 t = [t+p1+1, t+p1+2 .. t+p2-1]
Prelude> innerList 0 5 0
[1,2,3,4]
However, repeatedly calculating and concatenating innerList for increasing intervals seems clumsy.
Can I efficiently represent [0..] \\ (factors p t) without calculating rem or mod for each element?
For the infinite list [0..] \\ [t,t+p..],
yourlist t p = [0..t-1] ++ [i | m <- [0,p..], i <- [t+m+1..t+m+p-1]]
Of course this approach doesn't scale, at all, if you'd want to remove some other factors, like
[0..] \\ [t,t+p..] \\ [s,s+q..] \\ ...
in which case you'll have to remove them in sequence with minus, mentioned in Daniel Fischer's answer. There is no magic bullet here.
But there's also a union, with which the above becomes
[0..] \\ ( [t,t+p..] `union` [s,s+q..] `union` ... )
the advantage is, we can arrange the unions in a tree, and get algorithmic improvement.
You can't use (\\) for that, because
(\\) :: (Eq a) => [a] -> [a] -> [a]
(\\) = foldl (flip delete)
the list of elements you want to remove is infinite, and a left fold never terminates when the list it folds over is infinite.
If you rather want to use something already written than write it yourself, you can use minus from the data-ordlist package.
The performance should be adequate.
Otherwise,
minus :: Ord a => [a] -> [a] -> [a]
minus xxs#(x:xs) yys#(y:ys)
| x < y = x : minus xs yys
| x == y = minus xs ys
| otherwise = minus xss ys
minus xs _ = xs
You can use a list comprehesion with a predicate, using rem:
>>> let t = 0
>>> let p = 5
>>> take 40 $ [ x | x <- [1..], x `rem` p /= t ]
[1,2,3,4,6,7,8,9,11,12,13,14,16,17,18,19,21,22,23,24,26,27,28,29,31,32,33,34,36,37,38,39,41,42,43,44,46,47,48,49]
If you want efficiency, why does your solution have to use list comprehension syntax?
Why not something like this?
gen' n i p | i == p = gen' (n + p) 1 p
gen' n i p = (n+i) : gen' n (i+1) p
gen = gen' 0 1
and then do
gen 5
Because you have ascending lists, you can simply lazily merge them:
nums = [1..]
nogos = factors p t
result = merge nums (dropWhile (<head nums) nogos) where
merge (a:as) (b:bs)
| a < b = a : merge as (b:bs)
| a == b = merge as bs
| otherwise = error "should not happen"
Writing this in a general way so that we have a function that builds the difference of two infinite lists, provided only that they are in ascending order, is left as exercise. In the end, the following should be possible
[1..] `infiniteDifference` primes `infiniteDifference` squares
For this, make it a left associative operator.
I need to make a function that takes a list and an element and returns a list in which the first occurrence of the element is removed: something like
removeFst [1,5,2,3,5,3,4,5,6] 5
[1,2,3,5,3,4,5,6]
What I tried is:
main :: IO()
main = do
putStr ( show $ removeFst [1,5,2,3,5,3,4,5,6] 5)
removeFst :: [Int] -> Int -> [Int]
removeFst [] m = []
removeFst [x] m
| x == m = []
| otherwise = [x]
removeFst (x:xs) m
| x == m = xs
| otherwise = removeFst xs m
But this doesn't work... it returns the list without the first elements. I think I should make the recursive call to make the list something like:
removeFst (x:xs) m
| x == m = xs
| otherwise = removeFst (-- return the whole list till element x) m
You are very close, what you miss is prepending the elements before the first found m to the result list,
removeFst :: [Int] -> Int -> [Int]
removeFst [] m = []
removeFst (x:xs) m
| x == m = xs
| otherwise = x : removeFst xs m
-- ^^^ keep x /= m
Note that the special case for one-element lists is superfluous.
Also note that removeFst = flip delete with delete from Data.List.
It should be mentioned that your function is equivalent to Data.List.delete.
Here another version:
import Data.List
removeFst xs x = front ++ drop 1 back where
(front, back) = break (==x) xs
I have written a sudoku solver in Haskell. It goes through a list and when it finds '0' (an empty cell) it will get the numbers that could fit and try them:
import Data.List (group, (\\), sort)
import Data.Maybe (fromMaybe)
row :: Int -> [Int] -> [Int]
row y grid = foldl (\acc x -> (grid !! x):acc) [] [y*9 .. y*9+8]
where y' = y*9
column :: Int -> [Int] -> [Int]
column x grid = foldl (\acc n -> (grid !! n):acc) [] [x,x+9..80]
box :: Int -> Int -> [Int] -> [Int]
box x y grid = foldl (\acc n -> (grid !! n):acc) [] [x+y*9*3+y' | y' <- [0,9,18], x <- [x'..x'+2]]
where x' = x*3
isValid :: [Int] -> Bool
isValid grid = and [isValidRow, isValidCol, isValidBox]
where isValidRow = isValidDiv row
isValidCol = isValidDiv column
isValidBox = and $ foldl (\acc (x,y) -> isValidList (box x y grid):acc) [] [(x,y) | x <- [0..2], y <- [0..2]]
isValidDiv f = and $ foldl (\acc x -> isValidList (f x grid):acc) [] [0..8]
isValidList = all (\x -> length x <= 1) . tail . group . sort -- tail removes entries that are '0'
isComplete :: [Int] -> Bool
isComplete grid = length (filter (== 0) grid) == 0
solve :: Maybe [Int] -> Maybe [Int]
solve grid' = foldl f Nothing [0..80]
where grid = fromMaybe [] grid'
f acc x
| isValid grid = if isComplete grid then grid' else f' acc x
| otherwise = acc
f' acc x
| (grid !! x) == 0 = case guess x grid of
Nothing -> acc
Just x -> Just x
| otherwise = acc
guess :: Int -> [Int] -> Maybe [Int]
guess x grid
| length valid /= 0 = foldl f Nothing valid
| otherwise = Nothing
where valid = [1..9] \\ (row rowN grid ++ column colN grid ++ box (fst boxN) (snd boxN) grid) -- remove numbers already used in row/collumn/box
rowN = x `div` 9 -- e.g. 0/9=0 75/9=8
colN = x - (rowN * 9) -- e.g. 0-0=0 75-72=3
boxN = (colN `div` 3, rowN `div` 3)
before x = take x grid
after x = drop (x+1) grid
f acc y = case solve $ Just $ before x ++ [y] ++ after x of
Nothing -> acc
Just x -> Just x
For some puzzles this works, for example this one:
sudoku :: [Int]
sudoku = [5,3,0,6,7,8,0,1,2,
6,7,0,0,0,0,3,4,8,
0,0,8,0,0,0,5,0,7,
8,0,0,0,0,1,0,0,3,
4,2,6,0,0,3,7,9,0,
7,0,0,9,0,0,0,5,0,
9,0,0,5,0,7,0,0,0,
2,8,7,4,1,9,6,0,5,
3,0,0,2,8,0,1,0,0]
Took under a second, however this one:
sudoku :: [Int]
sudoku = [5,3,0,0,7,0,0,1,2,
6,7,0,0,0,0,3,4,8,
0,0,0,0,0,0,5,0,7,
8,0,0,0,0,1,0,0,3,
4,2,6,0,0,3,7,9,0,
7,0,0,9,0,0,0,5,0,
9,0,0,5,0,7,0,0,0,
2,8,7,4,1,9,6,0,5,
3,0,0,2,8,0,1,0,0]
I have not seen finish. I don't think this is a problem with the method, as it does return correct results.
Profiling showed that most of the time was spent in the "isValid" function. Is there something obviously inefficient/slow about that function?
The implementation is of course improvable, but that's not the problem. The problem is that for the second grid, the simple guess-and-check algorithm needs a lot of backtracking. Even if you speed up each of your functions 1000-fold, there will be grids where it still needs several times the age of the universe to find the (first, if the grid is not unique) solution.
You need a better algorithm to avoid that. A fairly efficient method to avoid such cases is to guess the square with the least number of possibilities first. That doesn't avoid all bad cases, but reduces them much.
One thing that you should also do is replace the length thing == 0 check with null thing. With the relatively short lists occurring here, the effect is limited, but in general it can be dramatic (and in general you should also not use length list <= 1, use null $ drop 1 list instead).
isValidList = all (\x -> length x <= 1) . tail . group . sort -- tail removes entries that are '0'
If the original list does not contain any zeros, tail will remove something else, perhaps a list of two ones. I'd replace tail . group. sort with group . sort . filter (/= 0).
I don't understand why isValidBox and isValidDiv use foldl as map appears to be adequate. Have I missed something / are they doing something terribly clever?