Better way to write the following program in Haskell

I'm writing a function that reduce free words. One can consider it as the following algorithm:

The idea is to cancel items in the list, if they are negative of each other and adjacent to each other. Apply it repeatedly until there is no more to cancel. For example [-2,1,-1,2,3] -> [-2,2,3]->[3]

I wrote the following code. It doesn't seem elegant. It uses head, tail many times, and there are total of 3 patterns for this function's input, it be nice if it can be reduced to 2. I want to know if there are more elegant ways to write it in Haskel开发者_如何学Gol. I suspect I can use fold for this, but I don't see how to do it naturally.

freeReduce []  = []
freeReduce [x] = [x]
freeReduce (x:xs)
  | x == -(head xs) = freeReduce (tail xs)
  | otherwise       = if' (rest == [])
                          [x]
                          (if' (x == - (head rest)) (tail rest) (x:rest))
  where rest = freeReduce xs

This is the clearest I can make it:

freeReduce []       = []
freeReduce (x : xs) = case freeReduce xs of
                           y : ys | y == -x ->     ys
                           ys               -> x : ys

Or equivalently:

freeReduce = foldr f []
  where f x (y : ys) | y == -x =     ys
        f x ys                 = x : ys

(Both untested.)

It seems that freeReduce is inherently strict.

(My original, incorrect attempt:

freeReduce (x : y : rest) | x == -y =     freeReduce rest
freeReduce (x : rest)               = x : freeReduce rest
freeReduce []                       =     []

(Untested.))

You need access to elements before and after the current inspection point, so something like this:

freeReduce :: (Num a) => [a] -> [a]
freeReduce = red []
  where red xs         []           = reverse xs
        red (x:xs) (y:ys) | x == -y = red    xs  ys
        red xs     (y:ys)           = red (y:xs) ys

You move elements from the second list to the first list and only ever compare the top of those list. So it's one sweep over the list, and then reversing it back at the end.

Wouldn't be the following code sufficient?

freeReduce[] = []
freeReduce(x:xs) 
  | rest == []         = [x]
  | x == -(head rest)  = (tail rest)
  | otherwise          = (x:rest)
  where rest = freeReduce xs

Idea is that rest is always reduced as much as possible and thus the only way to get better is, to have a x before rest which cancels with the head of rest leaving the tail of rest as result.

Edit: added a line to handle an empty rest.

You could split it up in two separate functions, one that just checks if the first two elements of a the list cancel each other out, and another one that uses that to reduce the whole list.

-- check if the first two elements cancel each other
headReduce (x:y:zs) | x == -y = zs
headReduce xs = xs

-- build a whole reduced list from that
freeReduce []     = []
freeReduce (x:xs) = headReduce (x : freeReduce xs)

It works because if a list is completely reduced and you add another element in front, the only new possible reduction is that the first two elements now cancel each other out. Then per induction the result of freeReduce is always completely reduced.

Here is one liner, I hope it does cover all the cases as I haven't tested it much

freeReduce = foldr (\i a -> if a /= [] && i == -(hea­d a) then tail a else i:a ) []

This looks like homework, so I'm going to give a hint only.

You need to compare the first two items in the list, but also allow for lists with only one element or none, so your cases look like this:

  freeReduce (x1 : x2 : xs) = ....
  freeReduce [x] = [x]
  freeReduce [] = []

That covers all the cases. So now you just need to decide what to do with the adjacent items x1 and x2, and how to feed this into the rest of the computation.

Collecting already inspected elements in a backward list, and going "one step back" when we find a match:

freeReduce xs = reduce [] xs where
   reduce acc [] = reverse acc
   reduce [] (x:y:ys) | x == -y = reduce [] ys 
   reduce (a:as) (x:y:ys) | x == -y = reduce as (a:ys) 
   reduce acc (x:xs) = reduce (x:acc) xs