Ponder this... in Haskell

So, I got a solution accepted for IBM's Ponder This... puzzle from August despite only finding two of the three solutions. Here's what I sent them (see if you can spot my error):

Here's my solution in the form of a literate haskell program. I fully understand if it is found insufficiently elegant (for the tl;dr version - I found two possible triangles, (4,4,4) and (4,4,6)).

module TrianglePuzzle where
import Control.Monad (guard, MonadPlus)

Initially, Charlie only knows the perimeter.

charlie0 :: (Integral e) => Perimeter e -> [Triangle e]
charlie0 = havingPerimeter

And Ariella only knows the area

ariella0 :: (Integral e) => Squarea e -> [Triangle e]
ariella0 = havingSquarea

After Ariella’s confession that she can’t solve the puzzle, Charlie knows that it can’t be any of the triangles that have unique area.

charlie1 :: (Integral e) => Perimeter e -> [Triangle e]
charlie1 = filter (not . unique . ariella0 . squarea) . charlie0

After Charlie announced that he’s solved it, Ariella knows that one of her possible triangles must be a unique solution for Charlie, given its perimeter and her confession.

ariella1 :: (Integral e) => Squarea e -> [Triangle e]
ariella1 = filter (identically $ charlie1 . perimeter) . ariella0
  where identically f a = f a == [ a ]

So which triangles satisfy all these conditions? It suffices to check that Ariella can solve the puzzle uniquely, since her solution includes a check that Charlie can as well.

solutions :: (Integral e) => [Triangle e]
solutions = concat . filter unique $ map (ariella1 . MkSquarea) [ 3.. ]

Now, optimally, I’d have a closed form solution, rather than an exhaustive infinite search, but until then, I know that it’s possible that

• either the triangle (4,4,4) (so Charlie was given 12 and Ariella was given 4√3)
• or the triangle (4,4,6) (so Charlie was given 14 and Ariella was given 3√7)

are possible solutions.

main = print $ take 2 solutions -- prints [(4,4,4), (4,4,6)]

Appendix: How to enumerate integer-sided triangles given their perimeter or area.

Given a triangle with sides of integer length a, b, and c, s.t.

a ≤ b ≤ c
a + b > c

The formula for the perimiter of the triangle is

perimeter :: (Num e) => Triangle e -> Perimeter e
perimeter (a,b,c) = MkPerimeter $ a + b + c

Given a perimeter p, we can enumerate all the triangles of integer size with that perimeter.

havingPerimeter :: (Integral e) => Perimeter e -> [Triangle e]
havingPerimeter (MkPerimeter p) = do

The longest edge of the triangle is smallest when one of three equal edges, and largest when just less than half of the perimeter (since the other two edges’s sum must be greater).

  c <- [ p `ceilingDiv` 3 .. (p - 1) `floorDiv` 2 ]

The next longest edge must be at least half of the remaining perimeter, but no longer than the largest edge.

  b <- [ (p - c) `ceilingDiv` 2 .. c ]

The smallest edge can be calculated directly using the perimeter and the other two.

  let a = p - c - b
  return (a,b,c)

The formula for the area of the triangle (a,b,c) is

area = (1/4)√s
s = 2a²b² - c⁴ + 2a²c² - b⁴ + 2b²c² - a⁴

area :: (Floating e) => Triangle e -> e
area t = sqrt (unSquarea $ squarea t) / 4

squarea :: (Num e) => Triangle e -> Squarea e
squarea (a,b,c) = MkSquarea $ term (a*b) c + term (a*c) b + term (b*c) a
  where term x y = 2*x^2 - y^4

Given an area r, we can enumerate all the triangles that have that area.

havingArea :: (RealFrac e) => e -> [Triangle e]
havingArea r = map cast . havingSquarea . MkSquarea . round $ 16 * r^2
  where cast (a,b,c) = (fromIntegral a, fromIntegral b, fromIntegral c)

Though it may be easier to reason in terms of a multiple of the area squared, s, so we can confine ourselves to integer operations.

havingSquarea :: (Integral e) => Squarea e -> [Triangle e]
havingSquarea (MkSquarea s) = do

The smallest side is at least one, and is its largest when all three sides are equal, which tells us:

s ≥ 2a² a² - a⁴ + 2a² a² - a⁴ + 2a² a² - a⁴ = 3a⁴

  a <- takeWhile (\a -> 3*a^4 <= s) [1..]

The next largest side is at least as large as the first, but we can do better than that sometimes. If we rearrange the definition of s, we can use the quadratic formula to solve for c², yielding

c² = (a² + b²) ± √( 4a²b² - s )

Since our solutions are non imaginary, this constrains

4a²b² - s ≥ 0
4a²b² ≥ s

We can cap the size of the second edge by stating that it can only be as large as the third edge, which gives

s ≥ 2a²b² - b⁴ + 2a²b² - b⁴ + 2b²b² - a⁴ ⇒
s ≥ 4a²b² - a⁴ ⇒
s + a⁴ ≥ 4a²b²

So we can combine all three constraints to get possible values for b.

  b <- let check cmp b = cmp $ 4*a^2*b^2 in
       takeWhile (check (<= s + a^4)) $ 
       dropWhile (check (< s))          $
       [ a .. ]

Now we can just use the quadratic formula to solve for c

y <- integralSqrt (4*a^2*b^2 - s)
c2 <- let x = a^2 + b^2 in 
      if y == 0 
       then [x] 
       else [x-y, x+y]
c <- integralSqrt c2
return (a,b,c)

Now that we have these tools, we can reason through the problem.

Utilities:

Let’s use a simple type for triangles (no need to get fancy), but since confusing a perimeter value and an area value could get bad, let’s wrap those up.

type Triangle e = (e,e,e)

newtype Perimeter e = MkPerimeter { unPerimeter :: e } deriving (Show, Eq)

newtype Squarea e = MkSquarea { unSquarea :: e } deriving (Show, Eq)

It’s handy to have some easily doing basic integer operations, like div with ceiling or floor, or a way to find integral square roots.

ceilingDiv :: (Integral e) => e -> e -> e
ceilingDiv n d = (n + d - 1) `div` d


floorDiv :: (Integral e) => e -> e -> e
floorDiv = div

integralSqrt :: (MonadPlus m, Integral i) => i -> m i
integralSqrt i = do
 let x' = sqrt $ fromIntegral i
 let x = round x'
 guard $ x' == fromIntegral x
 return x

Identifying a list that contains a unique element comes up a couple times.

unique :: [a] -> Bool
unique [_] = True
unique  _  = False